[project @ 1996-07-19 18:36:04 by partain]
authorpartain <unknown>
Fri, 19 Jul 1996 18:38:35 +0000 (18:38 +0000)
committerpartain <unknown>
Fri, 19 Jul 1996 18:38:35 +0000 (18:38 +0000)
partain 1.3 changes through 960719

83 files changed:
ghc/compiler/Jmakefile
ghc/compiler/README
ghc/compiler/absCSyn/CLabel.lhs
ghc/compiler/basicTypes/Id.lhs
ghc/compiler/basicTypes/IdInfo.lhs
ghc/compiler/basicTypes/IdLoop_1_3.lhi
ghc/compiler/basicTypes/IdUtils.lhs
ghc/compiler/basicTypes/Jmakefile [deleted file]
ghc/compiler/basicTypes/Name.lhs
ghc/compiler/basicTypes/basicTypes.lit [deleted file]
ghc/compiler/codeGen/ClosureInfo.lhs
ghc/compiler/codeGen/Jmakefile [deleted file]
ghc/compiler/codeGen/cgintro.lit [deleted file]
ghc/compiler/coreSyn/CoreUnfold.lhs
ghc/compiler/coreSyn/PprCore.lhs
ghc/compiler/coreSyn/root.lit [deleted file]
ghc/compiler/deSugar/DsBinds.lhs
ghc/compiler/deSugar/DsExpr.lhs
ghc/compiler/deSugar/DsUtils.lhs
ghc/compiler/deSugar/Jmakefile [deleted file]
ghc/compiler/deSugar/intro.lit [deleted file]
ghc/compiler/deSugar/root.lit [deleted file]
ghc/compiler/hsSyn/HsDecls.lhs
ghc/compiler/hsSyn/HsExpr.lhs
ghc/compiler/main/CmdLineOpts.lhs
ghc/compiler/main/MkIface.lhs
ghc/compiler/nativeGen/Jmakefile [deleted file]
ghc/compiler/nativeGen/root.lit [deleted file]
ghc/compiler/parser/hschooks.c
ghc/compiler/prelude/Jmakefile [deleted file]
ghc/compiler/prelude/Makefile-fig [deleted file]
ghc/compiler/prelude/PrelInfo.lhs
ghc/compiler/prelude/PrelVals.lhs
ghc/compiler/prelude/PrimOp.lhs
ghc/compiler/prelude/TysWiredIn.lhs
ghc/compiler/prelude/prelude-structure.fig [deleted file]
ghc/compiler/prelude/prelude-structure.tex [deleted file]
ghc/compiler/prelude/prelude.lit [deleted file]
ghc/compiler/reader/Jmakefile [deleted file]
ghc/compiler/reader/reader.lit [deleted file]
ghc/compiler/rename/ParseIface.y
ghc/compiler/rename/ParseUtils.lhs
ghc/compiler/rename/Rename.lhs
ghc/compiler/rename/RnBinds.lhs
ghc/compiler/rename/RnExpr.lhs
ghc/compiler/rename/RnHsSyn.lhs
ghc/compiler/rename/RnIfaces.lhs
ghc/compiler/rename/RnMonad.lhs
ghc/compiler/rename/RnNames.lhs
ghc/compiler/rename/RnSource.lhs
ghc/compiler/root.lit [deleted file]
ghc/compiler/simplCore/FloatIn.lhs
ghc/compiler/simplCore/SimplCase.lhs
ghc/compiler/simplCore/SimplCore.lhs
ghc/compiler/simplCore/SimplEnv.lhs
ghc/compiler/simplCore/Simplify.lhs
ghc/compiler/simplCore/simplifier.tib
ghc/compiler/specialise/SpecEnv.lhs
ghc/compiler/stgSyn/CoreToStg.lhs
ghc/compiler/stgSyn/Jmakefile [deleted file]
ghc/compiler/stgSyn/root.lit [deleted file]
ghc/compiler/typecheck/Inst.lhs
ghc/compiler/typecheck/Jmakefile [deleted file]
ghc/compiler/typecheck/TcClassDcl.lhs
ghc/compiler/typecheck/TcClassSig.lhs [deleted file]
ghc/compiler/typecheck/TcDeriv.lhs
ghc/compiler/typecheck/TcEnv.lhs
ghc/compiler/typecheck/TcInstDcls.lhs
ghc/compiler/typecheck/TcInstUtil.lhs
ghc/compiler/typecheck/TcLoop.lhs [deleted file]
ghc/compiler/typecheck/TcMonad.lhs
ghc/compiler/typecheck/TcMonoType.lhs
ghc/compiler/typecheck/TcPat.lhs
ghc/compiler/typecheck/TcPragmas.lhs [deleted file]
ghc/compiler/typecheck/TcSimplify.lhs
ghc/compiler/typecheck/TcTyDecls.lhs
ghc/compiler/typecheck/TcType.lhs
ghc/compiler/typecheck/root.lit [deleted file]
ghc/compiler/types/Class.lhs
ghc/compiler/types/PprType.lhs
ghc/compiler/types/TyCon.lhs
ghc/compiler/types/Type.lhs
ghc/compiler/utils/Util.lhs

