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