index aa10578..7bc091c 100644 (file)
@@ -402,9 +402,17 @@ ALLINTS=$(ALLSRCS_LHS:.lhs=.hi) $(ALLSRCS_HS:.hs=.hi)
 #endif
 
 #if GhcWithHscOptimised == YES
 #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
 #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" */
 #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 \
 #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
        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
 
 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,)
        @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/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,)
 compile(typecheck/TcSimplify,lhs,)
 compile(typecheck/TcTyClsDecls,lhs,)
 compile(typecheck/TcTyDecls,lhs,)
@@ -745,12 +752,10 @@ objs:: $(ALLOBJS)
 /* *** parser ************************************************* */
 
 YACC_OPTS = -d
 /* *** 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 */
 
 
 /* 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                \
 CPP_DEFINES = $(D_DEBUG)
 
 HSP_SRCS_C =    parser/constr.c                \
index 0830fb3..ca619cd 100644 (file)
@@ -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/.
 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.
index 284d6e7..1ecd2e1 100644 (file)
@@ -66,11 +66,11 @@ import Id           ( externallyVisibleId, cmpId_withSpecDataCon,
 import Maybes          ( maybeToBool )
 import PprStyle                ( PprStyle(..) )
 import PprType         ( showTyCon, GenType{-instance Outputable-} )
 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 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:
 \end{code}
 
 things we want to find out:
index ec613d6..7096362 100644 (file)
@@ -165,7 +165,6 @@ import PprType              ( getTypeString, typeMaybeString, specMaybeTysSuffix,
                        )
 import PprStyle
 import Pretty
                        )
 import PprStyle
 import Pretty
-import SpecEnv         ( SpecEnv(..) )
 import MatchEnv                ( MatchEnv )
 import SrcLoc          ( mkBuiltinSrcLoc )
 import TyCon           ( TyCon, mkTupleTyCon, tyConDataCons )
 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
   = 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
     umod = moduleOf unwrkr_orig
 
     n = mkCompoundName u umod SLIT("wrk") [Left unwrkr_orig] unwrkr_name
index 0f7f0eb..4bfc2c8 100644 (file)
@@ -30,7 +30,6 @@ module IdInfo (
        mkDemandInfo,
        willBeDemanded,
 
        mkDemandInfo,
        willBeDemanded,
 
-       MatchEnv,               -- the SpecEnv (why is this exported???)
        StrictnessInfo(..),     -- non-abstract
        Demand(..),             -- non-abstract
 
        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
                    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,
 
                                         -- better_id_fn inline_env (mEnvToList specenv)
                    else pp_NONE,
 
index 38ee2b9..30804fe 100644 (file)
@@ -4,6 +4,7 @@ __exports__
 CoreSyn CoreExpr
 CoreUnfold FormSummary (..)
 CoreUnfold Unfolding (..)
 CoreSyn CoreExpr
 CoreUnfold FormSummary (..)
 CoreUnfold Unfolding (..)
+CoreUnfold SimpleUnfolding (..)
 CoreUnfold UnfoldingGuidance (..)
 CoreUtils unTagBinders (..)
 Id IdEnv
 CoreUnfold UnfoldingGuidance (..)
 CoreUtils unTagBinders (..)
 Id IdEnv
@@ -19,6 +20,7 @@ MagicUFs MagicUnfoldingFun
 MagicUFs mkMagicUnfoldingFun (..)
 OccurAnal occurAnalyseGlobalExpr (..)
 PprType pprParendGenType (..)
 MagicUFs mkMagicUnfoldingFun (..)
 OccurAnal occurAnalyseGlobalExpr (..)
 PprType pprParendGenType (..)
+SpecEnv  SpecEnv
 SpecEnv  isNullSpecEnv (..)
 SpecEnv  nullSpecEnv (..)
 WwLib mAX_WORKER_ARGS (..)
 SpecEnv  isNullSpecEnv (..)
 SpecEnv  nullSpecEnv (..)
 WwLib mAX_WORKER_ARGS (..)
index 12c8d34..94703c3 100644 (file)
@@ -10,12 +10,12 @@ module IdUtils ( primOpNameInfo, primOpId ) where
 
 IMP_Ubiq()
 IMPORT_DELOOPER(PrelLoop)              -- here for paranoia checking
 
 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 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,
 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 (file)
index 46f17a0..0000000
+++ /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)
index d3eb0d5..3fdedfb 100644 (file)
@@ -70,7 +70,7 @@ import SrcLoc         ( mkBuiltinSrcLoc, mkUnknownSrcLoc, SrcLoc )
 import Unique          ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
                          pprUnique, Unique
                        )
 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
 
 #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
 
 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)
                                                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
 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"
                                                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 (file)
index 6490447..0000000
+++ /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}
index 1d4afc3..73f9e6f 100644 (file)
@@ -91,7 +91,7 @@ import Maybes         ( assocMaybe, maybeToBool )
 import Name            ( isLocallyDefined, nameOf, origName )
 import PprStyle                ( PprStyle(..) )
 import PprType         ( getTyDescription, GenType{-instance Outputable-} )
 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
 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
        (_, 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}
 
     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
     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}
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/codeGen/Jmakefile b/ghc/compiler/codeGen/Jmakefile
deleted file mode 100644 (file)
index 03e6c14..0000000
+++ /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 (file)
index 4df253e..0000000
+++ /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.]
index 37eede1..c45c498 100644 (file)
@@ -43,11 +43,10 @@ import CoreUtils    ( coreExprType )
 import CostCentre      ( ccMentionsId )
 import Id              ( idType, getIdArity,  isBottomingId, 
                          SYN_IE(IdSet), GenId{-instances-} )
 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 IdInfo          ( arityMaybe, bottomIsGuaranteed )
 import Literal         ( isNoRepLit, isLitLitLit )
 import Pretty
-import PrimOp          ( primOpCanTriggerGC, PrimOp(..) )
 import TyCon           ( tyConFamilySize )
 import Type            ( getAppDataTyConExpandingDicts )
 import UniqSet         ( emptyUniqSet, unitUniqSet, mkUniqSet,
 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
   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
     go n (SCC _ e)      = go n e
     go n (Coerce _ _ e) = go n e
     go n (Let _ e)      = OtherForm
index e9bb179..57945cb 100644 (file)
@@ -31,7 +31,6 @@ import Id             ( idType, getIdInfo, getIdStrictness, isTupleCon,
                          nullIdEnv, SYN_IE(DataCon), GenId{-instances-}
                        )
 import IdInfo          ( ppIdInfo, StrictnessInfo(..) )
                          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
 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 (file)
index caea1a6..0000000
+++ /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}
index a8f41bd..0331a37 100644 (file)
@@ -41,11 +41,11 @@ import Type         ( mkTyVarTys, mkForAllTys, splitSigmaTy,
                          tyVarsOfType, tyVarsOfTypes, isDictTy
                        )
 import TyVar           ( tyVarSetToList, GenTyVar{-instance Eq-} )
                          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}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
index b2adec7..4f2760e 100644 (file)
@@ -77,7 +77,7 @@ around; if we get hits, we use the value accordingly.
 \begin{code}
 dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
 
 \begin{code}
 dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
 
-dsExpr (HsVar var) = dsApp (HsVar var) []
+dsExpr e@(HsVar var) = dsApp e []
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -584,20 +584,9 @@ dsApp (TyApp expr tys) args
 
 -- we might should look out for SectionLs, etc., here, but we don't
 
 
 -- 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 ->
 
 dsApp anything_else args
   = dsExpr anything_else       `thenDs` \ core_expr ->
index 4e2126c..66472b7 100644 (file)
@@ -43,7 +43,7 @@ import PprStyle               ( PprStyle(..) )
 import PrelVals                ( iRREFUT_PAT_ERROR_ID, voidId )
 import Pretty          ( ppShow )
 import Id              ( idType, dataConArgTys, mkTupleCon,
 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 )
                          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 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 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}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/deSugar/Jmakefile b/ghc/compiler/deSugar/Jmakefile
deleted file mode 100644 (file)
index 3e0bd41..0000000
+++ /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 (file)
index 6ae7747..0000000
+++ /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 (file)
index 51c35f5..0000000
+++ /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}
index aac4f40..6341f66 100644 (file)
@@ -27,7 +27,7 @@ import Outputable     ( interppSP, interpp'SP,
                        )
 import Pretty
 import SrcLoc          ( SrcLoc )
                        )
 import Pretty
 import SrcLoc          ( SrcLoc )
-import Util            ( panic#{-ToDo:rm eventually-} )
+--import Util          ( panic#{-ToDo:rm eventually-} )
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
index e8bb141..56ad5d2 100644 (file)
@@ -26,7 +26,7 @@ import Pretty
 import PprStyle                ( PprStyle(..) )
 import SrcLoc          ( SrcLoc )
 import Usage           ( GenUsage{-instance-} )
 import PprStyle                ( PprStyle(..) )
 import SrcLoc          ( SrcLoc )
 import Usage           ( GenUsage{-instance-} )
-import Util            ( panic{-ToDo:rm eventually-} )
+--import Util          ( panic{-ToDo:rm eventually-} )
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
index d6ccc12..13abecb 100644 (file)
@@ -215,6 +215,8 @@ data SimplifierSwitch
                        -- Oops!
                        -- So only use this flag inside List.hs
                        -- (Sigh, what a HACK, Andy.  WDP 96/01)
                        -- Oops!
                        -- So only use this flag inside List.hs
                        -- (Sigh, what a HACK, Andy.  WDP 96/01)
+
+  | SimplCaseMerge
 \end{code}
 
 %************************************************************************
 \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)
          "-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)
          "-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 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"
 
 -- 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}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
index 43d1ebb..d8ead0b 100644 (file)
@@ -48,12 +48,12 @@ import PrelInfo             ( builtinValNamesMap, builtinTcNamesMap )
 import Pretty          ( prettyToUn )
 import Unpretty                -- ditto
 import RnHsSyn         ( isRnConstr, SYN_IE(RenamedHsModule), RnName(..) )
 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 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)
 
 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 ->
       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 ()
        return (Just if_hdl)
 
 endIface Nothing       = return ()
diff --git a/ghc/compiler/nativeGen/Jmakefile b/ghc/compiler/nativeGen/Jmakefile
deleted file mode 100644 (file)
index d98775c..0000000
+++ /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 (file)
index d383ab3..0000000
+++ /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}
index b630191..7fb06bb 100644 (file)
@@ -32,7 +32,7 @@ StackOverflowHook (I_ stack_size)    /* in bytes */
 void
 PatErrorHdrHook (FILE *where)
 {
 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
 }
 
 void
diff --git a/ghc/compiler/prelude/Jmakefile b/ghc/compiler/prelude/Jmakefile
deleted file mode 100644 (file)
index 9bc2736..0000000
+++ /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 (file)
index bcb4e60..0000000
+++ /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
-
index c62c6fd..04bd913 100644 (file)
@@ -20,6 +20,7 @@ module PrelInfo (
 
 IMP_Ubiq()
 IMPORT_DELOOPER(PrelLoop) ( primOpNameInfo )
 
 IMP_Ubiq()
 IMPORT_DELOOPER(PrelLoop) ( primOpNameInfo )
+IMPORT_DELOOPER(IdLoop)          ( SpecEnv )
 
 -- friends:
 import PrelMods                -- Prelude module names
 
 -- friends:
 import PrelMods                -- Prelude module names
index fe5b026..37d6f6b 100644 (file)
@@ -9,7 +9,7 @@
 module PrelVals where
 
 IMP_Ubiq()
 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)
 
 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 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
 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 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")
 
 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
   = 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
 
 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  :: 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
 \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
 
 \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)
        ((((noIdInfo
                {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
                `addInfo` mkStrictnessInfo [WwStrict] Nothing)
@@ -622,7 +623,7 @@ mkBuild ty tv c n g expr
 
 \begin{code}
 augmentId
 
 \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)
        (((noIdInfo
                {-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-})
                `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
index 0aa3a74..413bdf7 100644 (file)
@@ -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 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(..) )
 import PprType         ( pprParendGenType, GenTyVar{-instance Outputable-} )
 import Pretty
 import SMRep           ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
index ff2f55a..5b1e3d0 100644 (file)
@@ -86,14 +86,14 @@ module TysWiredIn (
 --import Kind
 
 IMP_Ubiq()
 --import Kind
 
 IMP_Ubiq()
-IMPORT_DELOOPER(TyLoop)                ( mkDataCon, StrictnessMark(..) )
+IMPORT_DELOOPER(TyLoop)        ( mkDataCon, StrictnessMark(..) )
+IMPORT_DELOOPER(IdLoop)        ( SpecEnv )
 
 -- friends:
 import PrelMods
 import TysPrim
 
 -- others:
 
 -- friends:
 import PrelMods
 import TysPrim
 
 -- others:
-import SpecEnv         ( SYN_IE(SpecEnv) )
 import Kind            ( mkBoxedTypeKind, mkArrowKind )
 import Name            ( mkWiredInName, ExportFlag(..) )
 import SrcLoc          ( mkBuiltinSrcLoc )
 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 (file)
index 0eada43..0000000
+++ /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\ 1
-4 0 1 12 0 -1 0 0.000 0 9 42 309 54 Prelude\ 1
-4 0 1 10 0 -1 0 0.000 0 9 24 174 94 Core\ 1
-4 0 1 10 0 -1 0 0.000 0 9 24 179 144 Text\ 1
-4 0 1 10 0 -1 0 0.000 0 9 30 174 184 Ratio\ 1
-4 0 1 10 0 -1 0 0.000 0 11 42 169 229 Complex\ 1
-4 0 1 10 0 -1 0 0.000 0 11 30 174 269 Array\ 1
-4 0 1 10 0 -1 0 0.000 0 9 12 179 314 IO\ 1
-4 0 1 10 0 -1 0 0.000 0 9 24 179 359 List\ 1
diff --git a/ghc/compiler/prelude/prelude-structure.tex b/ghc/compiler/prelude/prelude-structure.tex
deleted file mode 100644 (file)
index bcb7189..0000000
+++ /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 (file)
index 615f779..0000000
+++ /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 (file)
index 905d494..0000000
+++ /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 (file)
index 27b6dac..0000000
+++ /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}
index 015f6aa..30083ff 100644 (file)
@@ -16,10 +16,10 @@ import FiniteMap    ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
 import Name            ( ExportFlag(..), mkTupNameStr, preludeQual,
                          RdrName(..){-instance Outputable:ToDo:rm-}
                        )
 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 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);
                                            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)
                                          }}
                                        }
 
                                          }}
                                        }
 
index 08266c6..4e28daf 100644 (file)
@@ -24,13 +24,13 @@ import FiniteMap    ( unitFM, listToFM, lookupFM, plusFM, FiniteMap )
 import Maybes          ( maybeToBool, MaybeErr(..) )
 import Name            ( isLexConId, isLexVarId, isLexConSym,
                          mkTupNameStr, preludeQual, isRdrLexCon,
 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 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}
 \end{code}
 
 \begin{code}
index 3c827c1..2d8bd92 100644 (file)
@@ -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 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 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 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 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}
 \end{code}
 
 \begin{code}
@@ -90,7 +90,7 @@ renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
                                     , ppCat (map pp_pair (keysFM builtinKeysMap))
                                     ]}) $
     -}
                                     , 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 ->
     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 ...
     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) ->
     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 ...
     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.
     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)
             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)
     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)
 
     ASSERT (isEmptyBag orig_def_dups)
 
---    _scc_ "rnIfaces"
+    -- _scc_ "rnIfaces"
     rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env
     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,
        \ (rn_module_with_imports, final_env,
           (implicit_val_fm, implicit_tc_fm),
           usage_stuff,
index ac8dc51..ced653a 100644 (file)
@@ -34,12 +34,12 @@ import Digraph              ( stronglyConnComp )
 import ErrUtils                ( addErrLoc, addShortErrLocLine )
 import Name            ( getLocalName, RdrName )
 import Maybes          ( catMaybes )
 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 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
 \end{code}
 
 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
index 220a945..08b1763 100644 (file)
@@ -28,7 +28,7 @@ import RnMonad
 import ErrUtils                ( addErrLoc, addShortErrLocLine )
 import Name            ( isLocallyDefinedName, pprSym, Name, RdrName )
 import Pretty
 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)
 import UniqSet         ( emptyUniqSet, unitUniqSet,
                          unionUniqSets, unionManyUniqSets,
                          SYN_IE(UniqSet)
index e06d1e7..db994b1 100644 (file)
@@ -13,8 +13,8 @@ IMP_Ubiq()
 import HsSyn
 
 import Id              ( isDataCon, GenId, SYN_IE(Id) )
 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(..) )
                        )
 import Outputable      ( Outputable(..){-instance * []-} )
 import PprStyle                ( PprStyle(..) )
@@ -23,7 +23,7 @@ import Pretty
 import TyCon           ( TyCon )
 import TyVar           ( GenTyVar )
 import Unique          ( mkAlphaTyVarUnique, Unique )
 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}
 \end{code}
 
 \begin{code}
@@ -82,7 +82,7 @@ isRnField  (RnField _ _)  = True
 isRnField  _             = False
 
 isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls
 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
 
 isRnImplicit (RnImplicit _)      = True
 isRnImplicit (RnImplicitTyCon _) = True
index f805e31..396f021 100644 (file)
@@ -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,
 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 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,
 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}
 \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)
 ----------
 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)
     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")
        (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)
        (unionBags idefs1 idefs2)
-       (plusFM_C (dup_merge "pragma"      ppStr)                        prags1 prags2)
+       (plusFM_C (dup_merge {-"pragma"      ppStr-})                    prags1 prags2)
   where
   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
         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)
        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
          
          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 _ ->
             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:
                 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) ->
 
 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 ]
 --  ASSERT(isEmptyBag def_dups)
     let
        de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ]
index 0f668bf..22cb653 100644 (file)
@@ -51,7 +51,7 @@ import CmdLineOpts    ( opt_WarnNameShadowing )
 import ErrUtils                ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
                          SYN_IE(Error), SYN_IE(Warning)
                        )
 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,
 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 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 )
 import SrcLoc          ( SrcLoc, mkUnknownSrcLoc )
 import UniqFM          ( UniqFM, emptyUFM )
 import UniqSet         ( SYN_IE(UniqSet), mkUniqSet, minusUniqSet )
index 05d9e5a..f787950 100644 (file)
@@ -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 )
                          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,
 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,
 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}
 \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
          = 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
                                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_`
 
   | otherwise
   = addErrRn (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
-    returnRn (pprPanic "newGlobalName:Qual:" (ppr PprDebug rdr))
+    returnRn (panic "newGlobalName:Qual")
 \end{code}
 
 *********************************************************
 \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)
            (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...
                              (s, OrigName modname s)
        in
        case (lookupFM b_tc_names orig) of      -- NB: we favour the tycon/class FM...
index 277862f..d650c01 100644 (file)
@@ -30,8 +30,8 @@ import ListSetOps     ( unionLists, minusList )
 import Maybes          ( maybeToBool, catMaybes )
 import Name            ( isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..), 
                          nameImportFlag, RdrName, pprNonSym, Name )
 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-} )
 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,
 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.
 \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
          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)
          returnRn (emptyBag, emptyBag)
 
     exp_all n = (n, ExportAll)
diff --git a/ghc/compiler/root.lit b/ghc/compiler/root.lit
deleted file mode 100644 (file)
index 120cdad..0000000
+++ /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}
index 9cf9d7c..29ce8a9 100644 (file)
@@ -198,7 +198,7 @@ fiExpr to_drop (_, AnnSCC cc expr)
 
 \begin{code}
 fiExpr to_drop (_, AnnCoerce c ty 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}
 
     mkCoLets' to_drop (Coerce c ty (fiExpr [] expr))
 \end{code}
 
index ab3e4b2..786f723 100644 (file)
@@ -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 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
                        )
 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' ->
 \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}
 
 
 \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
                        -- 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')
                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}
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 \begin{code}
-mkCoCase :: OutExpr -> OutAlts -> SmplM OutExpr
+mkCoCase :: SimplEnv -> OutExpr -> OutAlts -> SmplM OutExpr
 \end{code}
 
 @mkCoCase@ tries the following transformation (if possible):
 \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}
 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))))
                          (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)
   =    -- 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
 
     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))))
                  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)
   =    -- 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}
 and similar friends.
 
 \begin{code}
-mkCoCase scrut alts
+mkCoCase env scrut alts
   | identity_alts alts
   = tick CaseIdentity          `thenSmpl_`
     returnSmpl scrut
   | identity_alts alts
   = tick CaseIdentity          `thenSmpl_`
     returnSmpl scrut
@@ -868,7 +872,7 @@ mkCoCase scrut alts
 The catch-all case
 
 \begin{code}
 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
 \end{code}
 
 Boring local functions used above.  They simply introduce a trivial binding
index d8aa007..0d3c544 100644 (file)
@@ -34,14 +34,14 @@ import CmdLineOpts  ( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
 import CoreLint                ( lintCoreBindings )
 import CoreSyn
 import CoreUnfold
 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,
 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-}
                          nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
                          lookupIdEnv, SYN_IE(IdEnv),
                          GenId{-instance Outputable-}
@@ -72,7 +72,6 @@ import DefUtils               ( deforestable )
 #endif
 
 isWrapperFor = panic "SimplCore.isWrapperFor (ToDo)"
 #endif
 
 isWrapperFor = panic "SimplCore.isWrapperFor (ToDo)"
-isWrapperId = panic "SimplCore.isWrapperId (ToDo)"
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
index b75369b..f984764 100644 (file)
@@ -526,7 +526,7 @@ data UnfoldConApp
 nullConApps = emptyFM
 
 extendConApps con_apps id (Con con args)
 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
   where
     val_args = filter isValArg args            -- Literals and Ids
     ty_args  = [ty | TyArg ty <- args]         -- Just types
index 5f00a8e..f1ac5d8 100644 (file)
@@ -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' ->
   =    -- 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' ->
 
        -- 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 &&
     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 ->
       = 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
 
     -- 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
            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')
 
 
         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
     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' ->
 
 
     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
 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
        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
     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
        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}
     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.
        -- 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 ->
   = (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
                        (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])
        
      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
   -- 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_`
     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
 
   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
     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])
        new_env = extendEnvGivenBinding env1 occ_info new_id new_rhs
     in
     returnSmpl (new_env, [NonRec new_id new_rhs])
index 375724b..18acd27 100644 (file)
@@ -17,7 +17,7 @@
 
 \author{Simon Peyton Jones and Andre Santos\\ 
 Department of Computing Science, University of Glasgow, G12 8QQ \\
 
 \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
 }
 
 \maketitle
index d7528b8..6efc6af 100644 (file)
@@ -18,8 +18,19 @@ import MatchEnv
 import Type            ( matchTys, isTyVarTy )
 import Usage           ( SYN_IE(UVar) )
 import OccurAnal       ( occurAnalyseGlobalExpr )
 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 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}
 
 
 \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 
 
 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
        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}
 \end{code}
index c3a8d4b..114131a 100644 (file)
@@ -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 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}
 
 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)
 
 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 ->
     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 (file)
index 32b8199..0000000
+++ /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 (file)
index 9842848..0000000
+++ /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}
index 34f0990..6b8a7af 100644 (file)
@@ -57,7 +57,7 @@ import Outputable
 import PprType ( GenClass, TyCon, GenType, GenTyVar, pprParendGenType )        
 import PprStyle        ( PprStyle(..) )
 import Pretty
 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,
 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 (file)
index 3e0bd41..0000000
+++ /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)
index c2818b3..fea81a4 100644 (file)
@@ -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 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 )
 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 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)
 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 (file)
index 08e2fe1..0000000
+++ /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}
index 35995fd..c937957 100644 (file)
@@ -32,7 +32,7 @@ import RnMonad
 import RnUtils         ( SYN_IE(RnEnv), extendGlobalRnEnv )
 import RnBinds         ( rnMethodBinds, rnTopBinds )
 
 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 )
 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 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,
 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,
 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}
 
                        )
 \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
          = (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}
 #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!
 
                -- 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}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -611,8 +611,9 @@ gen_inst_info modname fixities deriver_rn_env
     )                  `thenNF_Tc` \ (mbinds, errs) ->
 
     if not (isEmptyBag errs) then
     )                  `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
     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
     )                  `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}
     else
        returnTc (binds, deriver_rn_env)
 \end{code}
index 1360c47..bda4f4a 100644 (file)
@@ -41,10 +41,10 @@ import Name         ( getOccName, getSrcLoc, Name{-instance NamedThing-} )
 import PprStyle
 import Pretty
 import RnHsSyn         ( RnName(..) )
 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,
 import UniqFM       
 import Util            ( zipEqual, zipWithEqual, zipWith3Equal, zipLazy,
-                         panic, pprPanic, pprTrace{-ToDo:rm-}
+                         panic, pprPanic{-, pprTrace ToDo:rm-}
                        )
 \end{code}
 
                        )
 \end{code}
 
index e12fb7a..df32170 100644 (file)
@@ -80,7 +80,7 @@ import Type           ( GenType(..), SYN_IE(ThetaType), mkTyVarTys,
                          splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
                          getTyCon_maybe, maybeBoxedPrimType, splitRhoTy, eqTy
                        )
                          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 )
 import TysWiredIn      ( stringTy )
 import Unique          ( Unique )
 import Util            ( zipEqual, panic )
index 12e0f14..38b8f2f 100644 (file)
@@ -35,7 +35,7 @@ import Maybes         ( MaybeErr(..), mkLookupFunDef )
 import Name            ( getSrcLoc, Name{--O only-} )
 import PprType         ( GenClass, GenType, GenTyVar )
 import Pretty
 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) )
 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
 
        -- MAKE THE CONSTANT-METHOD IDS
        -- if there are no type variables involved
-    (if not (null inst_decl_theta)
+    (if (null inst_decl_theta)
      then
      then
-       returnTc []
-     else
        mapTc mk_const_meth_id class_ops
        mapTc mk_const_meth_id class_ops
+     else
+       returnTc []
     )                                  `thenTc` \ const_meth_ids ->
 
     returnTc (dfun_id, dfun_theta, const_meth_ids)
     )                                  `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)
        --
        -- 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
        --
        -- 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.
        --
        -- 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
                    | 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
                 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')
     }
     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 (file)
index 39cf96c..0000000
+++ /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}
index fa642c5..e595a83 100644 (file)
@@ -57,7 +57,7 @@ import RnUtils                ( SYN_IE(RnEnv) )
 
 import Bag             ( Bag, emptyBag, isEmptyBag,
                          foldBag, unitBag, unionBags, snocBag )
 
 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 )
 --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
                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)
            )
     in
     returnSST (rn_result, rn_errs)
index 5988dbb..d933c2f 100644 (file)
@@ -35,7 +35,7 @@ import TysWiredIn     ( mkListTy, mkTupleTy )
 import Unique          ( Unique )
 import PprStyle
 import Pretty
 import Unique          ( Unique )
 import PprStyle
 import Pretty
-import Util            ( zipWithEqual, panic, pprPanic{-ToDo:rm-} )
+import Util            ( zipWithEqual, panic{-, pprPanic ToDo:rm-} )
 \end{code}
 
 
 \end{code}
 
 
index 046ab6d..becc2d6 100644 (file)
@@ -33,7 +33,7 @@ import Id             ( GenId, idType )
 import Kind            ( Kind, mkBoxedTypeKind, mkTypeKind )
 import Maybes          ( maybeToBool )
 import PprType         ( GenType, GenTyVar )
 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,
 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 TysWiredIn      ( charTy, stringTy, mkListTy, mkTupleTy, addrTy )
 import Unique          ( Unique, eqClassOpKey )
-import Util            ( assertPanic, panic{-ToDo:rm-} )
+import Util            ( assertPanic, panic )
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
@@ -60,7 +60,7 @@ tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
 
 \begin{code}
 tcPat (VarPatIn name)
 
 \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)
     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 (file)
index 0652152..0000000
+++ /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}
index f9ac4f3..061dc65 100644 (file)
@@ -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 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 Pretty
 import SrcLoc          ( mkUnknownSrcLoc )
-import Util
 import Type            ( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy,
                          getTyVar_maybe )
 import TysWiredIn      ( intTy )
 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 )
                          elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
                          isEmptyTyVarSet, tyVarSetToList )
 import Unique          ( Unique )
+import Util
 \end{code}
 
 
 \end{code}
 
 
index a6f55f2..0eff0ad 100644 (file)
@@ -47,7 +47,7 @@ import Id             ( mkDataCon, dataConSig, mkRecordSelId, idType,
                        )
 import FieldLabel
 import Kind            ( Kind, mkArrowKind, mkBoxedTypeKind )
                        )
 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-}
                        )
 import Name            ( nameSrcLoc, isLocallyDefinedName, getSrcLoc,
                          Name{-instance Ord3-}
                        )
index e27dab5..eff458d 100644 (file)
@@ -61,12 +61,12 @@ IMP_Ubiq()
 import Unique          ( Unique )
 import UniqFM          ( UniqFM )
 import Maybes          ( assocMaybe )
 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}
 
 
 \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
     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
 
 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
     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
 
 zonkTcTyVarToTyVar :: TcTyVar s -> NF_TcM s TyVar
 zonkTcTyVarToTyVar tv
@@ -208,7 +208,7 @@ zonkTcTyVarToTyVar tv
 
       TyVarTy tv' ->    returnNF_Tc (tcTyVarToTyVar 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)
 
 
           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')
     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')
 
           
           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 (file)
index 401055f..0000000
+++ /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}
index e976349..adfbe51 100644 (file)
@@ -40,8 +40,8 @@ import MatchEnv               ( MatchEnv )
 import Maybes          ( assocMaybe )
 import Name            ( changeUnique, Name )
 import Unique          -- Keys for built-in classes
 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}
 import SrcLoc          ( SrcLoc )
 import Util
 \end{code}
index fd20329..7a6480f 100644 (file)
@@ -51,8 +51,7 @@ import Outputable     ( ifPprShowAll, interpp'SP )
 import PprEnv
 import PprStyle                ( PprStyle(..), codeStyle, showUserishTypes )
 import Pretty
 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}
 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
     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
   = 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 ->
   = 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}
 
        (nenv, tv)
 \end{code}
 
index a6b4730..e38da87 100644 (file)
@@ -60,7 +60,7 @@ import Unique         ( Unique, funTyConKey, mkTupleTyConUnique )
 import Pretty          ( SYN_IE(Pretty), PrettyRep )
 import PrimRep         ( PrimRep(..) )
 import SrcLoc          ( SrcLoc, mkBuiltinSrcLoc )
 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-}
 --import {-hide me-}
 --     PprType (pprTyCon)
 --import {-hide me-}
index 4ae211d..7b77b99 100644 (file)
@@ -64,20 +64,20 @@ import Maybes       ( maybeToBool, assocMaybe )
 import PrimRep ( PrimRep(..) )
 import Unique  -- quite a few *Keys
 import Util    ( thenCmp, zipEqual, assoc,
 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
                  Ord3(..){-instances-}
                )
 -- ToDo:rm all these
-import {-mumble-}
-       Pretty
-import  {-mumble-}
-       PprStyle
+--import       {-mumble-}
+--     Pretty
+--import  {-mumble-}
+--     PprStyle
 --import       {-mumble-}
 --     PprType --(pprType )
 --import       {-mumble-}
 --     PprType --(pprType )
-import  {-mumble-}
-       UniqFM (ufmToList )
-import {-mumble-}
-       Outputable
+--import  {-mumble-}
+--     UniqFM (ufmToList )
+--import {-mumble-}
+--     Outputable
 \end{code}
 
 Data types
 \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)
 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
                     go s (ty1:tys1) (ty2:tys2) = match ty1 ty2 (\s' -> go s' tys1 tys2) s
-                                                   
-
 \end{code}
 
 @match@ is the main function.
 \end{code}
 
 @match@ is the main function.
index c3f5039..adc6e65 100644 (file)
@@ -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 "
 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))
 
 pprPanic heading pretty_msg = panic (heading++(ppShow 80 pretty_msg))
 pprError heading pretty_msg = error (heading++(ppShow 80 pretty_msg))