diff options
| author | simonm <unknown> | 1998-01-08 18:12:31 +0000 |
|---|---|---|
| committer | simonm <unknown> | 1998-01-08 18:12:31 +0000 |
| commit | 9dd6e1c216993624a2cd74b62ca0f0569c02c26b (patch) | |
| tree | 28a471729f40b0a69dae5f748b53e0955aa300a3 | |
| parent | ff14742cc328f19b9bf7c04d9a69408e641cf64a (diff) | |
| download | haskell-9dd6e1c216993624a2cd74b62ca0f0569c02c26b.tar.gz | |
[project @ 1998-01-08 18:03:08 by simonm]
The Great Multi-Parameter Type Classes Merge.
Notes from Simon (abridged):
* Multi-parameter type classes are fully implemented.
* Error messages from the type checker should be noticeably improved
* Warnings for unused bindings (-fwarn-unused-names)
* many other minor bug fixes.
Internally there are the following changes
* Removal of Haskell 1.2 compatibility.
* Dramatic clean-up of the PprStyle stuff.
* The type Type has been substantially changed.
* The dictionary for each class is represented by a new
data type for that purpose, rather than by a tuple.
257 files changed, 10623 insertions, 12996 deletions
diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h index a515918173..2e1b154044 100644 --- a/ghc/compiler/HsVersions.h +++ b/ghc/compiler/HsVersions.h @@ -26,49 +26,13 @@ you will screw up the layout where they are used in case expressions! #define CAT2(a,b)a/**/b #endif -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ == 201 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 202 # define REALLY_HASKELL_1_3 # define SYN_IE(a) a # define EXP_MODULE(a) module a # define IMPORT_DELOOPER(mod) import mod # define IMPORT_1_3(mod) import mod -# define _tagCmp compare -# define _LT LT -# define _EQ EQ -# define _GT GT -# define _Addr GHCbase.Addr -# define _ByteArray GHCbase.ByteArray -# define _MutableByteArray GHCbase.MutableByteArray -# define _MutableArray GHCbase.MutableArray -# define _RealWorld GHCbase.RealWorld -# define _ST GHCbase.ST -# define _ForeignObj GHCbase.ForeignObj -# define _runST STbase.runST -# define failWith fail -# define MkST ST -# define STATE_TOK(x) (S# x) -# define ST_RET(x,y) (x,y) -# define unsafePerformST(x) unsafePerformPrimIO (x) -# define ST_TO_PrimIO(x) x -# define MkIOError(h,errt,msg) (errt msg) -# define Text Show -# define IMP_FASTSTRING() -# define IMP_Ubiq() IMPORT_DELOOPER(Ubiq); import qualified GHCbase -# define CHK_Ubiq() IMPORT_DELOOPER(Ubiq); import qualified GHCbase -# define minInt (minBound::Int) -# define maxInt (maxBound::Int) -#elif defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 202 -# define REALLY_HASKELL_1_3 -# define SYN_IE(a) a -# define EXP_MODULE(a) module a -# define IMPORT_DELOOPER(mod) import mod -# define IMPORT_1_3(mod) import mod -# define _CMP_TAG Ordering -# define _tagCmp compare -# define _LT LT -# define _EQ EQ -# define _GT GT -# define _Addr GlaExts.Addr +# define _Addr Addr # define _ByteArray GlaExts.ByteArray # define _MutableByteArray GlaExts.MutableByteArray # define _MutableArray GlaExts.MutableArray @@ -126,37 +90,19 @@ you will screw up the layout where they are used in case expressions! # define MkIOError(h,errt,msg) (errt msg) #endif -#if __GLASGOW_HASKELL__ >= 26 && __GLASGOW_HASKELL__ < 200 -#define trace _trace -#endif +#if defined(__GLASGOW_HASKELL__) -#define TAG_ Int# -#define LT_ -1# -#define EQ_ 0# -#define GT_ 1# -#define GT__ _ +-- Import the beggars +import GlaExts ( Int(..), Int#, (+#), (-#), (*#), + quotInt#, negateInt#, (==#), (<#), (<=#), (>=#), (>#) + ) -#if defined(__GLASGOW_HASKELL__) #define FAST_INT Int# #define ILIT(x) (x#) #define IBOX(x) (I# (x)) -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -#define _ADD_ `plusInt#` -#define _SUB_ `minusInt#` -#define _MUL_ `timesInt#` -#define _DIV_ `divInt#` -#define _QUOT_ `quotInt#` -#define _NEG_ negateInt# -#define _EQ_ `eqInt#` -#define _LT_ `ltInt#` -#define _LE_ `leInt#` -#define _GE_ `geInt#` -#define _GT_ `gtInt#` -#else #define _ADD_ +# #define _SUB_ -# #define _MUL_ *# -#define _DIV_ /# #define _QUOT_ `quotInt#` #define _NEG_ negateInt# #define _EQ_ ==# @@ -164,7 +110,6 @@ you will screw up the layout where they are used in case expressions! #define _LE_ <=# #define _GE_ >=# #define _GT_ ># -#endif #define FAST_BOOL Int# #define _TRUE_ 1# @@ -196,45 +141,29 @@ you will screw up the layout where they are used in case expressions! #endif {- ! __GLASGOW_HASKELL__ -} #if __GLASGOW_HASKELL__ >= 23 + +-- This #ifndef lets us switch off the "import FastString" +-- when compiling FastString itself +#ifndef COMPILING_FAST_STRING +-- +import FastString ( FastString, mkFastString, mkFastCharString#, nullFastString, + consFS, headFS, tailFS, lengthFS, unpackFS, appendFS, concatFS + ) +#endif + # define USE_FAST_STRINGS 1 -# if __GLASGOW_HASKELL__ < 200 || __GLASGOW_HASKELL__ >= 202 -# define FAST_STRING FastString {-_PackedString -} -# if __GLASGOW_HASKELL__ < 200 -# define SLIT(x) (mkFastCharString (A# (x#))) -# elif __GLASGOW_HASKELL__ < 209 -# define SLIT(x) (mkFastCharString (GlaExts.A# (x#))) -# else -# define SLIT(x) (mkFastCharString (Addr.A# (x#))) -# endif -# define _CMP_STRING_ cmpPString - /* cmpPString defined in utils/Util.lhs */ -# define _NULL_ nullFastString {-_nullPS-} -# define _NIL_ (mkFastString "") {-_nilPS -} -# define _CONS_ consFS {-_consPS-} -# define _HEAD_ headFS {-_headPS-} -# define _TAIL_ tailFS {-_tailPS-} -# define _LENGTH_ lengthFS {-_lengthPS-} -# define _PK_ mkFastString {-_packString-} -# define _UNPK_ unpackFS {-_unpackPS-} - /* # define _SUBSTR_ _substrPS */ -# define _APPEND_ `appendFS` {-`_appendPS`-} -# define _CONCAT_ concatFS {-_concatPS-} -# else -# define FAST_STRING GHCbase.PackedString -# define SLIT(x) (packCString (GHCbase.A# x#)) -# define _CMP_STRING_ cmpPString -# define _NULL_ nullPS -# define _NIL_ nilPS -# define _CONS_ consPS -# define _HEAD_ headPS -# define _TAIL_ tailPS -# define _LENGTH_ lengthPS -# define _PK_ packString -# define _UNPK_ unpackPS -# define _SUBSTR_ substrPS -# define _APPEND_ `appendPS` -# define _CONCAT_ concatPS -# endif +# define FAST_STRING FastString +# define SLIT(x) (mkFastCharString# (x#)) +# define _NULL_ nullFastString +# define _NIL_ (mkFastString "") +# define _CONS_ consFS +# define _HEAD_ headFS +# define _TAIL_ tailFS +# define _LENGTH_ lengthFS +# define _PK_ mkFastString +# define _UNPK_ unpackFS +# define _APPEND_ `appendFS` +# define _CONCAT_ concatFS #else # define FAST_STRING String # define SLIT(x) (x) diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 3e4dcb7a26..777b1384d7 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -32,6 +32,13 @@ HS_PROG=hsc # ----------------------------------------------------------------------------- +# Compilation history for Patrick + +# Make the sources first, because that's what the compilation history needs +$(HS_PROG) :: $(HS_SRCS) + + +# ----------------------------------------------------------------------------- # Set SRCS, LOOPS, HCS, OBJS # # First figure out DIRS, the source sub-directories @@ -53,7 +60,7 @@ endif HS_SRCS = $(SRCS_UGNHS) \ $(foreach dir,$(DIRS),$(wildcard $(dir)/*.lhs)) \ - rename/ParseIface.hs rename/ParseType.hs rename/ParseUnfolding.hs + rename/ParseIface.hs ifneq "$(Ghc2_0)" "YES" HS_SRCS += main/LoopHack.hc @@ -104,7 +111,7 @@ LIBOBJS = \ # # stuff you get for free in a source distribution # -SRC_DIST_FILES += \ +SRC_DIST_FILES += rename/ParseIface.hs \ parser/U_tree.c parser/tree.h parser/tree.c \ parser/hsparser.tab.c parser/hsparser.tab.h \ parser/hslexer.c @@ -148,6 +155,10 @@ SRC_HC_OPTS += $(GhcHcOpts) absCSyn/AbsCSyn_HC_OPTS = -fno-omit-reexported-instances absCSyn/CStrings_HC_OPTS = -monly-3-regs + +# Was 6m with 2.10 +absCSyn/PprAbsC_HC_OPTS = -H10m + basicTypes/IdInfo_HC_OPTS = -K2m coreSyn/AnnCoreSyn_HC_OPTS = -fno-omit-reexported-instances hsSyn/HsExpr_HC_OPTS = -K2m @@ -172,14 +183,13 @@ parser/U_tree_HC_OPTS = -H12m -fvia-C '-\#include"hspincl.h"' parser/U_ttype_HC_OPTS = -fvia-C '-\#include"hspincl.h"' prelude/PrimOp_HC_OPTS = -H12m -K3m reader/Lex_HC_OPTS = -K2m -H16m -fvia-C -reader/ReadPrefix_HC_OPTS = -fvia-C '-\#include"hspincl.h"' -rename/ParseIface_HC_OPTS += -Onot -H16m -rename/ParseType_HC_OPTS += -Onot -H16m -rename/ParseUnfolding_HC_OPTS += -Onot -H30m + +# Heap was 6m with 2.10 +reader/ReadPrefix_HC_OPTS = -fvia-C '-\#include"hspincl.h"' -H10m + +rename/ParseIface_HC_OPTS += -Onot -H30m ifeq "$(Ghc2_0)" "YES" rename/ParseIface_HC_OPTS += -fno-warn-incomplete-patterns -rename/ParseType_HC_OPTS += -fno-warn-incomplete-patterns -rename/ParseUnfolding_HC_OPTS += -fno-warn-incomplete-patterns endif ifeq "$(TARGETPLATFORM)" "hppa1.1-hp-hpux9" @@ -192,6 +202,7 @@ endif rename/RnEnv_HC_OPTS = -fvia-C rename/RnSource_HC_OPTS = -H12m rename/RnIfaces_HC_OPTS = -H8m -fvia-C +rename/RnExpr_HC_OPTS = -H10m rename/RnNames_HC_OPTS = -H12m rename/RnMonad_HC_OPTS = -fvia-C # Urk! Really big heap for ParseUnfolding @@ -199,8 +210,13 @@ rename/RnMonad_HC_OPTS = -fvia-C specialise/Specialise_HC_OPTS = -Onot -H12m stgSyn/StgSyn_HC_OPTS = -fno-omit-reexported-instances typecheck/TcGenDeriv_HC_OPTS = -H10m -typecheck/TcHsSyn_HC_OPTS = -H10m -typecheck/TcExpr_HC_OPTS = -H10m + +# Was 10m for 2.10 +typecheck/TcHsSyn_HC_OPTS = -H15m + +# Was 10m for 2.10 +typecheck/TcExpr_HC_OPTS = -H15m + typecheck/TcEnv_HC_OPTS = -H10m ifeq "$(Ghc2_0)" "NO" typecheck/TcMonad_HC_OPTS = -fvia-C @@ -258,16 +274,6 @@ rename/ParseIface.hs : rename/ParseIface.y $(HAPPY) $(HAPPY_OPTS) -g rename/ParseIface.y @chmod 444 rename/ParseIface.hs -rename/ParseType.hs : rename/ParseType.y - @$(RM) rename/ParseType.hs rename/ParseType.hinfo - $(HAPPY) $(HAPPY_OPTS) -g rename/ParseType.y - @chmod 444 rename/ParseType.hs - -rename/ParseUnfolding.hs : rename/ParseUnfolding.y - @$(RM) rename/ParseUnfolding.hs rename/ParseUnfolding.hinfo - $(HAPPY) $(HAPPY_OPTS) -g rename/ParseUnfolding.y - @chmod 444 rename/ParseUnfolding.hs - #---------------------------------------------------------------------- # # Building the stand-alone parser @@ -332,7 +338,7 @@ endif # # Before doing `make depend', need to build all derived Haskell source files # -depend :: $(LOOPS) $(SRCS_UGNHS) rename/ParseIface.hs rename/ParseUnfolding.hs rename/ParseType.hs +depend :: $(LOOPS) $(SRCS_UGNHS) rename/ParseIface.hs ifeq "$(GhcWithHscBuiltViaC)" "YES" diff --git a/ghc/compiler/absCSyn/AbsCLoop.lhi b/ghc/compiler/absCSyn/AbsCLoop.lhi deleted file mode 100644 index b28900e548..0000000000 --- a/ghc/compiler/absCSyn/AbsCLoop.lhi +++ /dev/null @@ -1,53 +0,0 @@ -Breaks the loop caused by PprAbsC needing to -see big swathes of ClosureInfo. - -Also from CLabel needing a couple of CgRetConv things. - -Also from HeapOffs needing some MachMisc things. - -\begin{code} -interface AbsCLoop where -import PreludeStdIO ( Maybe ) - -import CgRetConv ( ctrlReturnConvAlg, - CtrlReturnConvention(..) - ) -import ClosureInfo ( closureKind, closureLabelFromCI, - closureNonHdrSize, closurePtrsSize, - closureSMRep, closureSemiTag, - closureSizeWithoutFixedHdr, - closureTypeDescr, closureUpdReqd, - infoTableLabelFromCI, maybeSelectorInfo, - entryLabelFromCI,fastLabelFromCI, - ClosureInfo - ) -import CLabel ( mkReturnPtLabel, CLabel ) -import HeapOffs ( HeapOffset ) -import Id ( Id(..) ) -import MachMisc ( fixedHdrSizeInWords, varHdrSizeInWords ) -import SMRep ( SMRep ) -import TyCon ( TyCon ) -import Unique ( Unique ) - -closureKind :: ClosureInfo -> [Char] -closureLabelFromCI :: ClosureInfo -> CLabel -closureNonHdrSize :: ClosureInfo -> Int -closurePtrsSize :: ClosureInfo -> Int -closureSMRep :: ClosureInfo -> SMRep -closureSemiTag :: ClosureInfo -> Int -closureSizeWithoutFixedHdr :: ClosureInfo -> HeapOffset -closureTypeDescr :: ClosureInfo -> [Char] -closureUpdReqd :: ClosureInfo -> Bool -entryLabelFromCI :: ClosureInfo -> CLabel -fastLabelFromCI :: ClosureInfo -> CLabel -infoTableLabelFromCI :: ClosureInfo -> CLabel -maybeSelectorInfo :: ClosureInfo -> Maybe (Id, Int) - -mkReturnPtLabel :: Unique -> CLabel - -ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention -data CtrlReturnConvention = VectoredReturn Int | UnvectoredReturn Int - -fixedHdrSizeInWords :: Int -varHdrSizeInWords :: SMRep -> Int -\end{code} diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index ce5d77735c..afa43049b7 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -12,8 +12,6 @@ From @AbstractC@, one may convert to real C (for portability) or to raw assembler/machine code. \begin{code} -#include "HsVersions.h" - module AbsCSyn {- ( -- export everything AbstractC(..), @@ -35,15 +33,13 @@ module AbsCSyn {- ( CostRes(Cost) )-} where -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(AbsCLoop) -#else -# if ! OMIT_NATIVE_CODEGEN -import {-# SOURCE #-} MachMisc -# endif +#include "HsVersions.h" + import {-# SOURCE #-} ClosureInfo ( ClosureInfo ) import {-# SOURCE #-} CLabel ( CLabel ) + +#if ! OMIT_NATIVE_CODEGEN +import {-# SOURCE #-} MachMisc #endif import Constants ( mAX_Vanilla_REG, mAX_Float_REG, @@ -51,8 +47,8 @@ import Constants ( mAX_Vanilla_REG, mAX_Float_REG, lIVENESS_R3, lIVENESS_R4, lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8 ) -import HeapOffs ( SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset), - SYN_IE(VirtualHeapOffset), HeapOffset +import HeapOffs ( VirtualSpAOffset, VirtualSpBOffset, + VirtualHeapOffset, HeapOffset ) import CostCentre ( CostCentre ) import Literal ( mkMachInt, Literal ) diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 46e72ab94e..202b8f7709 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -4,8 +4,6 @@ \section[AbsCUtils]{Help functions for Abstract~C datatype} \begin{code} -#include "HsVersions.h" - module AbsCUtils ( nonemptyAbsC, mkAbstractCs, mkAbsCStmts, @@ -19,24 +17,21 @@ module AbsCUtils ( -- printing/forcing stuff comes from PprAbsC ) where -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 200 -import AbsCLoop (mkReturnPtLabel, CLabel ) -#else +#include "HsVersions.h" + import {-# SOURCE #-} CLabel ( mkReturnPtLabel, CLabel ) -- The loop here is (CLabel -> CgRetConv -> AbsCUtils -> CLabel) -#endif import AbsCSyn import Digraph ( stronglyConnComp, SCC(..) ) import HeapOffs ( possiblyEqualHeapOffset ) -import Id ( fIRST_TAG, SYN_IE(ConTag) ) +import Id ( fIRST_TAG, ConTag ) import Literal ( literalPrimRep, Literal(..) ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import Unique ( Unique{-instance Eq-} ) import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply ) -import Util ( assocDefaultUsing, panic, Ord3(..) ) +import Util ( assocDefaultUsing, panic ) infixr 9 `thenFlt` \end{code} diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 814b1d518c..ce23e2b039 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -4,8 +4,6 @@ \section[CLabel]{@CLabel@: Information to make C Labels} \begin{code} -#include "HsVersions.h" - module CLabel ( CLabel, -- abstract type @@ -47,15 +45,11 @@ module CLabel ( #endif ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" #if ! OMIT_NATIVE_CODEGEN -# if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl ) -# else import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl ) -# endif #endif import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg ) @@ -64,16 +58,15 @@ import Id ( externallyVisibleId, cmpId_withSpecDataCon, isDataCon, isDictFunId, isDefaultMethodId_maybe, isSuperDictSelId_maybe, fIRST_TAG, - SYN_IE(ConTag), GenId{-instance Outputable-}, - SYN_IE(Id) + ConTag, GenId{-instance Outputable-}, + Id ) import Maybes ( maybeToBool ) -import Outputable ( Outputable(..), PprStyle(..) ) import PprType ( showTyCon, GenType{-instance Outputable-} ) import TyCon ( TyCon{-instance Eq-} ) import Unique ( showUnique, pprUnique, Unique{-instance Eq-} ) -import Pretty -import Util ( assertPanic{-, pprTraceToDo:rm-}, Ord3(..) ) +import Util ( assertPanic{-, pprTraceToDo:rm-} ) +import Outputable \end{code} things we want to find out: @@ -115,19 +108,16 @@ unspecialised constructors are compared. \begin{code} data CLabelId = CLabelId Id -instance Ord3 CLabelId where - cmp (CLabelId a) (CLabelId b) = cmpId_withSpecDataCon a b - instance Eq CLabelId where - CLabelId a == CLabelId b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - CLabelId a /= CLabelId b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + CLabelId a == CLabelId b = case (a `compare` b) of { EQ -> True; _ -> False } + CLabelId a /= CLabelId b = case (a `compare` b) of { EQ -> False; _ -> True } instance Ord CLabelId where - CLabelId a <= CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } - CLabelId a < CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } - CLabelId a >= CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } - CLabelId a > CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp (CLabelId a) (CLabelId b) = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } + CLabelId a <= CLabelId b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + CLabelId a < CLabelId b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + CLabelId a >= CLabelId b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + CLabelId a > CLabelId b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare (CLabelId a) (CLabelId b) = a `cmpId_withSpecDataCon` b \end{code} \begin{code} @@ -316,77 +306,82 @@ duplicate declarations in generating C (see @labelSeenTE@ in \begin{code} -- specialised for PprAsm: saves lots of arg passing in NCG #if ! OMIT_NATIVE_CODEGEN -pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl) +pprCLabel_asm = pprCLabel #endif -pprCLabel :: PprStyle -> CLabel -> Doc +pprCLabel :: CLabel -> SDoc -pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u) +pprCLabel (AsmTempLabel u) = text (fmtAsmLbl (showUnique u)) -pprCLabel (PprForAsm prepend_cSEP _) lbl - = if prepend_cSEP - then (<>) pp_cSEP prLbl - else prLbl - where - prLbl = pprCLabel PprForC lbl +pprCLabel lbl + = getPprStyle $ \ sty -> + if asmStyle sty && underscorePrefix then + pp_cSEP <> pprCLbl lbl + else + pprCLbl lbl + -pprCLabel sty (TyConLabel tc UnvecConUpdCode) - = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc, +pprCLbl (TyConLabel tc UnvecConUpdCode) + = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon tc, pp_cSEP, ptext SLIT("upd")] -pprCLabel sty (TyConLabel tc (VecConUpdCode tag)) - = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP, +pprCLbl (TyConLabel tc (VecConUpdCode tag)) + = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon tc, pp_cSEP, int tag, pp_cSEP, ptext SLIT("upd")] -pprCLabel sty (TyConLabel tc (StdUpdCode tag)) +pprCLbl (TyConLabel tc (StdUpdCode tag)) = case (ctrlReturnConvAlg tc) of UnvectoredReturn _ -> ptext SLIT("IndUpdRetDir") VectoredReturn _ -> (<>) (ptext SLIT("IndUpdRetV")) (int (tag - fIRST_TAG)) -pprCLabel sty (TyConLabel tc InfoTblVecTbl) - = hcat [ppr_tycon sty tc, pp_cSEP, ptext SLIT("itblvtbl")] +pprCLbl (TyConLabel tc InfoTblVecTbl) + = hcat [ppr_tycon tc, pp_cSEP, ptext SLIT("itblvtbl")] -pprCLabel sty (TyConLabel tc StdUpdVecTbl) - = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc, +pprCLbl (TyConLabel tc StdUpdVecTbl) + = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon tc, pp_cSEP, ptext SLIT("upd")] -pprCLabel sty (CaseLabel u CaseReturnPt) +pprCLbl (CaseLabel u CaseReturnPt) = hcat [ptext SLIT("ret"), pp_cSEP, ppr_u u] -pprCLabel sty (CaseLabel u CaseVecTbl) +pprCLbl (CaseLabel u CaseVecTbl) = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_u u] -pprCLabel sty (CaseLabel u (CaseAlt tag)) +pprCLbl (CaseLabel u (CaseAlt tag)) = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, int tag] -pprCLabel sty (CaseLabel u CaseDefault) +pprCLbl (CaseLabel u CaseDefault) = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u] -pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("StdErrorCode") +pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("StdErrorCode") -pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info") +pprCLbl (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info") -pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset)) +pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset)) = hcat [ptext SLIT("__sel_info_"), text (show offset), ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")), ptext SLIT("__")] -pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset)) +pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset)) = hcat [ptext SLIT("__sel_entry_"), text (show offset), ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")), ptext SLIT("__")] -pprCLabel sty (IdLabel (CLabelId id) flavor) - = (<>) (ppr sty id) (ppFlavor flavor) +pprCLbl (IdLabel (CLabelId id) flavor) + = ppr id <> ppFlavor flavor + ppr_u u = pprUnique u -ppr_tycon sty tc +ppr_tycon :: TyCon -> SDoc +ppr_tycon tc = ppr tc +{- = let - str = showTyCon sty tc + str = showTyCon tc in --pprTrace "ppr_tycon:" (text str) $ text str +-} -ppFlavor :: IdLabelInfo -> Doc +ppFlavor :: IdLabelInfo -> SDoc ppFlavor x = (<>) pp_cSEP (case x of diff --git a/ghc/compiler/absCSyn/CStrings.lhs b/ghc/compiler/absCSyn/CStrings.lhs index b47da2bf0c..5a40e344f5 100644 --- a/ghc/compiler/absCSyn/CStrings.lhs +++ b/ghc/compiler/absCSyn/CStrings.lhs @@ -1,8 +1,6 @@ This module deals with printing (a) C string literals and (b) C labels. \begin{code} -#include "HsVersions.h" - module CStrings( cSEP, @@ -14,14 +12,10 @@ module CStrings( ) where -IMPORT_1_3(Char (isAlphanum,ord,chr)) -CHK_Ubiq() -- debugging consistency check - -import Pretty -#if __GLASGOW_HASKELL__ >= 209 -import Addr -#endif +#include "HsVersions.h" +import Char ( isAlphanum, ord, chr ) +import Outputable \end{code} @@ -42,7 +36,7 @@ Prelude<x> ZP<x> cSEP = SLIT("_") -- official C separator pp_cSEP = char '_' -identToC :: FAST_STRING -> Doc +identToC :: FAST_STRING -> SDoc modnameToC :: FAST_STRING -> FAST_STRING stringToC :: String -> String charToC, charToEasyHaskell :: Char -> String diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs index eb641bc88f..c1cb316019 100644 --- a/ghc/compiler/absCSyn/Costs.lhs +++ b/ghc/compiler/absCSyn/Costs.lhs @@ -44,8 +44,6 @@ These are first suggestions for scaling the costs. But, this scaling should be d \end{pseudocode} \begin{code} -#include "HsVersions.h" - #define ACCUM_COSTS(i,b,l,s,f) (i+b+l+s+f) #define NUM_REGS 10 {- PprAbsCSyn.lhs -} {- runtime/c-as-asm/CallWrap_C.lc -} @@ -57,10 +55,11 @@ module Costs( costs, addrModeCosts, CostRes(Cost), nullCosts, Side(..) ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import AbsCSyn import PrimOp ( primOpNeedsWrapper, PrimOp(..) ) +import GlaExts ( trace ) -- -------------------------------------------------------------------------- data CostRes = Cost (Int, Int, Int, Int, Int) diff --git a/ghc/compiler/absCSyn/HeapOffs.lhs b/ghc/compiler/absCSyn/HeapOffs.lhs index 10a5f6583f..a76987aa72 100644 --- a/ghc/compiler/absCSyn/HeapOffs.lhs +++ b/ghc/compiler/absCSyn/HeapOffs.lhs @@ -9,8 +9,6 @@ symbolic}---are sufficiently turgid that they get their own module. INTERNAL MODULE: should be accessed via @AbsCSyn.hi@. \begin{code} -#include "HsVersions.h" - module HeapOffs ( HeapOffset, @@ -26,25 +24,22 @@ module HeapOffs ( hpRelToInt, #endif - SYN_IE(VirtualHeapOffset), SYN_IE(HpRelOffset), - SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset), - SYN_IE(SpARelOffset), SYN_IE(SpBRelOffset) + VirtualHeapOffset, HpRelOffset, + VirtualSpAOffset, VirtualSpBOffset, + SpARelOffset, SpBRelOffset ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" + #if ! OMIT_NATIVE_CODEGEN -# if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(AbsCLoop) ( fixedHdrSizeInWords, varHdrSizeInWords ) -# else import {-# SOURCE #-} MachMisc -# endif #endif import Maybes ( catMaybes ) import SMRep -import Pretty -- ********** NOTE ********** import Util ( panic ) -import Outputable ( PprStyle ) +import Outputable +import GlaExts ( Int(..), Int#, (+#), negateInt#, (<=#), (>=#), (==#) ) \end{code} %************************************************************************ @@ -269,36 +264,35 @@ print either a single value, or a parenthesised value. No need for the caller to parenthesise. \begin{code} -pprHeapOffset :: PprStyle -> HeapOffset -> Doc +pprHeapOffset :: HeapOffset -> SDoc -pprHeapOffset sty ZeroHeapOffset = char '0' +pprHeapOffset ZeroHeapOffset = char '0' -pprHeapOffset sty (MaxHeapOffset off1 off2) +pprHeapOffset (MaxHeapOffset off1 off2) = (<>) (ptext SLIT("STG_MAX")) - (parens (hcat [pprHeapOffset sty off1, comma, pprHeapOffset sty off2])) + (parens (hcat [pprHeapOffset off1, comma, pprHeapOffset off2])) -pprHeapOffset sty (AddHeapOffset off1 off2) - = parens (hcat [pprHeapOffset sty off1, char '+', - pprHeapOffset sty off2]) -pprHeapOffset sty (SubHeapOffset off1 off2) - = parens (hcat [pprHeapOffset sty off1, char '-', - pprHeapOffset sty off2]) +pprHeapOffset (AddHeapOffset off1 off2) + = parens (hcat [pprHeapOffset off1, char '+', + pprHeapOffset off2]) +pprHeapOffset (SubHeapOffset off1 off2) + = parens (hcat [pprHeapOffset off1, char '-', + pprHeapOffset off2]) -pprHeapOffset sty (MkHeapOffset int_offs fxdhdr_offs varhdr_offs tothdr_offs) - = pprHeapOffsetPieces sty int_offs fxdhdr_offs varhdr_offs tothdr_offs +pprHeapOffset (MkHeapOffset int_offs fxdhdr_offs varhdr_offs tothdr_offs) + = pprHeapOffsetPieces int_offs fxdhdr_offs varhdr_offs tothdr_offs \end{code} \begin{code} -pprHeapOffsetPieces :: PprStyle - -> FAST_INT -- Words +pprHeapOffsetPieces :: FAST_INT -- Words -> FAST_INT -- Fixed hdrs -> [SMRep__Int] -- Var hdrs -> [SMRep__Int] -- Tot hdrs - -> Doc + -> SDoc -pprHeapOffsetPieces sty n ILIT(0) [] [] = int IBOX(n) -- Deals with zero case too +pprHeapOffsetPieces n ILIT(0) [] [] = int IBOX(n) -- Deals with zero case too -pprHeapOffsetPieces sty int_offs fxdhdr_offs varhdr_offs tothdr_offs +pprHeapOffsetPieces int_offs fxdhdr_offs varhdr_offs tothdr_offs = let pp_int_offs = if int_offs _EQ_ ILIT(0) then Nothing @@ -326,7 +320,7 @@ pprHeapOffsetPieces sty int_offs fxdhdr_offs varhdr_offs tothdr_offs pp_hdrs hdr_pp hdrs = Just (parens (hsep (punctuate (char '+') (map (pp_hdr hdr_pp) hdrs)))) - pp_hdr :: Doc -> SMRep__Int -> Doc + pp_hdr :: SDoc -> SMRep__Int -> SDoc pp_hdr pp_str (SMRI(rep, n)) = if n _EQ_ ILIT(1) then (<>) (text (show rep)) pp_str diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index fe822b4124..8483c9ba21 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -8,8 +8,6 @@ %************************************************************************ \begin{code} -#include "HsVersions.h" - module PprAbsC ( writeRealC, dumpRealC @@ -18,20 +16,11 @@ module PprAbsC ( #endif ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -IMPORT_1_3(IO(Handle)) -IMPORT_1_3(Char(isDigit,isPrint)) -#if __GLASGOW_HASKELL__ == 201 -IMPORT_1_3(GHCbase(Addr(..)) ) -- to see innards -#elif __GLASGOW_HASKELL__ >= 202 -import GlaExts (Addr(..)) -#endif - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(AbsCLoop) -- break its dependence on ClosureInfo -#else -#endif +import IO ( Handle ) +-- import Char ( Char, isDigit, isPrint ) +-- import GlaExts ( Addr(..) ) import AbsCSyn import ClosureInfo @@ -51,17 +40,16 @@ import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap ) import HeapOffs ( isZeroOff, subOff, pprHeapOffset ) import Literal ( showLiteral, Literal(..) ) import Maybes ( maybeToBool, catMaybes ) -import Pretty import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) ) -import PrimRep ( isFloatingRep, showPrimRep, PrimRep(..) ) +import PrimRep ( isFloatingRep, PrimRep(..) ) import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr, isConstantRep, isSpecRep, isPhantomRep ) import Unique ( pprUnique, Unique{-instance NamedThing-} ) import UniqSet ( emptyUniqSet, elementOfUniqSet, - addOneToUniqSet, SYN_IE(UniqSet) + addOneToUniqSet, UniqSet ) -import Outputable ( PprStyle(..), printDoc ) +import Outputable import Util ( nOfThem, panic, assertPanic ) infixr 9 `thenTE` @@ -74,17 +62,17 @@ call to a cost evaluation function @GRAN_EXEC@. For that, \begin{code} writeRealC :: Handle -> AbstractC -> IO () -writeRealC handle absC = printDoc LeftMode handle (pprAbsC PprForC absC (costs absC)) +writeRealC handle absC = printForC handle (pprAbsC absC (costs absC)) -dumpRealC :: AbstractC -> Doc -dumpRealC absC = pprAbsC PprForC absC (costs absC) +dumpRealC :: AbstractC -> SDoc +dumpRealC absC = pprAbsC absC (costs absC) \end{code} This emits the macro, which is used in GrAnSim to compute the total costs from a cost 5 tuple. %% HWL \begin{code} -emitMacro :: CostRes -> Doc +emitMacro :: CostRes -> SDoc -- ToDo: Check a compile time flag to decide whether a macro should be emitted emitMacro (Cost (i,b,l,s,f)) @@ -102,38 +90,38 @@ pp_paren_semi = text ");" -- which must be done before the return i.e. inside absC code) HWL -- --------------------------------------------------------------------------- -pprAbsC :: PprStyle -> AbstractC -> CostRes -> Doc +pprAbsC :: AbstractC -> CostRes -> SDoc -pprAbsC sty AbsCNop _ = empty -pprAbsC sty (AbsCStmts s1 s2) c = ($$) (pprAbsC sty s1 c) (pprAbsC sty s2 c) +pprAbsC AbsCNop _ = empty +pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c) -pprAbsC sty (CClosureUpdInfo info) c - = pprAbsC sty info c +pprAbsC (CClosureUpdInfo info) c + = pprAbsC info c -pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeRep dest) dest src +pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src -pprAbsC sty (CJump target) c +pprAbsC (CJump target) c = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CJump */"-} ]) - (hcat [ text jmp_lit, pprAmode sty target, pp_paren_semi ]) + (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ]) -pprAbsC sty (CFallThrough target) c +pprAbsC (CFallThrough target) c = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CFallThrough */"-} ]) - (hcat [ text jmp_lit, pprAmode sty target, pp_paren_semi ]) + (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ]) -- -------------------------------------------------------------------------- -- Spit out GRAN_EXEC macro immediately before the return HWL -pprAbsC sty (CReturn am return_info) c +pprAbsC (CReturn am return_info) c = ($$) (hcat [emitMacro c {-WDP:, text "/* <---- CReturn */"-} ]) (hcat [text jmp_lit, target, pp_paren_semi ]) where target = case return_info of - DirectReturn -> hcat [ptext SLIT("DIRECT"),char '(', pprAmode sty am, rparen] - DynamicVectoredReturn am' -> mk_vector (pprAmode sty am') + DirectReturn -> hcat [ptext SLIT("DIRECT"),char '(', pprAmode am, rparen] + DynamicVectoredReturn am' -> mk_vector (pprAmode am') StaticVectoredReturn n -> mk_vector (int n) -- Always positive - mk_vector x = hcat [parens (pprAmode sty am), brackets (text "RVREL" <> parens x)] + mk_vector x = hcat [parens (pprAmode am), brackets (text "RVREL" <> parens x)] -pprAbsC sty (CSplitMarker) _ = ptext SLIT("/* SPLIT */") +pprAbsC (CSplitMarker) _ = ptext SLIT("/* SPLIT */") -- we optimise various degenerate cases of CSwitches. @@ -145,60 +133,60 @@ pprAbsC sty (CSplitMarker) _ = ptext SLIT("/* SPLIT */") -- HWL -- -------------------------------------------------------------------------- -pprAbsC sty (CSwitch discrim [] deflt) c - = pprAbsC sty deflt (c + costs deflt) +pprAbsC (CSwitch discrim [] deflt) c + = pprAbsC deflt (c + costs deflt) -- Empty alternative list => no costs for discrim as nothing cond. here HWL -pprAbsC sty (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt +pprAbsC (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt = case (nonemptyAbsC deflt) of Nothing -> -- one alt and no default - pprAbsC sty alt_code (c + costs alt_code) + pprAbsC alt_code (c + costs alt_code) -- Nothing conditional in here either HWL Just dc -> -- make it an "if" - do_if_stmt sty discrim tag alt_code dc c + do_if_stmt discrim tag alt_code dc c -pprAbsC sty (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1), +pprAbsC (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1), (tag2@(MachInt i2 _), alt_code2)] deflt) c | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0)) = if (i1 == 0) then - do_if_stmt sty discrim tag1 alt_code1 alt_code2 c + do_if_stmt discrim tag1 alt_code1 alt_code2 c else - do_if_stmt sty discrim tag2 alt_code2 alt_code1 c + do_if_stmt discrim tag2 alt_code2 alt_code1 c where empty_deflt = not (maybeToBool (nonemptyAbsC deflt)) -pprAbsC sty (CSwitch discrim alts deflt) c -- general case +pprAbsC (CSwitch discrim alts deflt) c -- general case | isFloatingRep (getAmodeRep discrim) - = pprAbsC sty (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c + = pprAbsC (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c | otherwise = vcat [ hcat [text "switch (", pp_discrim, text ") {"], - nest 2 (vcat (map (ppr_alt sty) alts)), + nest 2 (vcat (map ppr_alt alts)), (case (nonemptyAbsC deflt) of Nothing -> empty Just dc -> nest 2 (vcat [ptext SLIT("default:"), - pprAbsC sty dc (c + switch_head_cost + pprAbsC dc (c + switch_head_cost + costs dc), ptext SLIT("break;")])), char '}' ] where pp_discrim - = pprAmode sty discrim + = pprAmode discrim - ppr_alt sty (lit, absC) - = vcat [ hcat [ptext SLIT("case "), pprBasicLit sty lit, char ':'], - nest 2 (($$) (pprAbsC sty absC (c + switch_head_cost + costs absC)) + ppr_alt (lit, absC) + = vcat [ hcat [ptext SLIT("case "), pprBasicLit lit, char ':'], + nest 2 (($$) (pprAbsC absC (c + switch_head_cost + costs absC)) (ptext SLIT("break;"))) ] -- Costs for addressing header of switch and cond. branching -- HWL switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0)) -pprAbsC sty stmt@(COpStmt results op@(CCallOp _ _ _ _ _) args liveness_mask vol_regs) _ - = pprCCall sty op args results liveness_mask vol_regs +pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _ _ _) args liveness_mask vol_regs) _ + = pprCCall op args results liveness_mask vol_regs -pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _ +pprAbsC stmt@(COpStmt results op args liveness_mask vol_regs) _ = let non_void_args = grab_non_void_amodes args non_void_results = grab_non_void_amodes results @@ -210,7 +198,7 @@ pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _ the_op = ppr_op_call non_void_results non_void_args -- liveness mask is *in* the non_void_args in - case (ppr_vol_regs sty vol_regs) of { (pp_saves, pp_restores) -> + case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) -> if primOpNeedsWrapper op then vcat [ pp_saves, the_op, @@ -221,52 +209,52 @@ pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _ } where ppr_op_call results args - = hcat [ pprPrimOp sty op, lparen, + = hcat [ pprPrimOp op, lparen, hcat (punctuate comma (map ppr_op_result results)), if null results || null args then empty else comma, - hcat (punctuate comma (map (pprAmode sty) args)), + hcat (punctuate comma (map pprAmode args)), pp_paren_semi ] - ppr_op_result r = ppr_amode sty r + ppr_op_result r = ppr_amode r -- primop macros do their own casting of result; -- hence we can toss the provided cast... -pprAbsC sty (CSimultaneous abs_c) c - = hcat [ptext SLIT("{{"), pprAbsC sty abs_c c, ptext SLIT("}}")] +pprAbsC (CSimultaneous abs_c) c + = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")] -pprAbsC sty stmt@(CMacroStmt macro as) _ +pprAbsC stmt@(CMacroStmt macro as) _ = hcat [text (show macro), lparen, - hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi] -- no casting -pprAbsC sty stmt@(CCallProfCtrMacro op as) _ + hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting +pprAbsC stmt@(CCallProfCtrMacro op as) _ = hcat [ptext op, lparen, - hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi] -pprAbsC sty stmt@(CCallProfCCMacro op as) _ + hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] +pprAbsC stmt@(CCallProfCCMacro op as) _ = hcat [ptext op, lparen, - hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi] + hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -pprAbsC sty (CCodeBlock label abs_C) _ +pprAbsC (CCodeBlock label abs_C) _ = ASSERT( maybeToBool(nonemptyAbsC abs_C) ) case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) -> vcat [ hcat [text (if (externallyVisibleCLabel label) then "FN_(" -- abbreviations to save on output else "IFN_("), - pprCLabel sty label, text ") {"], - case sty of - PprForC -> ($$) pp_exts pp_temps - _ -> empty, + pprCLabel label, text ") {"], + + pp_exts, pp_temps, + nest 8 (ptext SLIT("FB_")), - nest 8 (pprAbsC sty abs_C (costs abs_C)), + nest 8 (pprAbsC abs_C (costs abs_C)), nest 8 (ptext SLIT("FE_")), char '}' ] } -pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _ +pprAbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd) _ = hcat [ pp_init_hdr, text "_HDR(", - ppr_amode sty (CAddr reg_rel), comma, - pprCLabel sty info_lbl, comma, - if_profiling sty (pprAmode sty cost_centre), comma, - pprHeapOffset sty size, comma, int ptr_wds, pp_paren_semi ] + ppr_amode (CAddr reg_rel), comma, + pprCLabel info_lbl, comma, + if_profiling (pprAmode cost_centre), comma, + pprHeapOffset size, comma, int ptr_wds, pp_paren_semi ] where info_lbl = infoTableLabelFromCI cl_info sm_rep = closureSMRep cl_info @@ -278,32 +266,30 @@ pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _ else getSMInitHdrStr sm_rep) -pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ +pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> vcat [ - case sty of - PprForC -> pp_exts - _ -> empty, + pp_exts, hcat [ ptext SLIT("SET_STATIC_HDR"),char '(', - pprCLabel sty closure_lbl, comma, - pprCLabel sty info_lbl, comma, - if_profiling sty (pprAmode sty cost_centre), comma, + pprCLabel closure_lbl, comma, + pprCLabel info_lbl, comma, + if_profiling (pprAmode cost_centre), comma, ppLocalness closure_lbl, comma, ppLocalnessMacro False{-for data-} info_lbl, char ')' ], - nest 2 (hcat (map (ppr_item sty) amodes)), - nest 2 (hcat (map (ppr_item sty) padding_wds)), + nest 2 (hcat (map ppr_item amodes)), + nest 2 (hcat (map ppr_item padding_wds)), ptext SLIT("};") ] } where info_lbl = infoTableLabelFromCI cl_info - ppr_item sty item + ppr_item item = if getAmodeRep item == VoidRep then text ", (W_) 0" -- might not even need this... - else (<>) (text ", (W_)") (ppr_amode sty item) + else (<>) (text ", (W_)") (ppr_amode item) padding_wds = if not (closureUpdReqd cl_info) then @@ -324,21 +310,21 @@ pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ }; -} -pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _ +pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _ = vcat [ hcat [ pp_info_rep, ptext SLIT("_ITBL"),char '(', - pprCLabel sty info_lbl, comma, + pprCLabel info_lbl, comma, -- CONST_ITBL needs an extra label for -- the static version of the object. if isConstantRep sm_rep - then (<>) (pprCLabel sty (closureLabelFromCI cl_info)) comma + then (<>) (pprCLabel (closureLabelFromCI cl_info)) comma else empty, - pprCLabel sty slow_lbl, comma, - pprAmode sty upd, comma, + pprCLabel slow_lbl, comma, + pprAmode upd, comma, int liveness, comma, pp_tag, comma, @@ -352,16 +338,16 @@ pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liven then (<>) (int select_word_i) comma else empty, - if_profiling sty pp_kind, comma, - if_profiling sty pp_descr, comma, - if_profiling sty pp_type, + if_profiling pp_kind, comma, + if_profiling pp_descr, comma, + if_profiling pp_type, text ");" ], pp_slow, case maybe_fast of Nothing -> empty Just fast -> let stuff = CCodeBlock fast_lbl fast in - pprAbsC sty stuff (costs stuff) + pprAbsC stuff (costs stuff) ] where info_lbl = infoTableLabelFromCI cl_info @@ -373,7 +359,7 @@ pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liven Nothing -> (mkErrorStdEntryLabel, empty) Just xx -> (entryLabelFromCI cl_info, let stuff = CCodeBlock slow_lbl xx in - pprAbsC sty stuff (costs stuff)) + pprAbsC stuff (costs stuff)) maybe_selector = maybeSelectorInfo cl_info is_selector = maybeToBool maybe_selector @@ -392,7 +378,7 @@ pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liven else if is_phantom then -- do not have sizes for these empty else - pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info) + pprHeapOffset (closureSizeWithoutFixedHdr cl_info) pp_ptr_wds = if is_phantom then empty @@ -403,35 +389,33 @@ pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liven pp_descr = hcat [char '"', text (stringToC cl_descr), char '"'] pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"'] -pprAbsC sty (CRetVector lbl maybes deflt) c +pprAbsC (CRetVector lbl maybes deflt) c = vcat [ ptext SLIT("{ // CRetVector (lbl????)"), - nest 8 (sep (map (ppr_maybe_amode sty) maybes)), - text "} /*default=*/ {", pprAbsC sty deflt c, + nest 8 (sep (map ppr_maybe_amode maybes)), + text "} /*default=*/ {", pprAbsC deflt c, char '}'] where - ppr_maybe_amode sty Nothing = ptext SLIT("/*default*/") - ppr_maybe_amode sty (Just a) = pprAmode sty a + ppr_maybe_amode Nothing = ptext SLIT("/*default*/") + ppr_maybe_amode (Just a) = pprAmode a -pprAbsC sty stmt@(CRetUnVector label amode) _ - = hcat [ptext SLIT("UNVECTBL"),char '(', pp_static, comma, pprCLabel sty label, comma, - pprAmode sty amode, rparen] +pprAbsC stmt@(CRetUnVector label amode) _ + = hcat [ptext SLIT("UNVECTBL"),char '(', pp_static, comma, pprCLabel label, comma, + pprAmode amode, rparen] where pp_static = if externallyVisibleCLabel label then empty else ptext SLIT("static") -pprAbsC sty stmt@(CFlatRetVector label amodes) _ +pprAbsC stmt@(CFlatRetVector label amodes) _ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> vcat [ - case sty of - PprForC -> pp_exts - _ -> empty, + pp_exts, hcat [ppLocalness label, ptext SLIT(" W_ "), - pprCLabel sty label, text "[] = {"], - nest 2 (sep (punctuate comma (map (ppr_item sty) amodes))), + pprCLabel label, text "[] = {"], + nest 2 (sep (punctuate comma (map ppr_item amodes))), text "};" ] } where - ppr_item sty item = (<>) (text "(W_) ") (ppr_amode sty item) + ppr_item item = (<>) (text "(W_) ") (ppr_amode item) -pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc +pprAbsC (CCostCentreDecl is_local cc) _ = uppCostCentreDecl is_local cc \end{code} \begin{code} @@ -466,15 +450,15 @@ non_void amode \end{code} \begin{code} -ppr_vol_regs :: PprStyle -> [MagicId] -> (Doc, Doc) +ppr_vol_regs :: [MagicId] -> (SDoc, SDoc) -ppr_vol_regs sty [] = (empty, empty) -ppr_vol_regs sty (VoidReg:rs) = ppr_vol_regs sty rs -ppr_vol_regs sty (r:rs) +ppr_vol_regs [] = (empty, empty) +ppr_vol_regs (VoidReg:rs) = ppr_vol_regs rs +ppr_vol_regs (r:rs) = let pp_reg = case r of VanillaReg pk n -> pprVanillaReg n - _ -> pprMagicId sty r - (more_saves, more_restores) = ppr_vol_regs sty rs + _ -> pprMagicId r + (more_saves, more_restores) = ppr_vol_regs rs in (($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves, ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores) @@ -512,13 +496,10 @@ pp_basic_restores \end{code} \begin{code} -if_profiling sty pretty - = case sty of - PprForC -> if opt_SccProfilingOn - then pretty - else char '0' -- leave it out! - - _ -> {-print it anyway-} pretty +if_profiling pretty + = if opt_SccProfilingOn + then pretty + else char '0' -- leave it out! -- --------------------------------------------------------------------------- -- Changes for GrAnSim: @@ -527,30 +508,30 @@ if_profiling sty pretty -- guessing unknown values and fed into the costs function -- --------------------------------------------------------------------------- -do_if_stmt sty discrim tag alt_code deflt c +do_if_stmt discrim tag alt_code deflt c = case tag of -- This special case happens when testing the result of a comparison. -- We can just avoid some redundant clutter in the output. - MachInt n _ | n==0 -> ppr_if_stmt sty (pprAmode sty discrim) + MachInt n _ | n==0 -> ppr_if_stmt (pprAmode discrim) deflt alt_code (addrModeCosts discrim Rhs) c other -> let - cond = hcat [ pprAmode sty discrim, + cond = hcat [ pprAmode discrim, ptext SLIT(" == "), - pprAmode sty (CLit tag) ] + pprAmode (CLit tag) ] in - ppr_if_stmt sty cond + ppr_if_stmt cond alt_code deflt (addrModeCosts discrim Rhs) c -ppr_if_stmt sty pp_pred then_part else_part discrim_costs c +ppr_if_stmt pp_pred then_part else_part discrim_costs c = vcat [ hcat [text "if (", pp_pred, text ") {"], - nest 8 (pprAbsC sty then_part (c + discrim_costs + + nest 8 (pprAbsC then_part (c + discrim_costs + (Cost (0, 2, 0, 0, 0)) + costs then_part)), (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"), - nest 8 (pprAbsC sty else_part (c + discrim_costs + + nest 8 (pprAbsC else_part (c + discrim_costs + (Cost (0, 1, 0, 0, 0)) + costs else_part)), char '}' ] @@ -615,9 +596,10 @@ Amendment to the above: if we can GC, we have to: that the runtime check that PerformGC is being used sensibly will work. \begin{code} -pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_regs +pprCCall op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_regs = if (may_gc && liveness_mask /= noLiveRegsMask) - then panic ("Live register in _casm_GC_ \"" ++ casm_str ++ "\" " ++ (show (hsep pp_non_void_args)) ++ "\n") + then pprPanic "Live register in _casm_GC_ " + (doubleQuotes (text casm_str) <+> hsep pp_non_void_args) else vcat [ char '{', @@ -631,7 +613,7 @@ pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vo char '}' ] where - (pp_saves, pp_restores) = ppr_vol_regs sty vol_regs + (pp_saves, pp_restores) = ppr_vol_regs vol_regs (pp_save_context, pp_restore_context) = if may_gc then ( text "do { extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;", @@ -652,18 +634,18 @@ pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vo -- should ignore and a (possibly void) result. (local_arg_decls, pp_non_void_args) - = unzip [ ppr_casm_arg sty a i | (a,i) <- non_void_args `zip` [1..] ] + = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ] - pp_liveness = pprAmode sty (mkIntCLit liveness_mask) + pp_liveness = pprAmode (mkIntCLit liveness_mask) (declare_local_vars, local_vars, assign_results) - = ppr_casm_results sty non_void_results pp_liveness + = ppr_casm_results non_void_results pp_liveness casm_str = if is_asm then _UNPK_ op_str else ccall_str -- Remainder only used for ccall - ccall_str = show + ccall_str = showSDoc (hcat [ if null non_void_results then empty @@ -681,14 +663,14 @@ the bit the C world wants to see. The only heap objects which can be passed are @Array@s, @ByteArray@s and @ForeignObj@s. \begin{code} -ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Doc, Doc) +ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc) -- (a) decl and assignment, (b) local var to be used later -ppr_casm_arg sty amode a_num +ppr_casm_arg amode a_num = let a_kind = getAmodeRep amode - pp_amode = pprAmode sty amode - pp_kind = pprPrimKind sty a_kind + pp_amode = pprAmode amode + pp_kind = pprPrimKind a_kind local_var = (<>) (ptext SLIT("_ccall_arg")) (int a_num) @@ -726,21 +708,20 @@ For l-values, the critical questions are: The mallocptr must be encapsulated immediately in a heap object. -} \begin{code} -ppr_casm_results :: - PprStyle -- style - -> [CAddrMode] -- list of results (length <= 1) - -> Doc -- liveness mask +ppr_casm_results + :: [CAddrMode] -- list of results (length <= 1) + -> SDoc -- liveness mask -> - ( Doc, -- declaration of any local vars - [Doc], -- list of result vars (same length as results) - Doc ) -- assignment (if any) of results in local var to registers + ( SDoc, -- declaration of any local vars + [SDoc], -- list of result vars (same length as results) + SDoc ) -- assignment (if any) of results in local var to registers -ppr_casm_results sty [] liveness +ppr_casm_results [] liveness = (empty, [], empty) -- no results -ppr_casm_results sty [r] liveness +ppr_casm_results [r] liveness = let - result_reg = ppr_amode sty r + result_reg = ppr_amode r r_kind = getAmodeRep r local_var = ptext SLIT("_ccall_result") @@ -764,14 +745,14 @@ ppr_casm_results sty [r] liveness pp_paren_semi ]) -} _ -> - (pprPrimKind sty r_kind, + (pprPrimKind r_kind, hcat [ result_reg, equals, local_var, semi ]) declare_local_var = hcat [ result_type, space, local_var, semi ] in (declare_local_var, [local_var], assign_result) -ppr_casm_results sty rs liveness +ppr_casm_results rs liveness = panic "ppr_casm_results: ccall/casm with many results" \end{code} @@ -784,11 +765,11 @@ ToDo: Any chance of giving line numbers when process-casm fails? \begin{code} process_casm :: - [Doc] -- results (length <= 1) - -> [Doc] -- arguments + [SDoc] -- results (length <= 1) + -> [SDoc] -- arguments -> String -- format string (with embedded %'s) -> - Doc -- code being generated + SDoc -- code being generated process_casm results args string = process results args string where @@ -840,19 +821,19 @@ of the source addressing mode.) If the kind of the assignment is of @VoidRep@, then don't generate any code at all. \begin{code} -pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Doc +pprAssign :: PrimRep -> CAddrMode -> CAddrMode -> SDoc -pprAssign sty VoidRep dest src = empty +pprAssign VoidRep dest src = empty \end{code} Special treatment for floats and doubles, to avoid unwanted conversions. \begin{code} -pprAssign sty FloatRep dest@(CVal reg_rel _) src - = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode sty (CAddr reg_rel), comma, pprAmode sty src, pp_paren_semi ] +pprAssign FloatRep dest@(CVal reg_rel _) src + = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ] -pprAssign sty DoubleRep dest@(CVal reg_rel _) src - = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode sty (CAddr reg_rel), comma, pprAmode sty src, pp_paren_semi ] +pprAssign DoubleRep dest@(CVal reg_rel _) src + = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ] \end{code} Lastly, the question is: will the C compiler think the types of the @@ -867,34 +848,34 @@ whereas the A stack, temporaries, registers, etc., are only used for things of fixed type. \begin{code} -pprAssign sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src)) +pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src)) = hcat [ pprVanillaReg dest, equals, pprVanillaReg src, semi ] -pprAssign sty kind dest src +pprAssign kind dest src | mixedTypeLocn dest -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed - = hcat [ ppr_amode sty dest, equals, + = hcat [ ppr_amode dest, equals, text "(W_)(", -- Here is the cast - ppr_amode sty src, pp_paren_semi ] + ppr_amode src, pp_paren_semi ] -pprAssign sty kind dest src +pprAssign kind dest src | mixedPtrLocn dest && getAmodeRep src /= PtrRep -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed - = hcat [ ppr_amode sty dest, equals, + = hcat [ ppr_amode dest, equals, text "(P_)(", -- Here is the cast - ppr_amode sty src, pp_paren_semi ] + ppr_amode src, pp_paren_semi ] -pprAssign sty ByteArrayRep dest src +pprAssign ByteArrayRep dest src | mixedPtrLocn src -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed - = hcat [ ppr_amode sty dest, equals, + = hcat [ ppr_amode dest, equals, text "(B_)(", -- Here is the cast - ppr_amode sty src, pp_paren_semi ] + ppr_amode src, pp_paren_semi ] -pprAssign sty kind other_dest src - = hcat [ ppr_amode sty other_dest, equals, - pprAmode sty src, semi ] +pprAssign kind other_dest src + = hcat [ ppr_amode other_dest, equals, + pprAmode src, semi ] \end{code} @@ -909,7 +890,7 @@ pprAssign sty kind other_dest src @pprAmode@. \begin{code} -pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Doc +pprAmode, ppr_amode :: CAddrMode -> SDoc \end{code} For reasons discussed above under assignments, @CVal@ modes need @@ -920,82 +901,82 @@ similar to those in @pprAssign@: question.) \begin{code} -pprAmode sty (CVal reg_rel FloatRep) - = hcat [ text "PK_FLT(", ppr_amode sty (CAddr reg_rel), rparen ] -pprAmode sty (CVal reg_rel DoubleRep) - = hcat [ text "PK_DBL(", ppr_amode sty (CAddr reg_rel), rparen ] +pprAmode (CVal reg_rel FloatRep) + = hcat [ text "PK_FLT(", ppr_amode (CAddr reg_rel), rparen ] +pprAmode (CVal reg_rel DoubleRep) + = hcat [ text "PK_DBL(", ppr_amode (CAddr reg_rel), rparen ] \end{code} Next comes the case where there is some other cast need, and the no-cast case: \begin{code} -pprAmode sty amode +pprAmode amode | mixedTypeLocn amode - = parens (hcat [ pprPrimKind sty (getAmodeRep amode), ptext SLIT(")("), - ppr_amode sty amode ]) + = parens (hcat [ pprPrimKind (getAmodeRep amode), ptext SLIT(")("), + ppr_amode amode ]) | otherwise -- No cast needed - = ppr_amode sty amode + = ppr_amode amode \end{code} Now the rest of the cases for ``workhorse'' @ppr_amode@: \begin{code} -ppr_amode sty (CVal reg_rel _) - = case (pprRegRelative sty False{-no sign wanted-} reg_rel) of +ppr_amode (CVal reg_rel _) + = case (pprRegRelative False{-no sign wanted-} reg_rel) of (pp_reg, Nothing) -> (<>) (char '*') pp_reg (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ] -ppr_amode sty (CAddr reg_rel) - = case (pprRegRelative sty True{-sign wanted-} reg_rel) of +ppr_amode (CAddr reg_rel) + = case (pprRegRelative True{-sign wanted-} reg_rel) of (pp_reg, Nothing) -> pp_reg (pp_reg, Just offset) -> (<>) pp_reg offset -ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id +ppr_amode (CReg magic_id) = pprMagicId magic_id -ppr_amode sty (CTemp uniq kind) = pprUnique uniq <> char '_' +ppr_amode (CTemp uniq kind) = pprUnique uniq <> char '_' -ppr_amode sty (CLbl label kind) = pprCLabel sty label +ppr_amode (CLbl label kind) = pprCLabel label -ppr_amode sty (CUnVecLbl direct vectored) - = hcat [char '(',ptext SLIT("StgRetAddr"),char ')', ptext SLIT("UNVEC"),char '(', pprCLabel sty direct, comma, - pprCLabel sty vectored, rparen] +ppr_amode (CUnVecLbl direct vectored) + = hcat [char '(',ptext SLIT("StgRetAddr"),char ')', ptext SLIT("UNVEC"),char '(', pprCLabel direct, comma, + pprCLabel vectored, rparen] -ppr_amode sty (CCharLike ch) - = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode sty ch, rparen ] -ppr_amode sty (CIntLike int) - = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode sty int, rparen ] +ppr_amode (CCharLike ch) + = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ] +ppr_amode (CIntLike int) + = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode int, rparen ] -ppr_amode sty (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"'] +ppr_amode (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"'] -- ToDo: are these *used* for anything? -ppr_amode sty (CLit lit) = pprBasicLit sty lit +ppr_amode (CLit lit) = pprBasicLit lit -ppr_amode sty (CLitLit str _) = ptext str +ppr_amode (CLitLit str _) = ptext str -ppr_amode sty (COffset off) = pprHeapOffset sty off +ppr_amode (COffset off) = pprHeapOffset off -ppr_amode sty (CCode abs_C) - = vcat [ ptext SLIT("{ -- CCode"), nest 8 (pprAbsC sty abs_C (costs abs_C)), char '}' ] +ppr_amode (CCode abs_C) + = vcat [ ptext SLIT("{ -- CCode"), nest 8 (pprAbsC abs_C (costs abs_C)), char '}' ] -ppr_amode sty (CLabelledCode label abs_C) - = vcat [ hcat [pprCLabel sty label, ptext SLIT(" = { -- CLabelledCode")], - nest 8 (pprAbsC sty abs_C (costs abs_C)), char '}' ] +ppr_amode (CLabelledCode label abs_C) + = vcat [ hcat [pprCLabel label, ptext SLIT(" = { -- CLabelledCode")], + nest 8 (pprAbsC abs_C (costs abs_C)), char '}' ] -ppr_amode sty (CJoinPoint _ _) +ppr_amode (CJoinPoint _ _) = panic "ppr_amode: CJoinPoint" -ppr_amode sty (CTableEntry base index kind) - = hcat [text "((", pprPrimKind sty kind, text " *)(", - ppr_amode sty base, text "))[(I_)(", ppr_amode sty index, +ppr_amode (CTableEntry base index kind) + = hcat [text "((", pprPrimKind kind, text " *)(", + ppr_amode base, text "))[(I_)(", ppr_amode index, ptext SLIT(")]")] -ppr_amode sty (CMacroExpr pk macro as) - = hcat [lparen, pprPrimKind sty pk, text ")(", text (show macro), lparen, - hcat (punctuate comma (map (pprAmode sty) as)), text "))"] +ppr_amode (CMacroExpr pk macro as) + = hcat [lparen, pprPrimKind pk, text ")(", text (show macro), lparen, + hcat (punctuate comma (map pprAmode as)), text "))"] -ppr_amode sty (CCostCentre cc print_as_string) - = uppCostCentre sty print_as_string cc +ppr_amode (CCostCentre cc print_as_string) + = uppCostCentre print_as_string cc \end{code} %************************************************************************ @@ -1009,45 +990,44 @@ ppr_amode sty (CCostCentre cc print_as_string) (zero offset gives a @Nothing@). \begin{code} -addPlusSign :: Bool -> Doc -> Doc +addPlusSign :: Bool -> SDoc -> SDoc addPlusSign False p = p addPlusSign True p = (<>) (char '+') p -pprSignedInt :: Bool -> Int -> Maybe Doc -- Nothing => 0 +pprSignedInt :: Bool -> Int -> Maybe SDoc -- Nothing => 0 pprSignedInt sign_wanted n = if n == 0 then Nothing else if n > 0 then Just (addPlusSign sign_wanted (int n)) else Just (int n) -pprRegRelative :: PprStyle - -> Bool -- True <=> Print leading plus sign (if +ve) +pprRegRelative :: Bool -- True <=> Print leading plus sign (if +ve) -> RegRelative - -> (Doc, Maybe Doc) + -> (SDoc, Maybe SDoc) -pprRegRelative sty sign_wanted (SpARel spA off) - = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt spA off)) +pprRegRelative sign_wanted (SpARel spA off) + = (pprMagicId SpA, pprSignedInt sign_wanted (spARelToInt spA off)) -pprRegRelative sty sign_wanted (SpBRel spB off) - = (pprMagicId sty SpB, pprSignedInt sign_wanted (spBRelToInt spB off)) +pprRegRelative sign_wanted (SpBRel spB off) + = (pprMagicId SpB, pprSignedInt sign_wanted (spBRelToInt spB off)) -pprRegRelative sty sign_wanted r@(HpRel hp off) +pprRegRelative sign_wanted r@(HpRel hp off) = let to_print = hp `subOff` off - pp_Hp = pprMagicId sty Hp + pp_Hp = pprMagicId Hp in if isZeroOff to_print then (pp_Hp, Nothing) else - (pp_Hp, Just ((<>) (char '-') (pprHeapOffset sty to_print))) + (pp_Hp, Just ((<>) (char '-') (pprHeapOffset to_print))) -- No parens needed because pprHeapOffset -- does them when necessary -pprRegRelative sty sign_wanted (NodeRel off) - = let pp_Node = pprMagicId sty node +pprRegRelative sign_wanted (NodeRel off) + = let pp_Node = pprMagicId node in if isZeroOff off then (pp_Node, Nothing) else - (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset sty off))) + (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset off))) \end{code} @@ -1056,34 +1036,34 @@ represented by a discriminated union (@StgUnion@), so we use the @PrimRep@ to select the union tag. \begin{code} -pprMagicId :: PprStyle -> MagicId -> Doc +pprMagicId :: MagicId -> SDoc -pprMagicId sty BaseReg = ptext SLIT("BaseReg") -pprMagicId sty StkOReg = ptext SLIT("StkOReg") -pprMagicId sty (VanillaReg pk n) +pprMagicId BaseReg = ptext SLIT("BaseReg") +pprMagicId StkOReg = ptext SLIT("StkOReg") +pprMagicId (VanillaReg pk n) = hcat [ pprVanillaReg n, char '.', pprUnionTag pk ] -pprMagicId sty (FloatReg n) = (<>) (ptext SLIT("FltReg")) (int IBOX(n)) -pprMagicId sty (DoubleReg n) = (<>) (ptext SLIT("DblReg")) (int IBOX(n)) -pprMagicId sty TagReg = ptext SLIT("TagReg") -pprMagicId sty RetReg = ptext SLIT("RetReg") -pprMagicId sty SpA = ptext SLIT("SpA") -pprMagicId sty SuA = ptext SLIT("SuA") -pprMagicId sty SpB = ptext SLIT("SpB") -pprMagicId sty SuB = ptext SLIT("SuB") -pprMagicId sty Hp = ptext SLIT("Hp") -pprMagicId sty HpLim = ptext SLIT("HpLim") -pprMagicId sty LivenessReg = ptext SLIT("LivenessReg") -pprMagicId sty StdUpdRetVecReg = ptext SLIT("StdUpdRetVecReg") -pprMagicId sty StkStubReg = ptext SLIT("StkStubReg") -pprMagicId sty CurCostCentre = ptext SLIT("CCC") -pprMagicId sty VoidReg = panic "pprMagicId:VoidReg!" - -pprVanillaReg :: FAST_INT -> Doc +pprMagicId (FloatReg n) = (<>) (ptext SLIT("FltReg")) (int IBOX(n)) +pprMagicId (DoubleReg n) = (<>) (ptext SLIT("DblReg")) (int IBOX(n)) +pprMagicId TagReg = ptext SLIT("TagReg") +pprMagicId RetReg = ptext SLIT("RetReg") +pprMagicId SpA = ptext SLIT("SpA") +pprMagicId SuA = ptext SLIT("SuA") +pprMagicId SpB = ptext SLIT("SpB") +pprMagicId SuB = ptext SLIT("SuB") +pprMagicId Hp = ptext SLIT("Hp") +pprMagicId HpLim = ptext SLIT("HpLim") +pprMagicId LivenessReg = ptext SLIT("LivenessReg") +pprMagicId StdUpdRetVecReg = ptext SLIT("StdUpdRetVecReg") +pprMagicId StkStubReg = ptext SLIT("StkStubReg") +pprMagicId CurCostCentre = ptext SLIT("CCC") +pprMagicId VoidReg = panic "pprMagicId:VoidReg!" + +pprVanillaReg :: FAST_INT -> SDoc pprVanillaReg n = (<>) (char 'R') (int IBOX(n)) -pprUnionTag :: PrimRep -> Doc +pprUnionTag :: PrimRep -> SDoc pprUnionTag PtrRep = char 'p' pprUnionTag CodePtrRep = ptext SLIT("fp") @@ -1111,7 +1091,7 @@ pprUnionTag _ = panic "pprUnionTag:Odd kind" Find and print local and external declarations for a list of Abstract~C statements. \begin{code} -pprTempAndExternDecls :: AbstractC -> (Doc{-temps-}, Doc{-externs-}) +pprTempAndExternDecls :: AbstractC -> (SDoc{-temps-}, SDoc{-externs-}) pprTempAndExternDecls AbsCNop = (empty, empty) pprTempAndExternDecls (AbsCStmts stmt1 stmt2) @@ -1134,11 +1114,11 @@ pprTempAndExternDecls other_stmt Just pp -> pp ) ) -pprBasicLit :: PprStyle -> Literal -> Doc -pprPrimKind :: PprStyle -> PrimRep -> Doc +pprBasicLit :: Literal -> SDoc +pprPrimKind :: PrimRep -> SDoc -pprBasicLit sty lit = text (showLiteral sty lit) -pprPrimKind sty k = text (showPrimRep k) +pprBasicLit lit = ppr lit +pprPrimKind k = ppr k \end{code} @@ -1211,11 +1191,11 @@ labelSeenTE label env@(seen_uniqs, seen_labels) \end{code} \begin{code} -pprTempDecl :: Unique -> PrimRep -> Doc +pprTempDecl :: Unique -> PrimRep -> SDoc pprTempDecl uniq kind - = hcat [ pprPrimKind PprDebug kind, space, pprUnique uniq, ptext SLIT("_;") ] + = hcat [ pprPrimKind kind, space, pprUnique uniq, ptext SLIT("_;") ] -pprExternDecl :: CLabel -> PrimRep -> Doc +pprExternDecl :: CLabel -> PrimRep -> SDoc pprExternDecl clabel kind = if not (needsCDecl clabel) then @@ -1227,12 +1207,12 @@ pprExternDecl clabel kind _ -> ppLocalnessMacro False{-data-} clabel ) of { pp_macro_str -> - hcat [ pp_macro_str, lparen, pprCLabel PprForC clabel, pp_paren_semi ] + hcat [ pp_macro_str, lparen, pprCLabel clabel, pp_paren_semi ] } \end{code} \begin{code} -ppr_decls_AbsC :: AbstractC -> TeM (Maybe Doc{-temps-}, Maybe Doc{-externs-}) +ppr_decls_AbsC :: AbstractC -> TeM (Maybe SDoc{-temps-}, Maybe SDoc{-externs-}) ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing) @@ -1317,7 +1297,7 @@ ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes \end{code} \begin{code} -ppr_decls_Amode :: CAddrMode -> TeM (Maybe Doc, Maybe Doc) +ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc) ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing) ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing) ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing) @@ -1390,7 +1370,7 @@ ppr_decls_Amode (CMacroExpr _ _ amodes) ppr_decls_Amode other = returnTE (Nothing, Nothing) -maybe_vcat :: [(Maybe Doc, Maybe Doc)] -> (Maybe Doc, Maybe Doc) +maybe_vcat :: [(Maybe SDoc, Maybe SDoc)] -> (Maybe SDoc, Maybe SDoc) maybe_vcat ps = case (unzip ps) of { (ts, es) -> case (catMaybes ts) of { real_ts -> @@ -1401,7 +1381,7 @@ maybe_vcat ps \end{code} \begin{code} -ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Doc, Maybe Doc) +ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe SDoc, Maybe SDoc) ppr_decls_Amodes amodes = mapTE ppr_decls_Amode amodes `thenTE` \ ps -> returnTE ( maybe_vcat ps ) diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index 82a446bbad..b10fec9390 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -13,22 +13,35 @@ types that \end{itemize} \begin{code} -#include "HsVersions.h" - module BasicTypes( - SYN_IE(Version), SYN_IE(Arity), - SYN_IE(Module), moduleString, pprModule, + Version, Arity, + Unused, unused, + Module, moduleString, pprModule, Fixity(..), FixityDirection(..), - NewOrData(..), IfaceFlavour(..) + NewOrData(..), IfaceFlavour(..), TopLevelFlag(..), RecFlag(..) ) where -IMP_Ubiq() +#include "HsVersions.h" -import Pretty import Outputable +\end{code} + +%************************************************************************ +%* * +\subsection[Unused]{Unused} +%* * +%************************************************************************ + +Used as a placeholder in types. + +\begin{code} +type Unused = Void +unused :: Unused +unused = error "Unused is used!" \end{code} + %************************************************************************ %* * \subsection[Arity]{Arity} @@ -63,8 +76,8 @@ type Module = FAST_STRING moduleString :: Module -> String moduleString mod = _UNPK_ mod -pprModule :: PprStyle -> Module -> Doc -pprModule sty m = ptext m +pprModule :: Module -> SDoc +pprModule m = ptext m \end{code} %************************************************************************ @@ -112,12 +125,12 @@ data FixityDirection = InfixL | InfixR | InfixN deriving(Eq) instance Outputable Fixity where - ppr sty (Fixity prec dir) = hcat [ppr sty dir, space, int prec] + ppr (Fixity prec dir) = hcat [ppr dir, space, int prec] instance Outputable FixityDirection where - ppr sty InfixL = ptext SLIT("infixl") - ppr sty InfixR = ptext SLIT("infixr") - ppr sty InfixN = ptext SLIT("infix") + ppr InfixL = ptext SLIT("infixl") + ppr InfixR = ptext SLIT("infixr") + ppr InfixN = ptext SLIT("infix") instance Eq Fixity where -- Used to determine if two fixities conflict (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2 @@ -132,7 +145,35 @@ instance Eq Fixity where -- Used to determine if two fixities conflict \begin{code} data NewOrData - = NewType -- "newtype Blah ..." - | DataType -- "data Blah ..." - deriving( Eq ) + = NewType -- "newtype Blah ..." + | DataType -- "data Blah ..." + deriving( Eq ) -- Needed because Demand derives Eq +\end{code} + +The @RecFlag@ tells whether the thing is part of a recursive group or not. + + +%************************************************************************ +%* * +\subsection[Top-level/local]{Top-level/not-top level flag} +%* * +%************************************************************************ + +\begin{code} +data TopLevelFlag + = TopLevel + | NotTopLevel +\end{code} + + +%************************************************************************ +%* * +\subsection[Top-level/local]{Top-level/not-top level flag} +%* * +%************************************************************************ + +\begin{code} +data RecFlag + = Recursive + | NonRecursive \end{code} diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs index bd9c7c3e10..8592da40c8 100644 --- a/ghc/compiler/basicTypes/Demand.lhs +++ b/ghc/compiler/basicTypes/Demand.lhs @@ -4,8 +4,6 @@ \section[Demand]{@Demand@: the amount of demand on a value} \begin{code} -#include "HsVersions.h" - module Demand( Demand(..), @@ -15,9 +13,10 @@ module Demand( showDemands ) where +#include "HsVersions.h" + import BasicTypes ( NewOrData(..) ) import Outputable -import Pretty ( Doc, text ) import Util ( panic ) \end{code} @@ -147,5 +146,5 @@ show_demand (WwUnpack nd wu args) rest = ch:'(':showList args (')' : rest) | otherwise -> 'n' instance Outputable Demand where - ppr sty si = text (showList [si] "") + ppr si = text (showList [si] "") \end{code} diff --git a/ghc/compiler/basicTypes/FieldLabel.lhs b/ghc/compiler/basicTypes/FieldLabel.lhs index ccaf094620..683d8fd91f 100644 --- a/ghc/compiler/basicTypes/FieldLabel.lhs +++ b/ghc/compiler/basicTypes/FieldLabel.lhs @@ -4,14 +4,12 @@ \section[FieldLabel]{The @FieldLabel@ type} \begin{code} -#include "HsVersions.h" - module FieldLabel where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import Name ( Name{-instance Eq/Outputable-}, NamedThing(..), nameUnique ) -import Type ( SYN_IE(Type) ) +import Type ( Type ) import Outputable import Unique ( Uniquable(..) ) @@ -48,7 +46,7 @@ instance Eq FieldLabel where (FieldLabel n1 _ _) == (FieldLabel n2 _ _) = n1 == n2 instance Outputable FieldLabel where - ppr sty (FieldLabel n _ _) = ppr sty n + ppr (FieldLabel n _ _) = ppr n instance NamedThing FieldLabel where getName (FieldLabel n _ _) = n diff --git a/ghc/compiler/basicTypes/Id.hi-boot b/ghc/compiler/basicTypes/Id.hi-boot index c9591e87e0..7b3f99d6a6 100644 --- a/ghc/compiler/basicTypes/Id.hi-boot +++ b/ghc/compiler/basicTypes/Id.hi-boot @@ -5,10 +5,13 @@ _declarations_ 1 type Id = Id.GenId Type!Type ; 1 data GenId ty ; 1 data StrictnessMark = MarkedStrict | NotMarkedStrict ; -1 dataConArgTys _:_ Id -> [Type!Type] -> [Type!Type] ;; + +-- Not needed any more by Type.lhs +-- 1 dataConArgTys _:_ Id -> [Type!Type] -> [Type!Type] ;; + 1 idType _:_ Id.Id -> Type!Type ;; 1 isNullaryDataCon _:_ Id -> PrelBase.Bool ;; -1 mkDataCon _:_ Name.Name -> [Id.StrictnessMark] -> [FieldLabel.FieldLabel] -> [TyVar.TyVar] -> Type.ThetaType -> [TyVar.TyVar] -> Type!ThetaType -> [Type!TauType] -> TyCon!TyCon -> Id ;; +1 mkDataCon _:_ Name.Name -> [Id.StrictnessMark] -> [FieldLabel!FieldLabel] -> [TyVar.TyVar] -> Type.ThetaType -> [TyVar.TyVar] -> Type!ThetaType -> [Type!TauType] -> TyCon!TyCon -> Id ;; 1 mkTupleCon _:_ PrelBase.Int -> Name.Name -> Type!Type -> Id ;; -1 pprId _:_ _forall_ [ty] {Outputable.Outputable ty} => Outputable.PprStyle -> GenId ty -> Pretty.Doc ;; +1 pprId _:_ _forall_ [ty] {Outputable.Outputable ty} => GenId ty -> Outputable.SDoc ;; 1 idName _:_ _forall_ [ty] => GenId ty -> Name.Name ;; diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 3f4d8e170e..dc1cca8b55 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -1,18 +1,16 @@ -% + % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[Id]{@Ids@: Value and constructor identifiers} \begin{code} -#include "HsVersions.h" - module Id ( -- TYPES GenId(..), -- *naughtily* used in some places (e.g., TcHsSyn) - SYN_IE(Id), IdDetails, + Id, IdDetails, StrictnessMark(..), - SYN_IE(ConTag), fIRST_TAG, - SYN_IE(DataCon), SYN_IE(DictFun), SYN_IE(DictVar), + ConTag, fIRST_TAG, + DataCon, DictFun, DictVar, -- CONSTRUCTION mkDataCon, @@ -22,7 +20,6 @@ module Id ( mkImported, mkMethodSelId, mkRecordSelId, - mkSameSpecCon, mkSuperDictSelId, mkSysLocal, mkTemplateLocals, @@ -108,7 +105,7 @@ module Id ( addInlinePragma, nukeNoInlinePragma, addNoInlinePragma, -- IdEnvs AND IdSets - SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet), + IdEnv, GenIdSet, IdSet, addOneToIdEnv, addOneToIdSet, combineIdEnvs, @@ -138,68 +135,51 @@ module Id ( unitIdSet ) where -IMP_Ubiq() +#include "HsVersions.h" -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(IdLoop) -- for paranoia checking -IMPORT_DELOOPER(TyLoop) -- for paranoia checking -#else -import {-# SOURCE #-} SpecEnv ( SpecEnv ) import {-# SOURCE #-} CoreUnfold ( Unfolding ) import {-# SOURCE #-} StdIdInfo ( addStandardIdInfo ) --- Let's see how much we can leave out.. ---import {-# SOURCE #-} TysPrim -#endif +import CmdLineOpts ( opt_PprStyle_All ) +import SpecEnv ( SpecEnv ) import Bag -import Class ( SYN_IE(Class), GenClass ) -import BasicTypes ( SYN_IE(Arity) ) +import Class ( Class ) +import BasicTypes ( Arity ) import IdInfo import Maybes ( maybeToBool ) import Name ( nameUnique, mkLocalName, mkSysLocalName, isLocalName, - mkCompoundName, mkInstDeclName, + mkCompoundName, isLocallyDefinedName, occNameString, modAndOcc, isLocallyDefined, changeUnique, isWiredInName, nameString, getOccString, setNameVisibility, isExported, ExportFlag(..), Provenance, - OccName(..), Name, SYN_IE(Module), + OccName(..), Name, Module, NamedThing(..) ) +import PrimOp ( PrimOp ) import PrelMods ( pREL_TUP, pREL_BASE ) import Lex ( mkTupNameStr ) import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} ) import PragmaInfo ( PragmaInfo(..) ) -#if __GLASGOW_HASKELL__ >= 202 -import PrimOp ( PrimOp ) -#endif -import PprType ( getTypeString, specMaybeTysSuffix, - GenType, GenTyVar - ) -import Pretty -import MatchEnv ( MatchEnv ) import SrcLoc ( mkBuiltinSrcLoc ) import TysWiredIn ( tupleTyCon ) import TyCon ( TyCon, tyConDataCons, isDataTyCon, isNewTyCon, mkSpecTyCon ) -import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy, splitSigmaTy, - applyTyCon, instantiateTy, mkForAllTys, - tyVarsOfType, applyTypeEnvToTy, typePrimRep, - specialiseTy, instantiateTauTy, - GenType, SYN_IE(ThetaType), SYN_IE(TauType), SYN_IE(Type) +import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, splitSigmaTy, + mkTyConApp, instantiateTy, mkForAllTys, + tyVarsOfType, instantiateTy, typePrimRep, + instantiateTauTy, + GenType, ThetaType, TauType, Type + ) +import TyVar ( TyVar, alphaTyVars, isEmptyTyVarSet, + TyVarEnv, zipTyVarEnv, mkTyVarEnv ) -import TyVar ( SYN_IE(TyVar), GenTyVar, alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) ) -import Usage ( SYN_IE(UVar) ) import UniqFM import UniqSet -- practically all of it -import Unique ( getBuiltinUniques, pprUnique, - incrUnique, - Unique{-instance Ord3-}, - Uniquable(..) - ) -import Outputable ( ifPprDebug, Outputable(..), PprStyle(..) ) +import Unique ( getBuiltinUniques, pprUnique, Unique, Uniquable(..) ) +import Outputable import SrcLoc ( SrcLoc ) -import Util ( Ord3(..), mapAccumL, nOfThem, zipEqual, assoc, - panic, panic#, pprPanic, assertPanic - ) +import Util ( mapAccumL, nOfThem, zipEqual, assoc ) +import GlaExts ( Int# ) \end{code} Here are the @Id@ and @IdDetails@ datatypes; also see the notes that @@ -255,8 +235,8 @@ data IdDetails [FieldLabel] -- Field labels for this constructor; --length = 0 (not a record) or arity - [TyVar] [(Class,Type)] -- Type vars and context for the data type decl - [TyVar] [(Class,Type)] -- Ditto for the context of the constructor, + [TyVar] ThetaType -- Type vars and context for the data type decl + [TyVar] ThetaType -- Ditto for the context of the constructor, -- the existentially quantified stuff [Type] TyCon -- Args and result tycon -- the type is: @@ -287,7 +267,7 @@ data IdDetails -- see below | DictFunId Class -- A DictFun is uniquely identified - Type -- by its class and type; this type has free type vars, + [Type] -- by its class and type; this type has free type vars, -- whose identity is irrelevant. Eg Class = Eq -- Type = Tree a -- The "a" is irrelevant. As it is too painful to @@ -632,7 +612,7 @@ type TypeEnv = TyVarEnv Type applyTypeEnvToId :: TypeEnv -> Id -> Id applyTypeEnvToId type_env id@(Id _ _ ty _ _ _) = apply_to_Id ( \ ty -> - applyTypeEnvToTy type_env ty + instantiateTy type_env ty ) id \end{code} @@ -701,10 +681,10 @@ mkMethodSelId op_name rec_c ty mkDefaultMethodId dm_name rec_c ty = Id (uniqueOf dm_name) dm_name ty (DefaultMethodId rec_c) NoPragmaInfo noIdInfo -mkDictFunId dfun_name full_ty clas ity +mkDictFunId dfun_name full_ty clas itys = Id (nameUnique dfun_name) dfun_name full_ty details NoPragmaInfo noIdInfo where - details = DictFunId clas ity + details = DictFunId clas itys mkWorkerId u unwrkr ty info = Id u name ty details NoPragmaInfo info @@ -732,16 +712,12 @@ mkPrimitiveId n ty primop \end{code} \begin{code} - -type MyTy a b = GenType (GenTyVar a) b -type MyId a b = GenId (MyTy a b) - no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty) -- SysLocal: for an Id being created by the compiler out of thin air... -- UserLocal: an Id with a name the user might recognize... -mkSysLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b -mkUserLocal :: OccName -> Unique -> MyTy a b -> SrcLoc -> MyId a b +mkSysLocal :: FAST_STRING -> Unique -> GenType flexi -> SrcLoc -> GenId (GenType flexi) +mkUserLocal :: OccName -> Unique -> GenType flexi -> SrcLoc -> GenId (GenType flexi) mkSysLocal str uniq ty loc = Id uniq (mkSysLocalName uniq str loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo @@ -749,7 +725,7 @@ mkSysLocal str uniq ty loc mkUserLocal occ uniq ty loc = Id uniq (mkLocalName uniq occ loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo -mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b +mkUserId :: Name -> GenType flexi -> PragmaInfo -> GenId (GenType flexi) mkUserId name ty pragma_info = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo \end{code} @@ -772,6 +748,7 @@ mkIdWithNewType :: Id -> Type -> Id mkIdWithNewType (Id u name _ details pragma info) ty = Id u name ty details pragma info +{- -- Specialised version of constructor: only used in STG and code generation -- Note: The specialsied Id has the same unique as the unspeced Id @@ -783,7 +760,8 @@ mkSameSpecCon ty_maybes unspec@(Id u name ty details pragma info) new_ty = specialiseTy ty ty_maybes 0 -- pprTrace "SameSpecCon:Unique:" - -- (ppSep (ppr PprDebug unspec: [pprMaybeTy PprDebug ty | ty <- ty_maybes])) + -- (ppSep (ppr unspec: [pprMaybeTy ty | ty <- ty_maybes])) +-} \end{code} Make some local @Ids@ for a template @CoreExpr@. These have bogus @@ -865,7 +843,7 @@ mkDataCon n stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon data_con_ty = mkSigmaTy (tvs++con_tvs) (ctxt++con_ctxt) - (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs))) + (mkFunTys args_tys (mkTyConApp tycon (mkTyVarTys tvs))) mkTupleCon :: Arity -> Name -> Type -> Id @@ -888,7 +866,8 @@ dictionaries \begin{code} dataConNumFields id - = ASSERT(isDataCon id) + = ASSERT( if (isDataCon id) then True else + pprTrace "dataConNumFields" (ppr id) False ) case (dataConSig id) of { (_, _, _, con_theta, arg_tys, _) -> length con_theta + length arg_tys } @@ -918,6 +897,7 @@ dataConSig (Id _ _ _ (TupleConId arity) _ _) where tyvars = take arity alphaTyVars tyvar_tys = mkTyVarTys tyvars + dataConSig (Id _ _ _ (SpecId unspec ty_maybes _) _ _) = (spec_tyvars, spec_theta_ty, spec_con_tyvars, spec_con_theta, spec_arg_tys, spec_tycon) where @@ -925,15 +905,10 @@ dataConSig (Id _ _ _ (SpecId unspec ty_maybes _) _ _) ty_env = tyvars `zip` ty_maybes - spec_tyvars = foldr nothing_tyvars [] ty_env - spec_con_tyvars = foldr nothing_tyvars [] (con_tyvars `zip` ty_maybes) -- Hmm.. + spec_tyvars = [tyvar | (tyvar, Nothing) <- ty_env] + spec_con_tyvars = [tyvar | (tyvar, Nothing) <- con_tyvars `zip` ty_maybes] -- Hmm.. - nothing_tyvars (tyvar, Nothing) l = tyvar : l - nothing_tyvars (tyvar, Just ty) l = l - - spec_env = foldr just_env [] ty_env - just_env (tyvar, Nothing) l = l - just_env (tyvar, Just ty) l = (tyvar, ty) : l + spec_env = mkTyVarEnv [(tyvar, ty) | (tyvar, Just ty) <- ty_env] spec_arg_tys = map (instantiateTauTy spec_env) arg_tys spec_theta_ty = if null theta_ty then [] @@ -946,7 +921,10 @@ dataConSig (Id _ _ _ (SpecId unspec ty_maybes _) _ _) -- dataConRepType returns the type of the representation of a contructor -- This may differ from the type of the contructor Id itself for two reasons: -- a) the constructor Id may be overloaded, but the dictionary isn't stored +-- e.g. data Eq a => T a = MkT a a +-- -- b) the constructor may store an unboxed version of a strict field. +-- -- Here's an example illustrating both: -- data Ord a => T a = MkT Int! a -- Here @@ -955,11 +933,13 @@ dataConSig (Id _ _ _ (SpecId unspec ty_maybes _) _ _) -- Trep :: Int# -> a -> T a -- Actually, the unboxed part isn't implemented yet! -dataConRepType :: GenId (GenType tv u) -> GenType tv u -dataConRepType con - = mkForAllTys tyvars tau - where - (tyvars, theta, tau) = splitSigmaTy (idType con) +dataConRepType :: Id -> Type +dataConRepType (Id _ _ _ (AlgConId _ _ _ tyvars theta con_tyvars con_theta arg_tys tycon) _ _) + = mkForAllTys (tyvars++con_tyvars) + (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))) +dataConRepType other_id + = ASSERT( isDataCon other_id ) + idType other_id dataConFieldLabels :: DataCon -> [FieldLabel] dataConFieldLabels (Id _ _ _ (AlgConId _ _ fields _ _ _ _ _ _) _ _) = fields @@ -996,7 +976,7 @@ dataConArgTys con_id inst_tys = map (instantiateTy tenv) arg_tys where (tyvars, _, _, _, arg_tys, _) = dataConSig con_id - tenv = zipEqual "dataConArgTys" tyvars inst_tys + tenv = zipTyVarEnv tyvars inst_tys \end{code} \begin{code} @@ -1129,10 +1109,10 @@ addIdFBTypeInfo (Id u n ty info details) upd_info \end{code} \begin{code} -getIdSpecialisation :: Id -> SpecEnv +getIdSpecialisation :: Id -> IdSpecEnv getIdSpecialisation (Id _ _ _ _ _ info) = specInfo info -addIdSpecialisation :: Id -> SpecEnv -> Id +addIdSpecialisation :: Id -> IdSpecEnv -> Id addIdSpecialisation (Id u n ty details prags info) spec_info = Id u n ty details prags (info `addSpecInfo` spec_info) \end{code} @@ -1158,24 +1138,21 @@ addIdStrictness (Id u n ty details prags info) strict_info Comparison: equality and ordering---this stuff gets {\em hammered}. \begin{code} -cmpId (Id u1 _ _ _ _ _) (Id u2 _ _ _ _ _) = cmp u1 u2 +cmpId (Id u1 _ _ _ _ _) (Id u2 _ _ _ _ _) = compare u1 u2 -- short and very sweet \end{code} \begin{code} -instance Ord3 (GenId ty) where - cmp = cmpId - instance Eq (GenId ty) where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } instance Ord (GenId ty) where - a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpId a b \end{code} @cmpId_withSpecDataCon@ ensures that any spectys are taken into @@ -1184,7 +1161,7 @@ because a specialised data constructor has the same Unique as its unspecialised counterpart. \begin{code} -cmpId_withSpecDataCon :: Id -> Id -> TAG_ +cmpId_withSpecDataCon :: Id -> Id -> Ordering cmpId_withSpecDataCon id1 id2 | eq_ids && isDataCon id1 && isDataCon id2 @@ -1194,14 +1171,14 @@ cmpId_withSpecDataCon id1 id2 = cmp_ids where cmp_ids = cmpId id1 id2 - eq_ids = case cmp_ids of { EQ_ -> True; other -> False } + eq_ids = case cmp_ids of { EQ -> True; other -> False } cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _) _ _) (Id _ _ _ (SpecId _ mtys2 _) _ _) - = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2" + = panic "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2" -cmpEqDataCon _ (Id _ _ _ (SpecId _ _ _) _ _) = LT_ -cmpEqDataCon (Id _ _ _ (SpecId _ _ _) _ _) _ = GT_ -cmpEqDataCon _ _ = EQ_ +cmpEqDataCon _ (Id _ _ _ (SpecId _ _ _) _ _) = LT +cmpEqDataCon (Id _ _ _ (SpecId _ _ _) _ _) _ = GT +cmpEqDataCon _ _ = EQ \end{code} %************************************************************************ @@ -1212,28 +1189,25 @@ cmpEqDataCon _ _ = EQ_ \begin{code} instance Outputable ty => Outputable (GenId ty) where - ppr sty id = pprId sty id - --- and a SPECIALIZEd one: -instance Outputable {-Id, i.e.:-}(GenId Type) where - ppr sty id = pprId sty id + ppr id = pprId id -showId :: PprStyle -> Id -> String -showId sty id = show (pprId sty id) +showId :: Id -> String +showId id = showSDoc (pprId id) \end{code} Default printing code (not used for interfaces): \begin{code} -pprId :: Outputable ty => PprStyle -> GenId ty -> Doc +pprId :: Outputable ty => GenId ty -> SDoc -pprId sty (Id u n _ _ prags _) - = hcat [ppr sty n, pp_prags] +pprId (Id u n _ _ prags _) + = hcat [ppr n, pp_prags] where - pp_prags = ifPprDebug sty (case prags of - IMustNotBeINLINEd -> text "{n}" - IWantToBeINLINEd -> text "{i}" - IMustBeINLINEd -> text "{I}" - other -> empty) + pp_prags | opt_PprStyle_All = case prags of + IMustNotBeINLINEd -> text "{n}" + IWantToBeINLINEd -> text "{i}" + IMustBeINLINEd -> text "{I}" + other -> empty + | otherwise = empty -- WDP 96/05/06: We can re-elaborate this as we go along... \end{code} diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index b9e81f9d6c..da096ebc19 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -7,8 +7,6 @@ Haskell. [WDP 94/11]) \begin{code} -#include "HsVersions.h" - module IdInfo ( IdInfo, -- Abstract @@ -32,48 +30,34 @@ module IdInfo ( unfoldInfo, addUnfoldInfo, - specInfo, addSpecInfo, + IdSpecEnv, specInfo, addSpecInfo, - UpdateInfo, SYN_IE(UpdateSpec), + UpdateInfo, UpdateSpec, mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, addUpdateInfo, - ArgUsageInfo, ArgUsage(..), SYN_IE(ArgUsageType), + ArgUsageInfo, ArgUsage(..), ArgUsageType, mkArgUsageInfo, argUsageInfo, addArgUsageInfo, getArgUsage, FBTypeInfo, FBType(..), FBConsum(..), FBProd(..), fbTypeInfo, ppFBTypeInfo, addFBTypeInfo, mkFBTypeInfo, getFBType ) where -IMP_Ubiq() -IMPORT_1_3(Char(toLower)) +#include "HsVersions.h" -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and - -- we break those loops by using IdLoop and - -- *not* importing much of anything else, - -- except from the very general "utils". -#else -import {-# SOURCE #-} SpecEnv -import {-# SOURCE #-} Id -import {-# SOURCE #-} CoreUnfold -import {-# SOURCE #-} StdIdInfo -#endif +import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding ) +import {-# SOURCE #-} CoreSyn ( SimplifiableCoreExpr ) + +import SpecEnv ( SpecEnv, emptySpecEnv, isEmptySpecEnv ) import BasicTypes ( NewOrData ) -import CmdLineOpts ( opt_OmitInterfacePragmas ) import Demand import Maybes ( firstJust ) -import Outputable ( ifaceStyle, PprStyle(..), Outputable(..){-instances-} ) -import Pretty -import PprType () +import Outputable import Unique ( pprUnique ) -import Util ( mapAccumL, panic, assertPanic, pprPanic ) +import Util ( mapAccumL ) -#ifdef REALLY_HASKELL_1_3 ord = fromEnum :: Char -> Int -#endif - showTypeCategory = panic "IdInfo.showTypeCategory" \end{code} @@ -97,7 +81,7 @@ data IdInfo DemandInfo -- Whether or not it is definitely -- demanded - SpecEnv -- Specialisations of this function which exist + IdSpecEnv -- Specialisations of this function which exist StrictnessInfo -- Strictness properties @@ -112,7 +96,7 @@ data IdInfo \end{code} \begin{code} -noIdInfo = IdInfo UnknownArity UnknownDemand nullSpecEnv NoStrictnessInfo noUnfolding +noIdInfo = IdInfo UnknownArity UnknownDemand emptySpecEnv NoStrictnessInfo noUnfolding NoUpdateInfo NoArgUsageInfo NoFBTypeInfo \end{code} @@ -122,7 +106,7 @@ nasty loop, friends...) \begin{code} apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold update arg_usage fb_ww) - | isNullSpecEnv spec + | isEmptySpecEnv spec = idinfo | otherwise = panic "IdInfo:apply_to_IdInfo" @@ -136,19 +120,18 @@ applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold \end{code} \begin{code} -ppIdInfo :: PprStyle - -> Bool -- True <=> print specialisations, please +ppIdInfo :: Bool -- True <=> print specialisations, please -> IdInfo - -> Doc + -> SDoc -ppIdInfo sty specs_please +ppIdInfo specs_please (IdInfo arity demand specenv strictness unfold update arg_usage fbtype) = hsep [ -- order is important!: - ppArityInfo sty arity, - ppUpdateInfo sty update, + ppArityInfo arity, + ppUpdateInfo update, - ppStrictnessInfo sty strictness, + ppStrictnessInfo strictness, if specs_please then empty -- ToDo -- sty (not (isDataCon for_this_id)) @@ -156,8 +139,8 @@ ppIdInfo sty specs_please else empty, -- DemandInfo needn't be printed since it has no effect on interfaces - ppDemandInfo sty demand, - ppFBTypeInfo sty fbtype + ppDemandInfo demand, + ppFBTypeInfo fbtype ] \end{code} @@ -183,9 +166,9 @@ arityInfo (IdInfo arity _ _ _ _ _ _ _) = arity addArityInfo (IdInfo _ a b c d e f g) arity = IdInfo arity a b c d e f g -ppArityInfo sty UnknownArity = empty -ppArityInfo sty (ArityExactly arity) = hsep [ptext SLIT("_A_"), int arity] -ppArityInfo sty (ArityAtLeast arity) = hsep [ptext SLIT("_A>_"), int arity] +ppArityInfo UnknownArity = empty +ppArityInfo (ArityExactly arity) = hsep [ptext SLIT("_A_"), int arity] +ppArityInfo (ArityAtLeast arity) = hsep [ptext SLIT("_A>_"), int arity] \end{code} %************************************************************************ @@ -223,9 +206,8 @@ demandInfo (IdInfo _ demand _ _ _ _ _ _) = demand addDemandInfo (IdInfo a _ c d e f g h) demand = IdInfo a demand c d e f g h -ppDemandInfo PprInterface _ = empty -ppDemandInfo sty UnknownDemand = text "{-# L #-}" -ppDemandInfo sty (DemandedAsPer info) = hsep [text "{-#", text (showList [info] ""), text "#-}"] +ppDemandInfo UnknownDemand = text "{-# L #-}" +ppDemandInfo (DemandedAsPer info) = hsep [text "{-#", text (showList [info] ""), text "#-}"] \end{code} %************************************************************************ @@ -234,15 +216,47 @@ ppDemandInfo sty (DemandedAsPer info) = hsep [text "{-#", text (showList [info] %* * %************************************************************************ -See SpecEnv.lhs +A @IdSpecEnv@ holds details of an @Id@'s specialisations. + +\begin{code} +type IdSpecEnv = SpecEnv SimplifiableCoreExpr +\end{code} + +For example, if \tr{f}'s @SpecEnv@ contains the mapping: +\begin{verbatim} + [List a, b] ===> (\d -> f' a b) +\end{verbatim} +then when we find an application of f to matching types, we simply replace +it by the matching RHS: +\begin{verbatim} + f (List Int) Bool ===> (\d -> f' Int Bool) +\end{verbatim} +All the stuff about how many dictionaries to discard, and what types +to apply the specialised function to, are handled by the fact that the +SpecEnv contains a template for the result of the specialisation. + +There is one more exciting case, which is dealt with in exactly the same +way. If the specialised value is unboxed then it is lifted at its +definition site and unlifted at its uses. For example: + + pi :: forall a. Num a => a + +might have a specialisation + + [Int#] ===> (case pi' of Lift pi# -> pi#) + +where pi' :: Lift Int# is the specialised version of pi. + \begin{code} +specInfo :: IdInfo -> IdSpecEnv specInfo (IdInfo _ _ spec _ _ _ _ _) = spec -addSpecInfo id_info spec | isNullSpecEnv spec = id_info +addSpecInfo id_info spec | isEmptySpecEnv spec = id_info addSpecInfo (IdInfo a b _ d e f g h) spec = IdInfo a b spec d e f g h \end{code} + %************************************************************************ %* * \subsection[strictness-IdInfo]{Strictness info about an @Id@} @@ -305,10 +319,10 @@ strictnessInfo (IdInfo _ _ _ strict _ _ _ _) = strict addStrictnessInfo id_info NoStrictnessInfo = id_info addStrictnessInfo (IdInfo a b d _ e f g h) strict = IdInfo a b d strict e f g h -ppStrictnessInfo sty NoStrictnessInfo = empty -ppStrictnessInfo sty BottomGuaranteed = ptext SLIT("_bot_") +ppStrictnessInfo NoStrictnessInfo = empty +ppStrictnessInfo BottomGuaranteed = ptext SLIT("_bot_") -ppStrictnessInfo sty (StrictnessInfo wrapper_args wrkr_maybe) +ppStrictnessInfo (StrictnessInfo wrapper_args wrkr_maybe) = hsep [ptext SLIT("_S_"), text (showList wrapper_args "")] \end{code} @@ -376,9 +390,9 @@ updateInfo (IdInfo _ _ _ _ _ update _ _) = update addUpdateInfo id_info NoUpdateInfo = id_info addUpdateInfo (IdInfo a b d e f _ g h) upd_info = IdInfo a b d e f upd_info g h -ppUpdateInfo sty NoUpdateInfo = empty -ppUpdateInfo sty (SomeUpdateInfo []) = empty -ppUpdateInfo sty (SomeUpdateInfo spec) = (<>) (ptext SLIT("_U_ ")) (hcat (map int spec)) +ppUpdateInfo NoUpdateInfo = empty +ppUpdateInfo (SomeUpdateInfo []) = empty +ppUpdateInfo (SomeUpdateInfo spec) = (<>) (ptext SLIT("_U_ ")) (hcat (map int spec)) \end{code} %************************************************************************ @@ -413,8 +427,8 @@ argUsageInfo (IdInfo _ _ _ _ _ _ au _) = au addArgUsageInfo id_info NoArgUsageInfo = id_info addArgUsageInfo (IdInfo a b d e f g _ h) au_info = IdInfo a b d e f g au_info h -ppArgUsageInfo sty NoArgUsageInfo = empty -ppArgUsageInfo sty (SomeArgUsageInfo aut) = (<>) (ptext SLIT("_L_ ")) (ppArgUsageType aut) +ppArgUsageInfo NoArgUsageInfo = empty +ppArgUsageInfo (SomeArgUsageInfo aut) = (<>) (ptext SLIT("_L_ ")) (ppArgUsageType aut) ppArgUsage (ArgUsage n) = int n ppArgUsage (UnknownArgUsage) = char '-' @@ -456,8 +470,8 @@ fbTypeInfo (IdInfo _ _ _ _ _ _ _ fb) = fb addFBTypeInfo id_info NoFBTypeInfo = id_info addFBTypeInfo (IdInfo a b d e f g h _) fb_info = IdInfo a b d e f g h fb_info -ppFBTypeInfo sty NoFBTypeInfo = empty -ppFBTypeInfo sty (SomeFBTypeInfo (FBType cons prod)) +ppFBTypeInfo NoFBTypeInfo = empty +ppFBTypeInfo (SomeFBTypeInfo (FBType cons prod)) = (<>) (ptext SLIT("_F_ ")) (ppFBType cons prod) ppFBType cons prod = hcat diff --git a/ghc/compiler/basicTypes/IdLoop.lhi b/ghc/compiler/basicTypes/IdLoop.lhi deleted file mode 100644 index 48ea6b101d..0000000000 --- a/ghc/compiler/basicTypes/IdLoop.lhi +++ /dev/null @@ -1,111 +0,0 @@ -Breaks the IdInfo/<everything> loops. - -\begin{code} -interface IdLoop where - ---import PreludePS ( _PackedString ) -import FastString ( FastString ) -import PreludeStdIO ( Maybe ) - -import BinderInfo ( BinderInfo ) -import CoreSyn ( CoreExpr(..), GenCoreExpr, GenCoreArg ) -import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), mkUnfolding, - SimpleUnfolding(..), FormSummary(..), noUnfolding ) -import CoreUtils ( unTagBinders ) -import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId, - unfoldingUnfriendlyId, getIdInfo, nmbrId, pprId, idName, - nullIdEnv, lookupIdEnv, IdEnv(..), - Id(..), GenId - ) -import Name ( Name ) -import CostCentre ( CostCentre, - noCostCentre, subsumedCosts, cafifyCC, - useCurrentCostCentre, dontCareCostCentre, - overheadCostCentre, preludeCafsCostCentre, - preludeDictsCostCentre, mkAllCafsCC, - mkAllDictsCC, mkUserCC - ) -import IdInfo ( IdInfo, DemandInfo ) -import SpecEnv ( SpecEnv, nullSpecEnv, isNullSpecEnv ) -import Literal ( Literal ) -import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun ) -import OccurAnal ( occurAnalyseGlobalExpr ) -import Outputable ( Outputable(..), PprStyle ) -import PprType ( pprParendGenType ) -import PragmaInfo ( PragmaInfo ) -import Pretty ( Doc ) -import Type ( GenType ) -import TyVar ( GenTyVar ) -import UniqFM ( UniqFM ) -import Unique ( Unique ) -import Usage ( GenUsage ) -import Util ( Ord3(..) ) -import WwLib ( mAX_WORKER_ARGS ) -import StdIdInfo ( addStandardIdInfo ) -- Used in Id, but StdIdInfo needs lots of stuff from Id - -addStandardIdInfo :: Id -> Id - -nullSpecEnv :: SpecEnv -isNullSpecEnv :: SpecEnv -> Bool - --- occurAnalyseGlobalExpr :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique --- unTagBinders :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), a) b c d -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) b c d - -externallyVisibleId :: Id -> Bool -isDataCon :: GenId ty -> Bool -isWorkerId :: GenId ty -> Bool -pprId :: Outputable ty => PprStyle -> GenId ty -> Doc -mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun -idName :: Id -> Name - - -type IdEnv a = UniqFM a -type CoreExpr = GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) - (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) - (GenTyVar (GenUsage Unique)) Unique - -instance Outputable UnfoldingGuidance -instance Eq Unique -instance Outputable Unique -instance Eq (GenTyVar a) -instance Ord3 (GenTyVar a) -instance Outputable (GenTyVar a) -instance (Outputable a) => Outputable (GenId a) -instance (Eq a, Outputable a, Eq b, Outputable b) => Outputable (GenType a b) - -data DemandInfo -data SpecEnv -data MagicUnfoldingFun -data FormSummary = VarForm | ValueForm | BottomForm | OtherForm - --- data Unfolding --- = NoUnfolding --- | CoreUnfolding SimpleUnfolding --- | MagicUnfolding Unique MagicUnfoldingFun - -data Unfolding -noUnfolding :: Unfolding -mkUnfolding :: PragmaInfo -> CoreExpr -> Unfolding - --- data SimpleUnfolding = SimpleUnfolding FormSummary UnfoldingGuidance (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) - - -data UnfoldingGuidance - = UnfoldNever - | UnfoldAlways - | UnfoldIfGoodArgs Int Int [Bool] Int - -data CostCentre - -noCostCentre :: CostCentre -subsumedCosts :: CostCentre -useCurrentCostCentre :: CostCentre -dontCareCostCentre :: CostCentre -overheadCostCentre :: CostCentre -preludeCafsCostCentre :: CostCentre -preludeDictsCostCentre :: Bool -> CostCentre -mkAllCafsCC :: FastString -> FastString -> CostCentre -mkAllDictsCC :: FastString -> FastString -> Bool -> CostCentre -mkUserCC :: FastString -> FastString -> FastString -> CostCentre -cafifyCC :: CostCentre -> CostCentre -\end{code} diff --git a/ghc/compiler/basicTypes/IdUtils.lhs b/ghc/compiler/basicTypes/IdUtils.lhs index a0d7020605..fa75ed4ae3 100644 --- a/ghc/compiler/basicTypes/IdUtils.lhs +++ b/ghc/compiler/basicTypes/IdUtils.lhs @@ -4,29 +4,20 @@ \section[IdUtils]{Constructing PrimOp Ids} \begin{code} -#include "HsVersions.h" - module IdUtils ( primOpName ) where -IMP_Ubiq() - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(PrelLoop) -- here for paranoia checking -IMPORT_DELOOPER(IdLoop) (SpecEnv) -#else -import {-# SOURCE #-} SpecEnv ( SpecEnv ) -#endif +#include "HsVersions.h" import CoreSyn -import CoreUnfold ( UnfoldingGuidance(..), Unfolding ) -import Id ( mkPrimitiveId, mkTemplateLocals ) +import CoreUnfold ( UnfoldingGuidance(..), Unfolding, mkUnfolding ) +import Id ( mkPrimitiveId ) import IdInfo -- quite a few things import StdIdInfo import Name ( mkWiredInIdName, Name ) import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str, PrimOpInfo(..), PrimOpResultInfo(..), PrimOp ) import PrelMods ( gHC__ ) -import Type ( mkForAllTys, mkFunTy, mkFunTys, mkTyVarTy, applyTyCon ) +import Type ( mkForAllTys, mkFunTy, mkFunTys, mkTyVarTy, mkTyConApp ) import TysWiredIn ( boolTy ) import Unique ( mkPrimOpIdUnique ) import Util ( panic ) @@ -52,14 +43,14 @@ primOpName op mk_prim_name op str tyvars arg_tys - (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys))) + (mkForAllTys tyvars (mkFunTys arg_tys (mkTyConApp prim_tycon res_tys))) (length arg_tys) -- arity AlgResult str tyvars arg_tys tycon res_tys -> mk_prim_name op str tyvars arg_tys - (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys))) + (mkForAllTys tyvars (mkFunTys arg_tys (mkTyConApp tycon res_tys))) (length arg_tys) -- arity where mk_prim_name prim_op occ_name tyvar_tmpls arg_tys ty arity diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index 738dcf108c..eeddb56823 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -4,8 +4,6 @@ \section[Literal]{@Literal@: Machine literals (unboxed, of course)} \begin{code} -#include "HsVersions.h" - module Literal ( Literal(..), @@ -15,24 +13,23 @@ module Literal ( isNoRepLit, isLitLitLit ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(Ratio) +#include "HsVersions.h" -- friends: import PrimRep ( PrimRep(..), ppPrimRep ) -- non-abstract import TysPrim ( getPrimRepInfo, addrPrimTy, intPrimTy, floatPrimTy, - doublePrimTy, charPrimTy, wordPrimTy ) + doublePrimTy, charPrimTy, wordPrimTy + ) -- others: +import Type ( Type ) import CStrings ( stringToC, charToC, charToEasyHaskell ) import TysWiredIn ( stringTy ) -import Pretty -- pretty-printing stuff -import Outputable ( PprStyle(..), codeStyle, ifaceStyle, Outputable(..) ) -import Util ( thenCmp, panic, pprPanic, Ord3(..) ) -#if __GLASGOW_HASKELL__ >= 202 -import Type -#endif +import Outputable +import Util ( thenCmp ) + +import GlaExts ( (<#) ) \end{code} So-called @Literals@ are {\em either}: @@ -81,49 +78,46 @@ mkMachInt, mkMachWord :: Integer -> Literal mkMachInt x = MachInt x True{-signed-} mkMachWord x = MachInt x False{-unsigned-} -instance Ord3 Literal where - cmp (MachChar a) (MachChar b) = a `tcmp` b - cmp (MachStr a) (MachStr b) = a `tcmp` b - cmp (MachAddr a) (MachAddr b) = a `tcmp` b - cmp (MachInt a b) (MachInt c d) = (a `tcmp` c) `thenCmp` (b `tcmp` d) - cmp (MachFloat a) (MachFloat b) = a `tcmp` b - cmp (MachDouble a) (MachDouble b) = a `tcmp` b - cmp (MachLitLit a b) (MachLitLit c d) = (a `tcmp` c) `thenCmp` (b `tcmp` d) - cmp (NoRepStr a) (NoRepStr b) = a `tcmp` b - cmp (NoRepInteger a _) (NoRepInteger b _) = a `tcmp` b - cmp (NoRepRational a _) (NoRepRational b _) = a `tcmp` b - - -- now we *know* the tags are different, so... - cmp other_1 other_2 - | tag1 _LT_ tag2 = LT_ - | otherwise = GT_ - where - tag1 = tagof other_1 - tag2 = tagof other_2 - - tagof (MachChar _) = ILIT(1) - tagof (MachStr _) = ILIT(2) - tagof (MachAddr _) = ILIT(3) - tagof (MachInt _ _) = ILIT(4) - tagof (MachFloat _) = ILIT(5) - tagof (MachDouble _) = ILIT(6) - tagof (MachLitLit _ _) = ILIT(7) - tagof (NoRepStr _) = ILIT(8) - tagof (NoRepInteger _ _) = ILIT(9) - tagof (NoRepRational _ _) = ILIT(10) +cmpLit (MachChar a) (MachChar b) = a `compare` b +cmpLit (MachStr a) (MachStr b) = a `compare` b +cmpLit (MachAddr a) (MachAddr b) = a `compare` b +cmpLit (MachInt a b) (MachInt c d) = (a `compare` c) `thenCmp` (b `compare` d) +cmpLit (MachFloat a) (MachFloat b) = a `compare` b +cmpLit (MachDouble a) (MachDouble b) = a `compare` b +cmpLit (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `compare` d) +cmpLit (NoRepStr a) (NoRepStr b) = a `compare` b +cmpLit (NoRepInteger a _) (NoRepInteger b _) = a `compare` b +cmpLit (NoRepRational a _) (NoRepRational b _) = a `compare` b + + -- now we *know* the tags are different, so... +cmpLit other_1 other_2 + | tag1 _LT_ tag2 = LT + | otherwise = GT + where + tag1 = tagof other_1 + tag2 = tagof other_2 + + tagof (MachChar _) = ILIT(1) + tagof (MachStr _) = ILIT(2) + tagof (MachAddr _) = ILIT(3) + tagof (MachInt _ _) = ILIT(4) + tagof (MachFloat _) = ILIT(5) + tagof (MachDouble _) = ILIT(6) + tagof (MachLitLit _ _) = ILIT(7) + tagof (NoRepStr _) = ILIT(8) + tagof (NoRepInteger _ _) = ILIT(9) + tagof (NoRepRational _ _) = ILIT(10) -tcmp x y = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ } - instance Eq Literal where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } instance Ord Literal where - a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpLit a b \end{code} \begin{code} @@ -170,70 +164,59 @@ literalPrimRep (NoRepStr _) = panic "literalPrimRep:NoRepString" The boring old output stuff: \begin{code} -ppCast :: PprStyle -> FAST_STRING -> Doc -ppCast PprForC cast = ptext cast -ppCast _ _ = empty - -- MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo") -- exceptions: MachFloat and MachAddr get an initial keyword prefix -- -- NoRep things get an initial keyword prefix (e.g. _integer_ 3) instance Outputable Literal where - ppr sty (MachChar ch) - = let - char_encoding - = case sty of - PprForC -> charToC ch - PprForAsm _ _ -> charToC ch - PprInterface -> charToEasyHaskell ch - _ -> [ch] - in - hcat [ppCast sty SLIT("(C_)"), char '\'', text char_encoding, char '\''] - - ppr sty (MachStr s) - | codeStyle sty = hcat [char '"', text (stringToC (_UNPK_ s)), char '"'] - | otherwise = text (show (_UNPK_ s)) - - ppr sty lit@(NoRepStr s) - | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit) - | otherwise = hcat [ptext SLIT("_string_ "), text (show (_UNPK_ s))] - - ppr sty (MachInt i signed) - | codeStyle sty && out_of_range - = panic ("ERROR: Int " ++ show i ++ " out of range [" ++ - show range_min ++ " .. " ++ show range_max ++ "]\n") - - | otherwise = integer i - - where - range_min = if signed then minInt else 0 - range_max = maxInt - out_of_range = not (i >= toInteger range_min && i <= toInteger range_max) - - ppr sty (MachFloat f) - | codeStyle sty = hcat [ppCast sty SLIT("(StgFloat)"), rational f] - | otherwise = hcat [ptext SLIT("_float_ "), rational f] - - ppr sty (MachDouble d) = rational d - - ppr sty (MachAddr p) - | codeStyle sty = hcat [ppCast sty SLIT("(void*)"), integer p] - | otherwise = hcat [ptext SLIT("_addr_ "), integer p] - - ppr sty lit@(NoRepInteger i _) - | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit) - | otherwise = hsep [ptext SLIT("_integer_ "), integer i] - - ppr sty lit@(NoRepRational r _) - | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit) - | otherwise = hsep [ptext SLIT("_rational_ "), integer (numerator r), integer (denominator r)] - - ppr sty (MachLitLit s k) - | codeStyle sty = ptext s - | otherwise = hcat [ptext SLIT("_litlit_ "), ppPrimRep k, char ' ', text (show (_UNPK_ s))] - -showLiteral :: PprStyle -> Literal -> String -showLiteral sty lit = show (ppr sty lit) + ppr lit = pprLit lit + +pprLit lit + = getPprStyle $ \ sty -> + let + code_style = codeStyle sty + in + case lit of + MachChar ch | code_style -> hcat [ptext SLIT("(C_)"), char '\'', text (charToC ch), char '\''] + | ifaceStyle sty -> char '\'' <> text (charToEasyHaskell ch) <> char '\'' + | otherwise -> text ['\'', ch, '\''] + + MachStr s | code_style -> doubleQuotes (text (stringToC (_UNPK_ s))) + | otherwise -> text (show (_UNPK_ s)) + + NoRepStr s | code_style -> pprPanic "NoRep in code style" (ppr lit) + | otherwise -> ptext SLIT("_string_") <+> text (show (_UNPK_ s)) + + MachInt i signed | code_style && out_of_range + -> pprPanic "" (hsep [text "ERROR: Int ", text (show i), text "out of range", + brackets (ppr range_min <+> text ".." <+> ppr range_max)]) + | otherwise -> integer i + + where + range_min = if signed then minInt else 0 + range_max = maxInt + out_of_range = not (i >= toInteger range_min && i <= toInteger range_max) + + MachFloat f | code_style -> ptext SLIT("(StgFloat)") <> rational f + | otherwise -> ptext SLIT("_float_") <+> rational f + + MachDouble d -> rational d + + MachAddr p | code_style -> ptext SLIT("(void*)") <> integer p + | otherwise -> ptext SLIT("_addr_") <+> integer p + + NoRepInteger i _ | code_style -> pprPanic "NoRep in code style" (ppr lit) + | otherwise -> ptext SLIT("_integer_") <+> integer i + + NoRepRational r _ | code_style -> pprPanic "NoRep in code style" (ppr lit) + | otherwise -> hsep [ptext SLIT("_rational_"), integer (numerator r), + integer (denominator r)] + + MachLitLit s k | code_style -> ptext s + | otherwise -> hsep [ptext SLIT("_litlit_"), ppPrimRep k, text (show (_UNPK_ s))] + +showLiteral :: Literal -> String +showLiteral lit = showSDoc (ppr lit) \end{code} diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 79ffa108a9..e01e8c07cc 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -4,11 +4,9 @@ \section[Name]{@Name@: to transmit name info from renamer to typechecker} \begin{code} -#include "HsVersions.h" - module Name ( -- Re-export the Module type - SYN_IE(Module), + Module, pprModule, moduleString, -- The OccName type @@ -21,7 +19,7 @@ module Name ( Name, -- Abstract mkLocalName, mkSysLocalName, - mkCompoundName, mkGlobalName, mkInstDeclName, + mkCompoundName, mkGlobalName, mkWiredInIdName, mkWiredInTyConName, maybeWiredInIdName, maybeWiredInTyConName, @@ -39,13 +37,14 @@ module Name ( pprNameProvenance, -- Sets of Names - SYN_IE(NameSet), + NameSet, emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets, minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, isEmptyNameSet, -- Misc Provenance(..), pprProvenance, - ExportFlag(..), + ExportFlag(..), + PrintUnqualified, -- Class NamedThing and overloaded friends NamedThing(..), @@ -53,29 +52,25 @@ module Name ( getSrcLoc, isLocallyDefined, getOccString ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(TyLoop) ( GenId, Id(..), TyCon ) -- Used inside Names -#else +#include "HsVersions.h" + import {-# SOURCE #-} Id ( Id ) import {-# SOURCE #-} TyCon ( TyCon ) -#endif import CStrings ( identToC, modnameToC, cSEP ) -import CmdLineOpts ( opt_OmitInterfacePragmas, opt_EnsureSplittableC, all_toplev_ids_visible ) -import BasicTypes ( SYN_IE(Module), IfaceFlavour(..), moduleString, pprModule ) +import CmdLineOpts ( opt_PprStyle_All, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) +import BasicTypes ( Module, IfaceFlavour(..), moduleString, pprModule ) -import Outputable ( Outputable(..), PprStyle(..), codeStyle, ifaceStyle, userStyle ) import PrelMods ( gHC__ ) -import Pretty import Lex ( isLexSym, isLexConId ) -import SrcLoc ( noSrcLoc, SrcLoc ) -import Usage ( SYN_IE(UVar), SYN_IE(Usage) ) +import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc ) import Unique ( pprUnique, showUnique, Unique, Uniquable(..) ) -import UniqSet ( UniqSet(..), emptyUniqSet, unitUniqSet, unionUniqSets, uniqSetToList, isEmptyUniqSet, - unionManyUniqSets, minusUniqSet, mkUniqSet, elementOfUniqSet, addListToUniqSet, addOneToUniqSet ) +import UniqSet ( UniqSet(..), emptyUniqSet, unitUniqSet, unionUniqSets, uniqSetToList, + isEmptyUniqSet, unionManyUniqSets, minusUniqSet, mkUniqSet, + elementOfUniqSet, addListToUniqSet, addOneToUniqSet + ) import UniqFM ( UniqFM ) -import Util ( Ord3(..), cmpPString, panic, assertPanic {-, pprTrace ToDo:rm-} ) +import Outputable \end{code} @@ -90,10 +85,11 @@ data OccName = VarOcc FAST_STRING -- Variables and data constructors | TvOcc FAST_STRING -- Type variables | TCOcc FAST_STRING -- Type constructors and classes -pprOccName :: PprStyle -> OccName -> Doc -pprOccName sty n = if codeStyle sty - then identToC (occNameString n) - else ptext (occNameString n) +pprOccName :: OccName -> SDoc +pprOccName n = getPprStyle $ \ sty -> + if codeStyle sty + then identToC (occNameString n) + else ptext (occNameString n) occNameString :: OccName -> FAST_STRING occNameString (VarOcc s) = s @@ -125,27 +121,25 @@ isTCOcc (TCOcc s) = True isTCOcc other = False instance Eq OccName where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } instance Ord OccName where - a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } - -instance Ord3 OccName where - cmp = cmpOcc + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpOcc a b -(VarOcc s1) `cmpOcc` (VarOcc s2) = s1 `_CMP_STRING_` s2 -(VarOcc s1) `cmpOcc` other2 = LT_ +(VarOcc s1) `cmpOcc` (VarOcc s2) = s1 `compare` s2 +(VarOcc s1) `cmpOcc` other2 = LT -(TvOcc s1) `cmpOcc` (VarOcc s2) = GT_ -(TvOcc s1) `cmpOcc` (TvOcc s2) = s1 `_CMP_STRING_` s2 -(TvOcc s1) `cmpOcc` other = LT_ +(TvOcc s1) `cmpOcc` (VarOcc s2) = GT +(TvOcc s1) `cmpOcc` (TvOcc s2) = s1 `compare` s2 +(TvOcc s1) `cmpOcc` other = LT -(TCOcc s1) `cmpOcc` (TCOcc s2) = s1 `_CMP_STRING_` s2 -(TCOcc s1) `cmpOcc` other = GT_ +(TCOcc s1) `cmpOcc` (TCOcc s2) = s1 `compare` s2 +(TCOcc s1) `cmpOcc` other = GT instance Outputable OccName where ppr = pprOccName @@ -177,13 +171,23 @@ must be made @Global@ first. \begin{code} data Provenance - = LocalDef ExportFlag SrcLoc -- Locally defined - | Imported Module SrcLoc IfaceFlavour -- Directly imported from M; - -- gives name of module in import statement - -- and locn of import statement - | Implicit IfaceFlavour -- Implicitly imported + = NoProvenance + + | LocalDef -- Defined locally + SrcLoc -- Defn site + ExportFlag -- Whether it's exported + + | NonLocalDef -- Defined non-locally + SrcLoc -- Defined non-locally; src-loc gives defn site + IfaceFlavour -- Whether the defn site is an .hi-boot file or not + PrintUnqualified + | WiredInTyCon TyCon -- There's a wired-in version | WiredInId Id -- ...ditto... + +type PrintUnqualified = Bool -- True <=> the unqualified name of this thing is + -- in scope in this module, so print it unqualified + -- in error messages \end{code} Something is "Exported" if it may be mentioned by another module without @@ -236,25 +240,17 @@ mkCompoundName str_fn uniq (Global _ mod occ prov) mkCompoundName str_fn uniq (Local _ occ loc) = Local uniq (VarOcc (str_fn (occNameString occ))) loc - -- Rather a wierd one that's used for names generated for instance decls -mkInstDeclName :: Unique -> Module -> OccName -> SrcLoc -> Bool -> Name -mkInstDeclName uniq mod occ loc from_here - = Global uniq mod occ prov - where - prov | from_here = LocalDef Exported loc - | otherwise = Implicit HiFile -- Odd - setNameProvenance :: Name -> Provenance -> Name -- setNameProvenance used to only change the provenance of Implicit-provenance things, -- but that gives bad error messages for names defined twice in the same - -- module, so I changed it to set the proveance of *any* global (SLPJ Jun 97) + -- module, so I changed it to set the provenance of *any* global (SLPJ Jun 97) setNameProvenance (Global uniq mod occ _) prov = Global uniq mod occ prov setNameProvenance other_name prov = other_name getNameProvenance :: Name -> Provenance getNameProvenance (Global uniq mod occ prov) = prov -getNameProvenance (Local uniq occ locn) = LocalDef NotExported locn +getNameProvenance (Local uniq occ locn) = LocalDef locn NotExported -- When we renumber/rename things, we need to be -- able to change a Name's Unique to match the cached @@ -304,7 +300,7 @@ are exported. But also: \begin{code} setNameVisibility :: Maybe Module -> Unique -> Name -> Name -setNameVisibility maybe_mod occ_uniq name@(Global uniq mod occ (LocalDef NotExported loc)) +setNameVisibility maybe_mod occ_uniq name@(Global uniq mod occ (LocalDef loc NotExported)) | not all_toplev_ids_visible || not_top_level maybe_mod = Local uniq (uniqToOccName occ_uniq) loc -- Localise Global name @@ -315,7 +311,7 @@ setNameVisibility (Just mod) occ_uniq (Local uniq occ loc) | all_toplev_ids_visible = Global uniq mod -- Globalise Local name (uniqToOccName occ_uniq) - (LocalDef NotExported loc) + (LocalDef loc NotExported) setNameVisibility maybe_mod occ_uniq (Local uniq occ loc) = Local uniq (uniqToOccName occ_uniq) loc -- New OccName for Local @@ -326,6 +322,8 @@ uniqToOccName uniq = VarOcc (_PK_ ('$':showUnique uniq)) not_top_level (Just m) = False not_top_level Nothing = True +all_toplev_ids_visible = not opt_OmitInterfacePragmas || -- Pragmas can make them visible + opt_EnsureSplittableC -- Splitting requires visiblilty \end{code} %************************************************************************ @@ -361,15 +359,17 @@ nameModAndOcc (Global _ mod occ _) = (mod,occ) nameString (Local _ occ _) = occNameString occ nameString (Global _ mod occ _) = mod _APPEND_ SLIT(".") _APPEND_ occNameString occ -isExportedName (Global _ _ _ (LocalDef Exported _)) = True +isExportedName (Global _ _ _ (LocalDef _ Exported)) = True isExportedName other = False nameSrcLoc (Local _ _ loc) = loc -nameSrcLoc (Global _ _ _ (LocalDef _ loc)) = loc -nameSrcLoc (Global _ _ _ (Imported _ loc _)) = loc -nameSrcLoc other = noSrcLoc +nameSrcLoc (Global _ _ _ (LocalDef loc _)) = loc +nameSrcLoc (Global _ _ _ (NonLocalDef loc _ _)) = loc +nameSrcLoc (Global _ _ _ (WiredInTyCon _)) = mkBuiltinSrcLoc +nameSrcLoc (Global _ _ _ (WiredInId _)) = mkBuiltinSrcLoc +nameSrcLoc other = noSrcLoc -isLocallyDefinedName (Local _ _ _) = True +isLocallyDefinedName (Local _ _ _) = True isLocallyDefinedName (Global _ _ _ (LocalDef _ _)) = True isLocallyDefinedName other = False @@ -379,7 +379,7 @@ isLocallyDefinedName other = False -- them out, often in combination with isLocallyDefined. isWiredInName (Global _ _ _ (WiredInTyCon _)) = True isWiredInName (Global _ _ _ (WiredInId _)) = True -isWiredInName _ = False +isWiredInName _ = False maybeWiredInIdName :: Name -> Maybe Id maybeWiredInIdName (Global _ _ _ (WiredInId id)) = Just id @@ -404,25 +404,23 @@ isLocalName _ = False \begin{code} cmpName n1 n2 = c n1 n2 where - c (Local u1 _ _) (Local u2 _ _) = cmp u1 u2 - c (Local _ _ _) _ = LT_ - c (Global u1 _ _ _) (Global u2 _ _ _) = cmp u1 u2 - c (Global _ _ _ _) _ = GT_ + c (Local u1 _ _) (Local u2 _ _) = compare u1 u2 + c (Local _ _ _) _ = LT + c (Global u1 _ _ _) (Global u2 _ _ _) = compare u1 u2 + c (Global _ _ _ _) _ = GT \end{code} \begin{code} instance Eq Name where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } instance Ord Name where - a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } - -instance Ord3 Name where - cmp = cmpName + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpName a b instance Uniquable Name where uniqueOf = nameUnique @@ -441,64 +439,72 @@ instance NamedThing Name where \begin{code} instance Outputable Name where - ppr PprQuote name@(Local _ _ _) = quotes (ppr (PprForUser 1) name) - -- When printing interfaces, all Locals have been given nice print-names - ppr (PprForUser _) (Local _ n _) = ptext (occNameString n) - ppr PprInterface (Local _ n _) = ptext (occNameString n) - - ppr sty (Local u n _) | codeStyle sty = pprUnique u - - ppr sty (Local u n _) = hcat [ptext (occNameString n), ptext SLIT("_"), pprUnique u] - - ppr PprQuote name@(Global _ _ _ _) = quotes (ppr (PprForUser 1) name) - - ppr sty name@(Global u m n _) - | codeStyle sty - = identToC (m _APPEND_ SLIT(".") _APPEND_ occNameString n) - - ppr sty name@(Global u m n prov) - = hcat [pp_mod_dot, ptext (occNameString n), pp_debug sty name] - where - pp_mod = pprModule (PprForUser 1) m - - pp_mod_dot | userStyle sty -- Omit qualifier in user style - = empty - | otherwise - = case prov of -- Omit home module qualifier - LocalDef _ _ -> empty - Imported _ _ hif -> pp_mod <> pp_dot hif - Implicit hif -> pp_mod <> pp_dot hif - other -> pp_mod <> text "." - - pp_dot HiFile = text "." -- Vanilla case - pp_dot HiBootFile = text "!" -- M!t indicates a name imported from - -- a .hi-boot interface - - -pp_debug PprDebug (Global uniq m n prov) = hcat [text "{-", pprUnique uniq, char ',', - pp_prov prov, text "-}"] - where - pp_prov (LocalDef Exported _) = char 'x' - pp_prov (LocalDef NotExported _) = char 'l' - pp_prov (Imported _ _ _) = char 'i' - pp_prov (Implicit _) = char 'p' - pp_prov (WiredInTyCon _) = char 'W' - pp_prov (WiredInId _) = char 'w' -pp_debug other name = empty + ppr name = pprName name + +pprName name + = getPprStyle $ \ sty -> + let + ppr (Local u n _) + | userStyle sty + || ifaceStyle sty = ptext (occNameString n) + | codeStyle sty = pprUnique u + | otherwise = hcat [ptext (occNameString n), ptext SLIT("_"), pprUnique u] + + ppr name@(Global u m n prov) + | codeStyle sty + = identToC (m _APPEND_ SLIT(".") _APPEND_ occNameString n) + + | otherwise + = hcat [pp_mod_dot, ptext (occNameString n), pp_debug sty name] + where + pp_mod_dot + = case prov of -- Omit home module qualifier if its in scope + LocalDef _ _ -> pp_qual dot (user_sty || iface_sty) + NonLocalDef _ hif omit -> pp_qual (pp_hif hif) (omit && user_sty) + WiredInTyCon _ -> pp_qual dot user_sty -- Hack: omit qualifers on wired in things + WiredInId _ -> pp_qual dot user_sty -- in user style only + NoProvenance -> pp_qual dot False + + pp_qual sep omit_qual + | omit_qual = empty + | otherwise = pprModule m <> sep + + dot = text "." + pp_hif HiFile = dot -- Vanilla case + pp_hif HiBootFile = text "!" -- M!t indicates a name imported from a .hi-boot interface + + user_sty = userStyle sty + iface_sty = ifaceStyle sty + in + ppr name + + +pp_debug sty (Global uniq m n prov) + | debugStyle sty = hcat [text "{-", pprUnique uniq, prov_p, text "-}"] + | otherwise = empty + where + prov_p | opt_PprStyle_All = comma <> pp_prov prov + | otherwise = empty + +pp_prov (LocalDef _ Exported) = char 'x' +pp_prov (LocalDef _ NotExported) = char 'l' +pp_prov (NonLocalDef _ _ _) = char 'n' +pp_prov (WiredInTyCon _) = char 'W' +pp_prov (WiredInId _) = char 'w' +pp_prov NoProvenance = char '?' -- pprNameProvenance is used in error messages to say where a name came from -pprNameProvenance :: PprStyle -> Name -> Doc -pprNameProvenance sty (Local _ _ loc) = pprProvenance sty (LocalDef NotExported loc) -pprNameProvenance sty (Global _ _ _ prov) = pprProvenance sty prov - -pprProvenance :: PprStyle -> Provenance -> Doc -pprProvenance sty (Imported mod loc _) - = sep [ptext SLIT("Imported from"), pprModule sty mod, ptext SLIT("at"), ppr sty loc] -pprProvenance sty (LocalDef _ loc) = sep [ptext SLIT("Defined at"), ppr sty loc] -pprProvenance sty (Implicit _) = panic "pprNameProvenance: Implicit" -pprProvenance sty (WiredInTyCon tc) = ptext SLIT("Wired-in tycon") -pprProvenance sty (WiredInId id) = ptext SLIT("Wired-in id") +pprNameProvenance :: Name -> SDoc +pprNameProvenance (Local _ _ loc) = pprProvenance (LocalDef loc NotExported) +pprNameProvenance (Global _ _ _ prov) = pprProvenance prov + +pprProvenance :: Provenance -> SDoc +pprProvenance (LocalDef loc _) = ptext SLIT("Locally defined at") <+> ppr loc +pprProvenance (NonLocalDef loc _ _) = ptext SLIT("Non-locally defined at") <+> ppr loc +pprProvenance (WiredInTyCon tc) = ptext SLIT("Wired-in tycon") +pprProvenance (WiredInId id) = ptext SLIT("Wired-in id") +pprProvenance NoProvenance = ptext SLIT("No provenance") \end{code} diff --git a/ghc/compiler/basicTypes/PprEnv.lhs b/ghc/compiler/basicTypes/PprEnv.lhs index 0962f9ac32..6e07e395c8 100644 --- a/ghc/compiler/basicTypes/PprEnv.lhs +++ b/ghc/compiler/basicTypes/PprEnv.lhs @@ -4,137 +4,103 @@ \section[PprEnv]{The @PprEnv@ type} \begin{code} -#include "HsVersions.h" - module PprEnv ( - PprEnv{-abstract-}, + PprEnv{-abstract-}, + BindingSite(..), initPprEnv, - pCon, pLit, pMajBndr, pMinBndr, pOcc, pPrim, pSCC, pStyle, - pTy, pTyVarB, pTyVarO, pUVar, pUse + pCon, pLit, pValBndr, pOcc, pPrim, pSCC, + pTy, pTyVarB, pTyVarO ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" + +import {-# SOURCE #-} Id ( Id ) +import {-# SOURCE #-} PrimOp ( PrimOp ) +import {-# SOURCE #-} CostCentre ( CostCentre ) -import Pretty ( Doc ) +import Type ( GenType ) +import TyVar ( GenTyVar ) +import Literal ( Literal ) import Outputable import Unique ( Unique ) import UniqFM ( emptyUFM, UniqFM ) -import Util ( panic ) -#if __GLASGOW_HASKELL__ >= 202 -import {-# SOURCE #-} Type ( GenType ) -import {-# SOURCE #-} TyVar ( TyVar ) -import {-# SOURCE #-} Id ( Id ) -import Outputable ( PprStyle ) -import Literal ( Literal ) -import Usage ( GenUsage, SYN_IE(Usage) ) -import {-# SOURCE #-} PrimOp (PrimOp) -import {-# SOURCE #-} CostCentre ( CostCentre ) -#endif - \end{code} -For tyvars and uvars, we {\em do} normally use these homogenized -names; for values, we {\em don't}. In printing interfaces, though, -we use homogenized value names, so that interfaces don't wobble -uncontrollably from changing Unique-based names. +%************************************************************************ +%* * +\subsection{Public interfaces for Core printing (excluding instances)} +%* * +%************************************************************************ \begin{code} -data PprEnv tyvar uvar bndr occ - = PE PprStyle -- stored for safe keeping +data PprEnv flexi bndr occ + = PE (Literal -> SDoc) + (Id -> SDoc) + (PrimOp -> SDoc) + (CostCentre -> SDoc) - (Literal -> Doc) -- Doing these this way saves - (Id -> Doc) -- carrying around a PprStyle - (PrimOp -> Doc) - (CostCentre -> Doc) + (GenTyVar flexi -> SDoc) -- to print tyvar binders + (GenTyVar flexi -> SDoc) -- to print tyvar occurrences + (GenType flexi -> SDoc) -- to print types - (tyvar -> Doc) -- to print tyvar binders - (tyvar -> Doc) -- to print tyvar occurrences + (BindingSite -> bndr -> SDoc) -- to print val_bdrs + (occ -> SDoc) -- to print bindees - (uvar -> Doc) -- to print usage vars +\end{code} - (bndr -> Doc) -- to print "major" val_bdrs - (bndr -> Doc) -- to print "minor" val_bdrs - (occ -> Doc) -- to print bindees +@BindingSite@ is used to tell the thing that prints binder what +language construct is binding the identifier. - (GenType tyvar uvar -> Doc) - (GenUsage uvar -> Doc) +\begin{code} +data BindingSite = LambdaBind | CaseBind | LetBind \end{code} \begin{code} initPprEnv - :: PprStyle - -> Maybe (Literal -> Doc) - -> Maybe (Id -> Doc) - -> Maybe (PrimOp -> Doc) - -> Maybe (CostCentre -> Doc) - -> Maybe (tyvar -> Doc) - -> Maybe (tyvar -> Doc) - -> Maybe (uvar -> Doc) - -> Maybe (bndr -> Doc) - -> Maybe (bndr -> Doc) - -> Maybe (occ -> Doc) - -> Maybe (GenType tyvar uvar -> Doc) - -> Maybe (GenUsage uvar -> Doc) - -> PprEnv tyvar uvar bndr occ + :: Maybe (Literal -> SDoc) + -> Maybe (Id -> SDoc) + -> Maybe (PrimOp -> SDoc) + -> Maybe (CostCentre -> SDoc) + -> Maybe (GenTyVar flexi -> SDoc) + -> Maybe (GenTyVar flexi -> SDoc) + -> Maybe (GenType flexi -> SDoc) + -> Maybe (BindingSite -> bndr -> SDoc) + -> Maybe (occ -> SDoc) + -> PprEnv flexi bndr occ -- you can specify all the printers individually; if -- you don't specify one, you get bottom -initPprEnv sty l d p c tvb tvo uv maj_bndr min_bndr occ ty use - = PE sty - (demaybe l) +initPprEnv l d p c tvb tvo ty val_bndr occ + = PE (demaybe l) (demaybe d) (demaybe p) (demaybe c) (demaybe tvb) (demaybe tvo) - (demaybe uv) - (demaybe maj_bndr) - (demaybe min_bndr) - (demaybe occ) (demaybe ty) - (demaybe use) + (demaybe val_bndr) + (demaybe occ) where demaybe Nothing = bottom demaybe (Just x) = x bottom = panic "PprEnv.initPprEnv: unspecified printing function" - -{- -initPprEnv sty pmaj pmin pocc - = PE (ppr sty) -- for a Literal - (ppr sty) -- for a DataCon - (ppr sty) -- for a PrimOp - (\ cc -> text (showCostCentre sty True cc)) -- CostCentre - - (ppr sty) -- for a tyvar - (ppr sty) -- for a usage var - - pmaj pmin pocc -- for GenIds in various guises - - (ppr sty) -- for a Type - (ppr sty) -- for a Usage --} \end{code} \begin{code} -pStyle (PE s _ _ _ _ _ _ _ _ _ _ _ _) = s -pLit (PE _ pp _ _ _ _ _ _ _ _ _ _ _) = pp -pCon (PE _ _ pp _ _ _ _ _ _ _ _ _ _) = pp -pPrim (PE _ _ _ pp _ _ _ _ _ _ _ _ _) = pp -pSCC (PE _ _ _ _ pp _ _ _ _ _ _ _ _) = pp - -pTyVarB (PE _ _ _ _ _ pp _ _ _ _ _ _ _) = pp -pTyVarO (PE _ _ _ _ _ _ pp _ _ _ _ _ _) = pp -pUVar (PE _ _ _ _ _ _ _ pp _ _ _ _ _) = pp - -pMajBndr (PE _ _ _ _ _ _ _ _ pp _ _ _ _) = pp -pMinBndr (PE _ _ _ _ _ _ _ _ _ pp _ _ _) = pp -pOcc (PE _ _ _ _ _ _ _ _ _ _ pp _ _) = pp - -pTy (PE _ _ _ _ _ _ _ _ _ _ _ pp _) = pp -pUse (PE _ _ _ _ _ _ _ _ _ _ _ _ pp) = pp +pLit (PE pp _ _ _ _ _ _ _ _) = pp +pCon (PE _ pp _ _ _ _ _ _ _) = pp +pPrim (PE _ _ pp _ _ _ _ _ _) = pp +pSCC (PE _ _ _ pp _ _ _ _ _) = pp + +pTyVarB (PE _ _ _ _ pp _ _ _ _) = pp +pTyVarO (PE _ _ _ _ _ pp _ _ _) = pp +pTy (PE _ _ _ _ _ _ pp _ _) = pp + +pValBndr (PE _ _ _ _ _ _ _ pp _) = pp +pOcc (PE _ _ _ _ _ _ _ _ pp) = pp \end{code} diff --git a/ghc/compiler/basicTypes/PragmaInfo.lhs b/ghc/compiler/basicTypes/PragmaInfo.lhs index d7f514a82a..874a7f375e 100644 --- a/ghc/compiler/basicTypes/PragmaInfo.lhs +++ b/ghc/compiler/basicTypes/PragmaInfo.lhs @@ -4,11 +4,10 @@ \section[PragmaInfo]{@PragmaInfos@: The user's pragma requests} \begin{code} -#include "HsVersions.h" - module PragmaInfo where -IMP_Ubiq() +#include "HsVersions.h" + \end{code} \begin{code} diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index 20bc49a65e..cfd42a6f64 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -8,9 +8,7 @@ %************************************************************************ \begin{code} -#include "HsVersions.h" - -module SrcLoc {- ( +module SrcLoc ( SrcLoc, -- Abstract mkSrcLoc, @@ -21,14 +19,16 @@ module SrcLoc {- ( mkBuiltinSrcLoc, -- Something wired into the compiler - mkGeneratedSrcLoc -- Code generated within the compiler - ) -} where + mkGeneratedSrcLoc, -- Code generated within the compiler -IMP_Ubiq() + incSrcLine + ) where -import Outputable -import Pretty +#include "HsVersions.h" +import Outputable +import FastString ( unpackFS ) +import GlaExts ( Int(..), Int#, (+#) ) \end{code} %************************************************************************ @@ -43,7 +43,7 @@ this is the obvious stuff: data SrcLoc = NoSrcLoc - | SrcLoc FAST_STRING -- A precise location + | SrcLoc FAST_STRING -- A precise location (file name) FAST_INT | UnhelpfulSrcLoc FAST_STRING -- Just a general indication @@ -71,6 +71,10 @@ mkGeneratedSrcLoc = UnhelpfulSrcLoc SLIT("<compiler-generated-code>") isNoSrcLoc NoSrcLoc = True isNoSrcLoc other = False + +incSrcLine :: SrcLoc -> SrcLoc +incSrcLine (SrcLoc s l) = SrcLoc s (l +# 1#) +incSrcLine loc = loc \end{code} %************************************************************************ @@ -81,20 +85,25 @@ isNoSrcLoc other = False \begin{code} instance Outputable SrcLoc where - ppr sty (SrcLoc src_file src_line) - | userStyle sty - = hcat [ ptext src_file, char ':', text (show IBOX(src_line)) ] - - | otherwise - = hcat [text "{-# LINE ", text (show IBOX(src_line)), space, - char '\"', ptext src_file, text " #-}"] - ppr sty (UnhelpfulSrcLoc s) = ptext s - - ppr sty NoSrcLoc = text "<NoSrcLoc>" + ppr (SrcLoc src_path src_line) + = getPprStyle $ \ sty -> + if userStyle sty then + hcat [ text src_file, char ':', int IBOX(src_line) ] + else + if debugStyle sty then + hcat [ ptext src_path, char ':', int IBOX(src_line) ] + else + hcat [text "{-# LINE ", int IBOX(src_line), space, + char '\"', ptext src_path, text " #-}"] + where + src_file = remove_directory_prefix (unpackFS src_path) + + remove_directory_prefix path = case break (== '/') path of + (filename, []) -> filename + (prefix, slash : rest) -> ASSERT( slash == '/' ) + remove_directory_prefix rest + + ppr (UnhelpfulSrcLoc s) = ptext s + + ppr NoSrcLoc = text "<NoSrcLoc>" \end{code} - -{- - = hcat [ptext SLIT("{-# LINE "), text (show IBOX(src_line)), space, - char '"', ptext src_file, ptext SLIT(" #-}")] - --ptext SLIT("\" #-}")] --} diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs index 1c651cb62b..23bd2c051e 100644 --- a/ghc/compiler/basicTypes/UniqSupply.lhs +++ b/ghc/compiler/basicTypes/UniqSupply.lhs @@ -4,15 +4,13 @@ \section[UniqSupply]{The @UniqueSupply@ data type and a (monadic) supply thereof} \begin{code} -#include "HsVersions.h" - module UniqSupply ( UniqSupply, -- Abstractly getUnique, getUniques, -- basic ops - SYN_IE(UniqSM), -- type: unique supply monad + UniqSM, -- type: unique supply monad initUs, thenUs, returnUs, fixUs, mapUs, mapAndUnzipUs, mapAndUnzip3Us, thenMaybeUs, mapAccumLUs, @@ -21,30 +19,15 @@ module UniqSupply ( splitUniqSupply ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import Unique import Util -#if __GLASGOW_HASKELL__ == 201 -import PreludeGlaST -# define WHASH GHCbase.W# -#elif __GLASGOW_HASKELL__ >= 202 import GlaExts -import STBase -# if __GLASGOW_HASKELL__ == 202 +import IOBase ( IO(..), IOResult(..) ) import PrelBase ( Char(..) ) -# endif -# define WHASH GlaExts.W# -#else -import PreludeGlaST -# define WHASH W# -#endif - -#if __GLASGOW_HASKELL__ >= 209 -import Unsafe ( unsafeInterleaveIO ) -#endif w2i x = word2Int# x i2w x = int2Word# x @@ -91,41 +74,19 @@ mkSplitUniqSupply (C# c#) -- here comes THE MAGIC: + -- This is one of the most hammered bits in the whole compiler mk_supply# - = unsafe_interleave ( - mk_unique `thenPrimIO` \ uniq -> - mk_supply# `thenPrimIO` \ s1 -> - mk_supply# `thenPrimIO` \ s2 -> - returnPrimIO (MkSplitUniqSupply uniq s1 s2) + = unsafeInterleaveIO ( + mk_unique >>= \ uniq -> + mk_supply# >>= \ s1 -> + mk_supply# >>= \ s2 -> + return (MkSplitUniqSupply uniq s1 s2) ) - where --- - -- inlined copy of unsafeInterleavePrimIO; - -- this is the single-most-hammered bit of code - -- in the compiler.... - -- Too bad it's not 1.3-portable... - unsafe_interleave m = -#if __GLASGOW_HASKELL__ >= 209 - unsafeInterleaveIO m -#else - MkST ( \ s -> - let - (MkST m') = m - ST_RET(r, new_s) = m' s - in - ST_RET(r, s)) -#endif - - mk_unique = _ccall_ genSymZh `thenPrimIO` \ (WHASH u#) -> - returnPrimIO (I# (w2i (mask# `or#` u#))) + + mk_unique = _ccall_ genSymZh >>= \ (W# u#) -> + return (I# (w2i (mask# `or#` u#))) in -#if __GLASGOW_HASKELL__ >= 200 - primIOToIO mk_supply# >>= \ s -> - return s -#else - mk_supply# `thenPrimIO` \ s -> - return s -#endif + mk_supply# splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) \end{code} diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 34d05c48ba..4021d24276 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -16,10 +16,6 @@ Some of the other hair in this code is to be able to use a Haskell). \begin{code} -#include "HsVersions.h" - ---<mkdependHS:friends> UniqSupply - module Unique ( Unique, Uniquable(..), u2i, -- hack: used in UniqFM @@ -229,18 +225,14 @@ module Unique ( , allClassKey ) where -#if __GLASGOW_HASKELL__ <= 201 -import PreludeGlaST -#else +#include "HsVersions.h" + +import FastString ( uniqueOfFS ) import GlaExts import ST import PrelBase ( Char(..), chr, ord ) -#endif - -IMP_Ubiq(){-uitous-} import Outputable -import Pretty import Util \end{code} @@ -255,9 +247,6 @@ Fast comparison is everything on @Uniques@: \begin{code} data Unique = MkUnique Int# - -class Uniquable a where - uniqueOf :: a -> Unique \end{code} \begin{code} @@ -304,6 +293,26 @@ unpkUnique (MkUnique u) shiftr x y = shiftRA# x y \end{code} + + +%************************************************************************ +%* * +\subsection[Uniquable-class]{The @Uniquable@ class} +%* * +%************************************************************************ + +\begin{code} +class Uniquable a where + uniqueOf :: a -> Unique + +instance Uniquable FastString where + uniqueOf fs = mkUniqueGrimily (uniqueOfFS fs) + +instance Uniquable Int where + uniqueOf (I# i#) = mkUniqueGrimily i# +\end{code} + + %************************************************************************ %* * \subsection[Unique-instances]{Instance declarations for @Unique@} @@ -320,7 +329,7 @@ ltUnique (MkUnique u1) (MkUnique u2) = u1 <# u2 leUnique (MkUnique u1) (MkUnique u2) = u1 <=# u2 cmpUnique (MkUnique u1) (MkUnique u2) - = if u1 ==# u2 then EQ_ else if u1 <# u2 then LT_ else GT_ + = if u1 ==# u2 then EQ else if u1 <# u2 then LT else GT instance Eq Unique where a == b = eqUnique a b @@ -331,10 +340,7 @@ instance Ord Unique where a <= b = leUnique a b a > b = not (leUnique a b) a >= b = not (ltUnique a b) - _tagCmp a b = case cmpUnique a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } - -instance Ord3 Unique where - cmp = cmpUnique + compare a b = cmpUnique a b ----------------- instance Uniquable Unique where @@ -343,7 +349,7 @@ instance Uniquable Unique where We do sometimes make strings with @Uniques@ in them: \begin{code} -pprUnique, pprUnique10 :: Unique -> Doc +pprUnique, pprUnique10 :: Unique -> SDoc pprUnique uniq = case unpkUnique uniq of @@ -360,10 +366,10 @@ finish_ppr 't' u pp_u | u < 26 finish_ppr tag u pp_u = char tag <> pp_u showUnique :: Unique -> String -showUnique uniq = show (pprUnique uniq) +showUnique uniq = showSDoc (pprUnique uniq) instance Outputable Unique where - ppr sty u = pprUnique u + ppr u = pprUnique u instance Text Unique where showsPrec p uniq rest = showUnique uniq @@ -399,7 +405,7 @@ Code stolen from Lennart. # define RETURN returnStrictlyST #endif -iToBase62 :: Int -> Doc +iToBase62 :: Int -> SDoc iToBase62 n@(I# n#) = ASSERT(n >= 0) diff --git a/ghc/compiler/codeGen/CgBindery.hi-boot b/ghc/compiler/codeGen/CgBindery.hi-boot index e2c06aa4f7..b3b26b0940 100644 --- a/ghc/compiler/codeGen/CgBindery.hi-boot +++ b/ghc/compiler/codeGen/CgBindery.hi-boot @@ -1,8 +1,11 @@ _interface_ CgBindery 1 _exports_ -CgBindery CgBindings CgIdInfo(MkCgIdInfo) VolatileLoc nukeVolatileBinds; +CgBindery CgBindings CgIdInfo(MkCgIdInfo) VolatileLoc StableLoc nukeVolatileBinds maybeAStkLoc maybeBStkLoc; _declarations_ 1 type CgBindings = Id.IdEnv CgIdInfo; -1 data CgIdInfo = MkCgIdInfo Id.Id CgBindery.VolatileLoc CgMonad.StableLoc ClosureInfo!LambdaFormInfo; +1 data CgIdInfo = MkCgIdInfo Id.Id VolatileLoc StableLoc ClosureInfo!LambdaFormInfo; 1 data VolatileLoc; -1 nukeVolatileBinds _:_ CgBindery.CgBindings -> CgBindery.CgBindings ;; +1 data StableLoc; +1 nukeVolatileBinds _:_ CgBindings -> CgBindings ;; +1 maybeAStkLoc _:_ StableLoc -> PrelMaybe.Maybe HeapOffs.VirtualSpAOffset ;; +1 maybeBStkLoc _:_ StableLoc -> PrelMaybe.Maybe HeapOffs.VirtualSpBOffset ;; diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index d43313392b..f21d393b83 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -4,13 +4,11 @@ \section[CgBindery]{Utility functions related to doing @CgBindings@} \begin{code} -#include "HsVersions.h" - module CgBindery ( - SYN_IE(CgBindings), CgIdInfo(..){-dubiously concrete-}, - VolatileLoc, StableLoc, -- (the latter is defined in CgMonad) + CgBindings, CgIdInfo(..){-dubiously concrete-}, + StableLoc, VolatileLoc, --- maybeAStkLoc, maybeBStkLoc, + maybeAStkLoc, maybeBStkLoc, stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo, letNoEscapeIdInfo, idInfoToAmode, @@ -26,7 +24,7 @@ module CgBindery ( rebindToAStack, rebindToBStack ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import AbsCSyn import CgMonad @@ -34,26 +32,24 @@ import CgMonad import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset ) import CLabel ( mkStaticClosureLabel, mkClosureLabel ) import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument, LambdaFormInfo ) -import HeapOffs ( SYN_IE(VirtualHeapOffset), - SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset) +import HeapOffs ( VirtualHeapOffset, + VirtualSpAOffset, VirtualSpBOffset ) import Id ( idPrimRep, toplevelishId, - mkIdEnv, rngIdEnv, SYN_IE(IdEnv), + mkIdEnv, rngIdEnv, IdEnv, idSetToList, - GenId{-instance NamedThing-}, SYN_IE(Id) + Id ) +import Literal ( Literal ) import Maybes ( catMaybes ) import Name ( isLocallyDefined, isWiredInName, Name{-instance NamedThing-}, NamedThing(..) ) -#ifdef DEBUG import PprAbsC ( pprAmode ) -#endif -import Outputable ( PprStyle(..) ) -import Pretty ( Doc ) import PrimRep ( PrimRep ) -import StgSyn ( SYN_IE(StgArg), SYN_IE(StgLiveVars), GenStgArg(..) ) +import StgSyn ( StgArg, StgLiveVars, GenStgArg(..) ) import Unique ( Unique, Uniquable(..) ) import Util ( zipWithEqual, panic ) +import Outputable \end{code} @@ -91,7 +87,26 @@ data VolatileLoc | VirNodeLoc VirtualHeapOffset -- Cts of offset indirect from Node -- ie *(Node+offset) +\end{code} + +@StableLoc@ encodes where an Id can be found, used by +the @CgBindings@ environment in @CgBindery@. + +\begin{code} +data StableLoc + = NoStableLoc + | VirAStkLoc VirtualSpAOffset + | VirBStkLoc VirtualSpBOffset + | LitLoc Literal + | StableAmodeLoc CAddrMode + +-- these are so StableLoc can be abstract: + +maybeAStkLoc (VirAStkLoc offset) = Just offset +maybeAStkLoc _ = Nothing +maybeBStkLoc (VirBStkLoc offset) = Just offset +maybeBStkLoc _ = Nothing \end{code} %************************************************************************ @@ -398,7 +413,7 @@ bindNewPrimToAmode name (CVal (NodeRel offset) _) #ifdef DEBUG bindNewPrimToAmode name amode - = panic ("bindNew...:"++(show (pprAmode PprDebug amode))) + = pprPanic "bindNew...:" (pprAmode amode) #endif \end{code} diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index c6eb9f06f3..85cc41cf28 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -8,16 +8,11 @@ %******************************************************** \begin{code} -#include "HsVersions.h" - module CgCase ( cgCase, saveVolatileVarsAndRegs ) where -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(CgLoop2) ( cgExpr, getPrimOpArgAmodes ) -#else +#include "HsVersions.h" + import {-# SOURCE #-} CgExpr -#endif import CgMonad import StgSyn @@ -50,17 +45,15 @@ import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel, import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon ) import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) import CostCentre ( useCurrentCostCentre, CostCentre ) -import HeapOffs ( SYN_IE(VirtualSpBOffset), SYN_IE(VirtualHeapOffset) ) +import HeapOffs ( VirtualSpBOffset, VirtualHeapOffset ) import Id ( idPrimRep, toplevelishId, - dataConTag, fIRST_TAG, SYN_IE(ConTag), - isDataCon, SYN_IE(DataCon), - idSetToList, GenId{-instance Uniquable,Eq-}, SYN_IE(Id) + dataConTag, fIRST_TAG, ConTag, + isDataCon, DataCon, + idSetToList, GenId{-instance Uniquable,Eq-}, Id ) import Literal ( Literal ) import Maybes ( catMaybes ) -import Outputable ( Outputable(..), PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) -import Pretty ( Doc ) import PrimOp ( primOpCanTriggerGC, PrimOp(..), primOpStackRequired, StackRequirement(..) ) @@ -69,15 +62,12 @@ import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize, ) import TyCon ( isEnumerationTyCon ) import Type ( typePrimRep, - getAppSpecDataTyConExpandingDicts, - maybeAppSpecDataTyConExpandingDicts, - SYN_IE(Type) + splitAlgTyConApp, splitAlgTyConApp_maybe, + Type ) import Unique ( Unique, Uniquable(..) ) -import Util ( sortLt, isIn, isn'tIn, zipEqual, - pprError, panic, assertPanic - ) - +import Util ( sortLt, isIn, isn'tIn, zipEqual ) +import Outputable \end{code} \begin{code} @@ -411,7 +401,7 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used - -- A temporary variable to hold the tag; this is unaffected by GC because -- the heap-checks in the branches occur after the switch tag_amode = CTemp uniq IntRep - (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty + (spec_tycon, _, _) = splitAlgTyConApp ty getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default) -- Default is either StgNoDefault or StgBindDefault with unused binder @@ -477,7 +467,7 @@ cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt) -- which is worse than having the alt code in the switch statement let - (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty + (spec_tycon, _, _) = splitAlgTyConApp ty use_labelled_alts = case ctrlReturnConvAlg spec_tycon of @@ -628,7 +618,7 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging default_join_lbl = mkDefaultLabel uniq jump_instruction = CJump (CLbl default_join_lbl CodePtrRep) - (spec_tycon, _, spec_cons) = getAppSpecDataTyConExpandingDicts ty + (spec_tycon, _, spec_cons) = splitAlgTyConApp ty alt_cons = [ con | (con,_,_,_) <- alts ] @@ -1101,7 +1091,7 @@ mkReturnVector :: Unique mkReturnVector uniq ty tagged_alt_absCs deflt_absC = let - (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg spec_tycon) of { + (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg tycon) of { UnvectoredReturn _ -> (CUnVecLbl ret_label vtbl_label, @@ -1129,9 +1119,13 @@ mkReturnVector uniq ty tagged_alt_absCs deflt_absC -- ) where - (spec_tycon,_,_) = case (maybeAppSpecDataTyConExpandingDicts ty) of -- *must* be a real "data" type constructor + (tycon,_,_) = case splitAlgTyConApp_maybe ty of -- *must* be a real "data" type constructor Just xx -> xx - Nothing -> pprError "ERROR: can't generate code for polymorphic case;\nprobably a mis-use of `seq' or `par';\nthe User's Guide has more details.\nOffending type: " (ppr PprDebug ty) + Nothing -> pprPanic "ERROR: can't generate code for polymorphic case" + (vcat [text "probably a mis-use of `seq' or `par';", + text "the User's Guide has more details.", + text "Offending type:" <+> ppr ty + ]) vtbl_label = mkVecTblLabel uniq ret_label = mkReturnPtLabel uniq diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 673dd7ab76..8fbf5c689a 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -8,16 +8,11 @@ with {\em closures} on the RHSs of let(rec)s. See also @CgCon@, which deals with constructors. \begin{code} -#include "HsVersions.h" - module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(CgLoop2) ( cgExpr ) -#else +#include "HsVersions.h" + import {-# SOURCE #-} CgExpr ( cgExpr ) -#endif import CgMonad import AbsCSyn @@ -56,21 +51,19 @@ import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts, isCafCC, isDictCC, overheadCostCentre, showCostCentre, CostCentre ) -import HeapOffs ( SYN_IE(VirtualHeapOffset) ) +import HeapOffs ( VirtualHeapOffset ) import Id ( idType, idPrimRep, showId, getIdStrictness, dataConTag, emptyIdSet, - GenId{-instance Outputable-}, SYN_IE(Id) + Id ) import ListSetOps ( minusList ) import Maybes ( maybeToBool ) -import Outputable ( Outputable(..){-instances-}, PprStyle(..) ) -import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} ) -import Pretty ( Doc, hcat, char, ptext, hsep, text ) import PrimRep ( isFollowableRep, PrimRep(..) ) import TyCon ( isPrimTyCon, tyConDataCons ) import Type ( showTypeCategory ) -import Util ( isIn, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} ) +import Util ( isIn ) +import Outputable getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)" \end{code} @@ -108,7 +101,7 @@ cgTopRhsClosure name cc binder_info args body lf_info -- Don't build Vap info tables etc for -- a function whose result is an unboxed type, -- because we can never have thunks with such a type. - (if closureReturnsUnboxedType closure_info then + (if closureReturnsUnpointedType closure_info then nopC else let @@ -260,7 +253,7 @@ cgRhsClosure binder cc binder_info fvs args body lf_info -- Don't build Vap info tables etc for -- a function whose result is an unboxed type, -- because we can never have thunks with such a type. - (if closureReturnsUnboxedType closure_info then + (if closureReturnsUnpointedType closure_info then nopC else cgVapInfoTables False {- Not top level -} nopC binder_info binder args lf_info @@ -398,7 +391,7 @@ closureCodeBody binder_info closure_info cc [] body Just (tc,_,_) -> (True, tc) in if has_tycon && isPrimTyCon tycon then - pprPanic "closureCodeBody:thunk:prim type!" (ppr PprDebug tycon) + pprPanic "closureCodeBody:thunk:prim type!" (ppr tycon) else #endif getAbsC body_code `thenFC` \ body_absC -> @@ -471,7 +464,7 @@ closureCodeBody binder_info closure_info cc all_args body -- Old version (reschedule combined with heap check); -- see argSatisfactionCheck for new version --slow_entry_code = forceHeapCheck [node] True slow_entry_code' - -- where node = VanillaReg PtrRep 1 + -- where node = UnusedReg PtrRep 1 --slow_entry_code = forceHeapCheck [] True slow_entry_code' slow_entry_code @@ -507,7 +500,7 @@ closureCodeBody binder_info closure_info cc all_args body fast_entry_code = profCtrC SLIT("ENT_FUN_DIRECT") [ CLbl (mkRednCountsLabel id) PtrRep, - CString (_PK_ (showId PprDebug id)), + CString (_PK_ (showId id)), mkIntCLit stg_arity, -- total # of args mkIntCLit spA_stk_args, -- # passed on A stk mkIntCLit spB_stk_args, -- B stk (rest in regs) @@ -570,7 +563,7 @@ closureCodeBody binder_info closure_info cc all_args body Just xx -> get_ultimate_wrapper (Just xx) xx show_wrapper_name Nothing = "" - show_wrapper_name (Just xx) = showId PprDebug xx + show_wrapper_name (Just xx) = showId xx show_wrapper_arg_kinds Nothing = "" show_wrapper_arg_kinds (Just xx) @@ -605,7 +598,7 @@ enterCostCentreCode closure_info cc is_thunk if costsAreSubsumed cc then --ASSERT(isToplevClosure closure_info) --ASSERT(is_thunk == IsFunction) - (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (hsep [ppr PprDebug (is_thunk == IsFunction){-, ppr PprDebug closure_info-}, text (showCostCentre PprDebug False cc)])) $ + (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (hsep [ppr (is_thunk == IsFunction){-, ppr closure_info-}, text (showCostCentre False cc)])) $ costCentresC SLIT("ENTER_CC_FSUB") [] else if currentOrSubsumedCosts cc then @@ -809,7 +802,7 @@ stackCheck closure_info regs node_reqd code all_regs = if node_reqd then node:regs else regs liveness_mask = mkLiveRegsMask all_regs - returns_prim_type = closureReturnsUnboxedType closure_info + returns_prim_type = closureReturnsUnpointedType closure_info \end{code} %************************************************************************ @@ -918,11 +911,11 @@ closureDescription :: FAST_STRING -- Module -- CgConTbls.lhs with a description generated from the data constructor closureDescription mod_name name args body - = show ( + = showSDoc ( hcat [char '<', ptext mod_name, char '.', - ppr PprDebug name, + ppr name, char '>']) \end{code} @@ -975,7 +968,7 @@ mkWrapperArgTypeCategories -> String -- a string saying lots about the args mkWrapperArgTypeCategories wrapper_ty wrap_info - = case (splitFunTyExpandingDicts wrapper_ty) of { (arg_tys,_) -> + = case (splitFunTy_maybe wrapper_ty) of { Just (arg_tys,_) -> map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) } where -- ToDo: this needs FIXING UP (it was a hack anyway...) diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index a4110434d5..305b7eae89 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -8,15 +8,13 @@ with {\em constructors} on the RHSs of let(rec)s. See also @CgClosure@, which deals with closures. \begin{code} -#include "HsVersions.h" - module CgCon ( cgTopRhsCon, buildDynCon, bindConArgs, cgReturnDataCon ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CgMonad import AbsCSyn @@ -44,8 +42,8 @@ import CostCentre ( currentOrSubsumedCosts, useCurrentCostCentre, dontCareCostCentre, CostCentre ) import Id ( idPrimRep, dataConTag, dataConTyCon, - isDataCon, SYN_IE(DataCon), - emptyIdSet, SYN_IE(Id) + isDataCon, DataCon, + emptyIdSet, Id ) import Literal ( Literal(..) ) import Maybes ( maybeToBool ) diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index 09d9c109a1..a80322654f 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -4,11 +4,9 @@ \section[CgConTbls]{Info tables and update bits for constructors} \begin{code} -#include "HsVersions.h" - module CgConTbls ( genStaticConBits ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import AbsCSyn import CgMonad @@ -34,17 +32,17 @@ import ClosureInfo ( layOutStaticClosure, layOutDynCon, ) import CostCentre ( dontCareCostCentre, CostCentre ) import FiniteMap ( fmToList, FiniteMap ) -import HeapOffs ( zeroOff, SYN_IE(VirtualHeapOffset) ) +import HeapOffs ( zeroOff, VirtualHeapOffset ) import Id ( dataConTag, dataConRawArgTys, dataConNumFields, fIRST_TAG, emptyIdSet, - GenId{-instance NamedThing-}, SYN_IE(Id) + GenId{-instance NamedThing-}, Id ) import Name ( getOccString ) import PrelInfo ( maybeIntLikeTyCon ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import TyCon ( tyConDataCons, mkSpecTyCon, TyCon ) -import Type ( typePrimRep, SYN_IE(Type) ) +import Type ( typePrimRep, Type ) import Util ( panic ) mkSameSpecCon = panic "CgConTbls.mkSameSpecCon (ToDo)" diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index b600193b56..904dd5504e 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -8,14 +8,9 @@ %******************************************************** \begin{code} -#include "HsVersions.h" - module CgExpr ( cgExpr, getPrimOpArgAmodes ) where -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(CgLoop2) -- here for paranoia-checking -#endif +#include "HsVersions.h" import Constants ( mAX_SPEC_SELECTEE_SIZE ) import StgSyn @@ -40,22 +35,21 @@ import CLabel ( mkPhantomInfoTableLabel, mkInfoTableVecTblLabel ) import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo, mkVapLFInfo, layOutDynCon ) import CostCentre ( sccAbleCostCentre, isDictCC, isSccCountCostCentre ) -import HeapOffs ( SYN_IE(VirtualSpBOffset), intOffsetIntoGoods ) +import HeapOffs ( VirtualSpBOffset, intOffsetIntoGoods ) import Id ( dataConTyCon, idPrimRep, getIdArity, mkIdSet, unionIdSets, GenId{-instance Outputable-}, - SYN_IE(Id) + Id ) import IdInfo ( ArityInfo(..) ) import Name ( isLocallyDefined ) -import Outputable ( PprStyle(..), Outputable(..) ) -import Pretty ( Doc ) import PrimOp ( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..), getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import TyCon ( tyConDataCons, maybeTyConSingleCon ) import Maybes ( assocMaybe, maybeToBool ) -import Util ( panic, isIn, pprPanic, assertPanic ) +import Util ( isIn ) +import Outputable \end{code} This module provides the support code for @StgToAbstractC@ to deal @@ -193,7 +187,7 @@ cgExpr x@(StgPrim op args live_vars) mkIntCLit (length rs)) -- for ticky-ticky only ReturnInHeap - -> pprPanic "CgExpr: can't return prim in heap:" (ppr PprDebug data_con) + -> pprPanic "CgExpr: can't return prim in heap:" (ppr data_con) -- Never used, and no point in generating -- the code for it! where diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 903d072cac..01b2ed9461 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -4,8 +4,6 @@ \section[CgHeapery]{Heap management functions} \begin{code} -#include "HsVersions.h" - module CgHeapery ( heapCheck, allocHeap, allocDynClosure @@ -14,7 +12,7 @@ module CgHeapery ( , heapCheckOnly, fetchAndReschedule, yield ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import AbsCSyn import CgMonad @@ -27,7 +25,7 @@ import ClosureInfo ( closureSize, closureHdrSize, closureGoodStuffSize, slopSize, allocProfilingMsg, closureKind, ClosureInfo ) import HeapOffs ( isZeroOff, addOff, intOff, - SYN_IE(VirtualHeapOffset), HeapOffset + VirtualHeapOffset, HeapOffset ) import PrimRep ( PrimRep(..) ) \end{code} diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs index 935b441910..c7dee22598 100644 --- a/ghc/compiler/codeGen/CgLetNoEscape.lhs +++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs @@ -8,16 +8,11 @@ %******************************************************** \begin{code} -#include "HsVersions.h" - module CgLetNoEscape ( cgLetNoEscapeClosure ) where -IMP_Ubiq(){-uitious-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(CgLoop2) ( cgExpr ) -#else +#include "HsVersions.h" + import {-# SOURCE #-} CgExpr ( cgExpr ) -#endif import StgSyn import CgMonad @@ -34,8 +29,8 @@ import CgUsages ( setRealAndVirtualSps, getVirtSps ) import CLabel ( mkStdEntryLabel ) import ClosureInfo ( mkLFLetNoEscape ) import CostCentre ( CostCentre ) -import HeapOffs ( SYN_IE(VirtualSpBOffset) ) -import Id ( idPrimRep, SYN_IE(Id) ) +import HeapOffs ( VirtualSpBOffset ) +import Id ( idPrimRep, Id ) \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/CgLoop1.lhi b/ghc/compiler/codeGen/CgLoop1.lhi deleted file mode 100644 index 985529ba84..0000000000 --- a/ghc/compiler/codeGen/CgLoop1.lhi +++ /dev/null @@ -1,33 +0,0 @@ -\begin{code} -interface CgLoop1 where -import PreludeStdIO ( Maybe ) - -import CgBindery ( CgBindings(..), CgIdInfo(..), - VolatileLoc, nukeVolatileBinds - ) -import CgUsages ( getSpBRelOffset ) - -import AbsCSyn ( RegRelative ) -import CgMonad ( FCode(..), StableLoc, maybeAStkLoc, maybeBStkLoc ) -import ClosureInfo ( LambdaFormInfo ) -import HeapOffs ( VirtualSpAOffset(..), VirtualSpBOffset(..) ) -import Id ( IdEnv(..), Id(..) ) - -type CgBindings = IdEnv CgIdInfo - -data CgIdInfo - = MkCgIdInfo Id -- Id that this is the info for - VolatileLoc - StableLoc - LambdaFormInfo - -data VolatileLoc -data StableLoc -data LambdaFormInfo - -nukeVolatileBinds :: CgBindings -> CgBindings -maybeAStkLoc :: StableLoc -> Maybe VirtualSpAOffset -maybeBStkLoc :: StableLoc -> Maybe VirtualSpBOffset - -getSpBRelOffset :: VirtualSpBOffset -> FCode RegRelative -\end{code} diff --git a/ghc/compiler/codeGen/CgLoop2.lhi b/ghc/compiler/codeGen/CgLoop2.lhi deleted file mode 100644 index 421fbfa782..0000000000 --- a/ghc/compiler/codeGen/CgLoop2.lhi +++ /dev/null @@ -1,14 +0,0 @@ -Break loops caused by cgExpr and getPrimOpArgAmodes. -\begin{code} -interface CgLoop2 where - -import CgExpr ( cgExpr, getPrimOpArgAmodes ) - -import AbsCSyn ( CAddrMode ) -import CgMonad ( Code(..), FCode(..) ) -import PrimOp ( PrimOp ) -import StgSyn ( StgExpr(..), StgArg(..) ) - -cgExpr :: StgExpr -> Code -getPrimOpArgAmodes :: PrimOp -> [StgArg] -> FCode [CAddrMode] -\end{code} diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index 6c9e31f83f..5f8e1d2d97 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -7,25 +7,23 @@ See the beginning of the top-level @CodeGen@ module, to see how this monadic stuff fits into the Big Picture. \begin{code} -#include "HsVersions.h" - module CgMonad ( - SYN_IE(Code), -- type - SYN_IE(FCode), -- type + Code, -- type + FCode, -- type initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs, returnFC, fixC, absC, nopC, getAbsC, forkClosureBody, forkStatics, forkAlts, forkEval, forkEvalHelp, forkAbsC, - SYN_IE(SemiTaggingStuff), + SemiTaggingStuff, addBindC, addBindsC, modifyBindC, lookupBindC, EndOfBlockInfo(..), setEndOfBlockInfo, getEndOfBlockInfo, - SYN_IE(AStackUsage), SYN_IE(BStackUsage), SYN_IE(HeapUsage), + AStackUsage, BStackUsage, HeapUsage, StubFlag, isStubbed, @@ -42,22 +40,17 @@ module CgMonad ( Sequel(..), -- ToDo: unabstract? sequelToAmode, - StableLoc(..), maybeAStkLoc, maybeBStkLoc, - -- out of general friendliness, we also export ... CgInfoDownwards(..), CgState(..), -- non-abstract CompilationInfo(..) ) where -IMPORT_1_3(List(nub)) -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(CgLoop1) -- stuff from CgBindery and CgUsages -#else -import {-# SOURCE #-} CgBindery +import List ( nub ) + +import {-# SOURCE #-} CgBindery ( CgIdInfo(..), CgBindings, maybeAStkLoc, maybeBStkLoc, nukeVolatileBinds ) import {-# SOURCE #-} CgUsages -#endif import AbsCSyn import AbsCUtils ( mkAbsCStmts ) @@ -65,26 +58,24 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling, opt_OmitBlackHoling ) import HeapOffs ( maxOff, - SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset), + VirtualSpAOffset, VirtualSpBOffset, HeapOffset ) import CLabel ( CLabel ) import Id ( idType, nullIdEnv, mkIdEnv, addOneToIdEnv, - modifyIdEnv, lookupIdEnv, rngIdEnv, SYN_IE(IdEnv), - SYN_IE(ConTag), GenId{-instance Outputable-}, - SYN_IE(Id) + modifyIdEnv, lookupIdEnv, rngIdEnv, IdEnv, + ConTag, GenId{-instance Outputable-}, + Id ) import Literal ( Literal ) import Maybes ( maybeToBool ) -import Outputable ( PprStyle(..), Outputable(..) ) -import PprType ( GenType{-instance Outputable-} ) -import Pretty ( Doc, vcat, hsep, ptext ) import PrimRep ( getPrimRepSize, PrimRep(..) ) -import StgSyn ( SYN_IE(StgLiveVars) ) +import StgSyn ( StgLiveVars ) import Type ( typePrimRep ) import UniqSet ( elementOfUniqSet ) -import Util ( sortLt, panic, pprPanic ) +import Util ( sortLt ) +import Outputable infixr 9 `thenC` -- Right-associative! infixr 9 `thenFC` @@ -221,33 +212,6 @@ sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg) sequelToAmode (CaseAlts amode _) = returnFC amode \end{code} -@StableLoc@ encodes where an Id can be found, used by -the @CgBindings@ environment in @CgBindery@. - -The natural home for @StableLoc@ is @CgBindery@, but it is -stuck out here to avoid giving the type for @maybeBStkLoc@ -and @maybeAStkLoc@ in the @.hi-boot@ file for @CgBindery@. -This is problematic since they're both returning @Maybe@ types, -which lives in @PrelBase@ (< ghc-2.09) or @PrelMaybe@ (> 2.09). -ToDo: after the next major release, move it back. - -\begin{code} -data StableLoc - = NoStableLoc - | VirAStkLoc VirtualSpAOffset - | VirBStkLoc VirtualSpBOffset - | LitLoc Literal - | StableAmodeLoc CAddrMode - --- these are so StableLoc can be abstract: - -maybeAStkLoc (VirAStkLoc offset) = Just offset -maybeAStkLoc _ = Nothing - -maybeBStkLoc (VirBStkLoc offset) = Just offset -maybeBStkLoc _ = Nothing -\end{code} - See the NOTES about the details of stack/heap usage tracking. \begin{code} @@ -728,12 +692,12 @@ lookupBindC name info_down@(MkCgInfoDown _ static_binds _) Nothing -> pprPanic "lookupBindC:no info!\n" (vcat [ - hsep [ptext SLIT("for:"), ppr PprShowAll name], + hsep [ptext SLIT("for:"), ppr name], ptext SLIT("(probably: data dependencies broken by an optimisation pass)"), ptext SLIT("static binds for:"), - vcat [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ], + vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ], ptext SLIT("local binds for:"), - vcat [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ] + vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ] ]) \end{code} diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index a50c659604..d6342e2c3f 100644 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -7,8 +7,6 @@ The datatypes and functions here encapsulate what there is to know about return conventions. \begin{code} -#include "HsVersions.h" - module CgRetConv ( CtrlReturnConvention(..), DataReturnConvention(..), @@ -22,10 +20,7 @@ module CgRetConv ( assignRegs ) where -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(AbsCLoop) -- paranoia checking -#endif +#include "HsVersions.h" import AbsCSyn -- quite a few things import AbsCUtils ( mkAbstractCs, getAmodeRep, @@ -37,11 +32,10 @@ import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS, ) import CmdLineOpts ( opt_ReturnInRegsThreshold ) import Id ( isDataCon, dataConRawArgTys, - SYN_IE(DataCon), GenId{-instance Eq-}, - SYN_IE(Id) + DataCon, GenId{-instance Eq-}, + Id ) import Maybes ( catMaybes ) -import Outputable ( PprStyle(..), Outputable(..) ) import PprType ( TyCon{-instance Outputable-} ) import PrimOp ( primOpCanTriggerGC, getPrimOpResultInfo, PrimOpResultInfo(..), @@ -50,10 +44,8 @@ import PrimOp ( primOpCanTriggerGC, import PrimRep ( isFloatingRep, PrimRep(..) ) import TyCon ( tyConDataCons, tyConFamilySize ) import Type ( typePrimRep ) -import Pretty ( Doc ) -import Util ( zipWithEqual, mapAccumL, isn'tIn, - pprError, pprTrace, panic, assertPanic, assertPprPanic - ) +import Util ( zipWithEqual, mapAccumL, isn'tIn ) +import Outputable \end{code} %************************************************************************ @@ -96,7 +88,7 @@ ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention ctrlReturnConvAlg tycon = case (tyConFamilySize tycon) of - 0 -> pprTrace "ctrlReturnConvAlg:" (ppr PprDebug tycon) $ + 0 -> pprTrace "ctrlReturnConvAlg:" (ppr tycon) $ UnvectoredReturn 0 -- e.g., w/ "data Bin" size -> -- we're supposed to know... @@ -120,7 +112,7 @@ then it gives up, returning @ReturnInHeap@. dataReturnConvAlg :: DataCon -> DataReturnConvention dataReturnConvAlg data_con - = ASSERT2(isDataCon data_con, (ppr PprDebug data_con)) + = ASSERT2(isDataCon data_con, (ppr data_con)) case leftover_kinds of [] -> ReturnInRegs reg_assignment other -> ReturnInHeap -- Didn't fit in registers @@ -231,7 +223,7 @@ makePrimOpArgsRobust op arg_amodes -- Check that all the args fit before returning arg_regs final_arg_regs = case extra_args of [] -> arg_regs - other -> pprError "Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?)" (ppr PprDebug op) + other -> pprPanic "Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?)" (ppr op) arg_assts = mkAbstractCs (zipWithEqual "assign_to_reg" assign_to_reg final_arg_regs non_robust_amodes) diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs index cc845bf539..cba5106b4f 100644 --- a/ghc/compiler/codeGen/CgStackery.lhs +++ b/ghc/compiler/codeGen/CgStackery.lhs @@ -7,8 +7,6 @@ Stack-twiddling operations, which are pretty low-down and grimy. (This is the module that knows all about stack layouts, etc.) \begin{code} -#include "HsVersions.h" - module CgStackery ( allocAStack, allocBStack, allocAStackTop, allocBStackTop, allocUpdateFrame, @@ -16,13 +14,13 @@ module CgStackery ( mkVirtStkOffsets, mkStkAmodes ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CgMonad import AbsCSyn import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep ) -import HeapOffs ( SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset) ) +import HeapOffs ( VirtualSpAOffset, VirtualSpBOffset ) import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep(..) ) diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 87cd59c8b9..fb09a0e96b 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -8,8 +8,6 @@ %******************************************************** \begin{code} -#include "HsVersions.h" - module CgTailCall ( cgTailCall, performReturn, @@ -19,7 +17,7 @@ module CgTailCall ( tailCallBusiness ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CgMonad import AbsCSyn @@ -38,15 +36,15 @@ import ClosureInfo ( nodeMustPointToIt, LambdaFormInfo ) import CmdLineOpts ( opt_DoSemiTagging ) -import HeapOffs ( zeroOff, SYN_IE(VirtualSpAOffset) ) +import HeapOffs ( zeroOff, VirtualSpAOffset ) import Id ( idType, dataConTyCon, dataConTag, - fIRST_TAG, SYN_IE(Id) + fIRST_TAG, Id ) import Literal ( mkMachInt ) import Maybes ( assocMaybe ) import PrimRep ( PrimRep(..) ) -import StgSyn ( SYN_IE(StgArg), GenStgArg(..), SYN_IE(StgLiveVars) ) -import Type ( isPrimType ) +import StgSyn ( StgArg, GenStgArg(..), StgLiveVars ) +import Type ( isUnpointedType ) import TyCon ( TyCon ) import Util ( zipWithEqual, panic, assertPanic ) \end{code} @@ -101,7 +99,7 @@ mode for the local instead of (CLit lit) in the assignment. Case for unboxed @Ids@ first: \begin{code} cgTailCall atom@(StgVarArg fun) [] live_vars - | isPrimType (idType fun) + | isUnpointedType (idType fun) = getCAddrMode fun `thenFC` \ amode -> performPrimReturn amode live_vars \end{code} diff --git a/ghc/compiler/codeGen/CgUpdate.lhs b/ghc/compiler/codeGen/CgUpdate.lhs index 5c0accd692..43a21943d4 100644 --- a/ghc/compiler/codeGen/CgUpdate.lhs +++ b/ghc/compiler/codeGen/CgUpdate.lhs @@ -4,11 +4,9 @@ \section[CgUpdate]{Manipulating update frames} \begin{code} -#include "HsVersions.h" - module CgUpdate ( pushUpdateFrame ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CgMonad import AbsCSyn diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs index 3ff49808fa..adf6035796 100644 --- a/ghc/compiler/codeGen/CgUsages.lhs +++ b/ghc/compiler/codeGen/CgUsages.lhs @@ -7,8 +7,6 @@ This module provides the functions to access (\tr{get*} functions) and modify (\tr{set*} functions) the stacks and heap usage information. \begin{code} -#include "HsVersions.h" - module CgUsages ( initHeapUsage, setVirtHp, getVirtAndRealHp, setRealHp, setRealAndVirtualSps, @@ -20,19 +18,16 @@ module CgUsages ( freeBStkSlot ) where -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(CgLoop1) -- here for paranoia-checking -#endif +#include "HsVersions.h" import AbsCSyn ( RegRelative(..), AbstractC, CAddrMode ) import CgMonad import HeapOffs ( zeroOff, - SYN_IE(VirtualHeapOffset), - SYN_IE(VirtualSpAOffset), - SYN_IE(VirtualSpBOffset) + VirtualHeapOffset, + VirtualSpAOffset, + VirtualSpBOffset ) -import Id ( SYN_IE(IdEnv) ) +import Id ( IdEnv ) \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index a71f3c05ad..d14a8a7a13 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -7,8 +7,6 @@ Much of the rationale for these things is in the ``details'' part of the STG paper. \begin{code} -#include "HsVersions.h" - module ClosureInfo ( ClosureInfo, LambdaFormInfo, SMRep, -- all abstract StandardFormInfo, @@ -29,7 +27,7 @@ module ClosureInfo ( mkVirtHeapOffsets, nodeMustPointToIt, getEntryConvention, - SYN_IE(FCode), CgInfoDownwards, CgState, + FCode, CgInfoDownwards, CgState, blackHoleOnEntry, @@ -43,7 +41,7 @@ module ClosureInfo ( entryLabelFromCI, closureLFInfo, closureSMRep, closureUpdReqd, closureSingleEntry, closureSemiTag, closureType, - closureReturnsUnboxedType, getStandardFormThunkInfo, + closureReturnsUnpointedType, getStandardFormThunkInfo, GenStgArg, isToplevClosure, @@ -56,10 +54,7 @@ module ClosureInfo ( dataConLiveness -- concurrency ) where -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(AbsCLoop) -- here for paranoia-checking -#endif +#include "HsVersions.h" import AbsCSyn ( MagicId, node, mkLiveRegsMask, {- GHC 0.29 only -} AbstractC, CAddrMode @@ -84,30 +79,28 @@ import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel, ) import CmdLineOpts ( opt_SccProfilingOn, opt_ForConcurrent ) import HeapOffs ( intOff, addOff, totHdrSize, varHdrSize, - SYN_IE(VirtualHeapOffset), HeapOffset + VirtualHeapOffset, HeapOffset ) import Id ( idType, getIdArity, externallyVisibleId, dataConTag, fIRST_TAG, isDataCon, isNullaryDataCon, dataConTyCon, - isTupleCon, SYN_IE(DataCon), - GenId{-instance Eq-}, SYN_IE(Id) + isTupleCon, DataCon, + GenId{-instance Eq-}, Id ) import IdInfo ( ArityInfo(..) ) import Maybes ( maybeToBool ) import Name ( getOccString ) -import Outputable ( PprStyle(..), Outputable(..) ) -import PprType ( getTyDescription, GenType{-instance Outputable-} ) -import Pretty --ToDo:rm +import PprType ( getTyDescription ) import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon ) import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep ) import SMRep -- all of it -import TyCon ( TyCon{-instance NamedThing-} ) -import Type ( isPrimType, splitFunTyExpandingDictsAndPeeking, - mkFunTys, maybeAppSpecDataTyConExpandingDicts, - SYN_IE(Type) +import TyCon ( TyCon, isNewTyCon ) +import Type ( isUnpointedType, splitForAllTys, splitFunTys, mkFunTys, splitAlgTyConApp_maybe, + Type ) -import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic ) +import Util ( isIn, mapAccumL ) +import Outputable \end{code} The ``wrapper'' data type for closure information: @@ -1100,12 +1093,12 @@ closureType :: ClosureInfo -> Maybe (TyCon, [Type], [Id]) -- rather than take it from the Id. The Id is probably just "f"! closureType (MkClosureInfo id (LFThunk _ _ _ (VapThunk fun_id args _)) _) - = maybeAppSpecDataTyConExpandingDicts (fun_result_ty (length args) fun_id) + = splitAlgTyConApp_maybe (fun_result_ty (length args) (idType fun_id)) -closureType (MkClosureInfo id lf _) = maybeAppSpecDataTyConExpandingDicts (idType id) +closureType (MkClosureInfo id lf _) = splitAlgTyConApp_maybe (idType id) \end{code} -@closureReturnsUnboxedType@ is used to check whether a closure, {\em +@closureReturnsUnpointedType@ is used to check whether a closure, {\em once it has eaten its arguments}, returns an unboxed type. For example, the closure for a function: \begin{verbatim} @@ -1114,23 +1107,38 @@ example, the closure for a function: returns an unboxed type. This is important when dealing with stack overflow checks. \begin{code} -closureReturnsUnboxedType :: ClosureInfo -> Bool +closureReturnsUnpointedType :: ClosureInfo -> Bool -closureReturnsUnboxedType (MkClosureInfo fun_id (LFReEntrant _ arity _) _) - = isPrimType (fun_result_ty arity fun_id) +closureReturnsUnpointedType (MkClosureInfo fun_id (LFReEntrant _ arity _) _) + = isUnpointedType (fun_result_ty arity (idType fun_id)) -closureReturnsUnboxedType other_closure = False +closureReturnsUnpointedType other_closure = False -- All non-function closures aren't functions, -- and hence are boxed, since they are heap alloc'd --- ToDo: need anything like this in Type.lhs? -fun_result_ty arity id - = let - (arg_tys, res_ty) = splitFunTyExpandingDictsAndPeeking (idType id) - in --- ASSERT(arity >= 0 && length arg_tys >= arity) - (if (arity >= 0 && length arg_tys >= arity) then (\x->x) else pprPanic "fun_result_ty:" (hsep [int arity, ppr PprShowAll id, ppr PprDebug (idType id)])) $ - mkFunTys (drop arity arg_tys) res_ty +-- fun_result_ty is a disgusting little bit of code that finds the result +-- type of a function application. It looks "through" new types. +-- We don't have type args available any more, so we are pretty cavilier, +-- and quite possibly plain wrong. Let's hope it doesn't matter if we are! + +fun_result_ty arity ty + | arity <= n_arg_tys + = mkFunTys (drop arity arg_tys) res_ty + + | otherwise + = case splitAlgTyConApp_maybe res_ty of + Nothing -> pprPanic "fun_result_ty:" (hsep [int arity, + ppr ty]) + + Just (tycon, _, [con]) | isNewTyCon tycon + -> fun_result_ty (arity - n_arg_tys) rep_ty + where + ([rep_ty], _) = splitFunTys rho_ty + (_, rho_ty) = splitForAllTys (idType con) + where + (_, rho_ty) = splitForAllTys ty + (arg_tys, res_ty) = splitFunTys rho_ty + n_arg_tys = length arg_tys \end{code} \begin{code} @@ -1167,7 +1175,7 @@ fastLabelFromCI (MkClosureInfo id lf_info _) -} = case getIdArity id of ArityExactly arity -> mkFastEntryLabel id arity - other -> pprPanic "fastLabelFromCI" (ppr PprDebug id) + other -> pprPanic "fastLabelFromCI" (ppr id) infoTableLabelFromCI :: ClosureInfo -> CLabel infoTableLabelFromCI (MkClosureInfo id lf_info rep) diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 7f151456ef..a9437eb3ef 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -15,11 +15,9 @@ functions drive the mangling of top-level bindings. %************************************************************************ \begin{code} -#include "HsVersions.h" - module CodeGen ( codeGen ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import StgSyn import CgMonad @@ -38,11 +36,11 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_EnsureSplittableC, import CostCentre ( CostCentre ) import CStrings ( modnameToC ) import FiniteMap ( FiniteMap ) -import Id ( SYN_IE(Id) ) +import Id ( Id ) import Maybes ( maybeToBool ) -import Name ( SYN_IE(Module) ) +import Name ( Module ) import PrimRep ( getPrimRepSize, PrimRep(..) ) -import Type ( SYN_IE(Type) ) +import Type ( Type ) import TyCon ( TyCon ) import Util ( panic, assertPanic ) \end{code} diff --git a/ghc/compiler/codeGen/SMRep.lhs b/ghc/compiler/codeGen/SMRep.lhs index 78934e8668..4f106b3281 100644 --- a/ghc/compiler/codeGen/SMRep.lhs +++ b/ghc/compiler/codeGen/SMRep.lhs @@ -7,8 +7,6 @@ This is here, rather than in ClosureInfo, just to keep nhc happy. Other modules should access this info through ClosureInfo. \begin{code} -#include "HsVersions.h" - module SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..), getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr, @@ -17,13 +15,11 @@ module SMRep ( isIntLikeRep ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import Pretty ( text ) -import Util ( panic ) -#if __GLASGOW_HASKELL__ >= 202 import Outputable -#endif +import Util ( panic ) +import GlaExts ( Int(..), Int#, (<#), (==#), (<#), (>#) ) \end{code} %************************************************************************ @@ -221,7 +217,7 @@ instance Text SMRep where MuTupleRep _ -> "MUTUPLE") instance Outputable SMRep where - ppr sty rep = text (show rep) + ppr rep = text (show rep) getSMInfoStr :: SMRep -> String getSMInfoStr (StaticRep _ _) = "STATIC" diff --git a/ghc/compiler/coreSyn/AnnCoreSyn.lhs b/ghc/compiler/coreSyn/AnnCoreSyn.lhs index 59db4a5d19..7c74fd70ea 100644 --- a/ghc/compiler/coreSyn/AnnCoreSyn.lhs +++ b/ghc/compiler/coreSyn/AnnCoreSyn.lhs @@ -8,21 +8,19 @@ than that, just like @CoreSyntax@. (Important to be sure that it {\em really is} just like @CoreSyntax@.) \begin{code} -#include "HsVersions.h" - module AnnCoreSyn ( - AnnCoreBinding(..), SYN_IE(AnnCoreExpr), + AnnCoreBinding(..), AnnCoreExpr, AnnCoreExpr'(..), -- v sad that this must be exported AnnCoreCaseAlts(..), AnnCoreCaseDefault(..), deAnnotate -- we may eventually export some of the other deAnners ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CoreSyn -import Id ( SYN_IE(Id) ) +import Id ( Id ) import Literal ( Literal ) import PrimOp ( PrimOp ) import CostCentre ( CostCentre ) @@ -31,61 +29,61 @@ import Type ( GenType ) \end{code} \begin{code} -data AnnCoreBinding val_bdr val_occ tyvar uvar annot - = AnnNonRec val_bdr (AnnCoreExpr val_bdr val_occ tyvar uvar annot) - | AnnRec [(val_bdr, AnnCoreExpr val_bdr val_occ tyvar uvar annot)] +data AnnCoreBinding val_bdr val_occ flexi annot + = AnnNonRec val_bdr (AnnCoreExpr val_bdr val_occ flexi annot) + | AnnRec [(val_bdr, AnnCoreExpr val_bdr val_occ flexi annot)] \end{code} \begin{code} -type AnnCoreExpr val_bdr val_occ tyvar uvar annot - = (annot, AnnCoreExpr' val_bdr val_occ tyvar uvar annot) +type AnnCoreExpr val_bdr val_occ flexi annot + = (annot, AnnCoreExpr' val_bdr val_occ flexi annot) -data AnnCoreExpr' val_bdr val_occ tyvar uvar annot +data AnnCoreExpr' val_bdr val_occ flexi annot = AnnVar val_occ | AnnLit Literal - | AnnCon Id [GenCoreArg val_occ tyvar uvar] - | AnnPrim PrimOp [GenCoreArg val_occ tyvar uvar] + | AnnCon Id [GenCoreArg val_occ flexi] + | AnnPrim PrimOp [GenCoreArg val_occ flexi] - | AnnLam (GenCoreBinder val_bdr tyvar uvar) - (AnnCoreExpr val_bdr val_occ tyvar uvar annot) + | AnnLam (GenCoreBinder val_bdr flexi) + (AnnCoreExpr val_bdr val_occ flexi annot) - | AnnApp (AnnCoreExpr val_bdr val_occ tyvar uvar annot) - (GenCoreArg val_occ tyvar uvar) + | AnnApp (AnnCoreExpr val_bdr val_occ flexi annot) + (GenCoreArg val_occ flexi) - | AnnCase (AnnCoreExpr val_bdr val_occ tyvar uvar annot) - (AnnCoreCaseAlts val_bdr val_occ tyvar uvar annot) + | AnnCase (AnnCoreExpr val_bdr val_occ flexi annot) + (AnnCoreCaseAlts val_bdr val_occ flexi annot) - | AnnLet (AnnCoreBinding val_bdr val_occ tyvar uvar annot) - (AnnCoreExpr val_bdr val_occ tyvar uvar annot) + | AnnLet (AnnCoreBinding val_bdr val_occ flexi annot) + (AnnCoreExpr val_bdr val_occ flexi annot) | AnnSCC CostCentre - (AnnCoreExpr val_bdr val_occ tyvar uvar annot) + (AnnCoreExpr val_bdr val_occ flexi annot) | AnnCoerce Coercion - (GenType tyvar uvar) - (AnnCoreExpr val_bdr val_occ tyvar uvar annot) + (GenType flexi) + (AnnCoreExpr val_bdr val_occ flexi annot) \end{code} \begin{code} -data AnnCoreCaseAlts val_bdr val_occ tyvar uvar annot +data AnnCoreCaseAlts val_bdr val_occ flexi annot = AnnAlgAlts [(Id, [val_bdr], - AnnCoreExpr val_bdr val_occ tyvar uvar annot)] - (AnnCoreCaseDefault val_bdr val_occ tyvar uvar annot) + AnnCoreExpr val_bdr val_occ flexi annot)] + (AnnCoreCaseDefault val_bdr val_occ flexi annot) | AnnPrimAlts [(Literal, - AnnCoreExpr val_bdr val_occ tyvar uvar annot)] - (AnnCoreCaseDefault val_bdr val_occ tyvar uvar annot) + AnnCoreExpr val_bdr val_occ flexi annot)] + (AnnCoreCaseDefault val_bdr val_occ flexi annot) -data AnnCoreCaseDefault val_bdr val_occ tyvar uvar annot +data AnnCoreCaseDefault val_bdr val_occ flexi annot = AnnNoDefault | AnnBindDefault val_bdr - (AnnCoreExpr val_bdr val_occ tyvar uvar annot) + (AnnCoreExpr val_bdr val_occ flexi annot) \end{code} \begin{code} -deAnnotate :: AnnCoreExpr val_bdr val_occ tyvar uvar ann - -> GenCoreExpr val_bdr val_occ tyvar uvar +deAnnotate :: AnnCoreExpr val_bdr val_occ flexi ann + -> GenCoreExpr val_bdr val_occ flexi deAnnotate (_, AnnVar v) = Var v deAnnotate (_, AnnLit lit) = Lit lit diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs index cf63b8bdf2..eb284c185b 100644 --- a/ghc/compiler/coreSyn/CoreLift.lhs +++ b/ghc/compiler/coreSyn/CoreLift.lhs @@ -4,8 +4,6 @@ \section[CoreLift]{Lifts unboxed bindings and any references to them} \begin{code} -#include "HsVersions.h" - module CoreLift ( liftCoreBindings, @@ -16,18 +14,18 @@ module CoreLift ( ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CoreSyn import CoreUtils ( coreExprType ) import Id ( idType, mkSysLocal, nullIdEnv, growIdEnvList, lookupIdEnv, mkIdWithNewType, - SYN_IE(IdEnv), GenId{-instances-}, SYN_IE(Id) + IdEnv, GenId{-instances-}, Id ) import Name ( isLocallyDefined, getSrcLoc, getOccString ) import TyCon ( isBoxedTyCon, TyCon{-instance-} ) -import Type ( maybeAppDataTyConExpandingDicts, eqTy ) +import Type ( splitAlgTyConApp_maybe ) import TysPrim ( statePrimTyCon ) import TysWiredIn ( liftDataCon, mkLiftTy ) import Unique ( Unique ) @@ -82,7 +80,6 @@ liftBindAndScope top_lev bind scopeM liftCoreArg :: CoreArg -> LiftM (CoreArg, CoreExpr -> CoreExpr) liftCoreArg arg@(TyArg _) = returnL (arg, id) -liftCoreArg arg@(UsageArg _) = returnL (arg, id) liftCoreArg arg@(LitArg _) = returnL (arg, id) liftCoreArg arg@(VarArg v) = isLiftedId v `thenL` \ lifted -> @@ -289,7 +286,7 @@ mkLiftedId id u bindUnlift :: Id -> Id -> CoreExpr -> CoreExpr bindUnlift vlift vunlift expr = ASSERT (isUnboxedButNotState unlift_ty) - ASSERT (lift_ty `eqTy` mkLiftTy unlift_ty) + ASSERT (lift_ty == mkLiftTy unlift_ty) Case (Var vlift) (AlgAlts [(liftDataCon, [vunlift], expr)] NoDefault) where @@ -299,9 +296,9 @@ bindUnlift vlift vunlift expr liftExpr :: Id -> CoreExpr -> CoreExpr liftExpr vunlift rhs = ASSERT (isUnboxedButNotState unlift_ty) - ASSERT (rhs_ty `eqTy` unlift_ty) + ASSERT (rhs_ty == unlift_ty) Case rhs (PrimAlts [] - (BindDefault vunlift (mkCon liftDataCon [] [unlift_ty] [VarArg vunlift]))) + (BindDefault vunlift (mkCon liftDataCon [unlift_ty] [VarArg vunlift]))) where rhs_ty = coreExprType rhs unlift_ty = idType vunlift @@ -312,7 +309,7 @@ applyBindUnlifts [] expr = expr applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr) isUnboxedButNotState ty = - case (maybeAppDataTyConExpandingDicts ty) of + case (splitAlgTyConApp_maybe ty) of Nothing -> False Just (tycon, _, _) -> not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon) diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 981c0c495e..d4dffadb78 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -4,52 +4,48 @@ \section[CoreLint]{A ``lint'' pass to check for Core correctness} \begin{code} -#include "HsVersions.h" - module CoreLint ( lintCoreBindings, lintUnfolding ) where -IMP_Ubiq() -IMPORT_1_3(IO(hPutStr,stderr)) +#include "HsVersions.h" -import CmdLineOpts ( opt_D_show_passes, opt_PprUserLength, opt_DoCoreLinting ) +import IO ( hPutStr, stderr ) + +import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting ) import CoreSyn import Bag import Kind ( hasMoreBoxityInfo, Kind{-instance-}, isTypeKind, isBoxedTypeKind {- TEMP --SOF -} ) import Literal ( literalType, Literal{-instance-} ) -import Id ( idType, isBottomingId, dataConRepType, isDataCon, isNewCon, +import Id ( idType, isBottomingId, dataConRepType, isDataCon, isNewCon, isAlgCon, dataConArgTys, GenId{-instances-}, emptyIdSet, mkIdSet, intersectIdSets, - unionIdSets, elementOfIdSet, SYN_IE(IdSet), - SYN_IE(Id) + unionIdSets, elementOfIdSet, IdSet, + Id ) import Maybes ( catMaybes ) import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-}, NamedThing(..) ) import PprCore -import Outputable ( PprStyle(..), Outputable(..), pprDumpStyle, printErrs ) import ErrUtils ( doIfSet, ghcExit ) import PprType ( GenType, GenTyVar, TyCon ) -import Pretty import PrimOp ( primOpType, PrimOp(..) ) import PrimRep ( PrimRep(..) ) import SrcLoc ( SrcLoc ) -import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,mkForAllTys,getForAllTy_maybe, - getFunTyExpandingDicts_maybe, - getForAllTyExpandingDicts_maybe, - isPrimType,typeKind,instantiateTy,splitSigmaTy, - mkForAllUsageTy,getForAllUsageTy,instantiateUsage, - maybeAppDataTyConExpandingDicts, eqTy, SYN_IE(Type) +import Type ( mkFunTy, splitFunTy_maybe, mkForAllTy, + splitForAllTy_maybe, + isUnpointedType, typeKind, instantiateTy, splitSigmaTy, + splitAlgTyConApp_maybe, Type ) import TyCon ( isPrimTyCon, isDataTyCon ) -import TyVar ( tyVarKind, GenTyVar{-instances-} ) +import TyVar ( TyVar, tyVarKind, mkTyVarEnv ) +import ErrUtils ( ErrMsg ) import Unique ( Unique ) -import Usage ( GenUsage, SYN_IE(Usage) ) -import Util ( zipEqual, pprTrace, pprPanic, assertPanic, panic ) +import Util ( zipEqual ) +import Outputable infixr 9 `thenL`, `seqL`, `thenMaybeL`, `seqMaybeL` \end{code} @@ -99,7 +95,7 @@ lintCoreBindings whoDunnit spec_done binds Nothing -> doIfSet opt_D_show_passes (hPutStr stderr ("*** Core Linted result of " ++ whoDunnit ++ "\n")) - Just bad_news -> printErrs (display bad_news) >> + Just bad_news -> printDump (display bad_news) >> ghcExit 1 where lint_binds [] = returnL () @@ -110,9 +106,9 @@ lintCoreBindings whoDunnit spec_done binds display bad_news = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"), - bad_news pprDumpStyle, + bad_news, ptext SLIT("*** Offending Program ***"), - pprCoreBindings pprDumpStyle binds, + pprCoreBindings binds, ptext SLIT("*** End of Offense ***") ] \end{code} @@ -137,9 +133,9 @@ lintUnfolding locn expr Nothing -> Just expr Just msg -> pprTrace "WARNING: Discarded bad unfolding from interface:\n" - (vcat [msg (PprForUser opt_PprUserLength), + (vcat [msg, ptext SLIT("*** Bad unfolding ***"), - ppr PprDebug expr, + ppr expr, ptext SLIT("*** End unfolding ***")]) Nothing \end{code} @@ -177,8 +173,8 @@ lintSingleBinding (binder,rhs) Just ty -> checkTys (idType binder) ty (mkRhsMsg binder ty)) `seqL` - -- Check (not isPrimType) - checkIfSpecDoneL (not (isPrimType (idType binder))) + -- Check (not isUnpointedType) + checkIfSpecDoneL (not (isUnpointedType (idType binder))) (mkRhsPrimMsg binder rhs) -- We should check the unfolding, if any, but this is tricky because @@ -195,7 +191,20 @@ lintSingleBinding (binder,rhs) \begin{code} lintCoreExpr :: CoreExpr -> LintM (Maybe Type) -- Nothing if error found -lintCoreExpr (Var var) = checkInScope var `seqL` returnL (Just (idType var)) +lintCoreExpr (Var var) + | isAlgCon var = returnL (Just (idType var)) + -- Micro-hack here... Class decls generate applications of their + -- dictionary constructor, but don't generate a binding for the + -- constructor (since it would never be used). After a single round + -- of simplification, these dictionary constructors have been + -- inlined (from their UnfoldInfo) to CoCons. Just between + -- desugaring and simplfication, though, they appear as naked, unbound + -- variables as the function in an application. + -- The hack here simply doesn't check for out-of-scope-ness for + -- data constructors (at least, in a function position). + + | otherwise = checkInScope var `seqL` returnL (Just (idType var)) + lintCoreExpr (Lit lit) = returnL (Just (literalType lit)) lintCoreExpr (SCC _ expr) = lintCoreExpr expr lintCoreExpr e@(Coerce coercion ty expr) @@ -272,8 +281,8 @@ lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type) lintCoreArg e ty (LitArg lit) = -- Make sure function type matches argument - case (getFunTyExpandingDicts_maybe False{-no peeking in newtypes-} ty) of - Just (arg,res) | (lit_ty `eqTy` arg) -> returnL(Just res) + case (splitFunTy_maybe ty) of + Just (arg,res) | (lit_ty == arg) -> returnL(Just res) _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing where lit_ty = literalType lit @@ -282,15 +291,15 @@ lintCoreArg e ty (VarArg v) = -- Make sure variable is bound checkInScope v `seqL` -- Make sure function type matches argument - case (getFunTyExpandingDicts_maybe False{-as above-} ty) of - Just (arg,res) | (var_ty `eqTy` arg) -> returnL(Just res) + case (splitFunTy_maybe ty) of + Just (arg,res) | (var_ty == arg) -> returnL(Just res) _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing where var_ty = idType v lintCoreArg e ty a@(TyArg arg_ty) = -- ToDo: Check that ty is well-kinded and has no unbound tyvars - case (getForAllTyExpandingDicts_maybe ty) of + case (splitForAllTy_maybe ty) of Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing Just (tyvar,body) -> @@ -304,18 +313,10 @@ lintCoreArg e ty a@(TyArg arg_ty) -- error :: forall a:*. String -> a -- and then apply it to both boxed and unboxed types. then - returnL(Just(instantiateTy [(tyvar,arg_ty)] body)) + returnL(Just(instantiateTy (mkTyVarEnv [(tyvar,arg_ty)]) body)) else - pprTrace "lintCoreArg:kinds:" (hsep [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $ - addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing - -lintCoreArg e ty (UsageArg u) - = -- ToDo: Check that usage has no unbound usage variables - case (getForAllUsageTy ty) of - Just (uvar,bounds,body) -> - -- ToDo: Check argument satisfies bounds - returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body")) - _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing + pprTrace "lintCoreArg:kinds:" (hsep [ppr tyvar_kind, ppr argty_kind]) $ + addErrL (mkKindErrMsg tyvar arg_ty e) `seqL` returnL Nothing \end{code} %************************************************************************ @@ -369,7 +370,7 @@ lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts) lintAlgAlt scrut_ty (con,args,rhs) - = (case maybeAppDataTyConExpandingDicts scrut_ty of + = (case splitAlgTyConApp_maybe scrut_ty of Just (tycon, tys_applied, cons) | isDataTyCon tycon -> let arg_tys = dataConArgTys con tys_applied @@ -432,8 +433,6 @@ type LintM a = Bool -- True <=> specialisation has been done -> Bag ErrMsg -- Error messages so far -> (a, Bag ErrMsg) -- Result and error messages (if any) -type ErrMsg = PprStyle -> Doc - data LintLocInfo = RhsOf Id -- The variable bound | LambdaBodyOf Id -- The lambda-binder @@ -441,25 +440,27 @@ data LintLocInfo | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) instance Outputable LintLocInfo where - ppr sty (RhsOf v) - = hcat [ppr sty (getSrcLoc v), ptext SLIT(": [RHS of "), pp_binders sty [v], char ']'] + ppr (RhsOf v) + = ppr (getSrcLoc v) <> colon <+> + brackets (ptext SLIT("RHS of") <+> pp_binders [v]) - ppr sty (LambdaBodyOf b) - = hcat [ppr sty (getSrcLoc b), - ptext SLIT(": [in body of lambda with binder "), pp_binder sty b, char ']'] + ppr (LambdaBodyOf b) + = ppr (getSrcLoc b) <> colon <+> + brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b) - ppr sty (BodyOfLetRec bs) - = hcat [ppr sty (getSrcLoc (head bs)), - ptext SLIT(": [in body of letrec with binders "), pp_binders sty bs, char ']'] + ppr (BodyOfLetRec bs) + = ppr (getSrcLoc (head bs)) <> colon <+> + brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs) - ppr sty (ImportedUnfolding locn) - = (<>) (ppr sty locn) (ptext SLIT(": [in an imported unfolding]")) + ppr (ImportedUnfolding locn) + = ppr locn <> colon <+> + brackets (ptext SLIT("in an imported unfolding")) -pp_binders :: PprStyle -> [Id] -> Doc -pp_binders sty bs = sep (punctuate comma (map (pp_binder sty) bs)) +pp_binders :: [Id] -> SDoc +pp_binders bs = sep (punctuate comma (map pp_binder bs)) -pp_binder :: PprStyle -> Id -> Doc -pp_binder sty b = hsep [ppr sty b, text "::", ppr sty (idType b)] +pp_binder :: Id -> SDoc +pp_binder b = hsep [ppr b, text "::", ppr (idType b)] \end{code} \begin{code} @@ -469,9 +470,7 @@ initL m spec_done if isEmptyBag errs then Nothing else - Just ( \ sty -> - vcat [ msg sty | msg <- bagToList errs ] - ) + Just (vcat (bagToList errs)) } returnL :: a -> LintM a @@ -535,9 +534,7 @@ addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg addErr errs_so_far msg locs = ASSERT (not (null locs)) - errs_so_far `snocBag` ( \ sty -> - hang (ppr sty (head locs)) 4 (msg sty) - ) + errs_so_far `snocBag` (hang (ppr (head locs)) 4 msg) addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m spec loc scope errs @@ -558,7 +555,7 @@ addInScopeVars ids m spec loc scope errs -- names after all. WDP 94/07 -- (if isEmptyUniqSet shadowed -- then id --- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) ( +-- else pprTrace "Shadowed vars:" (ppr (uniqSetToList shadowed))) ( m spec loc (scope `unionIdSets` new_set) errs -- ) \end{code} @@ -570,134 +567,133 @@ checkInScope id spec loc scope errs id_name = getName id in if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then - ((),addErr errs (\sty -> hsep [ppr sty id, ptext SLIT("is out of scope")]) loc) + ((), addErr errs (hsep [ppr id, ptext SLIT("is out of scope")]) loc) else ((),errs) checkTys :: Type -> Type -> ErrMsg -> LintM () checkTys ty1 ty2 msg spec loc scope errs - = if ty1 `eqTy` ty2 then ((), errs) else ((), addErr errs msg loc) + = if ty1 == ty2 then ((), errs) else ((), addErr errs msg loc) \end{code} \begin{code} -mkConErrMsg e sty +mkConErrMsg e = ($$) (ptext SLIT("Application of newtype constructor:")) - (ppr sty e) + (ppr e) -mkCoerceErrMsg e sty +mkCoerceErrMsg e = ($$) (ptext SLIT("Coercion using a datatype constructor:")) - (ppr sty e) + (ppr e) mkCaseAltMsg :: CoreCaseAlts -> ErrMsg -mkCaseAltMsg alts sty +mkCaseAltMsg alts = ($$) (ptext SLIT("Type of case alternatives not the same:")) - (ppr sty alts) + (ppr alts) mkCaseDataConMsg :: CoreExpr -> ErrMsg -mkCaseDataConMsg expr sty +mkCaseDataConMsg expr = ($$) (ptext SLIT("A case scrutinee not of data constructor type:")) - (pp_expr sty expr) + (pprCoreExpr expr) mkCaseNotPrimMsg :: TyCon -> ErrMsg -mkCaseNotPrimMsg tycon sty +mkCaseNotPrimMsg tycon = ($$) (ptext SLIT("A primitive case on a non-primitive type:")) - (ppr sty tycon) + (ppr tycon) mkCasePrimMsg :: TyCon -> ErrMsg -mkCasePrimMsg tycon sty +mkCasePrimMsg tycon = ($$) (ptext SLIT("An algebraic case on a primitive type:")) - (ppr sty tycon) + (ppr tycon) mkCaseAbstractMsg :: TyCon -> ErrMsg -mkCaseAbstractMsg tycon sty +mkCaseAbstractMsg tycon = ($$) (ptext SLIT("An algebraic case on some weird type:")) - (ppr sty tycon) + (ppr tycon) mkDefltMsg :: CoreCaseDefault -> ErrMsg -mkDefltMsg deflt sty +mkDefltMsg deflt = ($$) (ptext SLIT("Binder in case default doesn't match type of scrutinee:")) - (ppr sty deflt) + (ppr deflt) mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg -mkAppMsg fun arg expr sty +mkAppMsg fun arg expr = vcat [ptext SLIT("Argument value doesn't match argument type:"), - hang (ptext SLIT("Fun type:")) 4 (ppr sty fun), - hang (ptext SLIT("Arg type:")) 4 (ppr sty arg), - hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)] + hang (ptext SLIT("Fun type:")) 4 (ppr fun), + hang (ptext SLIT("Arg type:")) 4 (ppr arg), + hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)] + +mkKindErrMsg :: TyVar -> Type -> CoreExpr -> ErrMsg +mkKindErrMsg tyvar arg_ty expr + = vcat [ptext SLIT("Kinds don't match in type application:"), + hang (ptext SLIT("Type variable:")) + 4 (ppr tyvar <+> ptext SLIT("::") <+> ppr (tyVarKind tyvar)), + hang (ptext SLIT("Arg type:")) + 4 (ppr arg_ty <+> ptext SLIT("::") <+> ppr (typeKind arg_ty)), + hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)] mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg -mkTyAppMsg msg ty arg expr sty +mkTyAppMsg msg ty arg expr = vcat [hsep [ptext msg, ptext SLIT("type application:")], - hang (ptext SLIT("Exp type:")) 4 (ppr sty ty), - hang (ptext SLIT("Arg type:")) 4 (ppr sty arg), - hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)] - -mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg -mkUsageAppMsg ty u expr sty - = vcat [ptext SLIT("Illegal usage application:"), - hang (ptext SLIT("Exp type:")) 4 (ppr sty ty), - hang (ptext SLIT("Usage exp:")) 4 (ppr sty u), - hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)] + hang (ptext SLIT("Exp type:")) + 4 (ppr ty <+> ptext SLIT("::") <+> ppr (typeKind ty)), + hang (ptext SLIT("Arg type:")) + 4 (ppr arg <+> ptext SLIT("::") <+> ppr (typeKind arg)), + hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)] mkAlgAltMsg1 :: Type -> ErrMsg -mkAlgAltMsg1 ty sty +mkAlgAltMsg1 ty = ($$) (text "In some case statement, type of scrutinee is not a data type:") - (ppr sty ty) --- (($$) (ppr sty ty) (ppr sty (expandTy ty))) -- ToDo: rm + (ppr ty) mkAlgAltMsg2 :: Type -> Id -> ErrMsg -mkAlgAltMsg2 ty con sty +mkAlgAltMsg2 ty con = vcat [ text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", - ppr sty ty, - ppr sty con + ppr ty, + ppr con ] mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg -mkAlgAltMsg3 con alts sty +mkAlgAltMsg3 con alts = vcat [ text "In some algebraic case alternative, number of arguments doesn't match constructor:", - ppr sty con, - ppr sty alts + ppr con, + ppr alts ] mkAlgAltMsg4 :: Type -> Id -> ErrMsg -mkAlgAltMsg4 ty arg sty +mkAlgAltMsg4 ty arg = vcat [ text "In some algebraic case alternative, type of argument doesn't match data constructor:", - ppr sty ty, - ppr sty arg + ppr ty, + ppr arg ] mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg -mkPrimAltMsg alt sty +mkPrimAltMsg alt = ($$) (text "In a primitive case alternative, type of literal doesn't match type of scrutinee:") - (ppr sty alt) + (ppr alt) mkRhsMsg :: Id -> Type -> ErrMsg -mkRhsMsg binder ty sty +mkRhsMsg binder ty = vcat [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"), - ppr sty binder], - hsep [ptext SLIT("Binder's type:"), ppr sty (idType binder)], - hsep [ptext SLIT("Rhs type:"), ppr sty ty]] + ppr binder], + hsep [ptext SLIT("Binder's type:"), ppr (idType binder)], + hsep [ptext SLIT("Rhs type:"), ppr ty]] mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg -mkRhsPrimMsg binder rhs sty +mkRhsPrimMsg binder rhs = vcat [hsep [ptext SLIT("The type of this binder is primitive:"), - ppr sty binder], - hsep [ptext SLIT("Binder's type:"), ppr sty (idType binder)] + ppr binder], + hsep [ptext SLIT("Binder's type:"), ppr (idType binder)] ] mkSpecTyAppMsg :: CoreArg -> ErrMsg -mkSpecTyAppMsg arg sty +mkSpecTyAppMsg arg = ($$) (ptext SLIT("Unboxed types in a type application (after specialisation):")) - (ppr sty arg) - -pp_expr :: PprStyle -> CoreExpr -> Doc -pp_expr sty expr - = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr + (ppr arg) \end{code} diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 6e28cf431d..596a7c2a69 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -4,8 +4,6 @@ \section[CoreSyn]{A data type for the Haskell compiler midsection} \begin{code} -#include "HsVersions.h" - module CoreSyn ( GenCoreBinding(..), GenCoreExpr(..), GenCoreArg(..), GenCoreBinder(..), GenCoreCaseAlts(..), @@ -14,11 +12,11 @@ module CoreSyn ( bindersOf, pairsFromCoreBinds, rhssOfBind, - mkGenApp, mkValApp, mkTyApp, mkUseApp, + mkGenApp, mkValApp, mkTyApp, mkApp, mkCon, mkPrim, - mkValLam, mkTyLam, mkUseLam, + mkValLam, mkTyLam, mkLam, - collectBinders, collectUsageAndTyBinders, collectValBinders, + collectBinders, collectValBinders, collectTyBinders, isValBinder, notValBinder, collectArgs, initialTyArgs, initialValArgs, isValArg, notValArg, numValArgs, @@ -30,42 +28,40 @@ module CoreSyn ( rhssOfAlts, -- Common type instantiation... - SYN_IE(CoreBinding), - SYN_IE(CoreExpr), - SYN_IE(CoreBinder), - SYN_IE(CoreArg), - SYN_IE(CoreCaseAlts), - SYN_IE(CoreCaseDefault), + CoreBinding, + CoreExpr, + CoreBinder, + CoreArg, + CoreCaseAlts, + CoreCaseDefault, -- And not-so-common type instantiations... - SYN_IE(TaggedCoreBinding), - SYN_IE(TaggedCoreExpr), - SYN_IE(TaggedCoreBinder), - SYN_IE(TaggedCoreArg), - SYN_IE(TaggedCoreCaseAlts), - SYN_IE(TaggedCoreCaseDefault), - - SYN_IE(SimplifiableCoreBinding), - SYN_IE(SimplifiableCoreExpr), - SYN_IE(SimplifiableCoreBinder), - SYN_IE(SimplifiableCoreArg), - SYN_IE(SimplifiableCoreCaseAlts), - SYN_IE(SimplifiableCoreCaseDefault) + TaggedCoreBinding, + TaggedCoreExpr, + TaggedCoreBinder, + TaggedCoreArg, + TaggedCoreCaseAlts, + TaggedCoreCaseDefault, + + SimplifiableCoreBinding, + SimplifiableCoreExpr, + SimplifiableCoreBinder, + SimplifiableCoreArg, + SimplifiableCoreCaseAlts, + SimplifiableCoreCaseDefault ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CostCentre ( showCostCentre, CostCentre ) -import Id ( idType, GenId{-instance Eq-}, SYN_IE(Id) ) -import Type ( isUnboxedType,GenType, SYN_IE(Type) ) -import TyVar ( GenTyVar, SYN_IE(TyVar) ) -import Usage ( SYN_IE(UVar),GenUsage,SYN_IE(Usage) ) +import Id ( idType, GenId{-instance Eq-}, Id ) +import Type ( isUnboxedType,GenType, Type ) +import TyVar ( GenTyVar, TyVar ) import Util ( panic, assertPanic {-pprTrace:ToDo:rm-} ) -#if __GLASGOW_HASKELL__ >= 202 -import Literal ( Literal ) import BinderInfo ( BinderInfo ) +import BasicTypes ( Unused ) +import Literal ( Literal ) import PrimOp ( PrimOp ) -#endif \end{code} %************************************************************************ @@ -83,19 +79,19 @@ bounder}. Or {\em binder} and {\em var}.] A @GenCoreBinding@ is either a single non-recursive binding of a ``binder'' to an expression, or a mutually-recursive blob of same. \begin{code} -data GenCoreBinding val_bdr val_occ tyvar uvar - = NonRec val_bdr (GenCoreExpr val_bdr val_occ tyvar uvar) - | Rec [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)] +data GenCoreBinding val_bdr val_occ flexi + = NonRec val_bdr (GenCoreExpr val_bdr val_occ flexi) + | Rec [(val_bdr, GenCoreExpr val_bdr val_occ flexi)] \end{code} \begin{code} -bindersOf :: GenCoreBinding val_bdr val_occ tyvar uvar -> [val_bdr] +bindersOf :: GenCoreBinding val_bdr val_occ flexi -> [val_bdr] pairsFromCoreBinds :: - [GenCoreBinding val_bdr val_occ tyvar uvar] -> - [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)] + [GenCoreBinding val_bdr val_occ flexi] -> + [(val_bdr, GenCoreExpr val_bdr val_occ flexi)] -rhssOfBind :: GenCoreBinding val_bdr val_occ tyvar uvar -> [GenCoreExpr val_bdr val_occ tyvar uvar] +rhssOfBind :: GenCoreBinding val_bdr val_occ flexi -> [GenCoreExpr val_bdr val_occ flexi] bindersOf (NonRec binder _) = [binder] bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] @@ -118,7 +114,7 @@ rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] (more-or-less) boiled-down second-order polymorphic lambda calculus. For types in the core world, we just keep using @Types@. \begin{code} -data GenCoreExpr val_bdr val_occ tyvar uvar +data GenCoreExpr val_bdr val_occ flexi = Var val_occ | Lit Literal -- literal constants \end{code} @@ -129,7 +125,7 @@ simplifier (and by the desugarer when it knows what it's doing). The desugarer sets up constructors as applications of global @Vars@s. \begin{code} - | Con Id [GenCoreArg val_occ tyvar uvar] + | Con Id [GenCoreArg val_occ flexi] -- Saturated constructor application: -- The constructor is a function of the form: -- /\ a1 -> ... /\ am -> \ b1 -> ... \ bn -> @@ -137,7 +133,7 @@ desugarer sets up constructors as applications of global @Vars@s. -- regular kind; there will be "m" Types and -- "n" bindees in the Con args. - | Prim PrimOp [GenCoreArg val_occ tyvar uvar] + | Prim PrimOp [GenCoreArg val_occ flexi] -- saturated primitive operation; -- comment on Cons applies here, too. @@ -145,11 +141,11 @@ desugarer sets up constructors as applications of global @Vars@s. Ye olde abstraction and application operators. \begin{code} - | Lam (GenCoreBinder val_bdr tyvar uvar) - (GenCoreExpr val_bdr val_occ tyvar uvar) + | Lam (GenCoreBinder val_bdr flexi) + (GenCoreExpr val_bdr val_occ flexi) - | App (GenCoreExpr val_bdr val_occ tyvar uvar) - (GenCoreArg val_occ tyvar uvar) + | App (GenCoreExpr val_bdr val_occ flexi) + (GenCoreArg val_occ flexi) \end{code} Case expressions (\tr{case <expr> of <List of alternatives>}): there @@ -157,8 +153,8 @@ are really two flavours masquerading here---those for scrutinising {\em algebraic} types and those for {\em primitive} types. Please see under @GenCoreCaseAlts@. \begin{code} - | Case (GenCoreExpr val_bdr val_occ tyvar uvar) - (GenCoreCaseAlts val_bdr val_occ tyvar uvar) + | Case (GenCoreExpr val_bdr val_occ flexi) + (GenCoreCaseAlts val_bdr val_occ flexi) \end{code} A Core case expression \tr{case e of v -> ...} implies evaluation of @@ -169,8 +165,8 @@ Non-recursive @Lets@ only have one binding; having more than one doesn't buy you much, and it is an easy way to mess up variable scoping. \begin{code} - | Let (GenCoreBinding val_bdr val_occ tyvar uvar) - (GenCoreExpr val_bdr val_occ tyvar uvar) + | Let (GenCoreBinding val_bdr val_occ flexi) + (GenCoreExpr val_bdr val_occ flexi) -- both recursive and non-. -- The "GenCoreBinding" records that information \end{code} @@ -181,7 +177,7 @@ alternative of using a new PrimativeOp may result in a bad transformations of which we are unaware. \begin{code} | SCC CostCentre -- label of scc - (GenCoreExpr val_bdr val_occ tyvar uvar) -- scc expression + (GenCoreExpr val_bdr val_occ flexi) -- scc expression \end{code} Coercions arise from uses of the constructor of a @newtype@ @@ -190,8 +186,8 @@ pattern matching (resulting in a @CoerceOut@). \begin{code} | Coerce Coercion - (GenType tyvar uvar) -- Type of the whole expression - (GenCoreExpr val_bdr val_occ tyvar uvar) + (GenType flexi) -- Type of the whole expression + (GenCoreExpr val_bdr val_occ flexi) \end{code} \begin{code} @@ -215,16 +211,16 @@ being bound has unboxed type. We have different variants ... (unboxed bindings in a letrec are still prohibited) \begin{code} -mkCoLetAny :: GenCoreBinding Id Id tyvar uvar - -> GenCoreExpr Id Id tyvar uvar - -> GenCoreExpr Id Id tyvar uvar -mkCoLetsAny :: [GenCoreBinding Id Id tyvar uvar] -> - GenCoreExpr Id Id tyvar uvar -> - GenCoreExpr Id Id tyvar uvar +mkCoLetAny :: GenCoreBinding Id Id flexi + -> GenCoreExpr Id Id flexi + -> GenCoreExpr Id Id flexi +mkCoLetsAny :: [GenCoreBinding Id Id flexi] -> + GenCoreExpr Id Id flexi -> + GenCoreExpr Id Id flexi -mkCoLetrecAny :: [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)] - -> GenCoreExpr val_bdr val_occ tyvar uvar - -> GenCoreExpr val_bdr val_occ tyvar uvar +mkCoLetrecAny :: [(val_bdr, GenCoreExpr val_bdr val_occ flexi)] + -> GenCoreExpr val_bdr val_occ flexi + -> GenCoreExpr val_bdr val_occ flexi mkCoLetrecAny [] body = body mkCoLetrecAny binds body = Let (Rec binds) body @@ -303,24 +299,24 @@ Case e [ BindDefaultAlt x -> b ] \end{verbatim} \begin{code} -data GenCoreCaseAlts val_bdr val_occ tyvar uvar +data GenCoreCaseAlts val_bdr val_occ flexi = AlgAlts [(Id, -- alts: data constructor, [val_bdr], -- constructor's parameters, - GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs. - (GenCoreCaseDefault val_bdr val_occ tyvar uvar) + GenCoreExpr val_bdr val_occ flexi)] -- rhs. + (GenCoreCaseDefault val_bdr val_occ flexi) | PrimAlts [(Literal, -- alts: unboxed literal, - GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs. - (GenCoreCaseDefault val_bdr val_occ tyvar uvar) + GenCoreExpr val_bdr val_occ flexi)] -- rhs. + (GenCoreCaseDefault val_bdr val_occ flexi) -- obvious things: if there are no alts in the list, then the default -- can't be NoDefault. -data GenCoreCaseDefault val_bdr val_occ tyvar uvar +data GenCoreCaseDefault val_bdr val_occ flexi = NoDefault -- small con family: all -- constructor accounted for | BindDefault val_bdr -- form: var -> expr; - (GenCoreExpr val_bdr val_occ tyvar uvar) -- "val_bdr" may or may not + (GenCoreExpr val_bdr val_occ flexi) -- "val_bdr" may or may not -- be used in RHS. \end{code} @@ -339,10 +335,9 @@ rhssOfDeflt (BindDefault _ rhs) = [rhs] %************************************************************************ \begin{code} -data GenCoreBinder val_bdr tyvar uvar +data GenCoreBinder val_bdr flexi = ValBinder val_bdr - | TyBinder tyvar - | UsageBinder uvar + | TyBinder (GenTyVar flexi) isValBinder (ValBinder _) = True isValBinder _ = False @@ -354,22 +349,18 @@ Clump Lams together if possible. \begin{code} mkValLam :: [val_bdr] - -> GenCoreExpr val_bdr val_occ tyvar uvar - -> GenCoreExpr val_bdr val_occ tyvar uvar -mkTyLam :: [tyvar] - -> GenCoreExpr val_bdr val_occ tyvar uvar - -> GenCoreExpr val_bdr val_occ tyvar uvar -mkUseLam :: [uvar] - -> GenCoreExpr val_bdr val_occ tyvar uvar - -> GenCoreExpr val_bdr val_occ tyvar uvar + -> GenCoreExpr val_bdr val_occ flexi + -> GenCoreExpr val_bdr val_occ flexi +mkTyLam :: [GenTyVar flexi] + -> GenCoreExpr val_bdr val_occ flexi + -> GenCoreExpr val_bdr val_occ flexi mkValLam binders body = foldr (Lam . ValBinder) body binders mkTyLam binders body = foldr (Lam . TyBinder) body binders -mkUseLam binders body = foldr (Lam . UsageBinder) body binders -mkLam :: [tyvar] -> [val_bdr] -- ToDo: could add a [uvar] arg... - -> GenCoreExpr val_bdr val_occ tyvar uvar - -> GenCoreExpr val_bdr val_occ tyvar uvar +mkLam :: [GenTyVar flexi] -> [val_bdr] -- ToDo: could add a [uvar] arg... + -> GenCoreExpr val_bdr val_occ flexi + -> GenCoreExpr val_bdr val_occ flexi mkLam tyvars valvars body = mkTyLam tyvars (mkValLam valvars body) @@ -383,45 +374,24 @@ order. \begin{code} collectBinders :: - GenCoreExpr val_bdr val_occ tyvar uvar -> - ([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar) + GenCoreExpr val_bdr val_occ flexi -> + ([GenTyVar flexi], [val_bdr], GenCoreExpr val_bdr val_occ flexi) collectBinders expr - = case collectValBinders body1 of { (vals,body) -> (usages, tyvars, vals, body) } + = case collectValBinders body1 of { (vals,body) -> (tyvars, vals, body) } where - (usages, tyvars, body1) = collectUsageAndTyBinders expr --- (vals, body) = collectValBinders body1 + (tyvars, body1) = collectTyBinders expr - -collectUsageAndTyBinders expr - = case usages expr [] of - ([],tyvars,body) -> ([],tyvars,body) - v -> v +collectTyBinders expr + = tyvars expr [] where - usages (Lam (UsageBinder u) body) uacc = usages body (u:uacc) - usages other uacc - = case (tyvars other []) of { (tacc, expr) -> - (reverse uacc, tacc, expr) } - tyvars (Lam (TyBinder t) body) tacc = tyvars body (t:tacc) - tyvars other tacc - = ASSERT(not (usage_lambda other)) - (reverse tacc, other) - - --------------------------------------- - usage_lambda (Lam (UsageBinder _) _) = True - usage_lambda _ = False + tyvars other tacc = (reverse tacc, other) - tyvar_lambda (Lam (TyBinder _) _) = True - tyvar_lambda _ = False - - -collectValBinders :: GenCoreExpr val_bdr val_occ tyvar uvar -> - ([val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar) +collectValBinders :: GenCoreExpr val_bdr val_occ flexi -> + ([val_bdr], GenCoreExpr val_bdr val_occ flexi) collectValBinders expr - = case go [] expr of - ([],body) -> ([],body) - v -> v + = go [] expr where go acc (Lam (ValBinder v) b) = go (v:acc) b go acc body = (reverse acc, body) @@ -435,31 +405,26 @@ collectValBinders expr %************************************************************************ \begin{code} -data GenCoreArg val_occ tyvar uvar +data GenCoreArg val_occ flexi = LitArg Literal | VarArg val_occ - | TyArg (GenType tyvar uvar) - | UsageArg (GenUsage uvar) + | TyArg (GenType flexi) \end{code} General and specific forms: \begin{code} -mkGenApp :: GenCoreExpr val_bdr val_occ tyvar uvar - -> [GenCoreArg val_occ tyvar uvar] - -> GenCoreExpr val_bdr val_occ tyvar uvar -mkTyApp :: GenCoreExpr val_bdr val_occ tyvar uvar - -> [GenType tyvar uvar] - -> GenCoreExpr val_bdr val_occ tyvar uvar -mkUseApp :: GenCoreExpr val_bdr val_occ tyvar uvar - -> [GenUsage uvar] - -> GenCoreExpr val_bdr val_occ tyvar uvar -mkValApp :: GenCoreExpr val_bdr val_occ tyvar uvar - -> [GenCoreArg val_occ tyvar uvar] -- but we ASSERT they are LitArg or VarArg - -> GenCoreExpr val_bdr val_occ tyvar uvar +mkGenApp :: GenCoreExpr val_bdr val_occ flexi + -> [GenCoreArg val_occ flexi] + -> GenCoreExpr val_bdr val_occ flexi +mkTyApp :: GenCoreExpr val_bdr val_occ flexi + -> [GenType flexi] + -> GenCoreExpr val_bdr val_occ flexi +mkValApp :: GenCoreExpr val_bdr val_occ flexi + -> [GenCoreArg val_occ flexi] -- but we ASSERT they are LitArg or VarArg + -> GenCoreExpr val_bdr val_occ flexi mkGenApp f args = foldl App f args mkTyApp f args = foldl (\ e a -> App e (TyArg a)) f args -mkUseApp f args = foldl (\ e a -> App e (UsageArg a)) f args mkValApp f args = foldl (\ e a -> App e (is_Lit_or_Var a)) f args #ifndef DEBUG @@ -483,49 +448,43 @@ mkApp fun = mk_thing (mkGenApp fun) mkCon con = mk_thing (Con con) mkPrim op = mk_thing (Prim op) -mk_thing thing uses tys vals - = thing (map UsageArg uses ++ map TyArg tys ++ map is_Lit_or_Var vals) +mk_thing thing tys vals + = ASSERT( all isValArg vals ) + thing (map TyArg tys ++ vals) \end{code} @collectArgs@ takes an application expression, returning the function and the arguments to which it is applied. \begin{code} -collectArgs :: GenCoreExpr val_bdr val_occ tyvar uvar - -> (GenCoreExpr val_bdr val_occ tyvar uvar, - [GenUsage uvar], - [GenType tyvar uvar], - [GenCoreArg val_occ tyvar uvar]{-ValArgs-}) +collectArgs :: GenCoreExpr val_bdr val_occ flexi + -> (GenCoreExpr val_bdr val_occ flexi, + [GenType flexi], + [GenCoreArg val_occ flexi]{-ValArgs-}) collectArgs expr = valvars expr [] where valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc) valvars fun vacc - = case (tyvars fun []) of { (expr, uacc, tacc) -> - (expr, uacc, tacc, vacc) } - - tyvars (App fun (TyArg t)) tacc = tyvars fun (t:tacc) - tyvars fun tacc - = case (usages fun []) of { (expr, uacc) -> - (expr, uacc, tacc) } + = case (tyvars fun []) of { (expr, tacc) -> + (expr, tacc, vacc) } - usages (App fun (UsageArg u)) uacc = usages fun (u:uacc) - usages fun uacc - = (fun,uacc) + tyvars (App fun (TyArg t)) tacc = tyvars fun (t:tacc) + tyvars fun tacc = (expr, tacc) \end{code} \begin{code} -initialTyArgs :: [GenCoreArg val_occ tyvar uvar] - -> ([GenType tyvar uvar], [GenCoreArg val_occ tyvar uvar]) +initialTyArgs :: [GenCoreArg val_occ flexi] + -> ([GenType flexi], [GenCoreArg val_occ flexi]) initialTyArgs (TyArg ty : args) = (ty:tys, args') where (tys, args') = initialTyArgs args initialTyArgs other = ([],other) -initialValArgs :: [GenCoreArg val_occ tyvar uvar] - -> ([GenCoreArg val_occ tyvar uvar], [GenCoreArg val_occ tyvar uvar]) +initialValArgs :: [GenCoreArg val_occ flexi] + -> ([GenCoreArg val_occ flexi], [GenCoreArg val_occ flexi]) initialValArgs args = span isValArg args \end{code} @@ -537,13 +496,13 @@ initialValArgs args = span isValArg args %************************************************************************ \begin{code} -type CoreBinding = GenCoreBinding Id Id TyVar UVar -type CoreExpr = GenCoreExpr Id Id TyVar UVar -type CoreBinder = GenCoreBinder Id TyVar UVar -type CoreArg = GenCoreArg Id TyVar UVar +type CoreBinding = GenCoreBinding Id Id Unused +type CoreExpr = GenCoreExpr Id Id Unused +type CoreBinder = GenCoreBinder Id Unused +type CoreArg = GenCoreArg Id Unused -type CoreCaseAlts = GenCoreCaseAlts Id Id TyVar UVar -type CoreCaseDefault = GenCoreCaseDefault Id Id TyVar UVar +type CoreCaseAlts = GenCoreCaseAlts Id Id Unused +type CoreCaseDefault = GenCoreCaseDefault Id Id Unused \end{code} %************************************************************************ @@ -556,13 +515,13 @@ Binders are ``tagged'' with a \tr{t}: \begin{code} type Tagged t = (Id, t) -type TaggedCoreBinding t = GenCoreBinding (Tagged t) Id TyVar UVar -type TaggedCoreExpr t = GenCoreExpr (Tagged t) Id TyVar UVar -type TaggedCoreBinder t = GenCoreBinder (Tagged t) TyVar UVar -type TaggedCoreArg t = GenCoreArg Id TyVar UVar +type TaggedCoreBinding t = GenCoreBinding (Tagged t) Id Unused +type TaggedCoreExpr t = GenCoreExpr (Tagged t) Id Unused +type TaggedCoreBinder t = GenCoreBinder (Tagged t) Unused +type TaggedCoreArg t = GenCoreArg Id Unused -type TaggedCoreCaseAlts t = GenCoreCaseAlts (Tagged t) Id TyVar UVar -type TaggedCoreCaseDefault t = GenCoreCaseDefault (Tagged t) Id TyVar UVar +type TaggedCoreCaseAlts t = GenCoreCaseAlts (Tagged t) Id Unused +type TaggedCoreCaseDefault t = GenCoreCaseDefault (Tagged t) Id Unused \end{code} %************************************************************************ @@ -575,11 +534,11 @@ Binders are tagged with @BinderInfo@: \begin{code} type Simplifiable = (Id, BinderInfo) -type SimplifiableCoreBinding = GenCoreBinding Simplifiable Id TyVar UVar -type SimplifiableCoreExpr = GenCoreExpr Simplifiable Id TyVar UVar -type SimplifiableCoreBinder = GenCoreBinder Simplifiable TyVar UVar -type SimplifiableCoreArg = GenCoreArg Id TyVar UVar +type SimplifiableCoreBinding = GenCoreBinding Simplifiable Id Unused +type SimplifiableCoreExpr = GenCoreExpr Simplifiable Id Unused +type SimplifiableCoreBinder = GenCoreBinder Simplifiable Unused +type SimplifiableCoreArg = GenCoreArg Id Unused -type SimplifiableCoreCaseAlts = GenCoreCaseAlts Simplifiable Id TyVar UVar -type SimplifiableCoreCaseDefault = GenCoreCaseDefault Simplifiable Id TyVar UVar +type SimplifiableCoreCaseAlts = GenCoreCaseAlts Simplifiable Id Unused +type SimplifiableCoreCaseDefault = GenCoreCaseDefault Simplifiable Id Unused \end{code} diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index e254958625..c92ffe6bdf 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -13,8 +13,6 @@ literal''). In the corner of a @SimpleUnfolding@ unfolding, you will find, unsurprisingly, a Core expression. \begin{code} -#include "HsVersions.h" - module CoreUnfold ( SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types UfExpr, RdrName, -- For closure (delete in 1.3) @@ -31,15 +29,9 @@ module CoreUnfold ( PragmaInfo(..) -- Re-export ) where -IMP_Ubiq() -#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(IdLoop) -- for paranoia checking; - -- and also to get mkMagicUnfoldingFun -IMPORT_DELOOPER(PrelLoop) -- for paranoia checking -IMPORT_DELOOPER(SmplLoop) -#else -import {-# SOURCE #-} MagicUFs -#endif +#include "HsVersions.h" + +import {-# SOURCE #-} MagicUFs ( MagicUnfoldingFun, mkMagicUnfoldingFun ) import Bag ( emptyBag, unitBag, unionBags, Bag ) @@ -61,27 +53,21 @@ import HsCore ( UfExpr ) import RdrHsSyn ( RdrName ) import OccurAnal ( occurAnalyseGlobalExpr ) import CoreUtils ( coreExprType ) ---import CostCentre ( ccMentionsId ) -import Id ( SYN_IE(Id), idType, getIdArity, isBottomingId, isDataCon, +import Id ( Id, idType, getIdArity, isBottomingId, isDataCon, idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd, - SYN_IE(IdSet), GenId{-instances-} ) + IdSet, GenId{-instances-} ) import PrimOp ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) ) import IdInfo ( ArityInfo(..), bottomIsGuaranteed ) import Literal ( isNoRepLit, isLitLitLit ) -import Pretty import TyCon ( tyConFamilySize ) -import Type ( maybeAppDataTyConExpandingDicts ) +import Type ( splitAlgTyConApp_maybe ) import Unique ( Unique ) import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet, addOneToUniqSet, unionUniqSets ) -import Usage ( SYN_IE(UVar) ) import Maybes ( maybeToBool ) import Util ( isIn, panic, assertPanic ) -#if __GLASGOW_HASKELL__ >= 202 import Outputable - -#endif \end{code} %************************************************************************ @@ -154,8 +140,8 @@ data UnfoldingGuidance \begin{code} instance Outputable UnfoldingGuidance where - ppr sty UnfoldAlways = ptext SLIT("_ALWAYS_") - ppr sty (UnfoldIfGoodArgs t v cs size discount) + ppr UnfoldAlways = ptext SLIT("_ALWAYS_") + ppr (UnfoldIfGoodArgs t v cs size discount) = hsep [ptext SLIT("_IF_ARGS_"), int t, int v, if null cs -- always print *something* then char 'X' @@ -180,12 +166,12 @@ data FormSummary | OtherForm -- Anything else instance Outputable FormSummary where - ppr sty VarForm = ptext SLIT("Var") - ppr sty ValueForm = ptext SLIT("Value") - ppr sty BottomForm = ptext SLIT("Bot") - ppr sty OtherForm = ptext SLIT("Other") + ppr VarForm = ptext SLIT("Var") + ppr ValueForm = ptext SLIT("Value") + ppr BottomForm = ptext SLIT("Bot") + ppr OtherForm = ptext SLIT("Other") -mkFormSummary ::GenCoreExpr bndr Id tyvar uvar -> FormSummary +mkFormSummary ::GenCoreExpr bndr Id flexi -> FormSummary mkFormSummary expr = go (0::Int) expr -- The "n" is the number of (value) arguments so far @@ -240,7 +226,7 @@ exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit) exprSmallEnoughToDup (Coerce _ _ e) = exprSmallEnoughToDup e exprSmallEnoughToDup expr - = case (collectArgs expr) of { (fun, _, _, vargs) -> + = case (collectArgs expr) of { (fun, _, vargs) -> case fun of Var v | length vargs <= 4 -> True _ -> False @@ -267,7 +253,7 @@ calcUnfoldingGuidance IWantToBeINLINEd bOMB_OUT_SIZE expr = UnfoldAlways -- Alw calcUnfoldingGuidance IMustNotBeINLINEd bOMB_OUT_SIZE expr = UnfoldNever -- ...and vice versa... calcUnfoldingGuidance NoPragmaInfo bOMB_OUT_SIZE expr - = case collectBinders expr of { (use_binders, ty_binders, val_binders, body) -> + = case collectBinders expr of { (ty_binders, val_binders, body) -> case (sizeExpr bOMB_OUT_SIZE val_binders body) of TooBig -> UnfoldNever @@ -285,7 +271,7 @@ calcUnfoldingGuidance NoPragmaInfo bOMB_OUT_SIZE expr | otherwise = 0 where (is_data, tycon) - = case (maybeAppDataTyConExpandingDicts (idType b)) of + = case (splitAlgTyConApp_maybe (idType b)) of Nothing -> (False, panic "discount") Just (tc,_,_) -> (True, tc) @@ -327,7 +313,7 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr size_up expr@(Lam _ _) = let - (uvars, tyvars, args, body) = collectBinders expr + (tyvars, args, body) = collectBinders expr in size_up body `addSizeN` length args @@ -376,7 +362,7 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr alt_cost :: Int alt_cost - = case (maybeAppDataTyConExpandingDicts scrut_ty) of + = case (splitAlgTyConApp_maybe scrut_ty) of Nothing -> 1 Just (tc,_,_) -> tyConFamilySize tc diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 6ace516408..bfc21df742 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -4,8 +4,6 @@ \section[CoreUtils]{Utility functions on @Core@ syntax} \begin{code} -#include "HsVersions.h" - module CoreUtils ( coreExprType, coreAltsType, coreExprCc, @@ -20,7 +18,7 @@ module CoreUtils ( , squashableDictishCcExpr ) where -IMP_Ubiq() +#include "HsVersions.h" import CoreSyn @@ -29,37 +27,33 @@ import Id ( idType, mkSysLocal, isBottomingId, toplevelishId, mkIdWithNewUniq, applyTypeEnvToId, dataConRepType, addOneToIdEnv, growIdEnvList, lookupIdEnv, - isNullIdEnv, SYN_IE(IdEnv), - GenId{-instances-}, SYN_IE(Id) + isNullIdEnv, IdEnv, Id ) import Literal ( literalType, isNoRepLit, Literal(..) ) import Maybes ( catMaybes, maybeToBool ) import PprCore -import Outputable ( PprStyle(..), Outputable(..) ) -import PprType ( GenType{-instances-}, GenTyVar ) -import Pretty ( Doc, vcat ) import PrimOp ( primOpType, PrimOp(..) ) import SrcLoc ( noSrcLoc ) import TyVar ( cloneTyVar, - isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv), - SYN_IE(TyVar), GenTyVar + isEmptyTyVarEnv, addToTyVarEnv, TyVarEnv, + TyVar, GenTyVar ) -import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy, - getFunTyExpandingDicts_maybe, applyTy, isPrimType, - splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy, - SYN_IE(Type) +import Type ( mkFunTy, mkForAllTy, mkTyVarTy, + splitFunTy_maybe, applyTy, isUnpointedType, + splitSigmaTy, splitFunTys, instantiateTy, + Type ) import TysWiredIn ( trueDataCon, falseDataCon ) import Unique ( Unique ) +import BasicTypes ( Unused ) import UniqSupply ( initUs, returnUs, thenUs, mapUs, mapAndUnzipUs, getUnique, - SYN_IE(UniqSM), UniqSupply + UniqSM, UniqSupply ) -import Usage ( SYN_IE(UVar) ) -import Util ( zipEqual, panic, pprTrace, pprPanic, assertPanic ) +import Util ( zipEqual ) +import Outputable type TypeEnv = TyVarEnv Type -applyUsage = panic "CoreUtils.applyUsage:ToDo" \end{code} %************************************************************************ @@ -84,9 +78,9 @@ coreExprType (Coerce _ ty _) = ty -- that's the whole point! -- a Prim is <ditto> of a PrimOp coreExprType (Con con args) = --- pprTrace "appTyArgs" (hsep [ppr PprDebug con, semi, --- ppr PprDebug con_ty, semi, --- ppr PprDebug args]) $ +-- pprTrace "appTyArgs" (hsep [ppr con, semi, +-- ppr con_ty, semi, +-- ppr args]) $ applyTypeToArgs con_ty args where con_ty = dataConRepType con @@ -99,30 +93,23 @@ coreExprType (Lam (ValBinder binder) expr) coreExprType (Lam (TyBinder tyvar) expr) = mkForAllTy tyvar (coreExprType expr) -coreExprType (Lam (UsageBinder uvar) expr) - = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr) - coreExprType (App expr (TyArg ty)) = --- pprTrace "appTy1" (hsep [ppr PprDebug fun_ty, space, ppr PprDebug ty]) $ +-- pprTrace "appTy1" (hsep [ppr fun_ty, space, ppr ty]) $ applyTy fun_ty ty where fun_ty = coreExprType expr -coreExprType (App expr (UsageArg use)) - = applyUsage (coreExprType expr) use - coreExprType (App expr val_arg) = ASSERT(isValArg val_arg) let fun_ty = coreExprType expr in - case (getFunTyExpandingDicts_maybe False{-no peeking-} fun_ty) of + case (splitFunTy_maybe fun_ty) of Just (_, result_ty) -> result_ty #ifdef DEBUG Nothing -> pprPanic "coreExprType:\n" - (vcat [ppr PprDebug fun_ty, - ppr PprShowAll (App expr val_arg)]) + (vcat [ppr fun_ty, ppr (App expr val_arg)]) #endif \end{code} @@ -143,8 +130,7 @@ default_ty (BindDefault _ rhs) = coreExprType rhs applyTypeToArgs op_ty args = foldl applyTypeToArg op_ty args applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty -applyTypeToArg op_ty (UsageArg _) = panic "applyTypeToArg: UsageArg" -applyTypeToArg op_ty val_or_lit_arg = case (getFunTyExpandingDicts_maybe False{-no peeking-} op_ty) of +applyTypeToArg op_ty val_or_lit_arg = case (splitFunTy_maybe op_ty) of Just (_, res_ty) -> res_ty \end{code} @@ -152,7 +138,7 @@ coreExprCc gets the cost centre enclosing an expression, if any. It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e \begin{code} -coreExprCc :: GenCoreExpr val_bdr val_occ tyvar uvar -> CostCentre +coreExprCc :: GenCoreExpr val_bdr val_occ flexi -> CostCentre coreExprCc (SCC cc e) = cc coreExprCc (Lam _ e) = coreExprCc e coreExprCc other = noCostCentre @@ -223,7 +209,7 @@ co_thing thing arg_exprs \begin{code} argToExpr :: - GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar + GenCoreArg val_occ flexi -> GenCoreExpr val_bdr val_occ flexi argToExpr (VarArg v) = Var v argToExpr (LitArg lit) = Lit lit @@ -234,15 +220,15 @@ transformation on them; ie. the function @(\ x -> (x,False))@ annotates all binders with False. \begin{code} -unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv +unTagBinders :: GenCoreExpr (Id,tag) bdee flexi -> GenCoreExpr Id bdee flexi unTagBinders expr = bop_expr fst expr -unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv +unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee flexi -> GenCoreCaseAlts Id bdee flexi unTagBindersAlts alts = bop_alts fst alts \end{code} \begin{code} -bop_expr :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv +bop_expr :: (a -> b) -> GenCoreExpr a bdee flexi -> GenCoreExpr b bdee flexi bop_expr f (Var b) = Var b bop_expr f (Lit lit) = Lit lit @@ -257,7 +243,6 @@ bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts) bop_binder f (ValBinder v) = ValBinder (f v) bop_binder f (TyBinder t) = TyBinder t -bop_binder f (UsageBinder u) = UsageBinder u bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e) bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs] @@ -305,7 +290,7 @@ Example: Notice that the \tr{<alts>} don't get duplicated. \begin{code} -nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar] +nonErrorRHSs :: GenCoreCaseAlts a Id Unused -> [GenCoreExpr a Id Unused] nonErrorRHSs alts = filter not_error_app (find_rhss alts) @@ -365,30 +350,30 @@ That is, we discard en+1 .. em \begin{code} maybeErrorApp - :: GenCoreExpr a Id TyVar UVar -- Expr to look at + :: GenCoreExpr a Id Unused -- Expr to look at -> Maybe Type -- Just ty => a result type *already cloned*; -- Nothing => don't know result ty; we -- *pretend* that the result ty won't be -- primitive -- somebody later must -- ensure this. - -> Maybe (GenCoreExpr b Id TyVar UVar) + -> Maybe (GenCoreExpr b Id Unused) maybeErrorApp expr result_ty_maybe = case (collectArgs expr) of - (Var fun, [{-no usage???-}], [ty], other_args) + (Var fun, [ty], other_args) | isBottomingId fun && maybeToBool result_ty_maybe -- we *know* the result type -- (otherwise: live a fairy-tale existence...) - && not (isPrimType result_ty) -> + && not (isUnpointedType result_ty) -> case (splitSigmaTy (idType fun)) of ([tyvar], [], tau_ty) -> - case (splitFunTy tau_ty) of { (arg_tys, res_ty) -> + case (splitFunTys tau_ty) of { (arg_tys, res_ty) -> let n_args_to_keep = length arg_tys args_to_keep = take n_args_to_keep other_args in - if (res_ty `eqTy` mkTyVarTy tyvar) + if (res_ty == mkTyVarTy tyvar) && n_args_to_keep <= length other_args then -- Phew! We're in business @@ -404,7 +389,7 @@ maybeErrorApp expr result_ty_maybe \end{code} \begin{code} -squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool +squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c -> Bool squashableDictishCcExpr cc expr = if not (isDictCC cc) then @@ -439,13 +424,13 @@ substCoreExpr :: ValEnv substCoreBindings venv tenv binds -- if the envs are empty, then avoid doing anything - = if (isNullIdEnv venv && isNullTyVarEnv tenv) then + = if (isNullIdEnv venv && isEmptyTyVarEnv tenv) then returnUs binds else do_CoreBindings venv tenv binds substCoreExpr venv tenv expr - = if (isNullIdEnv venv && isNullTyVarEnv tenv) then + = if (isNullIdEnv venv && isEmptyTyVarEnv tenv) then returnUs expr else do_CoreExpr venv tenv expr @@ -514,7 +499,7 @@ do_CoreArg venv tenv a@(VarArg v) ) do_CoreArg venv tenv (TyArg ty) - = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty))) + = returnUs (AnArg (TyArg (instantiateTy tenv ty))) do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg) \end{code} @@ -546,8 +531,8 @@ do_CoreExpr venv tenv (Prim op as) where do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty) = let - new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys - new_result_ty = applyTypeEnvToTy tenv result_ty + new_arg_tys = map (instantiateTy tenv) arg_tys + new_result_ty = instantiateTy tenv result_ty in returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty) @@ -562,13 +547,11 @@ do_CoreExpr venv tenv (Lam (ValBinder binder) expr) do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr) = dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) -> let - new_tenv = addOneToTyVarEnv tenv old new + new_tenv = addToTyVarEnv tenv old new in do_CoreExpr venv new_tenv expr `thenUs` \ new_expr -> returnUs (Lam (TyBinder new_tyvar) new_expr) -do_CoreExpr venv tenv (Lam _ expr) = panic "CoreUtils.do_CoreExpr:Lam UsageBinder" - do_CoreExpr venv tenv (App expr arg) = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> do_CoreArg venv tenv arg `thenUs` \ new_arg -> @@ -620,7 +603,7 @@ do_CoreExpr venv tenv (SCC label expr) do_CoreExpr venv tenv (Coerce c ty expr) = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> - returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr) + returnUs (Coerce c (instantiateTy tenv ty) new_expr) \end{code} \begin{code} diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs index d2a0588ab6..614016472c 100644 --- a/ghc/compiler/coreSyn/FreeVars.lhs +++ b/ghc/compiler/coreSyn/FreeVars.lhs @@ -4,8 +4,6 @@ Taken quite directly from the Peyton Jones/Lester paper. \begin{code} -#include "HsVersions.h" - module FreeVars ( freeVars, @@ -13,14 +11,14 @@ module FreeVars ( addTopBindsFVs, addExprFVs, freeVarsOf, freeTyVarsOf, - SYN_IE(FVCoreExpr), SYN_IE(FVCoreBinding), + FVCoreExpr, FVCoreBinding, - SYN_IE(CoreExprWithFVs), -- For the above functions - SYN_IE(AnnCoreExpr), -- Dito + CoreExprWithFVs, -- For the above functions + AnnCoreExpr, -- Dito FVInfo(..), LeakInfo(..) ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import AnnCoreSyn -- output @@ -28,17 +26,17 @@ import CoreSyn import Id ( idType, getIdArity, isBottomingId, emptyIdSet, unitIdSet, mkIdSet, elementOfIdSet, minusIdSet, unionManyIdSets, - SYN_IE(IdSet), SYN_IE(Id) + IdSet, Id ) import IdInfo ( ArityInfo(..) ) import PrimOp ( PrimOp(..) ) -import Type ( tyVarsOfType, SYN_IE(Type) ) +import Type ( tyVarsOfType, Type ) import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet, intersectTyVarSets, - SYN_IE(TyVarSet), SYN_IE(TyVar) + TyVarSet, TyVar ) +import BasicTypes ( Unused ) import UniqSet ( unionUniqSets ) -import Usage ( SYN_IE(UVar) ) import Util ( panic, assertPanic ) \end{code} @@ -59,7 +57,7 @@ I've half-convinced myself we don't for case- and letrec bound ids but I might be wrong. (SLPJ, date unknown) \begin{code} -type CoreExprWithFVs = AnnCoreExpr Id Id TyVar UVar FVInfo +type CoreExprWithFVs = AnnCoreExpr Id Id Unused FVInfo type TyVarCands = TyVarSet -- for when we carry around lists of type IdCands = IdSet -- "candidate" TyVars/Ids. @@ -168,9 +166,6 @@ fvExpr id_cands tyvar_cands (Prim op args) -- this Lam stuff could probably be improved by rewriting (WDP 96/03) -fvExpr id_cands tyvar_cands (Lam (UsageBinder uvar) body) - = panic "fvExpr:Lam UsageBinder" - fvExpr id_cands tyvar_cands (Lam b@(ValBinder binder) body) = (FVInfo (freeVarsOf body2 `minusIdSet` unitIdSet binder) (freeTyVarsOf body2 `combine` munge_id_ty binder) @@ -325,7 +320,6 @@ freeArgs icands tcands (arg:args) (arg_fvs `combine` irest, tfvs `combine` trest) } where free_arg (LitArg _) = noFreeAnything - free_arg (UsageArg _) = noFreeAnything free_arg (TyArg ty) = (noFreeIds, freeTy tcands ty) free_arg (VarArg v) | v `is_among` icands = (aFreeId v, noFreeTyVars) @@ -383,8 +377,8 @@ As it happens this is only ever used by the Specialiser! \begin{code} type FVCoreBinder = (Id, IdSet) -type FVCoreExpr = GenCoreExpr FVCoreBinder Id TyVar UVar -type FVCoreBinding = GenCoreBinding FVCoreBinder Id TyVar UVar +type FVCoreExpr = GenCoreExpr FVCoreBinder Id Unused +type FVCoreBinding = GenCoreBinding FVCoreBinder Id Unused type InterestingIdFun = IdSet -- Non-top-level in-scope variables @@ -420,7 +414,6 @@ addExprFVs fv_cand in_scope (Lam binder body) (new_binder, binder_set) = case binder of TyBinder t -> (TyBinder t, emptyIdSet) - UsageBinder u -> (UsageBinder u, emptyIdSet) ValBinder b -> (ValBinder (b, lam_fvs), unitIdSet b) diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index e822513a67..0c29fa0351 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -8,28 +8,18 @@ %************************************************************************ \begin{code} -#include "HsVersions.h" - module PprCore ( pprCoreExpr, pprIfaceUnfolding, - pprCoreBinding, pprCoreBindings, - pprBigCoreBinder, - pprTypedCoreBinder - - -- these are here to make the instances go in 0.26: -#if __GLASGOW_HASKELL__ <= 30 - , GenCoreBinding, GenCoreExpr, GenCoreCaseAlts - , GenCoreCaseDefault, GenCoreArg -#endif + pprCoreBinding, pprCoreBindings ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CoreSyn import CostCentre ( showCostCentre ) import Id ( idType, getIdInfo, getIdStrictness, isTupleCon, - nullIdEnv, SYN_IE(DataCon), GenId{-instances-}, - SYN_IE(Id) + nullIdEnv, DataCon, GenId{-instances-}, + Id ) import IdInfo ( ppIdInfo, ppStrictnessInfo ) import Literal ( Literal{-instances-} ) @@ -37,11 +27,9 @@ import Name ( OccName ) import Outputable -- quite a few things import PprEnv import PprType ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} ) -import Pretty import PrimOp ( PrimOp{-instances-} ) import TyVar ( GenTyVar{-instances-} ) import Unique ( Unique{-instances-} ) -import Usage ( GenUsage{-instances-} ) import Util ( panic{-ToDo:rm-} ) \end{code} @@ -65,39 +53,24 @@ print something. @pprParendCoreExpr@ puts parens around non-atomic Core expressions. \begin{code} -pprCoreBinding :: PprStyle -> CoreBinding -> Doc -pprCoreBindings :: PprStyle -> [CoreBinding] -> Doc - -pprGenCoreBinding - :: (Eq tyvar, Outputable tyvar, - Eq uvar, Outputable uvar, - Outputable bndr, - Outputable occ) - => PprStyle - -> (bndr -> Doc) -- to print "major" val_bdrs - -> (bndr -> Doc) -- to print "minor" val_bdrs - -> (occ -> Doc) -- to print bindees - -> GenCoreBinding bndr occ tyvar uvar - -> Doc - -pprGenCoreBinding sty pbdr1 pbdr2 pocc bind - = ppr_bind (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) bind - -init_ppr_env sty tvbndr pbdr1 pbdr2 pocc - = initPprEnv sty - (Just (ppr sty)) -- literals +pprCoreBinding :: CoreBinding -> SDoc +pprCoreBindings :: [CoreBinding] -> SDoc + +init_ppr_env tvbndr pbdr pocc + = initPprEnv + (Just ppr) -- literals (Just ppr_con) -- data cons (Just ppr_prim) -- primops - (Just (\ cc -> text (showCostCentre sty True cc))) + (Just (\ cc -> text (showCostCentre True cc))) + (Just tvbndr) -- tyvar binders - (Just (ppr sty)) -- tyvar occs - (Just (ppr sty)) -- usage vars - (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars - (Just (pprParendGenType sty)) -- types - (Just (ppr sty)) -- usages + (Just ppr) -- tyvar occs + (Just pprParendGenType) -- types + + (Just pbdr) (Just pocc) -- value vars where - ppr_con con = ppr sty con + ppr_con con = ppr con {- [We now use Con {a,b,c} for Con expressions. SLPJ March 97.] [We can't treat them as ordinary applications because the Con doesn't have @@ -114,78 +87,42 @@ init_ppr_env sty tvbndr pbdr1 pbdr2 pocc -- We add a "!" to distinguish Primitive applications from ordinary applications. -- But not when printing for interfaces, where they are treated -- as ordinary applications - ppr_prim prim | ifaceStyle sty = ppr sty prim - | otherwise = ppr sty prim <> char '!' + ppr_prim prim = getPprStyle (\sty -> if ifaceStyle sty then + ppr prim + else + ppr prim <> char '!') -------------- -pprCoreBindings sty binds = vcat (map (pprCoreBinding sty) binds) +pprCoreBindings binds = vcat (map pprCoreBinding binds) -pprCoreBinding sty (NonRec binder expr) - = hang (hsep [pprBigCoreBinder sty binder, equals]) - 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr) +pprCoreBinding (NonRec binder expr) = ppr_binding (binder, expr) -pprCoreBinding sty (Rec binds) +pprCoreBinding (Rec binds) = vcat [ptext SLIT("Rec {"), - vcat (map ppr_bind binds), - ptext SLIT("end Rec }")] - where - ppr_bind (binder, expr) - = hang (hsep [pprBigCoreBinder sty binder, equals]) - 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr) + vcat (map ppr_binding binds), + ptext SLIT("end Rec }")] + +ppr_binding (binder, expr) + = sep [pprCoreBinder LetBind binder, + nest 2 (equals <+> pprCoreExpr expr)] \end{code} +General expression printer + \begin{code} -pprCoreExpr - :: PprStyle - -> (Id -> Doc) -- to print "major" val_bdrs - -> (Id -> Doc) -- to print "minor" val_bdrs - -> (Id -> Doc) -- to print bindees - -> CoreExpr - -> Doc -pprCoreExpr = pprGenCoreExpr - -pprGenCoreExpr, pprParendCoreExpr - :: (Eq tyvar, Outputable tyvar, - Eq uvar, Outputable uvar, - Outputable bndr, - Outputable occ) - => PprStyle - -> (bndr -> Doc) -- to print "major" val_bdrs - -> (bndr -> Doc) -- to print "minor" val_bdrs - -> (occ -> Doc) -- to print bindees - -> GenCoreExpr bndr occ tyvar uvar - -> Doc - -pprGenCoreExpr sty pbdr1 pbdr2 pocc expr - = ppr_expr (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) expr - -pprParendCoreExpr sty pbdr1 pbdr2 pocc expr - = let - parenify - = case expr of - Var _ -> id -- leave unchanged - Lit _ -> id - _ -> parens -- wraps in parens - in - parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr) +pprCoreExpr :: CoreExpr -> SDoc +pprCoreExpr = ppr_expr pprCoreEnv --- Printer for unfoldings in interfaces -pprIfaceUnfolding :: CoreExpr -> Doc -pprIfaceUnfolding = ppr_expr env - where - env = init_ppr_env PprInterface (pprTyVarBndr PprInterface) - (pprTypedCoreBinder PprInterface) - (ppr PprInterface) - (ppr PprInterface) +pprCoreEnv = init_ppr_env ppr pprCoreBinder ppr +\end{code} -ppr_core_arg sty pocc arg - = ppr_arg (init_ppr_env sty (ppr sty) pocc pocc pocc) arg +Printer for unfoldings in interfaces -ppr_core_alts sty pbdr1 pbdr2 pocc alts - = ppr_alts (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) alts +\begin{code} +pprIfaceUnfolding :: CoreExpr -> SDoc +pprIfaceUnfolding = ppr_expr pprIfaceEnv -ppr_core_default sty pbdr1 pbdr2 pocc deflt - = ppr_default (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) deflt +pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder ppr \end{code} %************************************************************************ @@ -195,44 +132,26 @@ ppr_core_default sty pbdr1 pbdr2 pocc deflt %************************************************************************ \begin{code} -instance - (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar, - Eq uvar, Outputable uvar) - => - Outputable (GenCoreBinding bndr occ tyvar uvar) where - ppr sty bind = pprQuote sty $ \sty -> - pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind - -instance - (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar, - Eq uvar, Outputable uvar) - => - Outputable (GenCoreExpr bndr occ tyvar uvar) where - ppr sty expr = pprQuote sty $ \sty -> - pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr - -instance - (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => - Outputable (GenCoreArg occ tyvar uvar) where - ppr sty arg = pprQuote sty $ \sty -> - ppr_core_arg sty (ppr sty) arg - -instance - (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar, - Eq uvar, Outputable uvar) - => - Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where - ppr sty alts = pprQuote sty $ \sty -> - ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts - -instance - (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar, - Eq uvar, Outputable uvar) - => - Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where - ppr sty deflt = pprQuote sty $ \sty -> - ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt +pprGenEnv :: (Outputable bndr, Outputable occ) => PprEnv flexi bndr occ +pprGenEnv = init_ppr_env ppr (\_ -> ppr) ppr + +pprGenArgEnv :: (Outputable occ) => PprEnv flexi bndr occ +pprGenArgEnv = init_ppr_env ppr (error "ppr_bndr") ppr + +instance (Outputable bndr, Outputable occ) => Outputable (GenCoreBinding bndr occ flexi) where + ppr bind = ppr_bind pprGenEnv bind + +instance (Outputable bndr, Outputable occ) => Outputable (GenCoreExpr bndr occ flexi) where + ppr expr = ppr_expr pprGenEnv expr + +instance (Outputable occ) => Outputable (GenCoreArg occ flexi) where + ppr arg = ppr_arg pprGenArgEnv arg + +instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseAlts bndr occ flexi) where + ppr alts = ppr_alts pprGenEnv alts + +instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseDefault bndr occ flexi) where + ppr deflt = ppr_default pprGenEnv deflt \end{code} %************************************************************************ @@ -242,16 +161,14 @@ instance %************************************************************************ \begin{code} -ppr_bind pe (NonRec val_bdr expr) - = hang (hsep [pMajBndr pe val_bdr, equals]) - 4 (ppr_expr pe expr) - -ppr_bind pe (Rec binds) - = vcat (map ppr_pair binds) - where - ppr_pair (val_bdr, expr) - = hang (hsep [pMajBndr pe val_bdr, equals]) - 4 (ppr_expr pe expr <> semi) +ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr) +ppr_bind pe (Rec binds) = vcat (map pp binds) + where + pp bind = ppr_binding_pe pe bind <> semi + +ppr_binding_pe pe (val_bdr, expr) + = sep [pValBndr pe LetBind val_bdr, + nest 2 (equals <+> ppr_expr pe expr)] \end{code} \begin{code} @@ -271,20 +188,17 @@ ppr_expr pe (Var name) = pOcc pe name ppr_expr pe (Lit lit) = pLit pe lit ppr_expr pe (Con con args) - = hang (pCon pe con) - 4 (braces $ sep (map (ppr_arg pe) args)) + = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args)) ppr_expr pe (Prim prim args) - = hang (pPrim pe prim) - 4 (sep (map (ppr_arg pe) args)) + = pPrim pe prim <+> (sep (map (ppr_arg pe) args)) ppr_expr pe expr@(Lam _ _) = let - (uvars, tyvars, vars, body) = collectBinders expr + (tyvars, vars, body) = collectBinders expr in - hang (hsep [pp_vars SLIT("/u\\") (pUVar pe) uvars, - pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars, - pp_vars SLIT("\\") (pMajBndr pe) vars]) + hang (hsep [pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars, + pp_vars SLIT("\\") (pValBndr pe LambdaBind) vars]) 4 (ppr_expr pe body) where pp_vars lam pp [] = empty @@ -304,13 +218,14 @@ ppr_expr pe (Case expr alts) -- johan thinks that single case patterns should be on same line as case, -- and no indent; all sane persons agree with him. = let - - ppr_alt (AlgAlts [] (BindDefault n _)) = (<>) (pMinBndr pe n) ppr_arrow - ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (pMinBndr pe n) ppr_arrow + ppr_bndr = pValBndr pe CaseBind + + ppr_alt (AlgAlts [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow + ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow ppr_alt (PrimAlts ((l, _):[]) NoDefault)= (<>) (pLit pe l) ppr_arrow ppr_alt (AlgAlts ((con, params, _):[]) NoDefault) = hsep [pCon pe con, - hsep (map (pMinBndr pe) params), + hsep (map ppr_bndr params), ppr_arrow] ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr @@ -340,7 +255,7 @@ ppr_expr pe (Case expr alts) ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) = vcat [ - hsep [ptext SLIT("let {"), pMajBndr pe val_bdr, equals], + hsep [ptext SLIT("let {"), pValBndr pe LetBind val_bdr, equals], nest 2 (ppr_expr pe rhs), ptext SLIT("} in"), ppr_expr pe body ] @@ -348,7 +263,7 @@ ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) = ($$) (hang (ptext SLIT("let {")) - 2 (hsep [hang (hsep [pMajBndr pe val_bdr, equals]) + 2 (hsep [hang (hsep [pValBndr pe LetBind val_bdr, equals]) 4 (ppr_expr pe rhs), ptext SLIT("} in")])) (ppr_expr pe expr) @@ -369,8 +284,8 @@ ppr_expr pe (SCC cc expr) ppr_expr pe (Coerce c ty expr) = sep [pp_coerce c, pTy pe ty, ppr_expr pe expr] where - pp_coerce (CoerceIn v) = (<>) (ptext SLIT("_coerce_in_ ")) (ppr (pStyle pe) v) - pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_coerce_out_ ")) (ppr (pStyle pe) v) + pp_coerce (CoerceIn v) = (<>) (ptext SLIT("_coerce_in_ ")) (ppr v) + pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_coerce_out_ ")) (ppr v) only_one_alt (AlgAlts [] (BindDefault _ _)) = True only_one_alt (AlgAlts (_:[]) NoDefault) = True @@ -384,14 +299,15 @@ ppr_alts pe (AlgAlts alts deflt) = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ] where ppr_arrow = ptext SLIT("->") + ppr_bndr = pValBndr pe CaseBind ppr_alt (con, params, expr) = hang (if isTupleCon con then - hsep [parens (hsep (punctuate comma (map (pMinBndr pe) params))), + hsep [parens (hsep (punctuate comma (map ppr_bndr params))), ppr_arrow] else hsep [pCon pe con, - hsep (map (pMinBndr pe) params), + hsep (map ppr_bndr params), ppr_arrow] ) 4 (ppr_expr pe expr <> semi) @@ -408,7 +324,7 @@ ppr_alts pe (PrimAlts alts deflt) ppr_default pe NoDefault = empty ppr_default pe (BindDefault val_bdr expr) - = hang (hsep [pMinBndr pe val_bdr, ptext SLIT("->")]) + = hang (hsep [pValBndr pe CaseBind val_bdr, ptext SLIT("->")]) 4 (ppr_expr pe expr <> semi) \end{code} @@ -416,26 +332,32 @@ ppr_default pe (BindDefault val_bdr expr) ppr_arg pe (LitArg lit) = pLit pe lit ppr_arg pe (VarArg v) = pOcc pe v ppr_arg pe (TyArg ty) = ptext SLIT("_@_ ") <> pTy pe ty -ppr_arg pe (UsageArg use) = pUse pe use \end{code} Other printing bits-and-bobs used with the general @pprCoreBinding@ and @pprCoreExpr@ functions. \begin{code} -pprBigCoreBinder sty binder - = vcat [pragmas, - pprTypedCoreBinder sty binder] +-- Used for printing dump info +pprCoreBinder LetBind binder + = vcat [sig, pragmas, ppr binder] where - pragmas = ppIdInfo sty False{-no specs, thanks-} (getIdInfo binder) + sig = pprTypedBinder binder + pragmas = ppIdInfo False{-no specs, thanks-} (getIdInfo binder) -pprBabyCoreBinder sty binder - = hsep [ppr sty binder, pp_strictness] - where - pp_strictness = ppStrictnessInfo sty (getIdStrictness binder) +pprCoreBinder LambdaBind binder = pprTypedBinder binder +pprCoreBinder CaseBind binder = ppr binder + + +-- Used for printing interface-file unfoldings +pprIfaceBinder CaseBind binder = ppr binder +pprIfaceBinder other binder = pprTypedBinder binder -pprTypedCoreBinder sty binder - = hsep [ppr sty binder, ptext SLIT("::"), pprParendGenType sty (idType binder)] - -- The space before the :: is important; it helps the lexer - -- when reading inferfaces. Otherwise it would lex "a::b" as one thing. +pprTypedBinder binder + = ppr binder <+> ptext SLIT("::") <+> pprParendGenType (idType binder) + -- The space before the :: is important; it helps the lexer + -- when reading inferfaces. Otherwise it would lex "a::b" as one thing. + -- + -- It's important that the type is parenthesised too, at least when + -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ... \end{code} diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index dbbbea4742..fba9b3ae41 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -5,40 +5,33 @@ \begin{code} -#include "HsVersions.h" -module Check ( check , SYN_IE(ExhaustivePat), SYN_IE(WarningPat), BoxedString(..) ) where +module Check ( check , ExhaustivePat, WarningPat, BoxedString(..) ) where + -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons - -- and to break dsExpr/dsBinds-ish loop -#else import {-# SOURCE #-} DsExpr ( dsExpr ) import {-# SOURCE #-} DsBinds ( dsBinds ) -#endif import HsSyn -import TcHsSyn ( SYN_IE(TypecheckedPat), - SYN_IE(TypecheckedMatch), - SYN_IE(TypecheckedHsBinds), - SYN_IE(TypecheckedHsExpr) +import TcHsSyn ( TypecheckedPat, + TypecheckedMatch, + TypecheckedHsBinds, + TypecheckedHsExpr ) import DsHsSyn ( outPatType ) import CoreSyn -import DsMonad ( SYN_IE(DsM), DsMatchContext(..), +import DsMonad ( DsM, DsMatchContext(..), DsMatchKind(..) ) import DsUtils ( EquationInfo(..), MatchResult(..), - SYN_IE(EqnNo), - SYN_IE(EqnSet), + EqnNo, + EqnSet, CanItFail(..) ) import Id ( idType, - GenId{-instance-}, - SYN_IE(Id), + Id, idName, isTupleCon, getIdArity @@ -52,19 +45,11 @@ import Name ( occNameString, getOccName, getOccString ) -import Outputable ( PprStyle(..), - Outputable(..) - ) -import PprType ( GenType{-instance-}, - GenTyVar{-ditto-} - ) -import Pretty -import Type ( isPrimType, - eqTy, - SYN_IE(Type), - getAppTyCon +import Type ( Type, + isUnboxedType, + splitTyConApp_maybe ) -import TyVar ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) ) +import TyVar ( TyVar ) import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, @@ -84,11 +69,10 @@ import TysWiredIn ( nilDataCon, consDataCon, ) import TyCon ( tyConDataCons ) import UniqSet -import Unique ( Unique{-instance Eq-} ) -import Util ( pprTrace, - panic, - pprPanic - ) +import Unique ( Unique ) +import Outputable + +#include "HsVersions.h" \end{code} This module perfoms checks about if one list of equations are: @@ -140,7 +124,7 @@ type ExhaustivePat = ([WarningPat], [(BoxedString, [HsLit])]) instance Outputable BoxedString where - ppr sty (BS s) = text s + ppr (BS s) = text s check :: [EquationInfo] -> ([ExhaustivePat],EqnSet) @@ -390,7 +374,7 @@ get_unused_cons :: [TypecheckedPat] -> [Id] get_unused_cons used_cons = unused_cons where (ConPat _ ty _) = head used_cons - (ty_con,_) = getAppTyCon ty + Just (ty_con,_) = splitTyConApp_maybe ty all_cons = tyConDataCons ty_con used_cons_as_id = map (\ (ConPat id _ _) -> id) used_cons unused_cons = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) @@ -562,23 +546,23 @@ simplify_pat (RecPat id ty idps) = ConPat id ty pats pats = map (\ (id,p,_)-> simplify_pat p) idps simplify_pat pat@(LitPat lit lit_ty) - | isPrimType lit_ty = LitPat lit lit_ty + | isUnboxedType lit_ty = LitPat lit lit_ty - | lit_ty `eqTy` charTy = ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy] + | lit_ty == charTy = ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy] - | otherwise = pprPanic "tidy1:LitPat:" (ppr PprDebug pat) + | otherwise = pprPanic "tidy1:LitPat:" (ppr pat) where mk_char (HsChar c) = HsCharPrim c simplify_pat (NPat lit lit_ty hsexpr) = better_pat where better_pat - | lit_ty `eqTy` charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy] - | lit_ty `eqTy` intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy] - | lit_ty `eqTy` wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy] - | lit_ty `eqTy` addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy] - | lit_ty `eqTy` floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy] - | lit_ty `eqTy` doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy] + | lit_ty == charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy] + | lit_ty == intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy] + | lit_ty == wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy] + | lit_ty == addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy] + | lit_ty == floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy] + | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy] -- Convert the literal pattern "" to the constructor pattern []. | null_str_lit lit = ConPat nilDataCon lit_ty [] diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 14db54b456..87d90b2a2b 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -4,21 +4,18 @@ \section[Desugar]{@deSugar@: the main function} \begin{code} -#include "HsVersions.h" - module Desugar ( deSugar, pprDsWarnings #if __GLASGOW_HASKELL__ < 200 , DsMatchContext #endif ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CmdLineOpts ( opt_D_dump_ds ) -import HsSyn ( HsBinds, HsExpr, MonoBinds, - SYN_IE(RecFlag), nonRecursive, recursive +import HsSyn ( HsBinds, HsExpr, MonoBinds ) -import TcHsSyn ( SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedHsExpr) +import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr ) import CoreSyn import PprCore ( pprCoreBindings ) @@ -28,16 +25,15 @@ import DsBinds ( dsMonoBinds ) import DsUtils import Bag ( unionBags, isEmptyBag ) -import BasicTypes ( SYN_IE(Module) ) +import BasicTypes ( Module, RecFlag(..) ) import CmdLineOpts ( opt_DoCoreLinting, opt_SccGroup, opt_SccProfilingOn ) import CostCentre ( IsCafCC(..), mkAutoCC ) import CoreLift ( liftCoreBindings ) import CoreLint ( lintCoreBindings ) import Id ( nullIdEnv, mkIdEnv, idType, - SYN_IE(DictVar), GenId, SYN_IE(Id) ) + DictVar, GenId, Id ) import ErrUtils ( dumpIfSet, doIfSet ) -import Outputable ( PprStyle(..), pprDumpStyle, pprErrorsStyle, printErrs ) -import Pretty ( Doc ) +import Outputable import UniqSupply ( splitUniqSupply, UniqSupply ) \end{code} @@ -60,21 +56,21 @@ deSugar us mod_name all_binds Nothing -> mod_name -- default: module name (core_prs, ds_warns) = initDs us1 nullIdEnv module_and_group - (dsMonoBinds opt_SccProfilingOn recursive all_binds []) + (dsMonoBinds opt_SccProfilingOn all_binds []) ds_binds = liftCoreBindings us2 [Rec core_prs] in -- Display any warnings doIfSet (not (isEmptyBag ds_warns)) - (printErrs (pprDsWarnings pprErrorsStyle ds_warns)) >> + (printErrs (pprDsWarnings ds_warns)) >> -- Lint result if necessary lintCoreBindings "Desugarer" False ds_binds >> -- Dump output dumpIfSet opt_D_dump_ds "Desugared:" - (pprCoreBindings pprDumpStyle ds_binds) >> + (pprCoreBindings ds_binds) >> return ds_binds \end{code} diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index bfd4634dc8..c365d14500 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -8,44 +8,37 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at lower levels it is preserved with @let@/@letrec@s). \begin{code} -#include "HsVersions.h" - module DsBinds ( dsBinds, dsMonoBinds ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop -#else +#include "HsVersions.h" + import {-# SOURCE #-} DsExpr -#endif import HsSyn -- lots of things import CoreSyn -- lots of things import CoreUtils ( coreExprType ) -import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr), - SYN_IE(TypecheckedMonoBinds), - SYN_IE(TypecheckedPat) +import TcHsSyn ( TypecheckedHsBinds, TypecheckedHsExpr, + TypecheckedMonoBinds, + TypecheckedPat ) import DsMonad import DsGRHSs ( dsGuarded ) import DsUtils import Match ( matchWrapper ) -import BasicTypes ( SYN_IE(Module) ) +import BasicTypes ( Module, RecFlag(..) ) import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs ) import CostCentre ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre ) -import Id ( idType, SYN_IE(DictVar), GenId, SYN_IE(Id) ) ---ToDo: rm import ListSetOps ( minusList, intersectLists ) +import Id ( idType, DictVar, Id ) import Name ( isExported ) -import PprType ( GenType ) -import Outputable ( PprStyle(..) ) import Type ( mkTyVarTy, isDictTy, instantiateTy ) -import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} ) +import TyVar ( tyVarSetToList, zipTyVarEnv ) import TysPrim ( voidTy ) -import Util ( isIn, panic, assertPanic ) +import Util ( isIn ) +import Outputable \end{code} %************************************************************************ @@ -69,11 +62,10 @@ dsBinds auto_scc (ThenBinds binds_1 binds_2) = andDs (++) (dsBinds auto_scc binds_1) (dsBinds auto_scc binds_2) dsBinds auto_scc (MonoBind binds sigs is_rec) - = dsMonoBinds auto_scc is_rec binds [] `thenDs` \ prs -> - returnDs (if is_rec then - [Rec prs] - else - [NonRec binder rhs | (binder,rhs) <- prs] + = dsMonoBinds auto_scc binds [] `thenDs` \ prs -> + returnDs (case is_rec of + Recursive -> [Rec prs] + NonRecursive -> [NonRec binder rhs | (binder,rhs) <- prs] ) \end{code} @@ -86,21 +78,20 @@ dsBinds auto_scc (MonoBind binds sigs is_rec) \begin{code} dsMonoBinds :: Bool -- False => don't (auto-)annotate scc on toplevs. - -> RecFlag -> TypecheckedMonoBinds -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append) -> DsM [(Id,CoreExpr)] -- Result -dsMonoBinds _ is_rec EmptyMonoBinds rest = returnDs rest +dsMonoBinds _ EmptyMonoBinds rest = returnDs rest -dsMonoBinds auto_scc is_rec (AndMonoBinds binds_1 binds_2) rest - = dsMonoBinds auto_scc is_rec binds_2 rest `thenDs` \ rest' -> - dsMonoBinds auto_scc is_rec binds_1 rest' +dsMonoBinds auto_scc (AndMonoBinds binds_1 binds_2) rest + = dsMonoBinds auto_scc binds_2 rest `thenDs` \ rest' -> + dsMonoBinds auto_scc binds_1 rest' -dsMonoBinds _ is_rec (CoreMonoBind var core_expr) rest +dsMonoBinds _ (CoreMonoBind var core_expr) rest = returnDs ((var, core_expr) : rest) -dsMonoBinds _ is_rec (VarMonoBind var expr) rest +dsMonoBinds _ (VarMonoBind var expr) rest = dsExpr expr `thenDs` \ core_expr -> -- Dictionary bindings are always VarMonoBinds, so @@ -109,7 +100,7 @@ dsMonoBinds _ is_rec (VarMonoBind var expr) rest returnDs ((var, core_expr') : rest) -dsMonoBinds auto_scc is_rec (FunMonoBind fun _ matches locn) rest +dsMonoBinds auto_scc (FunMonoBind fun _ matches locn) rest = putSrcLocDs locn $ matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) -> addAutoScc auto_scc (fun, mkValLam args body) `thenDs` \ pair -> @@ -117,35 +108,35 @@ dsMonoBinds auto_scc is_rec (FunMonoBind fun _ matches locn) rest where error_string = "function " ++ showForErr fun -dsMonoBinds _ is_rec (PatMonoBind pat grhss_and_binds locn) rest +dsMonoBinds _ (PatMonoBind pat grhss_and_binds locn) rest = putSrcLocDs locn $ dsGuarded grhss_and_binds `thenDs` \ body_expr -> mkSelectorBinds pat body_expr `thenDs` \ sel_binds -> returnDs (sel_binds ++ rest) -- Common special case: no type or dictionary abstraction -dsMonoBinds auto_scc is_rec (AbsBinds [] [] exports binds) rest +dsMonoBinds auto_scc (AbsBinds [] [] exports binds) rest = mapDs (addAutoScc auto_scc) [(global, Var local) | (_, global, local) <- exports] `thenDs` \ exports' -> - dsMonoBinds False is_rec binds (exports' ++ rest) + dsMonoBinds False binds (exports' ++ rest) -- Another common case: one exported variable -- All non-recursive bindings come through this way -dsMonoBinds auto_scc is_rec (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds) rest +dsMonoBinds auto_scc (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds) rest = ASSERT( all (`elem` tyvars) all_tyvars ) - dsMonoBinds False is_rec binds [] `thenDs` \ core_prs -> + dsMonoBinds False binds [] `thenDs` \ core_prs -> let - core_binds | is_rec = [Rec core_prs] - | otherwise = [NonRec b e | (b,e) <- core_prs] + -- Always treat the binds as recursive, because the typechecker + -- makes rather mixed-up dictionary bindings + core_binds = [Rec core_prs] in addAutoScc auto_scc (global, mkLam tyvars dicts $ mkCoLetsAny core_binds (Var local)) `thenDs` \ global' -> returnDs (global' : rest) -dsMonoBinds auto_scc is_rec (AbsBinds all_tyvars dicts exports binds) rest - = dsMonoBinds False is_rec binds [] `thenDs` \ core_prs -> +dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports binds) rest + = dsMonoBinds False binds [] `thenDs` \ core_prs -> let - core_binds | is_rec = [Rec core_prs] - | otherwise = [NonRec b e | (b,e) <- core_prs] + core_binds = [Rec core_prs] tup_expr = mkLam all_tyvars dicts $ mkCoLetsAny core_binds $ @@ -169,7 +160,7 @@ dsMonoBinds auto_scc is_rec (AbsBinds all_tyvars dicts exports binds) rest mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar | otherwise = voidTy ty_args = map mk_ty_arg all_tyvars - env = all_tyvars `zip` ty_args + env = all_tyvars `zipTyVarEnv` ty_args in zipWithDs mk_bind exports [0..] `thenDs` \ export_binds -> -- don't scc (auto-)annotate the tuple itself. diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 1cae7d022b..019e207330 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -4,29 +4,26 @@ \section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s} \begin{code} -#include "HsVersions.h" - module DsCCall ( dsCCall ) where -IMP_Ubiq() +#include "HsVersions.h" -import CmdLineOpts (opt_PprUserLength) import CoreSyn import DsMonad import DsUtils +import TcHsSyn ( maybeBoxedPrimType ) import CoreUtils ( coreExprType ) import Id ( Id(..), dataConArgTys, dataConTyCon, idType ) import Maybes ( maybeToBool ) -import Outputable ( PprStyle(..), Outputable(..) ) import PprType ( GenType{-instances-} ) -import Pretty import PrelVals ( packStringForCId ) import PrimOp ( PrimOp(..) ) -import Type ( isPrimType, maybeAppDataTyConExpandingDicts, maybeAppTyCon, - eqTy, maybeBoxedPrimType, SYN_IE(Type), GenType(..), - splitFunTy, splitForAllTy, splitAppTys ) +import Type ( isUnpointedType, splitAlgTyConApp_maybe, + splitTyConApp_maybe, splitFunTys, splitForAllTys, + Type + ) import TyCon ( tyConDataCons ) import TysPrim ( byteArrayPrimTy, realWorldTy, realWorldStatePrimTy, byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) @@ -34,8 +31,7 @@ import TysWiredIn ( getStatePairingConInfo, unitDataCon, stringTy, realWorldStateTy, stateDataCon ) -import Util ( pprPanic, pprError, panic ) - +import Outputable \end{code} Desugaring of @ccall@s consists of adding some state manipulation, @@ -121,11 +117,11 @@ unboxArg arg -- which generates the boiler-plate box-unbox code for you, i.e., it may help -- us nuke this very module :-) -- - | isPrimType arg_ty + | isUnpointedType arg_ty = returnDs (arg, \body -> body) -- Strings - | arg_ty `eqTy` stringTy + | arg_ty == stringTy -- ToDo (ADR): - allow synonyms of Strings too? = newSysLocalDs byteArrayPrimTy `thenDs` \ prim_arg -> mkAppDs (Var packStringForCId) [VarArg arg] `thenDs` \ pack_appn -> @@ -160,14 +156,14 @@ unboxArg arg ) | otherwise - = pprPanic "unboxArg: " (ppr PprDebug arg_ty) + = pprPanic "unboxArg: " (ppr arg_ty) where arg_ty = coreExprType arg maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty - maybe_data_type = maybeAppDataTyConExpandingDicts arg_ty + maybe_data_type = splitAlgTyConApp_maybe arg_ty is_data_type = maybeToBool maybe_data_type (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type (the_data_con : other_data_cons) = data_cons @@ -175,12 +171,12 @@ unboxArg arg data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys - maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2 + maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2 Just (arg2_tycon,_) = maybe_arg2_tycon can't_see_datacons_error thing ty - = pprError "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ " - (hcat [text thing, text "; type: ", ppr (PprForUser opt_PprUserLength) ty, text "(try compiling with -fno-prune-tydecls ..)\n"]) + = pprPanic "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ " + (hcat [text thing, text "; type: ", ppr ty, text "(try compiling with -fno-prune-tydecls ..)\n"]) \end{code} @@ -195,12 +191,11 @@ boxResult ioOkDataCon result_ty -- oops! can't see the data constructors = can't_see_datacons_error "result" result_ty - -- Data types with a single constructor, - -- which has a single, primitive-typed arg. - | (maybeToBool maybe_data_type) && -- Data type - (null other_data_cons) && -- Just one constr - not (null data_con_arg_tys) && null other_args_tys && -- Just one arg - isPrimType the_prim_result_ty -- of primitive type + -- Data types with a single constructor, which has a single, primitive-typed arg + | (maybeToBool maybe_data_type) && -- Data type + (null other_data_cons) && -- Just one constr + not (null data_con_arg_tys) && null other_args_tys && -- Just one arg + isUnpointedType the_prim_result_ty -- of primitive type = newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id -> newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id -> @@ -236,10 +231,10 @@ boxResult ioOkDataCon result_ty ) | otherwise - = pprPanic "boxResult: " (ppr PprDebug result_ty) + = pprPanic "boxResult: " (ppr result_ty) where - maybe_data_type = maybeAppDataTyConExpandingDicts result_ty + maybe_data_type = splitAlgTyConApp_maybe result_ty Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type (the_data_con : other_data_cons) = data_cons @@ -262,19 +257,21 @@ newtype IO a = IO (State# RealWorld -> IOResult a) the constructor IO has type (State# RealWorld -> IOResult a) -> IO a \begin{code} -getIoOkDataCon :: Type -> (Id,Type) -getIoOkDataCon io_result_ty = - let - AppTy (TyConTy ioTyCon _) result_ty = io_result_ty +getIoOkDataCon :: Type -- IO t + -> (Id,Type) -- Returns (IOok, t) + +getIoOkDataCon io_ty + = let + Just (ioTyCon, [t]) = splitTyConApp_maybe io_ty [ioDataCon] = tyConDataCons ioTyCon ioDataConTy = idType ioDataCon - (_,ioDataConTy') = splitForAllTy ioDataConTy - ([arg],_) = splitFunTy ioDataConTy' - (_,AppTy (TyConTy ioResultTyCon _) _) = splitFunTy arg - [ioOkDataCon,ioFailDataCon] = tyConDataCons ioResultTyCon + (_, ioDataConTy') = splitForAllTys ioDataConTy + ([arg_ty], _) = splitFunTys ioDataConTy' + (_, io_result_ty) = splitFunTys arg_ty + Just (io_result_tycon, _) = splitTyConApp_maybe io_result_ty + [ioOkDataCon,ioFailDataCon] = tyConDataCons io_result_tycon in - (ioOkDataCon, result_ty) - + (ioOkDataCon, t) \end{code} Another way to do it, more sensitive: diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 1b46e7779e..06e7f875bf 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -4,25 +4,22 @@ \section[DsExpr]{Matching expressions (Exprs)} \begin{code} -#include "HsVersions.h" - module DsExpr ( dsExpr ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(DsLoop) -- partly to get dsBinds, partly to chk dsExpr -#else +#include "HsVersions.h" + import {-# SOURCE #-} DsBinds (dsBinds ) -#endif import HsSyn ( failureFreePat, HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..), Stmt(..), DoOrListComp(..), Match(..), HsBinds, HsType, Fixity, GRHSsAndBinds ) -import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds), - SYN_IE(TypecheckedRecordBinds), SYN_IE(TypecheckedPat), - SYN_IE(TypecheckedStmt) +import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, + TypecheckedRecordBinds, TypecheckedPat, + TypecheckedStmt, + maybeBoxedPrimType + ) import CoreSyn @@ -32,7 +29,7 @@ import DsHsSyn ( outPatType ) import DsListComp ( dsListComp ) import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtomGivenTy, mkTupleExpr, mkErrorAppDs, showForErr, EquationInfo, - MatchResult, SYN_IE(DsCoreArg) + MatchResult, DsCoreArg ) import Match ( matchWrapper ) @@ -41,29 +38,27 @@ import CoreUtils ( coreExprType, substCoreExpr, argToExpr, import CostCentre ( mkUserCC ) import FieldLabel ( fieldLabelType, FieldLabel ) import Id ( idType, nullIdEnv, addOneToIdEnv, - dataConArgTys, dataConFieldLabels, - recordSelectorFieldLabel, SYN_IE(Id) + dataConTyCon, dataConArgTys, dataConFieldLabels, + recordSelectorFieldLabel, Id ) import Literal ( mkMachInt, Literal(..) ) import Name ( Name{--O only-} ) -import Outputable ( PprStyle(..), Outputable(..) ) -import PprType ( GenType ) import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, voidId ) -import Pretty ( Doc, hcat, ptext, text ) -import Type ( splitSigmaTy, splitFunTy, typePrimRep, - getAppDataTyConExpandingDicts, maybeAppTyCon, getAppTyCon, applyTy, - maybeBoxedPrimType, splitAppTy, SYN_IE(Type) +import TyCon ( isNewTyCon ) +import Type ( splitSigmaTy, splitFunTys, typePrimRep, mkTyConApp, + splitAlgTyConApp, splitTyConApp_maybe, applyTy, + splitAppTy, Type ) import TysPrim ( voidTy ) import TysWiredIn ( mkTupleTy, tupleCon, nilDataCon, consDataCon, listTyCon, mkListTy, charDataCon, charTy ) -import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} ) -import Usage ( SYN_IE(UVar) ) +import TyVar ( addToTyVarEnv, GenTyVar{-instance Eq-} ) import Maybes ( maybeToBool ) -import Util ( zipEqual, pprError, panic, assertPanic ) +import Util ( zipEqual ) +import Outputable -mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility... +mk_nil_con ty = mkCon nilDataCon [ty] [] -- micro utility... \end{code} The funny business to do with variables is that we look them up in the @@ -110,7 +105,7 @@ dsExpr (HsLitOut (HsString s) _) | _LENGTH_ s == 1 = let - the_char = mkCon charDataCon [] [] [LitArg (MachChar (_HEAD_ s))] + the_char = mkCon charDataCon [] [LitArg (MachChar (_HEAD_ s))] the_nil = mk_nil_con charTy in mkConDs consDataCon [TyArg charTy, VarArg the_char, VarArg the_nil] @@ -145,15 +140,15 @@ dsExpr (HsLitOut (HsString str) _) = returnDs (Lit (NoRepStr str)) dsExpr (HsLitOut (HsLitLit s) ty) - = returnDs ( mkCon data_con [] [] [LitArg (MachLitLit s kind)] ) + = returnDs ( mkCon data_con [] [LitArg (MachLitLit s kind)] ) where (data_con, kind) = case (maybeBoxedPrimType ty) of Just (boxing_data_con, prim_ty) -> (boxing_data_con, typePrimRep prim_ty) Nothing - -> pprError "ERROR: ``literal-literal'' not a single-constructor type: " - (hcat [ptext s, text "; type: ", ppr PprDebug ty]) + -> pprPanic "ERROR: ``literal-literal'' not a single-constructor type: " + (hcat [ptext s, text "; type: ", ppr ty]) dsExpr (HsLitOut (HsInt i) ty) = returnDs (Lit (NoRepInteger i ty)) @@ -178,7 +173,7 @@ dsExpr (HsLitOut (HsDoublePrim d) _) -- ToDo: range checking needed! dsExpr (HsLitOut (HsChar c) _) - = returnDs ( mkCon charDataCon [] [] [LitArg (MachChar c)] ) + = returnDs ( mkCon charDataCon [] [LitArg (MachChar c)] ) dsExpr (HsLitOut (HsCharPrim c) _) = returnDs (Lit (MachChar c)) @@ -226,7 +221,7 @@ dsExpr (OpApp e1 op _ e2) = dsExpr op `thenDs` \ core_op -> -- for the type of y, we need the type of op's 2nd argument let - (x_ty:y_ty:_, _) = splitFunTy (coreExprType core_op) + (x_ty:y_ty:_, _) = splitFunTys (coreExprType core_op) in dsExpr e1 `thenDs` \ x_core -> dsExpr e2 `thenDs` \ y_core -> @@ -238,7 +233,7 @@ dsExpr (SectionL expr op) = dsExpr op `thenDs` \ core_op -> -- for the type of y, we need the type of op's 2nd argument let - (x_ty:y_ty:_, _) = splitFunTy (coreExprType core_op) + (x_ty:y_ty:_, _) = splitFunTys (coreExprType core_op) in dsExpr expr `thenDs` \ x_core -> dsExprToAtomGivenTy x_core x_ty $ \ x_atom -> @@ -251,7 +246,7 @@ dsExpr (SectionR op expr) = dsExpr op `thenDs` \ core_op -> -- for the type of x, we need the type of op's 2nd argument let - (x_ty:y_ty:_, _) = splitFunTy (coreExprType core_op) + (x_ty:y_ty:_, _) = splitFunTys (coreExprType core_op) in dsExpr expr `thenDs` \ y_expr -> dsExprToAtomGivenTy y_expr y_ty $ \ y_atom -> @@ -291,7 +286,7 @@ dsExpr (HsDoOut do_or_lc stmts return_id then_id zero_id result_ty src_loc) dsDo do_or_lc stmts return_id then_id zero_id result_ty where maybe_list_comp - = case (do_or_lc, maybeAppTyCon result_ty) of + = case (do_or_lc, splitTyConApp_maybe result_ty) of (ListComp, Just (tycon, [elt_ty])) | tycon == listTyCon -> Just elt_ty @@ -347,6 +342,18 @@ dsExpr (ExplicitTuple expr_list) mkConDs (tupleCon (length expr_list)) (map (TyArg . coreExprType) core_exprs ++ map VarArg core_exprs) +dsExpr (HsCon con_id [ty] [arg]) + | isNewTyCon tycon + = dsExpr arg `thenDs` \ arg' -> + returnDs (Coerce (CoerceIn con_id) result_ty arg') + where + result_ty = mkTyConApp tycon [ty] + tycon = dataConTyCon con_id + +dsExpr (HsCon con_id tys args) + = mapDs dsExpr args `thenDs` \ args2 -> + mkConDs con_id (map TyArg tys ++ map VarArg args2) + dsExpr (ArithSeqOut expr (From from)) = dsExpr expr `thenDs` \ expr2 -> dsExpr from `thenDs` \ from2 -> @@ -390,10 +397,10 @@ before printing it as \begin{code} -dsExpr (RecordConOut con_id con_expr rbinds) +dsExpr (RecordCon con_id con_expr rbinds) = dsExpr con_expr `thenDs` \ con_expr' -> let - (arg_tys, _) = splitFunTy (coreExprType con_expr') + (arg_tys, _) = splitFunTys (coreExprType con_expr') mk_arg (arg_ty, lbl) = case [rhs | (sel_id,rhs,_) <- rbinds, @@ -436,8 +443,8 @@ dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds) dsRbinds rbinds $ \ rbinds' -> let record_in_ty = coreExprType record_expr' - (tycon, in_inst_tys, cons) = getAppDataTyConExpandingDicts record_in_ty - (_, out_inst_tys, _) = getAppDataTyConExpandingDicts record_out_ty + (tycon, in_inst_tys, cons) = splitAlgTyConApp record_in_ty + (_, out_inst_tys, _) = splitAlgTyConApp record_out_ty cons_to_upd = filter has_all_fields cons -- initial_args are passed to every constructor @@ -497,46 +504,8 @@ dsExpr (DictApp expr dicts) -- becomes a curried application returnDs (foldl (\f d -> f `App` (VarArg d)) core_expr core_dicts) \end{code} -@SingleDicts@ become @Locals@; @Dicts@ turn into tuples, unless -of length 0 or 1. -@ClassDictLam dictvars methods expr@ is ``the opposite'': -\begin{verbatim} -\ x -> case x of ( dictvars-and-methods-tuple ) -> expr -\end{verbatim} \begin{code} -dsExpr (SingleDict dict) -- just a local - = lookupEnvDs dict `thenDs` \ dict' -> - returnDs (Var dict') - -dsExpr (Dictionary [] []) -- Empty dictionary represented by void, - = returnDs (Var voidId) -- (not, as would happen if we took the next case, by ()) -dsExpr (Dictionary dicts methods) - = mapDs lookupEnvDs (dicts ++ methods) `thenDs` \ d_and_ms' -> - returnDs (mkTupleExpr d_and_ms') - -dsExpr (ClassDictLam dicts methods expr) - = dsExpr expr `thenDs` \ core_expr -> - case num_of_d_and_ms of - 0 -> newSysLocalDs voidTy `thenDs` \ new_x -> - returnDs (mkValLam [new_x] core_expr) - - 1 -> -- no untupling - returnDs (mkValLam dicts_and_methods core_expr) - - _ -> -- untuple it - newSysLocalDs tuple_ty `thenDs` \ new_x -> - returnDs ( - Lam (ValBinder new_x) - (Case (Var new_x) - (AlgAlts - [(tuple_con, dicts_and_methods, core_expr)] - NoDefault))) - where - num_of_d_and_ms = length dicts + length methods - dicts_and_methods = dicts ++ methods - tuple_ty = mkTupleTy num_of_d_and_ms (map idType dicts_and_methods) - tuple_con = tupleCon num_of_d_and_ms #ifdef DEBUG -- HsSyn constructs that just shouldn't be here: @@ -578,7 +547,7 @@ dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with \begin{code} -- do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args) --- = do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args +-- = do_unfold (addToTyVarEnv ty_env tyvar ty) val_env body args -- -- do_unfold ty_env val_env (Lam (ValBinder binder) body) (arg@(VarArg expr) : args) -- = dsExprToAtom arg $ \ arg_atom -> diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index 2ba429ef0f..40b625cbe7 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -4,42 +4,32 @@ \section[DsGRHSs]{Matching guarded right-hand-sides (GRHSs)} \begin{code} -#include "HsVersions.h" - module DsGRHSs ( dsGuarded, dsGRHSs ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop -#else +#include "HsVersions.h" + import {-# SOURCE #-} DsExpr ( dsExpr ) import {-# SOURCE #-} DsBinds ( dsBinds ) import {-# SOURCE #-} Match ( matchExport ) -#endif import HsSyn ( GRHSsAndBinds(..), GRHS(..), HsExpr(..), HsBinds, Stmt(..), HsLit, Match, Fixity, DoOrListComp, HsType, ArithSeqInfo ) -import TcHsSyn ( SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS), - SYN_IE(TypecheckedPat), SYN_IE(TypecheckedHsBinds), - SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedStmt) +import TcHsSyn ( TypecheckedGRHSsAndBinds, TypecheckedGRHS, + TypecheckedPat, TypecheckedHsBinds, + TypecheckedHsExpr, TypecheckedStmt ) -import CoreSyn ( SYN_IE(CoreBinding), GenCoreBinding(..), SYN_IE(CoreExpr), mkCoLetsAny ) +import CoreSyn ( CoreBinding, GenCoreBinding(..), CoreExpr, mkCoLetsAny ) import DsMonad import DsUtils - -#if __GLASGOW_HASKELL__ < 200 -import Id ( GenId ) -#endif import CoreUtils ( coreExprType, mkCoreIfThenElse ) import PrelVals ( nON_EXHAUSTIVE_GUARDS_ERROR_ID ) -import Outputable ( PprStyle(..) ) import SrcLoc ( SrcLoc{-instance-} ) -import Type ( SYN_IE(Type) ) +import Type ( Type ) import Unique ( Unique, otherwiseIdKey, trueDataConKey, Uniquable(..) ) -import Util ( panic ) +import Outputable \end{code} @dsGuarded@ is used for both @case@ expressions and pattern bindings. @@ -90,14 +80,6 @@ dsGRHSs ty kind pats (grhs:grhss) dsGRHSs ty kind pats grhss `thenDs` \ match_result2 -> combineGRHSMatchResults match_result1 match_result2 -dsGRHS ty kind pats (OtherwiseGRHS expr locn) - = putSrcLocDs locn $ - dsExpr expr `thenDs` \ core_expr -> - let - expr_fn = \ ignore -> core_expr - in - returnDs (MatchResult CantFail ty expr_fn ) --(DsMatchContext kind pats locn)) - dsGRHS ty kind pats (GRHS guard expr locn) = putSrcLocDs locn $ dsExpr expr `thenDs` \ core_expr -> diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs index 070b243f4f..2e6b8882ef 100644 --- a/ghc/compiler/deSugar/DsHsSyn.lhs +++ b/ghc/compiler/deSugar/DsHsSyn.lhs @@ -4,19 +4,17 @@ \section[DsHsSyn]{Haskell abstract syntax---added things for desugarer} \begin{code} -#include "HsVersions.h" - module DsHsSyn where -IMP_Ubiq() +#include "HsVersions.h" import HsSyn ( OutPat(..), HsBinds(..), MonoBinds(..), Sig, HsExpr, GRHSsAndBinds, Match, HsLit ) -import TcHsSyn ( SYN_IE(TypecheckedPat), - SYN_IE(TypecheckedMonoBinds) ) +import TcHsSyn ( TypecheckedPat, + TypecheckedMonoBinds ) -import Id ( idType, SYN_IE(Id) ) -import Type ( SYN_IE(Type) ) +import Id ( idType, Id ) +import Type ( Type ) import TysWiredIn ( mkListTy, mkTupleTy, unitTy ) import Util ( panic ) \end{code} diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index a202ad92e4..56440968a2 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -4,20 +4,15 @@ \section[DsListComp]{Desugaring list comprehensions} \begin{code} -#include "HsVersions.h" - module DsListComp ( dsListComp ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop -#else +#include "HsVersions.h" + import {-# SOURCE #-} DsExpr ( dsExpr ) import {-# SOURCE #-} DsBinds ( dsBinds ) -#endif import HsSyn ( Stmt(..), HsExpr, HsBinds ) -import TcHsSyn ( SYN_IE(TypecheckedStmt), SYN_IE(TypecheckedHsExpr) , SYN_IE(TypecheckedHsBinds) ) +import TcHsSyn ( TypecheckedStmt, TypecheckedHsExpr , TypecheckedHsBinds ) import DsHsSyn ( outPatType ) import CoreSyn @@ -26,9 +21,9 @@ import DsUtils import CmdLineOpts ( opt_FoldrBuildOn ) import CoreUtils ( coreExprType, mkCoreIfThenElse ) -import Id ( SYN_IE(Id) ) +import Id ( Id ) import PrelVals ( mkBuild, foldrId ) -import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy, SYN_IE(Type) ) +import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy, Type ) import TysPrim ( alphaTy ) import TysWiredIn ( nilDataCon, consDataCon, listTyCon ) import TyVar ( alphaTyVar ) @@ -72,7 +67,7 @@ dsListComp quals elt_ty returnDs (mkBuild elt_ty n_tyvar c n g result) where - nil_expr = mkCon nilDataCon [] [elt_ty] [] + nil_expr = mkCon nilDataCon [elt_ty] [] \end{code} %************************************************************************ diff --git a/ghc/compiler/deSugar/DsLoop.lhi b/ghc/compiler/deSugar/DsLoop.lhi deleted file mode 100644 index 4464a5396f..0000000000 --- a/ghc/compiler/deSugar/DsLoop.lhi +++ /dev/null @@ -1,35 +0,0 @@ -Break the loop between Match and DsUtils and the loops -between DsExpr/DsBinds and various things. - -\begin{code} -interface DsLoop where - -import CoreSyn ( CoreBinding(..), CoreExpr(..) ) -import DsMonad ( DsM(..), DsMatchKind(..) ) -import DsBinds ( dsBinds ) -import DsExpr ( dsExpr ) -import DsUtils ( EquationInfo, MatchResult ) -import FastString ( FastString ) -import Id ( Id(..) ) -import Match ( matchExport, match, matchSimply ) -import PreludeStdIO ( Maybe ) -import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..), TypecheckedPat(..) ) -import Type ( Type(..) ) -match :: [Id] -- Variables rep'ing the exprs we're matching with - -> [EquationInfo] -- Info about patterns, etc. (type synonym below) - -> DsM MatchResult -- Desugared result! -matchExport :: [Id] -- Variables rep'ing the exprs we're matching with - -> [EquationInfo] -- Info about patterns, etc. (type synonym below) - -> DsM MatchResult -- Desugared result! - -matchSimply :: CoreExpr -- Scrutinee - -> DsMatchKind -- Type of Match - -> TypecheckedPat -- Pattern it should match - -> Type -- Type of result - -> CoreExpr -- Return this if it matches - -> CoreExpr -- Return this if it does - -> DsM CoreExpr - -dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding] -dsExpr :: TypecheckedHsExpr -> DsM CoreExpr -\end{code} diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 7ed81cfe2b..90e9958846 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -4,10 +4,8 @@ \section[DsMonad]{@DsMonad@: monadery used in desugaring} \begin{code} -#include "HsVersions.h" - module DsMonad ( - SYN_IE(DsM), + DsM, initDs, returnDs, thenDs, andDs, mapDs, listDs, mapAndUnzipDs, zipWithDs, uniqSMtoDsM, @@ -17,37 +15,33 @@ module DsMonad ( getSrcLocDs, putSrcLocDs, getModuleAndGroupDs, extendEnvDs, lookupEnvDs, - SYN_IE(DsIdEnv), + DsIdEnv, dsWarn, - SYN_IE(DsWarnings), + DsWarnings, DsMatchContext(..), DsMatchKind(..), pprDsWarnings - ) where -IMP_Ubiq() +#include "HsVersions.h" import Bag ( emptyBag, snocBag, bagToList, Bag ) -import BasicTypes ( SYN_IE(Module) ) -import CmdLineOpts ( opt_PprUserLength ) -import CoreSyn ( SYN_IE(CoreExpr) ) +import BasicTypes ( Module ) +import CoreSyn ( CoreExpr ) import CoreUtils ( substCoreExpr ) -import ErrUtils ( SYN_IE(Warning) ) +import ErrUtils ( WarnMsg ) import HsSyn ( OutPat ) import Id ( mkSysLocal, mkIdWithNewUniq, - lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv), - SYN_IE(Id) + lookupIdEnv, growIdEnvList, GenId, IdEnv, + Id ) import PprType ( GenType, GenTyVar ) -import Outputable ( pprQuote, Outputable(..), PprStyle(..) ) -import Pretty +import Outputable import SrcLoc ( noSrcLoc, SrcLoc ) -import TcHsSyn ( SYN_IE(TypecheckedPat) ) -import Type ( SYN_IE(Type) ) -import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-}, SYN_IE(TyVar) ) -import Unique ( Unique{-instances-} ) +import TcHsSyn ( TypecheckedPat ) +import Type ( Type ) +import TyVar ( cloneTyVar, TyVar ) import UniqSupply ( splitUniqSupply, getUnique, getUniques, - mapUs, thenUs, returnUs, SYN_IE(UniqSM), + mapUs, thenUs, returnUs, UniqSM, UniqSupply ) import Util ( assoc, mapAccumL, zipWithEqual, panic ) @@ -66,7 +60,7 @@ type DsM result = -> DsWarnings -> (result, DsWarnings) -type DsWarnings = Bag Warning -- The desugarer reports matches which are +type DsWarnings = Bag WarnMsg -- The desugarer reports matches which are -- completely shadowed or incomplete patterns type Group = FAST_STRING @@ -185,7 +179,7 @@ putSrcLocDs :: SrcLoc -> DsM a -> DsM a putSrcLocDs new_loc expr us old_loc mod_and_grp env warns = expr us new_loc mod_and_grp env warns -dsWarn :: Warning -> DsM () +dsWarn :: WarnMsg -> DsM () dsWarn warn us loc mod_and_grp env warns = ((), warns `snocBag` warn) \end{code} @@ -234,7 +228,6 @@ data DsMatchKind | LetMatch deriving () -pprDsWarnings :: PprStyle -> DsWarnings -> Doc -pprDsWarnings sty warns = vcat [ warn sty | warn <- (bagToList warns)] - +pprDsWarnings :: DsWarnings -> SDoc +pprDsWarnings warns = vcat (bagToList warns) \end{code} diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index ec7d25231e..1254d9a674 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -6,15 +6,13 @@ This module exports some utility functions of no great interest. \begin{code} -#include "HsVersions.h" - module DsUtils ( CanItFail(..), EquationInfo(..), MatchResult(..), - SYN_IE(EqnNo), SYN_IE(EqnSet), + EqnNo, EqnSet, combineGRHSMatchResults, combineMatchResults, - dsExprToAtomGivenTy, SYN_IE(DsCoreArg), + dsExprToAtomGivenTy, DsCoreArg, mkCoAlgCaseMatchResult, mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs, mkCoLetsMatchResult, @@ -29,48 +27,35 @@ module DsUtils ( showForErr ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(DsLoop) ( match, matchSimply ) -#else +#include "HsVersions.h" + import {-# SOURCE #-} Match (match, matchSimply ) -#endif import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), Fixity, Match, HsBinds, Stmt, DoOrListComp, HsType, ArithSeqInfo ) -import TcHsSyn ( SYN_IE(TypecheckedPat) ) +import TcHsSyn ( TypecheckedPat ) import DsHsSyn ( outPatType, collectTypedPatBinders ) -import CmdLineOpts ( opt_PprUserLength ) import CoreSyn import DsMonad import CoreUtils ( coreExprType, mkCoreIfThenElse ) import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId ) -import Pretty ( Doc, hcat, text ) import Id ( idType, dataConArgTys, --- pprId{-ToDo:rm-}, - SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId ) + DataCon, DictVar, Id, GenId ) import Literal ( Literal(..) ) -import PprType ( GenType, GenTyVar ) import PrimOp ( PrimOp ) import TyCon ( isNewTyCon, tyConDataCons ) import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy, - mkTheta, isUnboxedType, applyTyCon, getAppTyCon, - GenType {- instances -}, SYN_IE(Type) + isUnpointedType, mkTyConApp, splitAlgTyConApp, + Type ) -import TyVar ( GenTyVar {- instances -}, SYN_IE(TyVar) ) +import BasicTypes ( Unused ) import TysPrim ( voidTy ) import TysWiredIn ( tupleTyCon, unitDataCon, tupleCon ) -import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) ) -import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} ) +import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet ) import Unique ( Unique ) -import UniqSet -import Usage ( SYN_IE(UVar) ) -import SrcLoc ( SrcLoc {- instance Outputable -} ) - import Outputable - \end{code} @@ -213,8 +198,7 @@ mkCoAlgCaseMatchResult var alts where -- Common stuff scrut_ty = idType var - (tycon, tycon_arg_tys) = --pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $ - getAppTyCon scrut_ty + (tycon, tycon_arg_tys, _) = splitAlgTyConApp scrut_ty -- Stuff for newtype (con_id, arg_ids, match_result) = head alts @@ -281,7 +265,6 @@ dsArgToAtom :: DsCoreArg -- The argument expression -- and delivering an expression E -> DsM CoreExpr -- Either E or let x=arg-expr in E -dsArgToAtom (UsageArg u) continue_with = continue_with (UsageArg u) dsArgToAtom (TyArg t) continue_with = continue_with (TyArg t) dsArgToAtom (LitArg l) continue_with = continue_with (LitArg l) dsArgToAtom (VarArg arg) continue_with = dsExprToAtomGivenTy arg (coreExprType arg) continue_with @@ -299,7 +282,7 @@ dsExprToAtomGivenTy arg_expr arg_ty continue_with = newSysLocalDs arg_ty `thenDs` \ arg_id -> continue_with (VarArg arg_id) `thenDs` \ body -> returnDs ( - if isUnboxedType arg_ty + if isUnpointedType arg_ty then Case arg_expr (PrimAlts [] (BindDefault arg_id body)) else Let (NonRec arg_id arg_expr) body ) @@ -323,7 +306,7 @@ dsArgsToAtoms (arg:args) continue_with %************************************************************************ \begin{code} -type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar +type DsCoreArg = GenCoreArg CoreExpr{-NB!-} Unused mkAppDs :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr mkConDs :: Id -> [DsCoreArg] -> DsM CoreExpr @@ -344,7 +327,7 @@ mkPrimDs op args \begin{code} showForErr :: Outputable a => a -> String -- Boring but useful -showForErr thing = show (ppr PprQuote thing) +showForErr thing = showSDoc (ppr thing) mkErrorAppDs :: Id -- The error function -> Type -- Type to which it should be applied @@ -354,10 +337,10 @@ mkErrorAppDs :: Id -- The error function mkErrorAppDs err_id ty msg = getSrcLocDs `thenDs` \ src_loc -> let - full_msg = show (hcat [ppr (PprForUser opt_PprUserLength) src_loc, text "|", text msg]) + full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg]) msg_lit = NoRepStr (_PK_ full_msg) in - returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit]) + returnDs (mkApp (Var err_id) [ty] [LitArg msg_lit]) \end{code} %************************************************************************ @@ -410,7 +393,7 @@ mkSelectorBinds pat val_expr is_var_pat (VarPat v) = True is_var_pat other = False -- Even wild-card patterns aren't acceptable - pat_string = show (ppr (PprForUser opt_PprUserLength) pat) + pat_string = showSDoc (ppr pat) \end{code} @@ -441,7 +424,6 @@ mkTupleExpr :: [Id] -> CoreExpr mkTupleExpr [] = Con unitDataCon [] mkTupleExpr [id] = Var id mkTupleExpr ids = mkCon (tupleCon (length ids)) - [{-usages-}] (map idType ids) [ VarArg i | i <- ids ] \end{code} @@ -538,7 +520,7 @@ mkFailurePair :: Type -- Result type of the whole case expression CoreExpr) -- Either the fail variable, or fail variable -- applied to unit tuple mkFailurePair ty - | isUnboxedType ty + | isUnpointedType ty = newFailLocalDs (voidTy `mkFunTy` ty) `thenDs` \ fail_fun_var -> newSysLocalDs voidTy `thenDs` \ fail_fun_arg -> returnDs (\ body -> diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index ee9e8aa840..55a94542a9 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -5,50 +5,39 @@ \section[Main_match]{The @match@ function} \begin{code} -#include "HsVersions.h" +module Match ( match, matchExport, matchWrapper, matchSimply ) where -module Match ( matchExport, match, matchWrapper, matchSimply ) where +#include "HsVersions.h" -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons - -- and to break dsExpr/dsBinds-ish loop -#else import {-# SOURCE #-} DsExpr ( dsExpr ) import {-# SOURCE #-} DsBinds ( dsBinds ) -#endif import CmdLineOpts ( opt_WarnIncompletePatterns, opt_WarnOverlappingPatterns, opt_PprUserLength,opt_WarnSimplePatterns ) import HsSyn -import TcHsSyn ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedMatch), - SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) ) +import TcHsSyn ( TypecheckedPat, TypecheckedMatch, + TypecheckedHsBinds, TypecheckedHsExpr ) import DsHsSyn ( outPatType, collectTypedPatBinders ) -import Check ( check, SYN_IE(ExhaustivePat), SYN_IE(WarningPat), BoxedString ) +import Check ( check, ExhaustivePat, WarningPat, BoxedString ) import CoreSyn import CoreUtils ( coreExprType ) import DsMonad import DsGRHSs ( dsGRHSs ) import DsUtils -import ErrUtils ( SYN_IE(Warning) ) -import FieldLabel ( FieldLabel {- Eq instance -} ) import Id ( idType, dataConFieldLabels, dataConArgTys, recordSelectorFieldLabel, - GenId{-instance-}, SYN_IE(Id) + Id ) import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals ) import Name ( Name {--O only-} ) -import Outputable ( PprStyle(..), Outputable(..), pprQuote ) import PprType ( GenType{-instance-}, GenTyVar{-ditto-} ) -import Pretty import PrelVals ( pAT_ERROR_ID ) -import SrcLoc ( noSrcLoc, SrcLoc ) -import Type ( isPrimType, eqTy, getAppDataTyConExpandingDicts, - instantiateTauTy, SYN_IE(Type) +import Type ( isUnpointedType, splitAlgTyConApp, + instantiateTauTy, Type ) -import TyVar ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) ) +import TyVar ( TyVar ) import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy, addrPrimTy, wordPrimTy ) @@ -58,9 +47,8 @@ import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, doubleDataCon, stringTy, addrTy, addrDataCon, wordTy, wordDataCon ) -import Unique ( Unique{-instance Eq-} ) import UniqSet -import Util ( panic, pprPanic, assertPanic ) +import Outputable \end{code} This function is a wrapper of @match@, it must be called from all the parts where @@ -111,64 +99,64 @@ The next two functions creates the warning message. dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn where - warn sty | length qs > maximum_output = - hang (pp_context sty ctx (ptext SLIT("are overlapped"))) - 12 ((vcat $ map (ppr_eqn kind sty) (take maximum_output qs)) + warn | length qs > maximum_output + = hang (pp_context ctx (ptext SLIT("are overlapped"))) + 12 ((vcat $ map (ppr_eqn kind) (take maximum_output qs)) $$ ptext SLIT("...")) - warn sty = - hang (pp_context sty ctx (ptext SLIT("are overlapped"))) - 12 (vcat $ map (ppr_eqn kind sty) qs) + | otherwise + = hang (pp_context ctx (ptext SLIT("are overlapped"))) + 12 (vcat $ map (ppr_eqn kind) qs) dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn where - warn sty | length pats > maximum_output = - hang (pp_context sty ctx (ptext SLIT("are non-exhaustive"))) + warn | length pats > maximum_output + = hang (pp_context ctx (ptext SLIT("are non-exhaustive"))) 12 (hang (ptext SLIT("Patterns not recognized:")) - 4 ((vcat $ map (ppr_incomplete_pats kind sty) (take maximum_output pats)) + 4 ((vcat $ map (ppr_incomplete_pats kind) (take maximum_output pats)) $$ ptext SLIT("..."))) - warn sty = - hang (pp_context sty ctx (ptext SLIT("are non-exhaustive"))) + | otherwise + = hang (pp_context ctx (ptext SLIT("are non-exhaustive"))) 12 (hang (ptext SLIT("Patterns not recognized:")) - 4 (vcat $ map (ppr_incomplete_pats kind sty) pats)) + 4 (vcat $ map (ppr_incomplete_pats kind) pats)) -pp_context sty NoMatchContext msg = ptext SLIT("Warning: Some match(es)") <+> msg +pp_context NoMatchContext msg = ptext SLIT("Some match(es)") <+> msg -pp_context sty (DsMatchContext kind pats loc) msg - = hang (hcat [ppr (PprForUser opt_PprUserLength) loc, ptext SLIT(": ")]) +pp_context (DsMatchContext kind pats loc) msg + = hang (hcat [ppr loc, ptext SLIT(": ")]) 4 (hang message 4 (pp_match kind pats)) where - message = ptext SLIT("Warning: Pattern match(es)") <+> msg + message = ptext SLIT("Pattern match(es)") <+> msg pp_match (FunMatch fun) pats - = hsep [ptext SLIT("in the definition of function"), ppr sty fun] + = hsep [ptext SLIT("in the definition of function"), quotes (ppr fun)] pp_match CaseMatch pats = hang (ptext SLIT("in a group of case alternatives beginning:")) - 4 (ppr_pats sty pats) + 4 (ppr_pats pats) pp_match PatBindMatch pats = hang (ptext SLIT("in a pattern binding:")) - 4 (ppr_pats sty pats) + 4 (ppr_pats pats) pp_match LambdaMatch pats = hang (ptext SLIT("in a lambda abstraction:")) - 4 (ppr_pats sty pats) + 4 (ppr_pats pats) pp_match DoBindMatch pats = hang (ptext SLIT("in a `do' pattern binding:")) - 4 (ppr_pats sty pats) + 4 (ppr_pats pats) pp_match ListCompMatch pats = hang (ptext SLIT("in a `list comprension' pattern binding:")) - 4 (ppr_pats sty pats) + 4 (ppr_pats pats) pp_match LetMatch pats = hang (ptext SLIT("in a `let' pattern binding:")) - 4 (ppr_pats sty pats) + 4 (ppr_pats pats) -ppr_pats sty pats = pprQuote sty $ \ sty -> sep (map (ppr sty) pats) +ppr_pats pats = sep (map ppr pats) separator (FunMatch _) = SLIT("=") separator (CaseMatch) = SLIT("->") @@ -178,19 +166,17 @@ separator (DoBindMatch) = SLIT("<-") separator (ListCompMatch) = SLIT("<-") separator (LetMatch) = SLIT("=") -ppr_shadow_pats kind sty pats = pprQuote sty $ \ sty -> - sep [sep (map (ppr sty) pats), ptext (separator kind), ptext SLIT("...")] +ppr_shadow_pats kind pats = sep [ppr_pats pats, ptext (separator kind), ptext SLIT("...")] -ppr_incomplete_pats kind sty (pats,[]) = pprQuote sty $ \ sty -> - sep [sep (map (ppr sty) pats)] -ppr_incomplete_pats kind sty (pats,constraints) = pprQuote sty $ \ sty -> - sep [sep (map (ppr sty) pats), ptext SLIT("with"), - sep (map (ppr_constraint sty) constraints)] +ppr_incomplete_pats kind (pats,[]) = ppr_pats pats +ppr_incomplete_pats kind (pats,constraints) = + sep [ppr_pats pats, ptext SLIT("with"), + sep (map ppr_constraint constraints)] -ppr_constraint sty (var,pats) = sep [ppr sty var, ptext SLIT("`not_elem`"),ppr sty pats] +ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`not_elem`"), ppr pats] -ppr_eqn kind sty (EqnInfo _ _ pats _) = ppr_shadow_pats kind sty pats +ppr_eqn kind (EqnInfo _ _ pats _) = ppr_shadow_pats kind pats \end{code} @@ -461,7 +447,7 @@ tidy1 v (RecPat con_id pat_ty rpats) match_result pats = map mk_pat tagged_arg_tys -- Boring stuff to find the arg-tys of the constructor - (_, inst_tys, _) = getAppDataTyConExpandingDicts pat_ty + (_, inst_tys, _) = splitAlgTyConApp pat_ty con_arg_tys' = dataConArgTys con_id inst_tys tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels con_id) @@ -507,14 +493,14 @@ tidy1 v (DictPat dicts methods) match_result -- LitPats: the desugarer only sees these at well-known types tidy1 v pat@(LitPat lit lit_ty) match_result - | isPrimType lit_ty + | isUnpointedType lit_ty = returnDs (pat, match_result) - | lit_ty `eqTy` charTy + | lit_ty == charTy = returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy], match_result) - | otherwise = pprPanic "tidy1:LitPat:" (ppr PprDebug pat) + | otherwise = pprPanic "tidy1:LitPat:" (ppr pat) where mk_char (HsChar c) = HsCharPrim c @@ -525,12 +511,12 @@ tidy1 v pat@(NPat lit lit_ty _) match_result = returnDs (better_pat, match_result) where better_pat - | lit_ty `eqTy` charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy] - | lit_ty `eqTy` intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy] - | lit_ty `eqTy` wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy] - | lit_ty `eqTy` addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy] - | lit_ty `eqTy` floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy] - | lit_ty `eqTy` doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy] + | lit_ty == charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy] + | lit_ty == intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy] + | lit_ty == wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy] + | lit_ty == addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy] + | lit_ty == floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy] + | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy] -- Convert the literal pattern "" to the constructor pattern []. | null_str_lit lit = ConPat nilDataCon lit_ty [] @@ -741,7 +727,7 @@ matchWrapper kind [(PatMatch (WildPat ty) match)] error_string returnDs (var:vars, core_expr) matchWrapper kind [(GRHSMatch - (GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string + (GRHSsAndBindsOut [GRHS [] expr _] binds _))] error_string = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds -> dsExpr expr `thenDs` \ core_expr -> returnDs ([], mkCoLetsAny core_binds core_expr) diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs index 280103b056..152d082050 100644 --- a/ghc/compiler/deSugar/MatchCon.lhs +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -4,16 +4,11 @@ \section[MatchCon]{Pattern-matching constructors} \begin{code} -#include "HsVersions.h" - module MatchCon ( matchConFamily ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(DsLoop) ( match ) -- break match-ish loop -#else -import {-# SOURCE #-} Match -#endif +#include "HsVersions.h" + +import {-# SOURCE #-} Match ( match ) import HsSyn ( OutPat(..), HsLit, HsExpr ) import DsHsSyn ( outPatType ) @@ -21,7 +16,7 @@ import DsHsSyn ( outPatType ) import DsMonad import DsUtils -import Id ( GenId{-instances-}, SYN_IE(Id) ) +import Id ( GenId{-instances-}, Id ) import Util ( panic, assertPanic ) \end{code} diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index 8b40044a3d..b3e645d4a1 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -4,32 +4,27 @@ \section[MatchLit]{Pattern-matching literal patterns} \begin{code} -#include "HsVersions.h" - module MatchLit ( matchLiterals ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(DsLoop) -- break match-ish and dsExpr-ish loops -#else -import {-# SOURCE #-} Match +#include "HsVersions.h" + +import {-# SOURCE #-} Match ( match ) import {-# SOURCE #-} DsExpr ( dsExpr ) -#endif import HsSyn ( HsLit(..), OutPat(..), HsExpr(..), Fixity, Match, HsBinds, Stmt(..), DoOrListComp, HsType, ArithSeqInfo ) -import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds), - SYN_IE(TypecheckedPat) +import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, + TypecheckedPat ) -import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding), GenCoreExpr(..), GenCoreBinding(..) ) -import Id ( GenId {- instance Eq -}, SYN_IE(Id) ) +import CoreSyn ( CoreExpr, CoreBinding, GenCoreExpr(..), GenCoreBinding(..) ) +import Id ( GenId {- instance Eq -}, Id ) import DsMonad import DsUtils import Literal ( mkMachInt, Literal(..) ) import Maybes ( catMaybes ) -import Type ( isPrimType, SYN_IE(Type) ) +import Type ( isUnpointedType, Type ) import Util ( panic, assertPanic ) \end{code} @@ -79,7 +74,7 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal lit_t mk_core_lit ty (HsStringPrim s) = MachStr s mk_core_lit ty (HsFloatPrim f) = MachFloat f mk_core_lit ty (HsDoublePrim d) = MachDouble d - mk_core_lit ty (HsLitLit s) = ASSERT(isPrimType ty) + mk_core_lit ty (HsLitLit s) = ASSERT(isUnpointedType ty) MachLitLit s (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; typePrimRep???") mk_core_lit ty other = panic "matchLiterals:mk_core_lit:unhandled" \end{code} diff --git a/ghc/compiler/hsSyn/HsBasic.lhs b/ghc/compiler/hsSyn/HsBasic.lhs index afe2516b83..73e408671b 100644 --- a/ghc/compiler/hsSyn/HsBasic.lhs +++ b/ghc/compiler/hsSyn/HsBasic.lhs @@ -4,16 +4,12 @@ \section[HsLit]{Abstract syntax: source-language literals} \begin{code} -#include "HsVersions.h" - module HsBasic where -IMP_Ubiq(){-uitous-} - -IMPORT_1_3(Ratio(Rational)) +#include "HsVersions.h" -import Pretty import Outputable +import Ratio ( Rational ) \end{code} %************************************************************************ @@ -60,16 +56,16 @@ negLiteral (HsFrac f) = HsFrac (-f) \begin{code} instance Outputable HsLit where - ppr sty (HsChar c) = text (show c) - ppr sty (HsCharPrim c) = (<>) (text (show c)) (char '#') - ppr sty (HsString s) = text (show s) - ppr sty (HsStringPrim s) = (<>) (text (show s)) (char '#') - ppr sty (HsInt i) = integer i - ppr sty (HsFrac f) = rational f - ppr sty (HsFloatPrim f) = (<>) (rational f) (char '#') - ppr sty (HsDoublePrim d) = (<>) (rational d) (text "##") - ppr sty (HsIntPrim i) = (<>) (integer i) (char '#') - ppr sty (HsLitLit s) = hcat [text "``", ptext s, text "''"] + ppr (HsChar c) = text (show c) + ppr (HsCharPrim c) = (<>) (text (show c)) (char '#') + ppr (HsString s) = text (show s) + ppr (HsStringPrim s) = (<>) (text (show s)) (char '#') + ppr (HsInt i) = integer i + ppr (HsFrac f) = rational f + ppr (HsFloatPrim f) = (<>) (rational f) (char '#') + ppr (HsDoublePrim d) = (<>) (rational d) (text "##") + ppr (HsIntPrim i) = (<>) (integer i) (char '#') + ppr (HsLitLit s) = hcat [text "``", ptext s, text "''"] \end{code} diff --git a/ghc/compiler/hsSyn/HsBinds.hi-boot b/ghc/compiler/hsSyn/HsBinds.hi-boot index dd00458d45..f8645b236a 100644 --- a/ghc/compiler/hsSyn/HsBinds.hi-boot +++ b/ghc/compiler/hsSyn/HsBinds.hi-boot @@ -1,7 +1,7 @@ -_interface_ HsBinds 1 +d_interface_ HsBinds 1 _exports_ HsBinds HsBinds nullBinds; _instances_ _declarations_ -1 data HsBinds a b c d ; -1 nullBinds _:_ _forall_ [a b c d] => HsBinds.HsBinds a b c d -> PrelBase.Bool ;; +1 data HsBinds f i p ; +1 nullBinds _:_ _forall_ [f i p] => HsBinds.HsBinds f i p -> PrelBase.Bool ;; diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index c298d940d8..d020b76baf 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -6,42 +6,28 @@ Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@. \begin{code} -#include "HsVersions.h" - module HsBinds where -IMP_Ubiq() +#include "HsVersions.h" --- friends: -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(HsLoop) ( pprMatches, pprGRHSsAndBinds, - Match, GRHSsAndBinds, - pprExpr, HsExpr ) -#endif +import {-# SOURCE #-} HsExpr ( pprExpr, HsExpr ) +import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSsAndBinds, GRHSsAndBinds ) +-- friends: import HsPragmas ( GenPragmas, ClassOpPragmas ) import HsTypes ( HsType ) -import CoreSyn ( SYN_IE(CoreExpr) ) +import CoreSyn ( CoreExpr ) +import PprCore () -- Instances for Outputable --others: -import Id ( SYN_IE(DictVar), SYN_IE(Id), GenId ) +import Id ( DictVar, Id, GenId ) import Name ( OccName, NamedThing(..) ) -import Outputable ( interpp'SP, ifnotPprForUser, pprQuote, - Outputable(..){-instance * (,)-} - ) -import PprCore --( GenCoreExpr {- instance Outputable -} ) -import PprType ( GenTyVar {- instance Outputable -} ) -import Pretty +import BasicTypes ( RecFlag(..) ) +import Outputable import Bag -import SrcLoc ( SrcLoc{-instances-} ) -import TyVar ( GenTyVar{-instances-} ) -import Unique ( Unique {- instance Eq -} ) - -#if __GLASGOW_HASKELL__ >= 202 -import {-# SOURCE #-} HsExpr ( pprExpr, HsExpr ) -import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSsAndBinds, GRHSsAndBinds ) -#endif - +import SrcLoc ( SrcLoc ) +import Type ( GenType ) +import TyVar ( GenTyVar ) \end{code} %************************************************************************ @@ -59,23 +45,19 @@ grammar. Collections of bindings, created by dependency analysis and translation: \begin{code} -data HsBinds tyvar uvar id pat -- binders and bindees +data HsBinds flexi id pat -- binders and bindees = EmptyBinds - | ThenBinds (HsBinds tyvar uvar id pat) - (HsBinds tyvar uvar id pat) + | ThenBinds (HsBinds flexi id pat) + (HsBinds flexi id pat) - | MonoBind (MonoBinds tyvar uvar id pat) + | MonoBind (MonoBinds flexi id pat) [Sig id] -- Empty on typechecker output RecFlag - -type RecFlag = Bool -recursive = True -nonRecursive = False \end{code} \begin{code} -nullBinds :: HsBinds tyvar uvar id pat -> Bool +nullBinds :: HsBinds flexi id pat -> Bool nullBinds EmptyBinds = True nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2 @@ -83,26 +65,22 @@ nullBinds (MonoBind b _ _) = nullMonoBinds b \end{code} \begin{code} -instance (Outputable pat, NamedThing id, Outputable id, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (HsBinds tyvar uvar id pat) where - - ppr sty binds = pprQuote sty (\ sty -> ppr_binds sty binds) - -ppr_binds sty EmptyBinds = empty -ppr_binds sty (ThenBinds binds1 binds2) - = ($$) (ppr_binds sty binds1) (ppr_binds sty binds2) -ppr_binds sty (MonoBind bind sigs is_rec) - = vcat [ - ifnotPprForUser sty (ptext rec_str), - if null sigs - then empty - else vcat (map (ppr sty) sigs), - ppr sty bind +instance (Outputable pat, NamedThing id, Outputable id) => + Outputable (HsBinds flexi id pat) where + ppr binds = ppr_binds binds + +ppr_binds EmptyBinds = empty +ppr_binds (ThenBinds binds1 binds2) + = ($$) (ppr_binds binds1) (ppr_binds binds2) +ppr_binds (MonoBind bind sigs is_rec) + = vcat [ifNotPprForUser (ptext rec_str), + vcat (map ppr sigs), + ppr bind ] where - rec_str | is_rec = SLIT("{- rec -}") - | otherwise = SLIT("{- nonrec -}") + rec_str = case is_rec of + Recursive -> SLIT("{- rec -}") + NonRecursive -> SLIT("{- nonrec -}") \end{code} %************************************************************************ @@ -114,32 +92,32 @@ ppr_binds sty (MonoBind bind sigs is_rec) Global bindings (where clauses) \begin{code} -data MonoBinds tyvar uvar id pat +data MonoBinds flexi id pat = EmptyMonoBinds - | AndMonoBinds (MonoBinds tyvar uvar id pat) - (MonoBinds tyvar uvar id pat) + | AndMonoBinds (MonoBinds flexi id pat) + (MonoBinds flexi id pat) | PatMonoBind pat - (GRHSsAndBinds tyvar uvar id pat) + (GRHSsAndBinds flexi id pat) SrcLoc | FunMonoBind id Bool -- True => infix declaration - [Match tyvar uvar id pat] -- must have at least one Match + [Match flexi id pat] -- must have at least one Match SrcLoc | VarMonoBind id -- TRANSLATION - (HsExpr tyvar uvar id pat) + (HsExpr flexi id pat) | CoreMonoBind id -- TRANSLATION CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types! | AbsBinds -- Binds abstraction; TRANSLATION - [tyvar] -- Type variables + [GenTyVar flexi] -- Type variables [id] -- Dicts - [([tyvar], id, id)] -- (type variables, polymorphic, momonmorphic) triples - (MonoBinds tyvar uvar id pat) -- The "business end" + [([GenTyVar flexi], id, id)] -- (type variables, polymorphic, momonmorphic) triples + (MonoBinds flexi id pat) -- The "business end" -- Creates bindings for *new* (polymorphic, overloaded) locals -- in terms of *old* (monomorphic, non-overloaded) ones. @@ -174,46 +152,45 @@ So the desugarer tries to do a better job: in (fm,gm) \begin{code} -nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool +nullMonoBinds :: MonoBinds flexi id pat -> Bool nullMonoBinds EmptyMonoBinds = True nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2 nullMonoBinds other_monobind = False -andMonoBinds :: [MonoBinds tyvar uvar id pat] -> MonoBinds tyvar uvar id pat +andMonoBinds :: [MonoBinds flexi id pat] -> MonoBinds flexi id pat andMonoBinds binds = foldr AndMonoBinds EmptyMonoBinds binds \end{code} \begin{code} -instance (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (MonoBinds tyvar uvar id pat) where - ppr sty mbind = pprQuote sty (\ sty -> ppr_monobind sty mbind) +instance (NamedThing id, Outputable id, Outputable pat) => + Outputable (MonoBinds flexi id pat) where + ppr mbind = ppr_monobind mbind -ppr_monobind sty EmptyMonoBinds = empty -ppr_monobind sty (AndMonoBinds binds1 binds2) - = ($$) (ppr_monobind sty binds1) (ppr_monobind sty binds2) +ppr_monobind EmptyMonoBinds = empty +ppr_monobind (AndMonoBinds binds1 binds2) + = ($$) (ppr_monobind binds1) (ppr_monobind binds2) -ppr_monobind sty (PatMonoBind pat grhss_n_binds locn) - = sep [ppr sty pat, nest 4 (pprGRHSsAndBinds sty False grhss_n_binds)] +ppr_monobind (PatMonoBind pat grhss_n_binds locn) + = sep [ppr pat, nest 4 (pprGRHSsAndBinds False grhss_n_binds)] -ppr_monobind sty (FunMonoBind fun inf matches locn) - = pprMatches sty (False, ppr sty fun) matches +ppr_monobind (FunMonoBind fun inf matches locn) + = pprMatches (False, ppr fun) matches -- ToDo: print infix if appropriate -ppr_monobind sty (VarMonoBind name expr) - = sep [ppr sty name <+> equals, nest 4 (pprExpr sty expr)] +ppr_monobind (VarMonoBind name expr) + = sep [ppr name <+> equals, nest 4 (pprExpr expr)] -ppr_monobind sty (CoreMonoBind name expr) - = sep [ppr sty name <+> equals, nest 4 (ppr sty expr)] +ppr_monobind (CoreMonoBind name expr) + = sep [ppr name <+> equals, nest 4 (ppr expr)] -ppr_monobind sty (AbsBinds tyvars dictvars exports val_binds) +ppr_monobind (AbsBinds tyvars dictvars exports val_binds) = ($$) (sep [ptext SLIT("AbsBinds"), - brackets (interpp'SP sty tyvars), - brackets (interpp'SP sty dictvars), - brackets (interpp'SP sty exports)]) - (nest 4 (ppr sty val_binds)) + brackets (interpp'SP tyvars), + brackets (interpp'SP dictvars), + brackets (interpp'SP exports)]) + (nest 4 (ppr val_binds)) \end{code} %************************************************************************ @@ -254,29 +231,29 @@ data Sig name \begin{code} instance (NamedThing name, Outputable name) => Outputable (Sig name) where - ppr sty sig = pprQuote sty (\ sty -> ppr_sig sty sig) + ppr sig = ppr_sig sig -ppr_sig sty (Sig var ty _) - = sep [ppr sty var <+> ptext SLIT("::"), - nest 4 (ppr sty ty)] +ppr_sig (Sig var ty _) + = sep [ppr var <+> ptext SLIT("::"), + nest 4 (ppr ty)] -ppr_sig sty (ClassOpSig var _ ty _) - = sep [ppr sty (getOccName var) <+> ptext SLIT("::"), - nest 4 (ppr sty ty)] +ppr_sig (ClassOpSig var _ ty _) + = sep [ppr (getOccName var) <+> ptext SLIT("::"), + nest 4 (ppr ty)] -ppr_sig sty (SpecSig var ty using _) - = sep [ hsep [text "{-# SPECIALIZE", ppr sty var, ptext SLIT("::")], - nest 4 (hsep [ppr sty ty, pp_using using, text "#-}"]) +ppr_sig (SpecSig var ty using _) + = sep [ hsep [text "{-# SPECIALIZE", ppr var, ptext SLIT("::")], + nest 4 (hsep [ppr ty, pp_using using, text "#-}"]) ] where pp_using Nothing = empty - pp_using (Just me) = hsep [char '=', ppr sty me] + pp_using (Just me) = hsep [char '=', ppr me] -ppr_sig sty (InlineSig var _) - = hsep [text "{-# INLINE", ppr sty var, text "#-}"] +ppr_sig (InlineSig var _) + = hsep [text "{-# INLINE", ppr var, text "#-}"] -ppr_sig sty (MagicUnfoldingSig var str _) - = hsep [text "{-# MAGIC_UNFOLDING", ppr sty var, ptext str, text "#-}"] +ppr_sig (MagicUnfoldingSig var str _) + = hsep [text "{-# MAGIC_UNFOLDING", ppr var, ptext str, text "#-}"] \end{code} diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 6a37f2d147..05226a126e 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -11,15 +11,13 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and @TyVars@ as well. Currently trying the former... MEGA SIGH. \begin{code} -#include "HsVersions.h" - module HsCore ( UfExpr(..), UfAlts(..), UfBinder(..), UfCoercion(..), UfDefault(..), UfBinding(..), UfArg(..), UfPrimOp(..) ) where -IMP_Ubiq() +#include "HsVersions.h" -- friends: import HsTypes ( HsType, pprParendHsType ) @@ -29,12 +27,9 @@ import Type ( GenType {- instance Outputable -} ) -- others: import Literal ( Literal ) -import Outputable ( Outputable(..) ) -import Pretty import Util ( panic ) -#if __GLASGOW_HASKELL__ >= 202 import CostCentre -#endif +import Outputable \end{code} %************************************************************************ @@ -86,13 +81,11 @@ data UfBinding name data UfBinder name = UfValBinder name (HsType name) | UfTyBinder name Kind - | UfUsageBinder name data UfArg name = UfVarArg name | UfLitArg Literal | UfTyArg (HsType name) - | UfUsageArg name \end{code} %************************************************************************ @@ -103,74 +96,72 @@ data UfArg name \begin{code} instance Outputable name => Outputable (UfExpr name) where - ppr sty (UfVar v) = ppr sty v - ppr sty (UfLit l) = ppr sty l + ppr (UfVar v) = ppr v + ppr (UfLit l) = ppr l - ppr sty (UfCon c as) - = hsep [text "UfCon", ppr sty c, ppr sty as, char ')'] - ppr sty (UfPrim o as) - = hsep [text "UfPrim", ppr sty o, ppr sty as, char ')'] + ppr (UfCon c as) + = hsep [text "UfCon", ppr c, ppr as, char ')'] + ppr (UfPrim o as) + = hsep [text "UfPrim", ppr o, ppr as, char ')'] - ppr sty (UfLam b body) - = hsep [char '\\', ppr sty b, ptext SLIT("->"), ppr sty body] + ppr (UfLam b body) + = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body] - ppr sty (UfApp fun (UfTyArg ty)) - = hsep [ppr sty fun, char '@', pprParendHsType sty ty] + ppr (UfApp fun (UfTyArg ty)) + = hsep [ppr fun, char '@', pprParendHsType ty] - ppr sty (UfApp fun (UfLitArg lit)) - = hsep [ppr sty fun, ppr sty lit] + ppr (UfApp fun (UfLitArg lit)) + = hsep [ppr fun, ppr lit] - ppr sty (UfApp fun (UfVarArg var)) - = hsep [ppr sty fun, ppr sty var] + ppr (UfApp fun (UfVarArg var)) + = hsep [ppr fun, ppr var] - ppr sty (UfCase scrut alts) - = hsep [ptext SLIT("case"), ppr sty scrut, ptext SLIT("of {"), pp_alts alts, char '}'] + ppr (UfCase scrut alts) + = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of {"), pp_alts alts, char '}'] where pp_alts (UfAlgAlts alts deflt) = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt] where - pp_alt (c,bs,rhs) = hsep [ppr sty c, ppr sty bs, ppr_arrow, ppr sty rhs] + pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs] pp_alts (UfPrimAlts alts deflt) = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt] where - pp_alt (l,rhs) = hsep [ppr sty l, ppr_arrow, ppr sty rhs] + pp_alt (l,rhs) = hsep [ppr l, ppr_arrow, ppr rhs] pp_deflt UfNoDefault = empty - pp_deflt (UfBindDefault b rhs) = hsep [ppr sty b, ppr_arrow, ppr sty rhs] + pp_deflt (UfBindDefault b rhs) = hsep [ppr b, ppr_arrow, ppr rhs] ppr_arrow = ptext SLIT("->") - ppr sty (UfLet (UfNonRec b rhs) body) - = hsep [ptext SLIT("let"), ppr sty b, equals, ppr sty rhs, ptext SLIT("in"), ppr sty body] - ppr sty (UfLet (UfRec pairs) body) - = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr sty body] + ppr (UfLet (UfNonRec b rhs) body) + = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body] + ppr (UfLet (UfRec pairs) body) + = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body] where - pp_pair (b,rhs) = hsep [ppr sty b, equals, ppr sty rhs] + pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs] - ppr sty (UfSCC uf_cc body) - = hsep [ptext SLIT("_scc_ <cost-centre[ToDo]>"), ppr sty body] + ppr (UfSCC uf_cc body) + = hsep [ptext SLIT("_scc_ <cost-centre[ToDo]>"), ppr body] instance Outputable name => Outputable (UfPrimOp name) where - ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty) + ppr (UfCCallOp str is_casm can_gc arg_tys result_ty) = let before = ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ ")) after = if is_casm then text "'' " else space in hcat [before, ptext str, after, - brackets (ppr sty arg_tys), space, ppr sty result_ty] + brackets (ppr arg_tys), space, ppr result_ty] - ppr sty (UfOtherOp op) - = ppr sty op + ppr (UfOtherOp op) + = ppr op instance Outputable name => Outputable (UfArg name) where - ppr sty (UfVarArg v) = ppr sty v - ppr sty (UfLitArg l) = ppr sty l - ppr sty (UfTyArg ty) = pprParendHsType sty ty - ppr sty (UfUsageArg name) = ppr sty name + ppr (UfVarArg v) = ppr v + ppr (UfLitArg l) = ppr l + ppr (UfTyArg ty) = pprParendHsType ty instance Outputable name => Outputable (UfBinder name) where - ppr sty (UfValBinder name ty) = hsep [ppr sty name, ptext SLIT("::"), ppr sty ty] - ppr sty (UfTyBinder name kind) = hsep [ppr sty name, ptext SLIT("::"), ppr sty kind] - ppr sty (UfUsageBinder name) = ppr sty name + ppr (UfValBinder name ty) = hsep [ppr name, ptext SLIT("::"), ppr ty] + ppr (UfTyBinder name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind] \end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index d4c904f4e9..f466d59002 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -7,11 +7,9 @@ Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@, @InstDecl@, @DefaultDecl@. \begin{code} -#include "HsVersions.h" - module HsDecls where -IMP_Ubiq() +#include "HsVersions.h" -- friends: import HsBinds ( HsBinds, MonoBinds, Sig, nullMonoBinds ) @@ -19,17 +17,14 @@ import HsPragmas ( DataPragmas, ClassPragmas, InstancePragmas, ClassOpPragmas ) import HsTypes -import IdInfo -import SpecEnv ( SpecEnv ) import HsCore ( UfExpr ) import BasicTypes ( Fixity, NewOrData(..) ) +import IdInfo ( ArgUsageInfo, FBTypeInfo, ArityInfo, UpdateInfo ) +import Demand ( Demand ) -- others: import Name ( getOccName, OccName, NamedThing(..) ) -import Outputable ( interppSP, interpp'SP, - PprStyle(..), Outputable(..){-instance * []-} - ) -import Pretty +import Outputable import SrcLoc ( SrcLoc ) import Util \end{code} @@ -42,52 +37,58 @@ import Util %************************************************************************ \begin{code} -data HsDecl tyvar uvar name pat +data HsDecl flexi name pat = TyD (TyDecl name) - | ClD (ClassDecl tyvar uvar name pat) - | InstD (InstDecl tyvar uvar name pat) + | ClD (ClassDecl flexi name pat) + | InstD (InstDecl flexi name pat) | DefD (DefaultDecl name) - | ValD (HsBinds tyvar uvar name pat) + | ValD (HsBinds flexi name pat) | SigD (IfaceSig name) \end{code} \begin{code} #ifdef DEBUG -hsDeclName :: (NamedThing name, Outputable name, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => HsDecl tyvar uvar name pat -> name +hsDeclName :: (NamedThing name, Outputable name, Outputable pat) + => HsDecl flexi name pat -> name #endif hsDeclName (TyD (TyData _ _ name _ _ _ _ _)) = name hsDeclName (TyD (TySynonym name _ _ _)) = name -hsDeclName (ClD (ClassDecl _ name _ _ _ _ _)) = name +hsDeclName (ClD (ClassDecl _ name _ _ _ _ _ _ _)) = name hsDeclName (SigD (IfaceSig name _ _ _)) = name hsDeclName (InstD (InstDecl _ _ _ (Just name) _)) = name -- Others don't make sense #ifdef DEBUG -hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr PprDebug x) +hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x) #endif \end{code} \begin{code} -instance (NamedThing name, Outputable name, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => Outputable (HsDecl tyvar uvar name pat) where +instance (NamedThing name, Outputable name, Outputable pat) + => Outputable (HsDecl flexi name pat) where - ppr sty (TyD td) = ppr sty td - ppr sty (ClD cd) = ppr sty cd - ppr sty (SigD sig) = ppr sty sig - ppr sty (ValD binds) = ppr sty binds - ppr sty (DefD def) = ppr sty def - ppr sty (InstD inst) = ppr sty inst + ppr (TyD td) = ppr td + ppr (ClD cd) = ppr cd + ppr (SigD sig) = ppr sig + ppr (ValD binds) = ppr binds + ppr (DefD def) = ppr def + ppr (InstD inst) = ppr inst #ifdef DEBUG -instance (Ord3 name, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, - NamedThing name, Outputable name, Outputable pat) => - Ord3 (HsDecl tyvar uvar name pat) where +-- hsDeclName needs more context when DEBUG is on +instance (NamedThing name, Outputable name, Outputable pat, Eq name) + => Eq (HsDecl flex name pat) where + d1 == d2 = hsDeclName d1 == hsDeclName d2 + +instance (NamedThing name, Outputable name, Outputable pat, Ord name) + => Ord (HsDecl flex name pat) where + d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2 #else -instance (Ord3 name) => Ord3 (HsDecl tyvar uvar name pat) where +instance (Eq name) => Eq (HsDecl flex name pat) where + d1 == d2 = hsDeclName d1 == hsDeclName d2 + +instance (Ord name) => Ord (HsDecl flexi name pat) where + d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2 #endif - d1 `cmp` d2 = hsDeclName d1 `cmp` hsDeclName d2 \end{code} @@ -101,7 +102,7 @@ instance (Ord3 name) => Ord3 (HsDecl tyvar uvar name pat) where data FixityDecl name = FixityDecl name Fixity SrcLoc instance Outputable name => Outputable (FixityDecl name) where - ppr sty (FixityDecl name fixity loc) = sep [ppr sty fixity, ppr sty name] + ppr (FixityDecl name fixity loc) = sep [ppr fixity, ppr name] \end{code} @@ -136,40 +137,39 @@ data TyDecl name instance (NamedThing name, Outputable name) => Outputable (TyDecl name) where - ppr sty (TySynonym tycon tyvars mono_ty src_loc) - = hang (pp_decl_head sty SLIT("type") empty tycon tyvars) - 4 (ppr sty mono_ty) + ppr (TySynonym tycon tyvars mono_ty src_loc) + = hang (pp_decl_head SLIT("type") empty tycon tyvars) + 4 (ppr mono_ty) - ppr sty (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc) - = pp_tydecl sty - (pp_decl_head sty keyword (pp_context_and_arrow sty context) tycon tyvars) - (pp_condecls sty condecls) + ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc) + = pp_tydecl + (pp_decl_head keyword (pp_context_and_arrow context) tycon tyvars) + (pp_condecls condecls) derivings where keyword = case new_or_data of NewType -> SLIT("newtype") DataType -> SLIT("data") -pp_decl_head sty str pp_context tycon tyvars - = hsep [ptext str, pp_context, ppr sty tycon, - interppSP sty tyvars, ptext SLIT("=")] +pp_decl_head str pp_context tycon tyvars + = hsep [ptext str, pp_context, ppr tycon, + interppSP tyvars, ptext SLIT("=")] -pp_condecls sty [] = empty -- Curious! -pp_condecls sty (c:cs) - = sep (ppr sty c : map (\ c -> (<>) (ptext SLIT("| ")) (ppr sty c)) cs) +pp_condecls [] = empty -- Curious! +pp_condecls (c:cs) + = sep (ppr c : map (\ c -> (<>) (ptext SLIT("| ")) (ppr c)) cs) -pp_tydecl sty pp_head pp_decl_rhs derivings +pp_tydecl pp_head pp_decl_rhs derivings = hang pp_head 4 (sep [ pp_decl_rhs, - case (derivings, sty) of - (Nothing,_) -> empty - (_,PprInterface) -> empty -- No derivings in interfaces - (Just ds,_) -> hsep [ptext SLIT("deriving"), parens (interpp'SP sty ds)] + case derivings of + Nothing -> empty + Just ds -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)] ]) -pp_context_and_arrow :: Outputable name => PprStyle -> Context name -> Doc -pp_context_and_arrow sty [] = empty -pp_context_and_arrow sty theta = hsep [pprContext sty theta, ptext SLIT("=>")] +pp_context_and_arrow :: Outputable name => Context name -> SDoc +pp_context_and_arrow [] = empty +pp_context_and_arrow theta = hsep [pprContext theta, ptext SLIT("=>")] \end{code} A type for recording what types a datatype should be specialised to. @@ -185,8 +185,8 @@ data SpecDataSig name instance (NamedThing name, Outputable name) => Outputable (SpecDataSig name) where - ppr sty (SpecDataSig tycon ty _) - = hsep [text "{-# SPECIALIZE data", ppr sty ty, text "#-}"] + ppr (SpecDataSig tycon ty _) + = hsep [text "{-# SPECIALIZE data", ppr ty, text "#-}"] \end{code} %************************************************************************ @@ -223,27 +223,27 @@ data BangType name \begin{code} instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where - ppr sty (ConDecl con cxt con_details loc) - = pp_context_and_arrow sty cxt <+> ppr_con_details sty con con_details + ppr (ConDecl con cxt con_details loc) + = pp_context_and_arrow cxt <+> ppr_con_details con con_details -ppr_con_details sty con (InfixCon ty1 ty2) - = hsep [ppr_bang sty ty1, ppr sty con, ppr_bang sty ty2] +ppr_con_details con (InfixCon ty1 ty2) + = hsep [ppr_bang ty1, ppr con, ppr_bang ty2] -ppr_con_details sty con (VanillaCon tys) - = ppr sty con <+> hsep (map (ppr_bang sty) tys) +ppr_con_details con (VanillaCon tys) + = ppr con <+> hsep (map (ppr_bang) tys) -ppr_con_details sty con (NewCon ty) - = ppr sty con <+> pprParendHsType sty ty +ppr_con_details con (NewCon ty) + = ppr con <+> pprParendHsType ty -ppr_con_details sty con (RecCon fields) - = ppr sty con <+> braces (hsep (punctuate comma (map ppr_field fields))) +ppr_con_details con (RecCon fields) + = ppr con <+> braces (hsep (punctuate comma (map ppr_field fields))) where - ppr_field (ns, ty) = hsep (map (ppr sty) ns) <+> + ppr_field (ns, ty) = hsep (map (ppr) ns) <+> ptext SLIT("::") <+> - ppr_bang sty ty + ppr_bang ty -ppr_bang sty (Banged ty) = ptext SLIT("!") <> pprParendHsType sty ty -ppr_bang sty (Unbanged ty) = pprParendHsType sty ty +ppr_bang (Banged ty) = ptext SLIT("!") <> pprParendHsType ty +ppr_bang (Unbanged ty) = pprParendHsType ty \end{code} %************************************************************************ @@ -253,34 +253,35 @@ ppr_bang sty (Unbanged ty) = pprParendHsType sty ty %************************************************************************ \begin{code} -data ClassDecl tyvar uvar name pat +data ClassDecl flexi name pat = ClassDecl (Context name) -- context... name -- name of the class - (HsTyVar name) -- the class type variable + [HsTyVar name] -- the class type variables [Sig name] -- methods' signatures - (MonoBinds tyvar uvar name pat) -- default methods + (MonoBinds flexi name pat) -- default methods (ClassPragmas name) + name name -- The names of the tycon and datacon for this class + -- These are filled in by the renamer SrcLoc \end{code} \begin{code} -instance (NamedThing name, Outputable name, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => Outputable (ClassDecl tyvar uvar name pat) where +instance (NamedThing name, Outputable name, Outputable pat) + => Outputable (ClassDecl flexi name pat) where - ppr sty (ClassDecl context clas tyvar sigs methods pragmas src_loc) + ppr (ClassDecl context clas tyvars sigs methods pragmas _ _ src_loc) | null sigs -- No "where" part = top_matter | otherwise -- Laid out = sep [hsep [top_matter, ptext SLIT("where {")], nest 4 (vcat [sep (map ppr_sig sigs), - ppr sty methods, + ppr methods, char '}'])] where - top_matter = hsep [ptext SLIT("class"), pp_context_and_arrow sty context, - ppr sty clas, ppr sty tyvar] - ppr_sig sig = ppr sty sig <> semi + top_matter = hsep [ptext SLIT("class"), pp_context_and_arrow context, + ppr clas, hsep (map (ppr) tyvars)] + ppr_sig sig = ppr sig <> semi \end{code} %************************************************************************ @@ -290,12 +291,12 @@ instance (NamedThing name, Outputable name, Outputable pat, %************************************************************************ \begin{code} -data InstDecl tyvar uvar name pat +data InstDecl flexi name pat = InstDecl (HsType name) -- Context => Class Instance-type -- Using a polytype means that the renamer conveniently -- figures out the quantified type variables for us. - (MonoBinds tyvar uvar name pat) + (MonoBinds flexi name pat) [Sig name] -- User-supplied pragmatic info @@ -305,19 +306,17 @@ data InstDecl tyvar uvar name pat \end{code} \begin{code} -instance (NamedThing name, Outputable name, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => Outputable (InstDecl tyvar uvar name pat) where - - ppr sty (InstDecl inst_ty binds uprags dfun_name src_loc) - | case sty of { PprInterface -> True; other -> False} || - nullMonoBinds binds && null uprags - = hsep [ptext SLIT("instance"), ppr sty inst_ty] - - | otherwise - = vcat [hsep [ptext SLIT("instance"), ppr sty inst_ty, ptext SLIT("where")], - nest 4 (ppr sty uprags), - nest 4 (ppr sty binds) ] +instance (NamedThing name, Outputable name, Outputable pat) + => Outputable (InstDecl flexi name pat) where + + ppr (InstDecl inst_ty binds uprags dfun_name src_loc) + = getPprStyle $ \ sty -> + if ifaceStyle sty || (nullMonoBinds binds && null uprags) then + hsep [ptext SLIT("instance"), ppr inst_ty] + else + vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")], + nest 4 (ppr uprags), + nest 4 (ppr binds) ] \end{code} A type for recording what instances the user wants to specialise; @@ -332,8 +331,8 @@ data SpecInstSig name instance (NamedThing name, Outputable name) => Outputable (SpecInstSig name) where - ppr sty (SpecInstSig clas ty _) - = hsep [text "{-# SPECIALIZE instance", ppr sty clas, ppr sty ty, text "#-}"] + ppr (SpecInstSig clas ty _) + = hsep [text "{-# SPECIALIZE instance", ppr clas, ppr ty, text "#-}"] \end{code} %************************************************************************ @@ -354,8 +353,8 @@ data DefaultDecl name instance (NamedThing name, Outputable name) => Outputable (DefaultDecl name) where - ppr sty (DefaultDecl tys src_loc) - = (<>) (ptext SLIT("default ")) (parens (interpp'SP sty tys)) + ppr (DefaultDecl tys src_loc) + = ptext SLIT("default") <+> parens (interpp'SP tys) \end{code} %************************************************************************ @@ -372,9 +371,9 @@ data IfaceSig name SrcLoc instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where - ppr sty (IfaceSig var ty _ _) - = hang (hsep [ppr sty var, ptext SLIT("::")]) - 4 (ppr sty ty) + ppr (IfaceSig var ty _ _) + = hang (hsep [ppr var, ptext SLIT("::")]) + 4 (ppr ty) data HsIdInfo name = HsArity ArityInfo diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot b/ghc/compiler/hsSyn/HsExpr.hi-boot index 0398326f43..82447a0a2e 100644 --- a/ghc/compiler/hsSyn/HsExpr.hi-boot +++ b/ghc/compiler/hsSyn/HsExpr.hi-boot @@ -2,5 +2,5 @@ _interface_ HsExpr 1 _exports_ HsExpr HsExpr pprExpr; _declarations_ -1 data HsExpr a b c d; -1 pprExpr _:_ _forall_ [a b c d] {Name.NamedThing c, Outputable.Outputable c, Outputable.Outputable d, PrelBase.Eq a, Outputable.Outputable a, PrelBase.Eq b, Outputable.Outputable b} => Outputable.PprStyle -> HsExpr.HsExpr a b c d -> Pretty.Doc ;; +1 data HsExpr f i p; +1 pprExpr _:_ _forall_ [i p f] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr f i p -> Outputable.SDoc ;; diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 44b250bc06..85ea35a8f5 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -4,18 +4,12 @@ \section[HsExpr]{Abstract Haskell syntax: expressions} \begin{code} -#include "HsVersions.h" - module HsExpr where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -- friends: -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(HsLoop) ( pprMatches, pprMatch, Match ) -#else import {-# SOURCE #-} HsMatches ( pprMatches, pprMatch, Match ) -#endif import HsBinds ( HsBinds ) import HsBasic ( HsLit ) @@ -23,16 +17,11 @@ import BasicTypes ( Fixity(..), FixityDirection(..) ) import HsTypes ( HsType ) -- others: -import Id ( SYN_IE(DictVar), GenId, SYN_IE(Id) ) -import Outputable ( pprQuote, interppSP, interpp'SP, ifnotPprForUser, - PprStyle(..), userStyle, Outputable(..) ) -import PprType ( pprGenType, pprParendGenType, GenType{-instance-} ) -import Pretty +import Name ( NamedThing ) +import Id ( Id ) +import Outputable +import PprType ( pprGenType, pprParendGenType, GenType, GenTyVar ) import SrcLoc ( SrcLoc ) -import Usage ( GenUsage{-instance-} ) -#if __GLASGOW_HASKELL__ >= 202 -import Name -#endif \end{code} %************************************************************************ @@ -42,15 +31,15 @@ import Name %************************************************************************ \begin{code} -data HsExpr tyvar uvar id pat +data HsExpr flexi id pat = HsVar id -- variable | HsLit HsLit -- literal | HsLitOut HsLit -- TRANSLATION - (GenType tyvar uvar) -- (with its type) + (GenType flexi) -- (with its type) - | HsLam (Match tyvar uvar id pat) -- lambda - | HsApp (HsExpr tyvar uvar id pat) -- application - (HsExpr tyvar uvar id pat) + | HsLam (Match flexi id pat) -- lambda + | HsApp (HsExpr flexi id pat) -- application + (HsExpr flexi id pat) -- Operator applications: -- NB Bracketed ops such as (+) come out as Vars. @@ -58,89 +47,91 @@ data HsExpr tyvar uvar id pat -- NB We need an expr for the operator in an OpApp/Section since -- the typechecker may need to apply the operator to a few types. - | OpApp (HsExpr tyvar uvar id pat) -- left operand - (HsExpr tyvar uvar id pat) -- operator + | OpApp (HsExpr flexi id pat) -- left operand + (HsExpr flexi id pat) -- operator Fixity -- Renamer adds fixity; bottom until then - (HsExpr tyvar uvar id pat) -- right operand + (HsExpr flexi id pat) -- right operand -- We preserve prefix negation and parenthesis for the precedence parser. -- They are eventually removed by the type checker. - | NegApp (HsExpr tyvar uvar id pat) -- negated expr - (HsExpr tyvar uvar id pat) -- the negate id (in a HsVar) + | NegApp (HsExpr flexi id pat) -- negated expr + (HsExpr flexi id pat) -- the negate id (in a HsVar) - | HsPar (HsExpr tyvar uvar id pat) -- parenthesised expr + | HsPar (HsExpr flexi id pat) -- parenthesised expr - | SectionL (HsExpr tyvar uvar id pat) -- operand - (HsExpr tyvar uvar id pat) -- operator - | SectionR (HsExpr tyvar uvar id pat) -- operator - (HsExpr tyvar uvar id pat) -- operand + | SectionL (HsExpr flexi id pat) -- operand + (HsExpr flexi id pat) -- operator + | SectionR (HsExpr flexi id pat) -- operator + (HsExpr flexi id pat) -- operand - | HsCase (HsExpr tyvar uvar id pat) - [Match tyvar uvar id pat] -- must have at least one Match + | HsCase (HsExpr flexi id pat) + [Match flexi id pat] -- must have at least one Match SrcLoc - | HsIf (HsExpr tyvar uvar id pat) -- predicate - (HsExpr tyvar uvar id pat) -- then part - (HsExpr tyvar uvar id pat) -- else part + | HsIf (HsExpr flexi id pat) -- predicate + (HsExpr flexi id pat) -- then part + (HsExpr flexi id pat) -- else part SrcLoc - | HsLet (HsBinds tyvar uvar id pat) -- let(rec) - (HsExpr tyvar uvar id pat) + | HsLet (HsBinds flexi id pat) -- let(rec) + (HsExpr flexi id pat) | HsDo DoOrListComp - [Stmt tyvar uvar id pat] -- "do":one or more stmts + [Stmt flexi id pat] -- "do":one or more stmts SrcLoc | HsDoOut DoOrListComp - [Stmt tyvar uvar id pat] -- "do":one or more stmts + [Stmt flexi id pat] -- "do":one or more stmts id -- id for return id -- id for >>= id -- id for zero - (GenType tyvar uvar) -- Type of the whole expression + (GenType flexi) -- Type of the whole expression SrcLoc | ExplicitList -- syntactic list - [HsExpr tyvar uvar id pat] + [HsExpr flexi id pat] | ExplicitListOut -- TRANSLATION - (GenType tyvar uvar) -- Gives type of components of list - [HsExpr tyvar uvar id pat] + (GenType flexi) -- Gives type of components of list + [HsExpr flexi id pat] | ExplicitTuple -- tuple - [HsExpr tyvar uvar id pat] + [HsExpr flexi id pat] -- NB: Unit is ExplicitTuple [] -- for tuples, we can get the types -- direct from the components - -- Record construction - | RecordCon id - (HsRecordBinds tyvar uvar id pat) + | HsCon Id -- TRANSLATION; a saturated constructor application + [GenType flexi] + [HsExpr flexi id pat] - | RecordConOut id -- The constructor - (HsExpr tyvar uvar id pat) -- The constructor applied to type/dict args - (HsRecordBinds tyvar uvar id pat) + -- Record construction + | RecordCon id -- The constructor + (HsExpr flexi id pat) -- Always (HsVar id) until type checker, + -- but the latter adds its type args too + (HsRecordBinds flexi id pat) -- Record update - | RecordUpd (HsExpr tyvar uvar id pat) - (HsRecordBinds tyvar uvar id pat) + | RecordUpd (HsExpr flexi id pat) + (HsRecordBinds flexi id pat) - | RecordUpdOut (HsExpr tyvar uvar id pat) -- TRANSLATION - (GenType tyvar uvar) -- Type of *result* record (may differ from + | RecordUpdOut (HsExpr flexi id pat) -- TRANSLATION + (GenType flexi) -- Type of *result* record (may differ from -- type of input record) [id] -- Dicts needed for construction - (HsRecordBinds tyvar uvar id pat) + (HsRecordBinds flexi id pat) | ExprWithTySig -- signature binding - (HsExpr tyvar uvar id pat) + (HsExpr flexi id pat) (HsType id) | ArithSeqIn -- arithmetic sequence - (ArithSeqInfo tyvar uvar id pat) + (ArithSeqInfo flexi id pat) | ArithSeqOut - (HsExpr tyvar uvar id pat) -- (typechecked, of course) - (ArithSeqInfo tyvar uvar id pat) + (HsExpr flexi id pat) -- (typechecked, of course) + (ArithSeqInfo flexi id pat) | CCall FAST_STRING -- call into the C world; string is - [HsExpr tyvar uvar id pat] -- the C function; exprs are the + [HsExpr flexi id pat] -- the C function; exprs are the -- arguments to pass. Bool -- True <=> might cause Haskell -- garbage-collection (must generate @@ -149,45 +140,33 @@ data HsExpr tyvar uvar id pat -- NOTE: this CCall is the *boxed* -- version; the desugarer will convert -- it into the unboxed "ccall#". - (GenType tyvar uvar) -- The result type; will be *bottom* + (GenType flexi) -- The result type; will be *bottom* -- until the typechecker gets ahold of it | HsSCC FAST_STRING -- "set cost centre" (_scc_) annotation - (HsExpr tyvar uvar id pat) -- expr whose cost is to be measured + (HsExpr flexi id pat) -- expr whose cost is to be measured \end{code} Everything from here on appears only in typechecker output. \begin{code} | TyLam -- TRANSLATION - [tyvar] - (HsExpr tyvar uvar id pat) + [GenTyVar flexi] + (HsExpr flexi id pat) | TyApp -- TRANSLATION - (HsExpr tyvar uvar id pat) -- generated by Spec - [GenType tyvar uvar] + (HsExpr flexi id pat) -- generated by Spec + [GenType flexi] -- DictLam and DictApp are "inverses" | DictLam [id] - (HsExpr tyvar uvar id pat) + (HsExpr flexi id pat) | DictApp - (HsExpr tyvar uvar id pat) + (HsExpr flexi id pat) [id] - -- ClassDictLam and Dictionary are "inverses" (see note below) - | ClassDictLam - [id] -- superclass dicts - [id] -- methods - (HsExpr tyvar uvar id pat) - | Dictionary - [id] -- superclass dicts - [id] -- methods - - | SingleDict -- a simple special case of Dictionary - id -- local dictionary name - -type HsRecordBinds tyvar uvar id pat - = [(id, HsExpr tyvar uvar id pat, Bool)] +type HsRecordBinds flexi id pat + = [(id, HsExpr flexi id pat, Bool)] -- True <=> source code used "punning", -- i.e. {op1, op2} rather than {op1=e1, op2=e2} \end{code} @@ -199,188 +178,172 @@ A @Dictionary@, unless of length 0 or 1, becomes a tuple. A \end{verbatim} \begin{code} -instance (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (HsExpr tyvar uvar id pat) where - ppr sty expr = pprQuote sty $ \ sty -> pprExpr sty expr +instance (NamedThing id, Outputable id, Outputable pat) => + Outputable (HsExpr flexi id pat) where + ppr expr = pprExpr expr \end{code} \begin{code} -pprExpr :: (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> HsExpr tyvar uvar id pat -> Doc +pprExpr :: (NamedThing id, Outputable id, Outputable pat) + => HsExpr flexi id pat -> SDoc -pprExpr sty (HsVar v) = ppr sty v +pprExpr e = pprDeeper (ppr_expr e) -pprExpr sty (HsLit lit) = ppr sty lit -pprExpr sty (HsLitOut lit _) = ppr sty lit +ppr_expr (HsVar v) = ppr v -pprExpr sty (HsLam match) - = hsep [char '\\', nest 2 (pprMatch sty True match)] +ppr_expr (HsLit lit) = ppr lit +ppr_expr (HsLitOut lit _) = ppr lit -pprExpr sty expr@(HsApp e1 e2) +ppr_expr (HsLam match) + = hsep [char '\\', nest 2 (pprMatch True match)] + +ppr_expr expr@(HsApp e1 e2) = let (fun, args) = collect_args expr [] in - (pprExpr sty fun) <+> (sep (map (pprExpr sty) args)) + (pprExpr fun) <+> (sep (map pprExpr args)) where collect_args (HsApp fun arg) args = collect_args fun (arg:args) collect_args fun args = (fun, args) -pprExpr sty (OpApp e1 op fixity e2) +ppr_expr (OpApp e1 op fixity e2) = case op of HsVar v -> pp_infixly v _ -> pp_prefixly where - pp_e1 = pprParendExpr sty e1 -- Add parens to make precedence clear - pp_e2 = pprParendExpr sty e2 + pp_e1 = pprParendExpr e1 -- Add parens to make precedence clear + pp_e2 = pprParendExpr e2 pp_prefixly - = hang (pprExpr sty op) 4 (sep [pp_e1, pp_e2]) + = hang (pprExpr op) 4 (sep [pp_e1, pp_e2]) pp_infixly v - = sep [pp_e1, hsep [ppr sty v, pp_e2]] + = sep [pp_e1, hsep [ppr v, pp_e2]] -pprExpr sty (NegApp e _) - = (<>) (char '-') (pprParendExpr sty e) +ppr_expr (NegApp e _) + = (<>) (char '-') (pprParendExpr e) -pprExpr sty (HsPar e) - = parens (pprExpr sty e) +ppr_expr (HsPar e) + = parens (ppr_expr e) -pprExpr sty (SectionL expr op) +ppr_expr (SectionL expr op) = case op of HsVar v -> pp_infixly v _ -> pp_prefixly where - pp_expr = pprParendExpr sty expr + pp_expr = pprParendExpr expr - pp_prefixly = hang (hsep [text " \\ x_ ->", ppr sty op]) + pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) 4 (hsep [pp_expr, ptext SLIT("x_ )")]) - pp_infixly v = parens (sep [pp_expr, ppr sty v]) + pp_infixly v = parens (sep [pp_expr, ppr v]) -pprExpr sty (SectionR op expr) +ppr_expr (SectionR op expr) = case op of HsVar v -> pp_infixly v _ -> pp_prefixly where - pp_expr = pprParendExpr sty expr + pp_expr = pprParendExpr expr - pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr sty op, ptext SLIT("x_")]) + pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext SLIT("x_")]) 4 ((<>) pp_expr rparen) pp_infixly v - = parens (sep [ppr sty v, pp_expr]) + = parens (sep [ppr v, pp_expr]) -pprExpr sty (HsCase expr matches _) - = sep [ sep [ptext SLIT("case"), nest 4 (pprExpr sty expr), ptext SLIT("of")], - nest 2 (pprMatches sty (True, empty) matches) ] +ppr_expr (HsCase expr matches _) + = sep [ sep [ptext SLIT("case"), nest 4 (ppr_expr expr), ptext SLIT("of")], + nest 2 (pprMatches (True, empty) matches) ] -pprExpr sty (HsIf e1 e2 e3 _) - = sep [hsep [ptext SLIT("if"), nest 2 (pprExpr sty e1), ptext SLIT("then")], - nest 4 (pprExpr sty e2), +ppr_expr (HsIf e1 e2 e3 _) + = sep [hsep [ptext SLIT("if"), nest 2 (ppr_expr e1), ptext SLIT("then")], + nest 4 (ppr_expr e2), ptext SLIT("else"), - nest 4 (pprExpr sty e3)] + nest 4 (ppr_expr e3)] -- special case: let ... in let ... -pprExpr sty (HsLet binds expr@(HsLet _ _)) - = sep [hang (ptext SLIT("let")) 2 (hsep [ppr sty binds, ptext SLIT("in")]), - ppr sty expr] - -pprExpr sty (HsLet binds expr) - = sep [hang (ptext SLIT("let")) 2 (ppr sty binds), - hang (ptext SLIT("in")) 2 (ppr sty expr)] - -pprExpr sty (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp sty stmts -pprExpr sty (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp sty stmts - -pprExpr sty (ExplicitList exprs) - = brackets (fsep (punctuate comma (map (pprExpr sty) exprs))) -pprExpr sty (ExplicitListOut ty exprs) - = hcat [ brackets (fsep (punctuate comma (map (pprExpr sty) exprs))), - ifnotPprForUser sty ((<>) space (parens (pprGenType sty ty))) ] - -pprExpr sty (ExplicitTuple exprs) - = parens (sep (punctuate comma (map (pprExpr sty) exprs))) - -pprExpr sty (RecordCon con rbinds) - = pp_rbinds sty (ppr sty con) rbinds -pprExpr sty (RecordConOut con_id con_expr rbinds) - = pp_rbinds sty (ppr sty con_expr) rbinds - -pprExpr sty (RecordUpd aexp rbinds) - = pp_rbinds sty (pprParendExpr sty aexp) rbinds -pprExpr sty (RecordUpdOut aexp _ _ rbinds) - = pp_rbinds sty (pprParendExpr sty aexp) rbinds - -pprExpr sty (ExprWithTySig expr sig) - = hang ((<>) (nest 2 (pprExpr sty expr)) (ptext SLIT(" ::"))) - 4 (ppr sty sig) - -pprExpr sty (ArithSeqIn info) - = brackets (ppr sty info) -pprExpr sty (ArithSeqOut expr info) - | userStyle sty = brackets (ppr sty info) - | otherwise = brackets (hcat [parens (ppr sty expr), space, ppr sty info]) - -pprExpr sty (CCall fun args _ is_asm result_ty) - = hang (if is_asm - then hcat [ptext SLIT("_casm_ ``"), ptext fun, ptext SLIT("''")] - else (<>) (ptext SLIT("_ccall_ ")) (ptext fun)) - 4 (sep (map (pprParendExpr sty) args)) +ppr_expr (HsLet binds expr@(HsLet _ _)) + = sep [hang (ptext SLIT("let")) 2 (hsep [ppr binds, ptext SLIT("in")]), + ppr_expr expr] -pprExpr sty (HsSCC label expr) - = sep [ (<>) (ptext SLIT("_scc_ ")) (hcat [char '"', ptext label, char '"']), - pprParendExpr sty expr ] +ppr_expr (HsLet binds expr) + = sep [hang (ptext SLIT("let")) 2 (ppr binds), + hang (ptext SLIT("in")) 2 (ppr expr)] -pprExpr sty (TyLam tyvars expr) - = hang (hsep [ptext SLIT("/\\"), interppSP sty tyvars, ptext SLIT("->")]) - 4 (pprExpr sty expr) +ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts +ppr_expr (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp stmts -pprExpr sty (TyApp expr [ty]) - = hang (pprExpr sty expr) 4 (pprParendGenType sty ty) +ppr_expr (ExplicitList exprs) + = brackets (fsep (punctuate comma (map pprExpr exprs))) +ppr_expr (ExplicitListOut ty exprs) + = hcat [ brackets (fsep (punctuate comma (map pprExpr exprs))), + ifNotPprForUser ((<>) space (parens (pprGenType ty))) ] + +ppr_expr (ExplicitTuple exprs) + = parens (sep (punctuate comma (map pprExpr exprs))) + +ppr_expr (HsCon con_id tys args) + = ppr con_id <+> sep (map pprParendGenType tys ++ + map pprParendExpr args) + +ppr_expr (RecordCon con_id con rbinds) + = pp_rbinds (ppr con) rbinds + +ppr_expr (RecordUpd aexp rbinds) + = pp_rbinds (pprParendExpr aexp) rbinds +ppr_expr (RecordUpdOut aexp _ _ rbinds) + = pp_rbinds (pprParendExpr aexp) rbinds + +ppr_expr (ExprWithTySig expr sig) + = hang (nest 2 (pprExpr expr) <+> ptext SLIT("::")) + 4 (ppr sig) + +ppr_expr (ArithSeqIn info) + = brackets (ppr info) +ppr_expr (ArithSeqOut expr info) + = brackets (ppr info) + +ppr_expr (CCall fun args _ is_asm result_ty) + = hang (if is_asm + then ptext SLIT("_casm_ ``") <> ptext fun <> ptext SLIT("''") + else ptext SLIT("_ccall_") <+> ptext fun) + 4 (sep (map pprParendExpr args)) -pprExpr sty (TyApp expr tys) - = hang (pprExpr sty expr) - 4 (brackets (interpp'SP sty tys)) +ppr_expr (HsSCC label expr) + = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ptext label), pprParendExpr expr ] -pprExpr sty (DictLam dictvars expr) - = hang (hsep [ptext SLIT("\\{-dict-}"), interppSP sty dictvars, ptext SLIT("->")]) - 4 (pprExpr sty expr) +ppr_expr (TyLam tyvars expr) + = hang (hsep [ptext SLIT("/\\"), interppSP tyvars, ptext SLIT("->")]) + 4 (pprExpr expr) -pprExpr sty (DictApp expr [dname]) - = hang (pprExpr sty expr) 4 (ppr sty dname) +ppr_expr (TyApp expr [ty]) + = hang (pprExpr expr) 4 (pprParendGenType ty) -pprExpr sty (DictApp expr dnames) - = hang (pprExpr sty expr) - 4 (brackets (interpp'SP sty dnames)) +ppr_expr (TyApp expr tys) + = hang (pprExpr expr) + 4 (brackets (interpp'SP tys)) -pprExpr sty (ClassDictLam dicts methods expr) - = hang (hsep [ptext SLIT("\\{-classdict-}"), - brackets (interppSP sty dicts), - brackets (interppSP sty methods), - ptext SLIT("->")]) - 4 (pprExpr sty expr) +ppr_expr (DictLam dictvars expr) + = hang (hsep [ptext SLIT("\\{-dict-}"), interppSP dictvars, ptext SLIT("->")]) + 4 (pprExpr expr) -pprExpr sty (Dictionary dicts methods) - = parens (sep [ptext SLIT("{-dict-}"), - brackets (interpp'SP sty dicts), - brackets (interpp'SP sty methods)]) +ppr_expr (DictApp expr [dname]) + = hang (pprExpr expr) 4 (ppr dname) -pprExpr sty (SingleDict dname) - = hsep [ptext SLIT("{-singleDict-}"), ppr sty dname] +ppr_expr (DictApp expr dnames) + = hang (pprExpr expr) + 4 (brackets (interpp'SP dnames)) \end{code} Parenthesize unless very simple: \begin{code} -pprParendExpr :: (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> HsExpr tyvar uvar id pat -> Doc +pprParendExpr :: (NamedThing id, Outputable id, Outputable pat) + => HsExpr flexi id pat -> SDoc -pprParendExpr sty expr +pprParendExpr expr = let - pp_as_was = pprExpr sty expr + pp_as_was = pprExpr expr in case expr of - HsLit l -> ppr sty l - HsLitOut l _ -> ppr sty l + HsLit l -> ppr l + HsLitOut l _ -> ppr l HsVar _ -> pp_as_was ExplicitList _ -> pp_as_was @@ -398,17 +361,20 @@ pprParendExpr sty expr %************************************************************************ \begin{code} -pp_rbinds :: (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> Doc - -> HsRecordBinds tyvar uvar id pat -> Doc +pp_rbinds :: (NamedThing id, Outputable id, Outputable pat) + => SDoc + -> HsRecordBinds flexi id pat -> SDoc -pp_rbinds sty thing rbinds +pp_rbinds thing rbinds = hang thing - 4 (braces (hsep (punctuate comma (map (pp_rbind sty) rbinds)))) + 4 (braces (hsep (punctuate comma (map (pp_rbind) rbinds)))) where - pp_rbind sty (v, _, True) | userStyle sty = ppr sty v - pp_rbind sty (v, e, _) = hsep [ppr sty v, char '=', ppr sty e] + pp_rbind (v, e, pun_flag) + = getPprStyle $ \ sty -> + if pun_flag && userStyle sty then + ppr v + else + hsep [ppr v, char '=', ppr e] \end{code} %************************************************************************ @@ -420,50 +386,49 @@ pp_rbinds sty thing rbinds \begin{code} data DoOrListComp = DoStmt | ListComp | Guard -pprDo DoStmt sty stmts - = hang (ptext SLIT("do")) 2 (vcat (map (ppr sty) stmts)) -pprDo ListComp sty stmts +pprDo DoStmt stmts + = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts)) +pprDo ListComp stmts = brackets $ - hang (pprExpr sty expr <+> char '|') - 4 (interpp'SP sty quals) + hang (pprExpr expr <+> char '|') + 4 (interpp'SP quals) where ReturnStmt expr = last stmts -- Last stmt should be a ReturnStmt for list comps quals = init stmts \end{code} \begin{code} -data Stmt tyvar uvar id pat +data Stmt flexi id pat = BindStmt pat - (HsExpr tyvar uvar id pat) + (HsExpr flexi id pat) SrcLoc - | LetStmt (HsBinds tyvar uvar id pat) + | LetStmt (HsBinds flexi id pat) - | GuardStmt (HsExpr tyvar uvar id pat) -- List comps only + | GuardStmt (HsExpr flexi id pat) -- List comps only SrcLoc - | ExprStmt (HsExpr tyvar uvar id pat) -- Do stmts only + | ExprStmt (HsExpr flexi id pat) -- Do stmts only SrcLoc - | ReturnStmt (HsExpr tyvar uvar id pat) -- List comps only, at the end + | ReturnStmt (HsExpr flexi id pat) -- List comps only, at the end \end{code} \begin{code} -instance (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (Stmt tyvar uvar id pat) where - ppr sty stmt = pprQuote sty $ \ sty -> pprStmt sty stmt - -pprStmt sty (BindStmt pat expr _) - = hsep [ppr sty pat, ptext SLIT("<-"), ppr sty expr] -pprStmt sty (LetStmt binds) - = hsep [ptext SLIT("let"), ppr sty binds] -pprStmt sty (ExprStmt expr _) - = ppr sty expr -pprStmt sty (GuardStmt expr _) - = ppr sty expr -pprStmt sty (ReturnStmt expr) - = hsep [ptext SLIT("return"), ppr sty expr] +instance (NamedThing id, Outputable id, Outputable pat) => + Outputable (Stmt flexi id pat) where + ppr stmt = pprStmt stmt + +pprStmt (BindStmt pat expr _) + = hsep [ppr pat, ptext SLIT("<-"), ppr expr] +pprStmt (LetStmt binds) + = hsep [ptext SLIT("let"), ppr binds] +pprStmt (ExprStmt expr _) + = ppr expr +pprStmt (GuardStmt expr _) + = ppr expr +pprStmt (ReturnStmt expr) + = hsep [ptext SLIT("return"), ppr expr] \end{code} %************************************************************************ @@ -473,26 +438,25 @@ pprStmt sty (ReturnStmt expr) %************************************************************************ \begin{code} -data ArithSeqInfo tyvar uvar id pat - = From (HsExpr tyvar uvar id pat) - | FromThen (HsExpr tyvar uvar id pat) - (HsExpr tyvar uvar id pat) - | FromTo (HsExpr tyvar uvar id pat) - (HsExpr tyvar uvar id pat) - | FromThenTo (HsExpr tyvar uvar id pat) - (HsExpr tyvar uvar id pat) - (HsExpr tyvar uvar id pat) +data ArithSeqInfo flexi id pat + = From (HsExpr flexi id pat) + | FromThen (HsExpr flexi id pat) + (HsExpr flexi id pat) + | FromTo (HsExpr flexi id pat) + (HsExpr flexi id pat) + | FromThenTo (HsExpr flexi id pat) + (HsExpr flexi id pat) + (HsExpr flexi id pat) \end{code} \begin{code} -instance (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (ArithSeqInfo tyvar uvar id pat) where - ppr sty (From e1) = hcat [ppr sty e1, pp_dotdot] - ppr sty (FromThen e1 e2) = hcat [ppr sty e1, comma, space, ppr sty e2, pp_dotdot] - ppr sty (FromTo e1 e3) = hcat [ppr sty e1, pp_dotdot, ppr sty e3] - ppr sty (FromThenTo e1 e2 e3) - = hcat [ppr sty e1, comma, space, ppr sty e2, pp_dotdot, ppr sty e3] +instance (NamedThing id, Outputable id, Outputable pat) => + Outputable (ArithSeqInfo flexi id pat) where + ppr (From e1) = hcat [ppr e1, pp_dotdot] + ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] + ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] + ppr (FromThenTo e1 e2 e3) + = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3] pp_dotdot = ptext SLIT(" .. ") \end{code} diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs index 2e24797a5e..97c23f48fb 100644 --- a/ghc/compiler/hsSyn/HsImpExp.lhs +++ b/ghc/compiler/hsSyn/HsImpExp.lhs @@ -4,19 +4,14 @@ \section[HsImpExp]{Abstract syntax: imports, exports, interfaces} \begin{code} -#include "HsVersions.h" - module HsImpExp where -IMP_Ubiq() +#include "HsVersions.h" -import BasicTypes ( IfaceFlavour(..) ) +import BasicTypes ( Module, IfaceFlavour(..) ) +import Name ( NamedThing ) import Outputable -import Pretty import SrcLoc ( SrcLoc ) -#if __GLASGOW_HASKELL__ >= 202 -import Name -#endif \end{code} %************************************************************************ @@ -39,7 +34,7 @@ data ImportDecl name \begin{code} instance (NamedThing name, Outputable name) => Outputable (ImportDecl name) where - ppr sty (ImportDecl mod qual as_source as spec _) + ppr (ImportDecl mod qual as_source as spec _) = hang (hsep [ptext SLIT("import"), pp_src as_source, pp_qual qual, ptext mod, pp_as as]) 4 (pp_spec spec) @@ -51,13 +46,13 @@ instance (NamedThing name, Outputable name) => Outputable (ImportDecl name) wher pp_qual True = ptext SLIT("qualified") pp_as Nothing = empty - pp_as (Just a) = (<>) (ptext SLIT("as ")) (ptext a) + pp_as (Just a) = ptext SLIT("as ") <+> ptext a pp_spec Nothing = empty pp_spec (Just (False, spec)) - = parens (interpp'SP sty spec) + = parens (interpp'SP spec) pp_spec (Just (True, spec)) - = (<>) (ptext SLIT("hiding ")) (parens (interpp'SP sty spec)) + = ptext SLIT("hiding") <+> parens (interpp'SP spec) \end{code} %************************************************************************ @@ -85,14 +80,12 @@ ieName (IEThingAll n) = n \begin{code} instance (NamedThing name, Outputable name) => Outputable (IE name) where - ppr sty (IEVar var) = ppr sty var - ppr sty (IEThingAbs thing) = ppr sty thing - ppr sty (IEThingAll thing) - = hcat [ppr sty thing, text "(..)"] - ppr sty (IEThingWith thing withs) - = (<>) (ppr sty thing) - (parens (fsep (punctuate comma (map (ppr sty) withs)))) - ppr sty (IEModuleContents mod) - = (<>) (ptext SLIT("module ")) (ptext mod) + ppr (IEVar var) = ppr var + ppr (IEThingAbs thing) = ppr thing + ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"] + ppr (IEThingWith thing withs) + = ppr thing <> parens (fsep (punctuate comma (map ppr withs))) + ppr (IEModuleContents mod) + = ptext SLIT("module") <+> ptext mod \end{code} diff --git a/ghc/compiler/hsSyn/HsLoop.lhi b/ghc/compiler/hsSyn/HsLoop.lhi deleted file mode 100644 index e507d2e1c4..0000000000 --- a/ghc/compiler/hsSyn/HsLoop.lhi +++ /dev/null @@ -1,33 +0,0 @@ -\begin{code} - -interface HsLoop where - -import HsMatches( Match, GRHSsAndBinds, pprMatch, pprMatches, pprGRHSsAndBinds ) -import HsExpr ( HsExpr, pprExpr ) -import HsDecls ( ConDecl ) -import Name ( NamedThing ) -import Outputable ( Outputable, PprStyle ) -import Pretty ( Doc ) - --- HsMatches outputs -data Match tyvar uvar id pat -data GRHSsAndBinds tyvar uvar id pat - -pprGRHSsAndBinds :: (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - PprStyle -> Bool -> GRHSsAndBinds tyvar uvar id pat -> Doc - -pprMatches :: (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - PprStyle -> (Bool, Doc) -> [Match tyvar uvar id pat] -> Doc - -pprMatch :: (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - PprStyle -> Bool -> Match tyvar uvar id pat -> Doc - --- HsExpr outputs -data HsExpr tyvar uvar id pat -pprExpr :: (NamedThing c, Outputable c, Outputable d, Eq a, Outputable a, Eq b, Outputable b) - => PprStyle -> HsExpr a b c d -> Doc - -\end{code} diff --git a/ghc/compiler/hsSyn/HsMatches.hi-boot b/ghc/compiler/hsSyn/HsMatches.hi-boot index c1a24cae91..b783d025c9 100644 --- a/ghc/compiler/hsSyn/HsMatches.hi-boot +++ b/ghc/compiler/hsSyn/HsMatches.hi-boot @@ -2,8 +2,8 @@ _interface_ HsMatches 1 _exports_ HsMatches Match GRHSsAndBinds pprMatch pprMatches pprGRHSsAndBinds ; _declarations_ -1 data Match a b c d ; -1 data GRHSsAndBinds a b c d ; -1 pprGRHSsAndBinds _:_ _forall_ [a b c d] {Name.NamedThing c, Outputable.Outputable c, Outputable.Outputable d, PrelBase.Eq a, Outputable.Outputable a, PrelBase.Eq b, Outputable.Outputable b} => Outputable.PprStyle -> PrelBase.Bool -> HsMatches.GRHSsAndBinds a b c d -> Pretty.Doc ;; -1 pprMatch _:_ _forall_ [a b c d] {Name.NamedThing c, Outputable.Outputable c, Outputable.Outputable d, PrelBase.Eq a, Outputable.Outputable a, PrelBase.Eq b, Outputable.Outputable b} => Outputable.PprStyle -> PrelBase.Bool -> HsMatches.Match a b c d -> Pretty.Doc ;; -1 pprMatches _:_ _forall_ [a b c d] {Name.NamedThing c, Outputable.Outputable c, Outputable.Outputable d, PrelBase.Eq a, Outputable.Outputable a, PrelBase.Eq b, Outputable.Outputable b} => Outputable.PprStyle -> (PrelBase.Bool, Pretty.Doc) -> [HsMatches.Match a b c d] -> Pretty.Doc ;; +1 data Match a b c ; +1 data GRHSsAndBinds a b c ; +1 pprGRHSsAndBinds _:_ _forall_ [i p f] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsMatches.GRHSsAndBinds f i p -> Outputable.SDoc ;; +1 pprMatch _:_ _forall_ [i p f] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsMatches.Match f i p -> Outputable.SDoc ;; +1 pprMatches _:_ _forall_ [i p f] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> [HsMatches.Match f i p] -> Outputable.SDoc ;; diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs index 1d85fbb3e3..63a783a2c5 100644 --- a/ghc/compiler/hsSyn/HsMatches.lhs +++ b/ghc/compiler/hsSyn/HsMatches.lhs @@ -6,27 +6,20 @@ The @Match@, @GRHSsAndBinds@ and @GRHS@ datatypes. \begin{code} -#include "HsVersions.h" - module HsMatches where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -- Friends import HsExpr ( HsExpr, Stmt ) import HsBinds ( HsBinds, nullBinds ) -- Others -import Outputable ( ifPprShowAll, PprStyle, interpp'SP ) import PprType ( GenType{-instance Outputable-} ) -import Pretty import SrcLoc ( SrcLoc{-instances-} ) import Util ( panic ) -import Outputable ( Outputable(..) ) -#if __GLASGOW_HASKELL__ >= 202 -import Name -#endif - +import Outputable +import Name ( NamedThing ) \end{code} %************************************************************************ @@ -50,12 +43,12 @@ a function defined by pattern matching must have the same number of patterns in each equation. \begin{code} -data Match tyvar uvar id pat +data Match flexi id pat = PatMatch pat - (Match tyvar uvar id pat) - | GRHSMatch (GRHSsAndBinds tyvar uvar id pat) + (Match flexi id pat) + | GRHSMatch (GRHSsAndBinds flexi id pat) - | SimpleMatch (HsExpr tyvar uvar id pat) -- Used in translations + | SimpleMatch (HsExpr flexi id pat) -- Used in translations \end{code} Sets of guarded right hand sides (GRHSs). In: @@ -70,21 +63,31 @@ For each match, there may be several guarded right hand sides, as the definition of @f@ shows. \begin{code} -data GRHSsAndBinds tyvar uvar id pat - = GRHSsAndBindsIn [GRHS tyvar uvar id pat] -- at least one GRHS - (HsBinds tyvar uvar id pat) +data GRHSsAndBinds flexi id pat + = GRHSsAndBindsIn [GRHS flexi id pat] -- at least one GRHS + (HsBinds flexi id pat) - | GRHSsAndBindsOut [GRHS tyvar uvar id pat] -- at least one GRHS - (HsBinds tyvar uvar id pat) - (GenType tyvar uvar) + | GRHSsAndBindsOut [GRHS flexi id pat] -- at least one GRHS + (HsBinds flexi id pat) + (GenType flexi) -data GRHS tyvar uvar id pat - = GRHS [Stmt tyvar uvar id pat] -- guard(ed)... - (HsExpr tyvar uvar id pat) -- ... right-hand side +data GRHS flexi id pat + = GRHS [Stmt flexi id pat] -- guard(ed)... + (HsExpr flexi id pat) -- ... right-hand side SrcLoc - | OtherwiseGRHS (HsExpr tyvar uvar id pat) -- guard-free - SrcLoc +unguardedRHS :: (HsExpr flexi id pat) -> SrcLoc -> [GRHS flexi id pat] +unguardedRHS rhs loc = [GRHS [] rhs loc] +\end{code} + +@getMatchLoc@ takes a @Match@ and returns the +source-location gotten from the GRHS inside. +THis is something of a nuisance, but no more. + +\begin{code} +getMatchLoc :: Match flexi id pat -> SrcLoc +getMatchLoc (PatMatch _ m) = getMatchLoc m +getMatchLoc (GRHSMatch (GRHSsAndBindsIn (GRHS _ _ loc : _) _)) = loc \end{code} %************************************************************************ @@ -95,75 +98,66 @@ data GRHS tyvar uvar id pat We know the list must have at least one @Match@ in it. \begin{code} -pprMatches :: (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - PprStyle -> (Bool, Doc) -> [Match tyvar uvar id pat] -> Doc +pprMatches :: (NamedThing id, Outputable id, Outputable pat) + => (Bool, SDoc) -> [Match flexi id pat] -> SDoc -pprMatches sty print_info@(is_case, name) [match] +pprMatches print_info@(is_case, name) [match] = if is_case then - pprMatch sty is_case match + pprMatch is_case match else - name <+> (pprMatch sty is_case match) + name <+> (pprMatch is_case match) -pprMatches sty print_info (match1 : rest) - = ($$) (pprMatches sty print_info [match1]) - (pprMatches sty print_info rest) +pprMatches print_info (match1 : rest) + = ($$) (pprMatches print_info [match1]) + (pprMatches print_info rest) --------------------------------------------- -pprMatch :: (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - PprStyle -> Bool -> Match tyvar uvar id pat -> Doc +pprMatch :: (NamedThing id, Outputable id, Outputable pat) + => Bool -> Match flexi id pat -> SDoc -pprMatch sty is_case first_match - = sep [(sep (map (ppr sty) row_of_pats)), +pprMatch is_case first_match + = sep [(sep (map (ppr) row_of_pats)), grhss_etc_stuff] where - (row_of_pats, grhss_etc_stuff) = ppr_match sty is_case first_match + (row_of_pats, grhss_etc_stuff) = ppr_match is_case first_match - ppr_match sty is_case (PatMatch pat match) + ppr_match is_case (PatMatch pat match) = (pat:pats, grhss_stuff) where - (pats, grhss_stuff) = ppr_match sty is_case match + (pats, grhss_stuff) = ppr_match is_case match - ppr_match sty is_case (GRHSMatch grhss_n_binds) - = ([], pprGRHSsAndBinds sty is_case grhss_n_binds) + ppr_match is_case (GRHSMatch grhss_n_binds) + = ([], pprGRHSsAndBinds is_case grhss_n_binds) - ppr_match sty is_case (SimpleMatch expr) - = ([], text (if is_case then "->" else "=") <+> ppr sty expr) + ppr_match is_case (SimpleMatch expr) + = ([], text (if is_case then "->" else "=") <+> ppr expr) ---------------------------------------------------------- -pprGRHSsAndBinds :: (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - PprStyle -> Bool -> GRHSsAndBinds tyvar uvar id pat -> Doc +pprGRHSsAndBinds :: (NamedThing id, Outputable id, Outputable pat) + => Bool -> GRHSsAndBinds flexi id pat -> SDoc -pprGRHSsAndBinds sty is_case (GRHSsAndBindsIn grhss binds) - = ($$) (vcat (map (pprGRHS sty is_case) grhss)) +pprGRHSsAndBinds is_case (GRHSsAndBindsIn grhss binds) + = ($$) (vcat (map (pprGRHS is_case) grhss)) (if (nullBinds binds) then empty - else vcat [ text "where", nest 4 (ppr sty binds) ]) + else vcat [ text "where", nest 4 (ppr binds) ]) -pprGRHSsAndBinds sty is_case (GRHSsAndBindsOut grhss binds ty) - = ($$) (vcat (map (pprGRHS sty is_case) grhss)) +pprGRHSsAndBinds is_case (GRHSsAndBindsOut grhss binds ty) + = ($$) (vcat (map (pprGRHS is_case) grhss)) (if (nullBinds binds) then empty - else vcat [ ifPprShowAll sty - (hsep [text "{- ty:", ppr sty ty, text "-}"]), - text "where", nest 4 (ppr sty binds) ]) + else vcat [text "where", nest 4 (ppr binds) ]) --------------------------------------------- -pprGRHS :: (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> Bool -> GRHS tyvar uvar id pat -> Doc +pprGRHS :: (NamedThing id, Outputable id, Outputable pat) + => Bool -> GRHS flexi id pat -> SDoc -pprGRHS sty is_case (GRHS [] expr locn) - = text (if is_case then "->" else "=") <+> ppr sty expr +pprGRHS is_case (GRHS [] expr locn) + = text (if is_case then "->" else "=") <+> ppr expr -pprGRHS sty is_case (GRHS guard expr locn) - = sep [char '|' <+> interpp'SP sty guard, - text (if is_case then "->" else "=") <+> ppr sty expr +pprGRHS is_case (GRHS guard expr locn) + = sep [char '|' <+> interpp'SP guard, + text (if is_case then "->" else "=") <+> ppr expr ] - -pprGRHS sty is_case (OtherwiseGRHS expr locn) - = text (if is_case then "->" else "=") <+> ppr sty expr \end{code} diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 2405fae4a3..8e89bb2f3d 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -4,8 +4,6 @@ \section[PatSyntax]{Abstract Haskell syntax---patterns} \begin{code} -#include "HsVersions.h" - module HsPat ( InPat(..), OutPat(..), @@ -17,27 +15,20 @@ module HsPat ( collectPatBinders ) where -IMP_Ubiq() +#include "HsVersions.h" -- friends: --- IMPORT_DELOOPER(IdLoop) import HsBasic ( HsLit ) import HsExpr ( HsExpr ) import BasicTypes ( Fixity ) -- others: -import Id ( SYN_IE(Id), dataConTyCon, GenId ) +import Id ( Id, dataConTyCon, GenId ) import Maybes ( maybeToBool ) -import Outputable ( PprStyle(..), userStyle, interppSP, - interpp'SP, ifPprShowAll, Outputable(..) - ) -import Pretty +import Outputable import TyCon ( maybeTyConSingleCon ) import PprType ( GenType ) -import CmdLineOpts ( opt_PprUserLength ) -#if __GLASGOW_HASKELL__ >= 202 -import Name -#endif +import Name ( NamedThing ) \end{code} Patterns come in distinct before- and after-typechecking flavo(u)rs. @@ -71,46 +62,46 @@ data InPat name | RecPatIn name -- record [(name, InPat name, Bool)] -- True <=> source used punning -data OutPat tyvar uvar id - = WildPat (GenType tyvar uvar) -- wild card +data OutPat flexi id + = WildPat (GenType flexi) -- wild card | VarPat id -- variable (type is in the Id) - | LazyPat (OutPat tyvar uvar id) -- lazy pattern + | LazyPat (OutPat flexi id) -- lazy pattern | AsPat id -- as pattern - (OutPat tyvar uvar id) + (OutPat flexi id) | ConPat Id -- Constructor is always an Id - (GenType tyvar uvar) -- the type of the pattern - [OutPat tyvar uvar id] + (GenType flexi) -- the type of the pattern + [OutPat flexi id] - | ConOpPat (OutPat tyvar uvar id) -- just a special case... + | ConOpPat (OutPat flexi id) -- just a special case... Id - (OutPat tyvar uvar id) - (GenType tyvar uvar) + (OutPat flexi id) + (GenType flexi) | ListPat -- syntactic list - (GenType tyvar uvar) -- the type of the elements - [OutPat tyvar uvar id] + (GenType flexi) -- the type of the elements + [OutPat flexi id] - | TuplePat [OutPat tyvar uvar id] -- tuple + | TuplePat [OutPat flexi id] -- tuple -- UnitPat is TuplePat [] | RecPat Id -- record constructor - (GenType tyvar uvar) -- the type of the pattern - [(Id, OutPat tyvar uvar id, Bool)] -- True <=> source used punning + (GenType flexi) -- the type of the pattern + [(Id, OutPat flexi id, Bool)] -- True <=> source used punning | LitPat -- Used for *non-overloaded* literal patterns: -- Int#, Char#, Int, Char, String, etc. HsLit - (GenType tyvar uvar) -- type of pattern + (GenType flexi) -- type of pattern | NPat -- Used for *overloaded* literal patterns HsLit -- the literal is retained so that -- the desugarer can readily identify -- equations with identical literal-patterns - (GenType tyvar uvar) -- type of pattern, t - (HsExpr tyvar uvar id (OutPat tyvar uvar id)) + (GenType flexi) -- type of pattern, t + (HsExpr flexi id (OutPat flexi id)) -- of type t -> Bool; detects match | NPlusKPat id @@ -118,9 +109,9 @@ data OutPat tyvar uvar id -- (This could be an Integer, but then -- it's harder to partitionEqnsByLit -- in the desugarer.) - (GenType tyvar uvar) -- Type of pattern, t - (HsExpr tyvar uvar id (OutPat tyvar uvar id)) -- Of type t -> Bool; detects match - (HsExpr tyvar uvar id (OutPat tyvar uvar id)) -- Of type t -> t; subtracts k + (GenType flexi) -- Type of pattern, t + (HsExpr flexi id (OutPat flexi id)) -- Of type t -> Bool; detects match + (HsExpr flexi id (OutPat flexi id)) -- Of type t -> t; subtracts k | DictPat -- Used when destructing Dictionaries with an explicit case [id] -- superclass dicts @@ -136,101 +127,95 @@ JJQC-2-12-97 instance (Outputable name) => Outputable (InPat name) where ppr = pprInPat -pprInPat :: (Outputable name) => PprStyle -> InPat name -> Doc +pprInPat :: (Outputable name) => InPat name -> SDoc -pprInPat sty (WildPatIn) = char '_' -pprInPat sty (VarPatIn var) = ppr sty var -pprInPat sty (LitPatIn s) = ppr sty s -pprInPat sty (LazyPatIn pat) = (<>) (char '~') (ppr sty pat) -pprInPat sty (AsPatIn name pat) - = parens (hcat [ppr sty name, char '@', ppr sty pat]) +pprInPat (WildPatIn) = char '_' +pprInPat (VarPatIn var) = ppr var +pprInPat (LitPatIn s) = ppr s +pprInPat (LazyPatIn pat) = char '~' <> ppr pat +pprInPat (AsPatIn name pat) = parens (hcat [ppr name, char '@', ppr pat]) -pprInPat sty (ConPatIn c pats) - = if null pats then - ppr sty c - else - hsep [ppr sty c, interppSP sty pats] -- ParPats put in the parens +pprInPat (ConPatIn c pats) + | null pats = ppr c + | otherwise = hsep [ppr c, interppSP pats] -- ParPats put in the parens -pprInPat sty (ConOpPatIn pat1 op fixity pat2) - = hsep [ppr sty pat1, ppr sty op, ppr sty pat2] -- ParPats put in parens +pprInPat (ConOpPatIn pat1 op fixity pat2) + = hsep [ppr pat1, ppr op, ppr pat2] -- ParPats put in parens -- ToDo: use pprSym to print op (but this involves fiddling various -- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP) -pprInPat sty (NegPatIn pat) +pprInPat (NegPatIn pat) = let - pp_pat = pprInPat sty pat + pp_pat = pprInPat pat in - (<>) (char '-') ( + char '-' <> ( case pat of LitPatIn _ -> pp_pat _ -> parens pp_pat ) -pprInPat sty (ParPatIn pat) - = parens (pprInPat sty pat) +pprInPat (ParPatIn pat) + = parens (pprInPat pat) -pprInPat sty (ListPatIn pats) - = brackets (interpp'SP sty pats) -pprInPat sty (TuplePatIn pats) - = parens (interpp'SP sty pats) -pprInPat sty (NPlusKPatIn n k) - = parens (hcat [ppr sty n, char '+', ppr sty k]) +pprInPat (ListPatIn pats) + = brackets (interpp'SP pats) +pprInPat (TuplePatIn pats) + = parens (interpp'SP pats) +pprInPat (NPlusKPatIn n k) + = parens (hcat [ppr n, char '+', ppr k]) -pprInPat sty (RecPatIn con rpats) - = hsep [ppr sty con, braces (hsep (punctuate comma (map (pp_rpat sty) rpats)))] +pprInPat (RecPatIn con rpats) + = hsep [ppr con, braces (hsep (punctuate comma (map (pp_rpat) rpats)))] where - pp_rpat sty (v, _, True) | userStyle sty = ppr (PprForUser opt_PprUserLength) v - pp_rpat sty (v, p, _) = hsep [ppr sty v, char '=', ppr sty p] + pp_rpat (v, _, True) = ppr v + pp_rpat (v, p, _) = hsep [ppr v, char '=', ppr p] \end{code} \begin{code} -instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, Outputable id) - => Outputable (OutPat tyvar uvar id) where +instance (Outputable id) => Outputable (OutPat flexi id) where ppr = pprOutPat \end{code} \begin{code} -pprOutPat sty (WildPat ty) = char '_' -pprOutPat sty (VarPat var) = ppr sty var -pprOutPat sty (LazyPat pat) = hcat [char '~', ppr sty pat] -pprOutPat sty (AsPat name pat) - = parens (hcat [ppr sty name, char '@', ppr sty pat]) - -pprOutPat sty (ConPat name ty []) - = (<>) (ppr sty name) - (ifPprShowAll sty (pprConPatTy sty ty)) - -pprOutPat sty (ConPat name ty pats) - = hcat [parens (hcat [ppr sty name, space, interppSP sty pats]), - ifPprShowAll sty (pprConPatTy sty ty) ] - -pprOutPat sty (ConOpPat pat1 op pat2 ty) - = parens (hcat [ppr sty pat1, space, ppr sty op, space, ppr sty pat2]) - -pprOutPat sty (ListPat ty pats) - = brackets (interpp'SP sty pats) -pprOutPat sty (TuplePat pats) - = parens (interpp'SP sty pats) - -pprOutPat sty (RecPat con ty rpats) - = hcat [ppr sty con, braces (hsep (punctuate comma (map (pp_rpat sty) rpats)))] +pprOutPat (WildPat ty) = char '_' +pprOutPat (VarPat var) = ppr var +pprOutPat (LazyPat pat) = hcat [char '~', ppr pat] +pprOutPat (AsPat name pat) + = parens (hcat [ppr name, char '@', ppr pat]) + +pprOutPat (ConPat name ty []) + = ppr name + +pprOutPat (ConPat name ty pats) + = hcat [parens (hcat [ppr name, space, interppSP pats])] + +pprOutPat (ConOpPat pat1 op pat2 ty) + = parens (hcat [ppr pat1, space, ppr op, space, ppr pat2]) + +pprOutPat (ListPat ty pats) + = brackets (interpp'SP pats) +pprOutPat (TuplePat pats) + = parens (interpp'SP pats) + +pprOutPat (RecPat con ty rpats) + = hcat [ppr con, braces (hsep (punctuate comma (map (pp_rpat) rpats)))] where - pp_rpat sty (v, _, True) | userStyle sty = ppr (PprForUser opt_PprUserLength) v - pp_rpat sty (v, p, _) = hsep [ppr sty v, char '=', ppr sty p] + pp_rpat (v, _, True) = ppr v + pp_rpat (v, p, _) = hsep [ppr v, char '=', ppr p] -pprOutPat sty (LitPat l ty) = ppr sty l -- ToDo: print more -pprOutPat sty (NPat l ty e) = ppr sty l -- ToDo: print more -pprOutPat sty (NPlusKPat n k ty e1 e2) -- ToDo: print more - = parens (hcat [ppr sty n, char '+', ppr sty k]) +pprOutPat (LitPat l ty) = ppr l -- ToDo: print more +pprOutPat (NPat l ty e) = ppr l -- ToDo: print more +pprOutPat (NPlusKPat n k ty e1 e2) -- ToDo: print more + = parens (hcat [ppr n, char '+', ppr k]) -pprOutPat sty (DictPat dicts methods) +pprOutPat (DictPat dicts methods) = parens (sep [ptext SLIT("{-dict-}"), - brackets (interpp'SP sty dicts), - brackets (interpp'SP sty methods)]) + brackets (interpp'SP dicts), + brackets (interpp'SP methods)]) -pprConPatTy sty ty - = parens (ppr sty ty) +pprConPatTy ty + = parens (ppr ty) \end{code} %************************************************************************ @@ -262,7 +247,7 @@ patterns are treated specially, of course. The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. \begin{code} -irrefutablePats :: [OutPat a b c] -> Bool +irrefutablePats :: [OutPat a b] -> Bool irrefutablePats pat_list = all irrefutablePat pat_list irrefutablePat (AsPat _ pat) = irrefutablePat pat @@ -272,7 +257,7 @@ irrefutablePat (LazyPat _) = True irrefutablePat (DictPat ds ms) = (length ds + length ms) <= 1 irrefutablePat other = False -failureFreePat :: OutPat a b c -> Bool +failureFreePat :: OutPat a b -> Bool failureFreePat (WildPat _) = True failureFreePat (VarPat _) = True @@ -290,7 +275,7 @@ only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con)) \end{code} \begin{code} -patsAreAllCons :: [OutPat a b c] -> Bool +patsAreAllCons :: [OutPat a b] -> Bool patsAreAllCons pat_list = all isConPat pat_list isConPat (AsPat _ pat) = isConPat pat @@ -302,7 +287,7 @@ isConPat (RecPat _ _ _) = True isConPat (DictPat ds ms) = (length ds + length ms) > 1 isConPat other = False -patsAreAllLits :: [OutPat a b c] -> Bool +patsAreAllLits :: [OutPat a b] -> Bool patsAreAllLits pat_list = all isLitPat pat_list isLitPat (AsPat _ pat) = isLitPat pat diff --git a/ghc/compiler/hsSyn/HsPragmas.lhs b/ghc/compiler/hsSyn/HsPragmas.lhs index cc3733ebe4..418c150783 100644 --- a/ghc/compiler/hsSyn/HsPragmas.lhs +++ b/ghc/compiler/hsSyn/HsPragmas.lhs @@ -12,20 +12,16 @@ for values show up; ditto @SpecInstSig@ (for instances) and @SpecDataSig@ (for data types). \begin{code} -#include "HsVersions.h" - module HsPragmas where -IMP_Ubiq() +#include "HsVersions.h" -- friends: import HsTypes ( HsType ) -- others: import IdInfo -import SpecEnv ( SpecEnv ) -import Outputable ( Outputable(..) ) -import Pretty +import Outputable \end{code} All the pragma stuff has changed. Here are some placeholders! @@ -53,16 +49,16 @@ noClassOpPragmas = NoClassOpPragmas isNoClassOpPragmas NoClassOpPragmas = True instance Outputable name => Outputable (ClassPragmas name) where - ppr sty NoClassPragmas = empty + ppr NoClassPragmas = empty instance Outputable name => Outputable (ClassOpPragmas name) where - ppr sty NoClassOpPragmas = empty + ppr NoClassOpPragmas = empty instance Outputable name => Outputable (InstancePragmas name) where - ppr sty NoInstancePragmas = empty + ppr NoInstancePragmas = empty instance Outputable name => Outputable (GenPragmas name) where - ppr sty NoGenPragmas = empty + ppr NoGenPragmas = empty \end{code} ========================= OLD CODE SCEDULED FOR DELETION SLPJ Nov 96 ============== @@ -170,41 +166,41 @@ isNoInstancePragmas _ = False Some instances for printing (just for debugging, really) \begin{code} instance Outputable name => Outputable (ClassPragmas name) where - ppr sty NoClassPragmas = empty - ppr sty (SuperDictPragmas sdsel_prags) + ppr NoClassPragmas = empty + ppr (SuperDictPragmas sdsel_prags) = ($$) (ptext SLIT("{-superdict pragmas-}")) - (ppr sty sdsel_prags) + (ppr sdsel_prags) instance Outputable name => Outputable (ClassOpPragmas name) where - ppr sty NoClassOpPragmas = empty - ppr sty (ClassOpPragmas op_prags defm_prags) - = ($$) (hsep [ptext SLIT("{-meth-}"), ppr sty op_prags]) - (hsep [ptext SLIT("{-defm-}"), ppr sty defm_prags]) + ppr NoClassOpPragmas = empty + ppr (ClassOpPragmas op_prags defm_prags) + = ($$) (hsep [ptext SLIT("{-meth-}"), ppr op_prags]) + (hsep [ptext SLIT("{-defm-}"), ppr defm_prags]) instance Outputable name => Outputable (InstancePragmas name) where - ppr sty NoInstancePragmas = empty - ppr sty (SimpleInstancePragma dfun_pragmas) - = hsep [ptext SLIT("{-dfun-}"), ppr sty dfun_pragmas] - ppr sty (ConstantInstancePragma dfun_pragmas name_pragma_pairs) - = ($$) (hsep [ptext SLIT("{-constm-}"), ppr sty dfun_pragmas]) + ppr NoInstancePragmas = empty + ppr (SimpleInstancePragma dfun_pragmas) + = hsep [ptext SLIT("{-dfun-}"), ppr dfun_pragmas] + ppr (ConstantInstancePragma dfun_pragmas name_pragma_pairs) + = ($$) (hsep [ptext SLIT("{-constm-}"), ppr dfun_pragmas]) (vcat (map pp_pair name_pragma_pairs)) where pp_pair (n, prags) - = hsep [ppr sty n, equals, ppr sty prags] + = hsep [ppr n, equals, ppr prags] - ppr sty (SpecialisedInstancePragma dfun_pragmas spec_pragma_info) - = ($$) (hsep [ptext SLIT("{-spec'd-}"), ppr sty dfun_pragmas]) + ppr (SpecialisedInstancePragma dfun_pragmas spec_pragma_info) + = ($$) (hsep [ptext SLIT("{-spec'd-}"), ppr dfun_pragmas]) (vcat (map pp_info spec_pragma_info)) where pp_info (ty_maybes, num_dicts, prags) = hcat [brackets (hsep (map pp_ty ty_maybes)), - parens (int num_dicts), equals, ppr sty prags] + parens (int num_dicts), equals, ppr prags] pp_ty Nothing = ptext SLIT("_N_") - pp_ty (Just t)= ppr sty t + pp_ty (Just t)= ppr t instance Outputable name => Outputable (GenPragmas name) where - ppr sty NoGenPragmas = empty - ppr sty (GenPragmas arity_maybe upd_maybe def strictness unfolding specs) + ppr NoGenPragmas = empty + ppr (GenPragmas arity_maybe upd_maybe def strictness unfolding specs) = hsep [pp_arity arity_maybe, pp_upd upd_maybe, -- ToDo: print def? pp_str strictness, pp_unf unfolding, pp_specs specs] @@ -213,27 +209,27 @@ instance Outputable name => Outputable (GenPragmas name) where pp_arity (Just i) = (<>) (ptext SLIT("ARITY=")) (int i) pp_upd Nothing = empty - pp_upd (Just u) = ppUpdateInfo sty u + pp_upd (Just u) = ppUpdateInfo u pp_str NoImpStrictness = empty pp_str (ImpStrictness is_bot demands wrkr_prags) - = hcat [ptext SLIT("IS_BOT="), ppr sty is_bot, + = hcat [ptext SLIT("IS_BOT="), ppr is_bot, ptext SLIT("STRICTNESS="), text (showList demands ""), - ptext SLIT(" {"), ppr sty wrkr_prags, char '}'] + ptext SLIT(" {"), ppr wrkr_prags, char '}'] pp_unf NoImpUnfolding = ptext SLIT("NO_UNFOLDING") pp_unf (ImpMagicUnfolding m) = (<>) (ptext SLIT("MAGIC=")) (ptext m) - pp_unf (ImpUnfolding g core) = (<>) (ptext SLIT("UNFOLD=")) (ppr sty core) + pp_unf (ImpUnfolding g core) = (<>) (ptext SLIT("UNFOLD=")) (ppr core) pp_specs [] = empty pp_specs specs = hcat [ptext SLIT("SPECS=["), hsep (map pp_spec specs), char ']'] where pp_spec (ty_maybes, num_dicts, gprags) - = hsep [brackets (hsep (map pp_MaB ty_maybes)), int num_dicts, ppr sty gprags] + = hsep [brackets (hsep (map pp_MaB ty_maybes)), int num_dicts, ppr gprags] pp_MaB Nothing = ptext SLIT("_N_") - pp_MaB (Just x) = ppr sty x + pp_MaB (Just x) = ppr x \end{code} diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 3f949aafec..237b660ee4 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -8,28 +8,26 @@ which is declared in the various \tr{Hs*} modules. This module, therefore, is almost nothing but re-exporting. \begin{code} -#include "HsVersions.h" - module HsSyn ( -- NB: don't reexport HsCore or HsPragmas; -- this module tells about "real Haskell" - EXP_MODULE(HsSyn) , - EXP_MODULE(HsBinds) , - EXP_MODULE(HsDecls) , - EXP_MODULE(HsExpr) , - EXP_MODULE(HsImpExp) , - EXP_MODULE(HsBasic) , - EXP_MODULE(HsMatches) , - EXP_MODULE(HsPat) , - EXP_MODULE(HsTypes), + module HsSyn, + module HsBinds, + module HsDecls, + module HsExpr, + module HsImpExp, + module HsBasic, + module HsMatches, + module HsPat, + module HsTypes, Fixity, NewOrData, IfaceFlavour, collectTopBinders, collectMonoBinders ) where -IMP_Ubiq() +#include "HsVersions.h" -- friends: import HsBinds @@ -49,29 +47,19 @@ import HsTypes import HsPragmas ( ClassPragmas, ClassOpPragmas, DataPragmas, GenPragmas, InstancePragmas ) import HsCore -import BasicTypes ( Fixity, SYN_IE(Version), NewOrData, IfaceFlavour ) +import BasicTypes ( Fixity, Version, NewOrData, IfaceFlavour, Module ) -- others: import FiniteMap ( FiniteMap ) -import Outputable ( ifPprShowAll, ifnotPprForUser, interpp'SP, Outputable(..) ) -import Pretty +import Outputable import SrcLoc ( SrcLoc ) import Bag -#if __GLASGOW_HASKELL__ >= 202 -import Name -#endif -\end{code} - -@Fake@ is a placeholder type; for when tyvars and uvars aren't used. -\begin{code} -data Fake = Fake -instance Eq Fake -instance Outputable Fake +import Name ( NamedThing ) \end{code} All we actually declare here is the top-level structure for a module. \begin{code} -data HsModule tyvar uvar name pat +data HsModule flexi name pat = HsModule Module -- module name (Maybe Version) -- source interface version number @@ -83,25 +71,22 @@ data HsModule tyvar uvar name pat -- info to TyDecls/etc; so this list is -- often empty, downstream. [FixityDecl name] - [HsDecl tyvar uvar name pat] -- Type, class, value, and interface signature decls + [HsDecl flexi name pat] -- Type, class, value, and interface signature decls SrcLoc \end{code} \begin{code} -instance (NamedThing name, Outputable name, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => Outputable (HsModule tyvar uvar name pat) where +instance (NamedThing name, Outputable name, Outputable pat) + => Outputable (HsModule flexi name pat) where - ppr sty (HsModule name iface_version exports imports fixities + ppr (HsModule name iface_version exports imports fixities decls src_loc) = vcat [ - ifPprShowAll sty (ppr sty src_loc), - ifnotPprForUser sty (pp_iface_version iface_version), case exports of Nothing -> hsep [ptext SLIT("module"), ptext name, ptext SLIT("where")] Just es -> vcat [ hsep [ptext SLIT("module"), ptext name, lparen], - nest 8 (interpp'SP sty es), + nest 8 (interpp'SP es), nest 4 (ptext SLIT(") where")) ], pp_nonnull imports, @@ -110,7 +95,7 @@ instance (NamedThing name, Outputable name, Outputable pat, ] where pp_nonnull [] = empty - pp_nonnull xs = vcat (map (ppr sty) xs) + pp_nonnull xs = vcat (map ppr xs) pp_iface_version Nothing = empty pp_iface_version (Just n) = hsep [text "{-# INTERFACE", int n, text "#-}"] @@ -137,13 +122,13 @@ where it should return @[x, y, f, a, b]@ (remember, order important). \begin{code} -collectTopBinders :: HsBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc) +collectTopBinders :: HsBinds flexi name (InPat name) -> Bag (name,SrcLoc) collectTopBinders EmptyBinds = emptyBag collectTopBinders (MonoBind b _ _) = collectMonoBinders b collectTopBinders (ThenBinds b1 b2) = collectTopBinders b1 `unionBags` collectTopBinders b2 -collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc) +collectMonoBinders :: MonoBinds flexi name (InPat name) -> Bag (name,SrcLoc) collectMonoBinders EmptyMonoBinds = emptyBag collectMonoBinders (PatMonoBind pat grhss_w_binds loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat)) collectMonoBinders (FunMonoBind f _ matches loc) = unitBag (f,loc) diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 2f1594af38..759251b5fc 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -6,30 +6,26 @@ If compiled without \tr{#define COMPILING_GHC}, you get (part of) a Haskell-abstract-syntax library. With it, you get part of GHC. -[OLD COMMENT -- SOF 7/97] \begin{code} -#include "HsVersions.h" - module HsTypes ( HsType(..), HsTyVar(..), - SYN_IE(Context), SYN_IE(ClassAssertion) + Context, ClassAssertion , mkHsForAllTy , getTyVarName, replaceTyVarName , pprParendHsType - , pprContext - , cmpHsType, cmpContext + , pprContext, pprClassAssertion + , cmpHsType, cmpHsTypes, cmpContext ) where -IMP_Ubiq() +#include "HsVersions.h" -import CmdLineOpts ( opt_PprUserLength ) -import Outputable ( Outputable(..), PprStyle(..), pprQuote, interppSP ) +import Outputable import Kind ( Kind {- instance Outputable -} ) import Name ( nameOccName ) -import Pretty -import Util ( thenCmp, cmpList, isIn, panic# ) +import Util ( thenCmp, cmpList, isIn, panic ) +import GlaExts ( Int#, (<#) ) \end{code} This is the syntax for types as seen in type signatures. @@ -37,7 +33,7 @@ This is the syntax for types as seen in type signatures. \begin{code} type Context name = [ClassAssertion name] -type ClassAssertion name = (name, HsType name) +type ClassAssertion name = (name, [HsType name]) -- The type is usually a type variable, but it -- doesn't have to be when reading interface files @@ -71,7 +67,7 @@ data HsType name -- these next two are only used in unfoldings in interfaces | MonoDictTy name -- Class - (HsType name) + [HsType name] mkHsForAllTy [] [] ty = ty mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty @@ -101,27 +97,27 @@ replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k \begin{code} instance (Outputable name) => Outputable (HsType name) where - ppr sty ty = pprQuote sty $ \ sty -> pprHsType sty ty + ppr ty = pprHsType ty instance (Outputable name) => Outputable (HsTyVar name) where - ppr sty (UserTyVar name) = ppr sty name - ppr sty (IfaceTyVar name kind) = pprQuote sty $ \ sty -> - hsep [ppr sty name, ptext SLIT("::"), ppr sty kind] + ppr (UserTyVar name) = ppr name + ppr (IfaceTyVar name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind] -ppr_forall sty ctxt_prec [] [] ty - = ppr_mono_ty sty ctxt_prec ty -ppr_forall sty ctxt_prec tvs ctxt ty +ppr_forall ctxt_prec [] [] ty + = ppr_mono_ty ctxt_prec ty +ppr_forall ctxt_prec tvs ctxt ty = maybeParen (ctxt_prec >= pREC_FUN) $ - sep [ptext SLIT("_forall_"), brackets (interppSP sty tvs), - pprContext sty ctxt, ptext SLIT("=>"), - pprHsType sty ty] - -pprContext :: (Outputable name) => PprStyle -> (Context name) -> Doc -pprContext sty [] = empty -pprContext sty context - = pprQuote sty $ \ sty -> parens (hsep (punctuate comma (map ppr_assert context))) - where - ppr_assert (clas, ty) = hsep [ppr sty clas, ppr sty ty] + sep [ptext SLIT("_forall_"), brackets (interppSP tvs), + pprContext ctxt, ptext SLIT("=>"), + pprHsType ty] + +pprContext :: (Outputable name) => Context name -> SDoc +pprContext [] = empty +pprContext context = parens (hsep (punctuate comma (map pprClassAssertion context))) + +pprClassAssertion :: (Outputable name) => ClassAssertion name -> SDoc +pprClassAssertion (clas, tys) + = ppr clas <+> hsep (map ppr tys) \end{code} \begin{code} @@ -129,41 +125,41 @@ pREC_TOP = (0 :: Int) pREC_FUN = (1 :: Int) pREC_CON = (2 :: Int) -maybeParen :: Bool -> Doc -> Doc +maybeParen :: Bool -> SDoc -> SDoc maybeParen True p = parens p maybeParen False p = p -- printing works more-or-less as for Types -pprHsType, pprParendHsType :: (Outputable name) => PprStyle -> HsType name -> Doc +pprHsType, pprParendHsType :: (Outputable name) => HsType name -> SDoc -pprHsType sty ty = ppr_mono_ty sty pREC_TOP ty -pprParendHsType sty ty = ppr_mono_ty sty pREC_CON ty +pprHsType ty = ppr_mono_ty pREC_TOP ty +pprParendHsType ty = ppr_mono_ty pREC_CON ty -ppr_mono_ty sty ctxt_prec (HsPreForAllTy ctxt ty) = ppr_forall sty ctxt_prec [] ctxt ty -ppr_mono_ty sty ctxt_prec (HsForAllTy tvs ctxt ty) = ppr_forall sty ctxt_prec tvs ctxt ty +ppr_mono_ty ctxt_prec (HsPreForAllTy ctxt ty) = ppr_forall ctxt_prec [] ctxt ty +ppr_mono_ty ctxt_prec (HsForAllTy tvs ctxt ty) = ppr_forall ctxt_prec tvs ctxt ty -ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty name +ppr_mono_ty ctxt_prec (MonoTyVar name) = ppr name -ppr_mono_ty sty ctxt_prec (MonoFunTy ty1 ty2) - = let p1 = ppr_mono_ty sty pREC_FUN ty1 - p2 = ppr_mono_ty sty pREC_TOP ty2 +ppr_mono_ty ctxt_prec (MonoFunTy ty1 ty2) + = let p1 = ppr_mono_ty pREC_FUN ty1 + p2 = ppr_mono_ty pREC_TOP ty2 in maybeParen (ctxt_prec >= pREC_FUN) (sep [p1, (<>) (ptext SLIT("-> ")) p2]) -ppr_mono_ty sty ctxt_prec (MonoTupleTy _ tys) - = parens (sep (punctuate comma (map (ppr sty) tys))) +ppr_mono_ty ctxt_prec (MonoTupleTy _ tys) + = parens (sep (punctuate comma (map ppr tys))) -ppr_mono_ty sty ctxt_prec (MonoListTy _ ty) - = brackets (ppr_mono_ty sty pREC_TOP ty) +ppr_mono_ty ctxt_prec (MonoListTy _ ty) + = brackets (ppr_mono_ty pREC_TOP ty) -ppr_mono_ty sty ctxt_prec (MonoTyApp fun_ty arg_ty) +ppr_mono_ty ctxt_prec (MonoTyApp fun_ty arg_ty) = maybeParen (ctxt_prec >= pREC_CON) - (hsep [ppr_mono_ty sty pREC_FUN fun_ty, ppr_mono_ty sty pREC_CON arg_ty]) + (hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty]) -ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty) - = hsep [ppr sty clas, ppr_mono_ty sty pREC_CON ty] +ppr_mono_ty ctxt_prec (MonoDictTy clas tys) + = ppr clas <+> hsep (map (ppr_mono_ty pREC_CON) tys) \end{code} @@ -178,20 +174,26 @@ in checking interfaces. Most any other use is likely to be {\em wrong}, so be careful! \begin{code} -cmpHsTyVar :: (a -> a -> TAG_) -> HsTyVar a -> HsTyVar a -> TAG_ ---cmpHsType :: (a -> a -> TAG_) -> HsType a -> HsType a -> TAG_ ---cmpContext :: (a -> a -> TAG_) -> Context a -> Context a -> TAG_ +cmpHsTyVar :: (a -> a -> Ordering) -> HsTyVar a -> HsTyVar a -> Ordering +cmpHsType :: (a -> a -> Ordering) -> HsType a -> HsType a -> Ordering +cmpHsTypes :: (a -> a -> Ordering) -> [HsType a] -> [HsType a] -> Ordering +cmpContext :: (a -> a -> Ordering) -> Context a -> Context a -> Ordering cmpHsTyVar cmp (UserTyVar v1) (UserTyVar v2) = v1 `cmp` v2 cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2 -cmpHsTyVar cmp (UserTyVar _) other = LT_ -cmpHsTyVar cmp other1 other2 = GT_ +cmpHsTyVar cmp (UserTyVar _) other = LT +cmpHsTyVar cmp other1 other2 = GT + +cmpHsTypes cmp [] [] = EQ +cmpHsTypes cmp [] tys2 = LT +cmpHsTypes cmp tys1 [] = GT +cmpHsTypes cmp (ty1:tys1) (ty2:tys2) = cmpHsType cmp ty1 ty2 `thenCmp` cmpHsTypes cmp tys1 tys2 -- We assume that HsPreForAllTys have been smashed by now. # ifdef DEBUG -cmpHsType _ (HsPreForAllTy _ _) _ = panic# "cmpHsType:HsPreForAllTy:1st arg" -cmpHsType _ _ (HsPreForAllTy _ _) = panic# "cmpHsType:HsPreForAllTy:2nd arg" +cmpHsType _ (HsPreForAllTy _ _) _ = panic "cmpHsType:HsPreForAllTy:1st arg" +cmpHsType _ _ (HsPreForAllTy _ _) = panic "cmpHsType:HsPreForAllTy:2nd arg" # endif cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2) @@ -213,21 +215,21 @@ cmpHsType cmp (MonoTyApp fun_ty1 arg_ty1) (MonoTyApp fun_ty2 arg_ty2) cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2) = cmpHsType cmp a1 a2 `thenCmp` cmpHsType cmp b1 b2 -cmpHsType cmp (MonoDictTy c1 ty1) (MonoDictTy c2 ty2) - = cmp c1 c2 `thenCmp` cmpHsType cmp ty1 ty2 +cmpHsType cmp (MonoDictTy c1 tys1) (MonoDictTy c2 tys2) + = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2 cmpHsType cmp ty1 ty2 -- tags must be different = let tag1 = tag ty1 tag2 = tag ty2 in - if tag1 _LT_ tag2 then LT_ else GT_ + if tag1 _LT_ tag2 then LT else GT where tag (MonoTyVar n1) = (ILIT(1) :: FAST_INT) tag (MonoTupleTy _ tys1) = ILIT(2) tag (MonoListTy _ ty1) = ILIT(3) tag (MonoTyApp tc1 tys1) = ILIT(4) tag (MonoFunTy a1 b1) = ILIT(5) - tag (MonoDictTy c1 ty1) = ILIT(7) + tag (MonoDictTy c1 tys1) = ILIT(7) tag (HsForAllTy _ _ _) = ILIT(8) tag (HsPreForAllTy _ _) = ILIT(9) @@ -235,6 +237,6 @@ cmpHsType cmp ty1 ty2 -- tags must be different cmpContext cmp a b = cmpList cmp_ctxt a b where - cmp_ctxt (c1, ty1) (c2, ty2) - = cmp c1 c2 `thenCmp` cmpHsType cmp ty1 ty2 + cmp_ctxt (c1, tys1) (c2, tys2) + = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2 \end{code} diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index d6085f34d6..09de84a969 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -4,8 +4,6 @@ \section[CmdLineOpts]{Things to do with command-line options} \begin{code} -#include "HsVersions.h" - module CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), @@ -57,6 +55,7 @@ module CmdLineOpts ( opt_IgnoreIfacePragmas, opt_IrrefutableTuples, opt_LiberateCaseThreshold, + opt_MultiParamClasses, opt_NoImplicitPrelude, opt_NumbersStrict, opt_OmitBlackHoling, @@ -95,31 +94,17 @@ module CmdLineOpts ( opt_WarnMissingMethods, opt_WarnDuplicateExports, opt_PruneTyDecls, opt_PruneInstDecls, - opt_D_show_unused_imports, - opt_D_show_rn_stats, - - all_toplev_ids_visible + opt_D_show_rn_stats ) where -IMPORT_1_3(Array(array, (//))) -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -import PreludeGlaST -- bad bad bad boy, Will (_Array internals) -#else +#include "HsVersions.h" + +import Array ( array, (//) ) import GlaExts import ArrBase -#if __GLASGOW_HASKELL__ >= 209 -import Addr -#endif --- 2.04 and later exports Lift from GlaExts -#if __GLASGOW_HASKELL__ < 204 -import PrelBase (Lift(..)) -#endif -#endif - -CHK_Ubiq() -- debugging consistency check - import Argv import Constants -- Default values for some flags + import Maybes ( assocMaybe, firstJust, maybeToBool ) import Util ( startsWith, panic, panic#, assertPanic ) \end{code} @@ -310,10 +295,10 @@ opt_FoldrBuildOn = lookUp SLIT("-ffoldr-build-on") opt_ForConcurrent = lookUp SLIT("-fconcurrent") opt_GranMacros = lookUp SLIT("-fgransim") opt_GlasgowExts = lookUp SLIT("-fglasgow-exts") ---UNUSED:opt_Haskell_1_3 = lookUp SLIT("-fhaskell-1.3") opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas") opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples") +opt_MultiParamClasses = opt_GlasgowExts opt_NoImplicitPrelude = lookUp SLIT("-fno-implicit-prelude") opt_NumbersStrict = lookUp SLIT("-fnumbers-strict") opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing") @@ -356,27 +341,11 @@ opt_WarnMissingMethods = lookUp SLIT("-fwarn-missing-methods") opt_WarnDuplicateExports = lookUp SLIT("-fwarn-duplicate-exports") opt_PruneTyDecls = not (lookUp SLIT("-fno-prune-tydecls")) opt_PruneInstDecls = not (lookUp SLIT("-fno-prune-instdecls")) -opt_D_show_unused_imports = lookUp SLIT("-dshow-unused-imports") opt_D_show_rn_stats = lookUp SLIT("-dshow-rn-stats") -- opt_UnfoldingOverrideThreshold = lookup_int "-funfolding-override-threshold" \end{code} - -\begin{code} -all_toplev_ids_visible :: Bool -all_toplev_ids_visible = - not opt_OmitInterfacePragmas || -- Pragmas can make them visible - opt_EnsureSplittableC || -- Splitting requires visiblilty - opt_AutoSccsOnAllToplevs -- ditto for profiling - -- (ToDo: fix up the auto-annotation - -- pass in the desugarer to avoid having - -- to do this) - -\end{code} - - - \begin{code} classifyOpts :: ([CoreToDo], -- Core-to-Core processing spec [StgToDo]) -- STG-to-STG processing spec diff --git a/ghc/compiler/main/Constants.lhs b/ghc/compiler/main/Constants.lhs index 75adfaeda3..96a01b7dd1 100644 --- a/ghc/compiler/main/Constants.lhs +++ b/ghc/compiler/main/Constants.lhs @@ -8,8 +8,6 @@ *** This SHOULD BE the only module that is CPP'd with "stgdefs.h" stuff. \begin{code} -#include "HsVersions.h" - module Constants ( uNFOLDING_USE_THRESHOLD, uNFOLDING_CREATION_THRESHOLD, @@ -72,10 +70,9 @@ module Constants ( -- we want; if we just hope a -I... will get the right one, we could -- be in trouble. +#include "HsVersions.h" #include "../../includes/GhcConstants.h" -CHK_Ubiq() -- debugging consistency check - import Util \end{code} diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index 486cb6ed07..71823f14e1 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -4,59 +4,48 @@ \section[ErrsUtils]{Utilities for error reporting} \begin{code} -#include "HsVersions.h" - module ErrUtils ( - SYN_IE(Error), SYN_IE(Warning), SYN_IE(Message), - addErrLoc, + ErrMsg, WarnMsg, Message, addShortErrLocLine, addShortWarnLocLine, dontAddErrLoc, - pprBagOfErrors, + pprBagOfErrors, pprBagOfWarnings, ghcExit, doIfSet, dumpIfSet ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import CmdLineOpts ( opt_PprUserLength ) -import Bag --( bagToList ) -import Outputable ( PprStyle(..), Outputable(..), printErrs ) -import Pretty -import SrcLoc ( noSrcLoc, SrcLoc{-instance-} ) +import Bag ( Bag, bagToList ) +import SrcLoc ( SrcLoc ) +import Outputable \end{code} \begin{code} -type Error = PprStyle -> Doc -type Warning = PprStyle -> Doc -type Message = PprStyle -> Doc +type ErrMsg = SDoc +type WarnMsg = SDoc +type Message = SDoc -addErrLoc :: SrcLoc -> String -> Error -> Error -addErrLoc locn title rest_of_err_msg sty - = hang (hcat [ppr (PprForUser opt_PprUserLength) locn, - if null title then empty else text (": " ++ title), - char ':']) - 4 (rest_of_err_msg sty) +addShortErrLocLine, addShortWarnLocLine :: SrcLoc -> ErrMsg -> ErrMsg -addShortErrLocLine, addShortWarnLocLine :: SrcLoc -> Error -> Error +addShortErrLocLine locn rest_of_err_msg + = hang (ppr locn <> colon) + 4 rest_of_err_msg -addShortErrLocLine locn rest_of_err_msg sty - = hang ((<>) (ppr (PprForUser opt_PprUserLength) locn) (char ':')) - 4 (rest_of_err_msg sty) +addShortWarnLocLine locn rest_of_err_msg + = hang (ppr locn <> ptext SLIT(": Warning:")) + 4 rest_of_err_msg -addShortWarnLocLine locn rest_of_err_msg sty - = hang ((<>) (ppr (PprForUser opt_PprUserLength) locn) (ptext SLIT(":warning:"))) - 4 (rest_of_err_msg sty) - -dontAddErrLoc :: String -> Error -> Error -dontAddErrLoc title rest_of_err_msg sty +dontAddErrLoc :: String -> ErrMsg -> ErrMsg +dontAddErrLoc title rest_of_err_msg = hang (hcat [text title, char ':']) - 4 (rest_of_err_msg sty) + 4 rest_of_err_msg + +pprBagOfErrors :: Bag ErrMsg -> SDoc +pprBagOfErrors bag_of_errors + = vcat [space $$ p | p <- bagToList bag_of_errors] -pprBagOfErrors :: PprStyle -> Bag Error -> Doc -pprBagOfErrors sty bag_of_errors - = let pretties = map ( \ e -> e sty ) (bagToList bag_of_errors) - in - vcat (map (\ p -> ($$) space p) pretties) +pprBagOfWarnings :: Bag ErrMsg -> SDoc +pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns \end{code} \begin{code} @@ -75,15 +64,14 @@ doIfSet flag action | flag = action \end{code} \begin{code} -dumpIfSet :: Bool -> String -> Doc -> IO () +dumpIfSet :: Bool -> String -> SDoc -> IO () dumpIfSet flag hdr doc | not flag = return () - | otherwise = printErrs dump + | otherwise = printDump dump where - dump = (line <+> text hdr <+> line) - $$ - doc - $$ - text "" + dump = vcat [text "", + line <+> text hdr <+> line, + doc, + text ""] line = text (take 20 (repeat '=')) \end{code} diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index a1eb377ffa..01c5a55662 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -4,13 +4,14 @@ \section[GHC_Main]{Main driver for Glasgow Haskell compiler} \begin{code} -#include "HsVersions.h" - module Main ( main ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(IO(stderr,hPutStr,hClose,openFile,IOMode(..))) +#include "HsVersions.h" +import IO ( IOMode(..), + hGetContents, hPutStr, hClose, openFile, + stdin,stderr + ) import HsSyn import RdrHsSyn ( RdrName ) import BasicTypes ( NewOrData(..) ) @@ -21,11 +22,7 @@ import RnMonad ( ExportEnv ) import MkIface -- several functions import TcModule ( typecheckModule ) -import Desugar ( deSugar, pprDsWarnings -#if __GLASGOW_HASKELL__ <= 200 - , DsMatchContext -#endif - ) +import Desugar ( deSugar, pprDsWarnings ) import SimplCore ( core2core ) import CoreToStg ( topCoreBindsToStg ) import StgSyn ( collectFinalStgBinders, pprStgBindings ) @@ -46,20 +43,13 @@ import Specialise ( SpecialiseData(..) ) import StgSyn ( GenStgBinding ) import TcInstUtil ( InstInfo ) import TyCon ( isDataTyCon ) +import Class ( classTyCon ) import UniqSupply ( mkSplitUniqSupply ) import PprAbsC ( dumpRealC, writeRealC ) import PprCore ( pprCoreBinding ) -import Pretty - -import Id ( GenId ) -- instances -import Name ( Name ) -- instances -import PprType ( GenType, GenTyVar ) -- instances -import TyVar ( GenTyVar ) -- instances -import Unique ( Unique ) -- instances - -import Outputable ( PprStyle(..), Outputable(..), pprDumpStyle, pprErrorsStyle ) - +import FiniteMap ( emptyFM ) +import Outputable \end{code} \begin{code} @@ -85,8 +75,7 @@ doIt (core_cmds, stg_cmds) _scc_ "Reader" rdModule >>= \ (mod_name, rdr_module) -> - dumpIfSet opt_D_dump_rdr "Reader" - (ppr pprDumpStyle rdr_module) >> + dumpIfSet opt_D_dump_rdr "Reader" (ppr rdr_module) >> dumpIfSet opt_D_source_stats "Source Statistics" (ppSourceStats rdr_module) >> @@ -140,7 +129,7 @@ doIt (core_cmds, stg_cmds) Nothing -> ghcExit 1; -- Type checker failed Just (all_binds, - local_tycons, local_classes, inst_info, pragma_tycon_specs, + local_tycons, local_classes, inst_info, ddump_deriv) -> @@ -157,10 +146,11 @@ doIt (core_cmds, stg_cmds) local_data_tycons = filter isDataTyCon local_tycons in core2core core_cmds mod_name - sm_uniqs local_data_tycons pragma_tycon_specs desugared + sm_uniqs local_data_tycons desugared >>= - \ (simplified, - SpecData _ _ _ gen_data_tycons all_tycon_specs _ _ _) -> + \ (simplified, spec_data + {- SpecData _ _ _ gen_data_tycons all_tycon_specs _ _ _ -} + ) -> -- ******* STG-TO-STG SIMPLIFICATION @@ -176,9 +166,7 @@ doIt (core_cmds, stg_cmds) >>= \ (stg_binds2, cost_centre_info) -> - dumpIfSet opt_D_dump_stg "STG syntax:" - (pprStgBindings pprDumpStyle stg_binds2) - >> + dumpIfSet opt_D_dump_stg "STG syntax:" (pprStgBindings stg_binds2) >> -- Dump instance decls and type signatures into the interface file let @@ -195,10 +183,17 @@ doIt (core_cmds, stg_cmds) show_pass "CodeGen" >> _scc_ "CodeGen" let + all_local_data_tycons = filter isDataTyCon (map classTyCon local_classes) + ++ local_data_tycons + -- Generate info tables for the data constrs arising + -- from class decls as well + + all_tycon_specs = emptyFM -- Not specialising tycons any more + abstractC = codeGen mod_name -- module name for CC labelling cost_centre_info imported_modules -- import names for CC registering - gen_data_tycons -- type constructors generated locally + all_local_data_tycons -- type constructors generated locally all_tycon_specs -- tycon specialisations stg_binds2 @@ -364,7 +359,7 @@ ppSourceStats (HsModule name version exports imports fixities decls src_loc) data_info (TyData _ _ _ _ constrs derivs _ _) = (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds}) - class_info (ClassDecl _ _ _ meth_sigs def_meths _ _) + class_info (ClassDecl _ _ _ meth_sigs def_meths _ _ _ _) = case count_sigs meth_sigs of (_,classops,_,_) -> (classops, addpr (count_monobinds def_meths)) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 2b3e68a029..255dc59833 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -4,77 +4,68 @@ \section[MkIface]{Print an interface for a module} \begin{code} -#include "HsVersions.h" - module MkIface ( startIface, endIface, ifaceMain, ifaceDecls ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(IO(Handle,hPutStr,openFile,hClose,IOMode(..))) +#include "HsVersions.h" + +import IO ( Handle, hPutStr, openFile, hClose, IOMode(..) ) import HsSyn import RdrHsSyn ( RdrName(..) ) -import RnHsSyn ( SYN_IE(RenamedHsModule) ) -import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) ) +import RnHsSyn ( RenamedHsModule ) +import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..), + pprModule + ) import RnMonad import RnEnv ( availName, ifaceFlavour ) import TcInstUtil ( InstInfo(..) ) +import WorkWrap ( getWorkerIdAndCons ) import CmdLineOpts import Id ( idType, dataConRawArgTys, dataConFieldLabels, getIdInfo, getInlinePragma, omitIfaceSigForId, dataConStrictMarks, StrictnessMark(..), - SYN_IE(IdSet), idSetToList, unionIdSets, unitIdSet, minusIdSet, - isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet, pprId, - GenId{-instance NamedThing/Outputable-}, SYN_IE(Id) + IdSet, idSetToList, unionIdSets, unitIdSet, minusIdSet, + isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet, + pprId, + Id ) -import IdInfo ( StrictnessInfo, ArityInfo, +import IdInfo ( IdInfo, StrictnessInfo, ArityInfo, arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo, - workerExists, bottomIsGuaranteed, IdInfo + bottomIsGuaranteed, workerExists, ) -import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding), GenCoreExpr, GenCoreBinding(..) ) +import CoreSyn ( CoreExpr, CoreBinding, GenCoreExpr, GenCoreBinding(..) ) import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding ) import FreeVars ( addExprFVs ) -import WorkWrap ( getWorkerIdAndCons ) import Name ( isLocallyDefined, isWiredInName, modAndOcc, nameModule, pprOccName, OccName, occNameString, nameOccName, nameString, isExported, Name {-instance NamedThing-}, Provenance, NamedThing(..) ) -import TyCon ( TyCon {-instance NamedThing-}, - isSynTyCon, isAlgTyCon, isNewTyCon, tyConDataCons, - tyConTheta, tyConTyVars, - getSynTyConDefn +import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, + tyConTheta, tyConTyVars, tyConDataCons ) -import Class ( GenClass(..){-instance NamedThing-}, SYN_IE(Class), classBigSig ) -import FieldLabel ( FieldLabel{-instance NamedThing-}, - fieldLabelName, fieldLabelType ) -import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitSigmaTy, - mkTyVarTy, SYN_IE(Type) +import Class ( Class, classBigSig ) +import FieldLabel ( fieldLabelName, fieldLabelType ) +import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, + mkTyVarTys, Type, ThetaType ) -import TyVar ( GenTyVar {- instance Eq -} ) -import Unique ( Unique {- instance Eq -} ) import PprEnv -- not sure how much... -import Outputable ( PprStyle(..), Outputable(..) ) import PprType import PprCore ( pprIfaceUnfolding ) -import Pretty -import Outputable ( printDoc ) - import Bag ( bagToList, isEmptyBag ) import Maybes ( catMaybes, maybeToBool ) import FiniteMap ( emptyFM, addToFM, addToFM_C, lookupFM, fmToList, eltsFM, FiniteMap ) import UniqFM ( UniqFM, lookupUFM, listToUFM ) -import Util ( sortLt, zipWithEqual, zipWith3Equal, mapAccumL, - assertPanic, panic{-ToDo:rm-}, pprTrace, - pprPanic - ) +import Util ( sortLt, zipWithEqual, zipWith3Equal, mapAccumL ) +import Outputable \end{code} We have a function @startIface@ to open the output file and put @@ -155,20 +146,22 @@ ifaceUsages if_hdl import_usages = hPutStr if_hdl "_usages_\n" >> hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages) where - upp_uses (m, hif, mv, versions) - = hsep [upp_module m, pp_hif hif, int mv, ptext SLIT("::"), - upp_import_versions (sort_versions versions) + upp_uses (m, hif, mv, whats_imported) + = hsep [pprModule m, pp_hif hif, int mv, ptext SLIT("::"), + upp_import_versions whats_imported ] <> semi - -- For imported versions we do print the version number - upp_import_versions nvs - = hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- nvs ] + -- Importing the whole module is indicated by an empty list + upp_import_versions Everything = empty + -- For imported versions we do print the version number + upp_import_versions (Specifically nvs) + = hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- sort_versions nvs ] ifaceInstanceModules if_hdl [] = return () ifaceInstanceModules if_hdl imods = hPutStr if_hdl "_instance_modules_\n" >> - printDoc OneLineMode if_hdl (hsep (map ptext (sortLt (<) imods))) >> + printForIface if_hdl (hsep (map ptext (sortLt (<) imods))) >> hPutStr if_hdl "\n" ifaceExports if_hdl [] = return () @@ -188,7 +181,7 @@ ifaceExports if_hdl avails -- Print one module's worth of stuff do_one_module (mod_name, avails@(avail1:_)) = hsep [pp_hif (ifaceFlavour (availName avail1)), - upp_module mod_name, + pprModule mod_name, hsep (map upp_avail (sortLt lt_avail avails)) ] <> semi @@ -229,12 +222,12 @@ ifaceInstances if_hdl inst_infos -- occurrence, and this makes as good a sort order as any ------- - pp_inst (InstInfo clas tvs ty theta _ dfun_id _ _ _) + pp_inst (InstInfo clas tvs tys theta _ dfun_id _ _ _) = let - forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty) + forall_ty = mkSigmaTy tvs theta (mkDictTy clas tys) renumbered_ty = nmbrGlobalType forall_ty in - hcat [ptext SLIT("instance "), ppr_ty renumbered_ty, + hcat [ptext SLIT("instance "), pprType renumbered_ty, ptext SLIT(" = "), ppr_unqual_name dfun_id, semi] \end{code} @@ -255,7 +248,7 @@ ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added -> Bool -- True <=> recursive, so don't print unfolding -> Id -> CoreExpr -- The Id's right hand side - -> Maybe (Doc, IdSet) -- The emitted stuff, plus a possibly-augmented set of needed Ids + -> Maybe (SDoc, IdSet) -- The emitted stuff, plus a possibly-augmented set of needed Ids ifaceId get_idinfo needed_ids is_rec id rhs | not (id `elementOfIdSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId] @@ -269,24 +262,25 @@ ifaceId get_idinfo needed_ids is_rec id rhs idinfo = get_idinfo id inline_pragma = getInlinePragma id - ty_pretty = pprType PprInterface (nmbrGlobalType (idType id)) - sig_pretty = hcat [ppr PprInterface (getOccName id), ptext SLIT(" _:_ "), ty_pretty] + ty_pretty = pprType (nmbrGlobalType (idType id)) + sig_pretty = hcat [ppr (getOccName id), ptext SLIT(" _:_ "), ty_pretty] prag_pretty | opt_OmitInterfacePragmas = empty | otherwise = hsep [arity_pretty, strict_pretty, unfold_pretty, pp_double_semi] ------------ Arity -------------- - arity_pretty = ppArityInfo PprInterface (arityInfo idinfo) + arity_pretty = ppArityInfo (arityInfo idinfo) ------------ Strictness -------------- strict_info = strictnessInfo idinfo has_worker = workerExists strict_info - strict_pretty = ppStrictnessInfo PprInterface strict_info <+> wrkr_pretty + strict_pretty = ppStrictnessInfo strict_info <+> wrkr_pretty wrkr_pretty | not has_worker = empty - | null con_list = pprId PprInterface work_id - | otherwise = pprId PprInterface work_id <+> braces (hsep (map (pprId PprInterface) con_list)) + | null con_list = pprId work_id + | otherwise = pprId work_id <+> + braces (hsep (map (pprId) con_list)) (work_id, wrapper_cons) = getWorkerIdAndCons id rhs con_list = idSetToList wrapper_cons @@ -338,20 +332,20 @@ ifaceBinds :: Handle -> IO () ifaceBinds hdl needed_ids final_ids binds - = mapIO (printDoc OneLineMode hdl) pretties >> + = mapIO (printForIface hdl) pretties >> hPutStr hdl "\n" where final_id_map = listToUFM [(id,id) | id <- final_ids] get_idinfo id = case lookupUFM final_id_map id of Just id' -> getIdInfo id' - Nothing -> pprTrace "ifaceBinds not found:" (ppr PprDebug id) $ + Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $ getIdInfo id pretties = go needed_ids (reverse binds) -- Reverse so that later things will -- provoke earlier ones to be emitted go needed [] = if not (isEmptyIdSet needed) then pprTrace "ifaceBinds: free vars:" - (sep (map (ppr PprDebug) (idSetToList needed))) $ + (sep (map ppr (idSetToList needed))) $ [] else [] @@ -371,7 +365,7 @@ ifaceBinds hdl needed_ids final_ids binds needed'' = needed' `minusIdSet` mkIdSet (map fst pairs) -- Later ones may spuriously cause earlier ones to be "needed" again - go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [Doc]) + go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [SDoc]) go_rec needed pairs | null pretties = (needed, []) | otherwise = (final_needed, more_pretties ++ pretties) @@ -400,32 +394,31 @@ ifaceClasses hdl classes = hPutCol hdl upp_class (sortLt (<) (filter (for_iface_ for_iface_name name = isLocallyDefined name && not (isWiredInName name) -upp_tycon tycon = ifaceTyCon PprInterface tycon -upp_class clas = ifaceClass PprInterface clas +upp_tycon tycon = ifaceTyCon tycon +upp_class clas = ifaceClass clas \end{code} \begin{code} -ifaceTyCon :: PprStyle -> TyCon -> Doc - -ifaceTyCon sty tycon +ifaceTyCon :: TyCon -> SDoc +ifaceTyCon tycon | isSynTyCon tycon = hsep [ ptext SLIT("type"), - ppr sty (getName tycon), - hsep (map (pprTyVarBndr sty) tyvars), + ppr (getName tycon), + pprTyVarBndrs tyvars, ptext SLIT("="), - ppr sty ty, + ppr ty, semi ] where (tyvars, ty) = getSynTyConDefn tycon -ifaceTyCon sty tycon +ifaceTyCon tycon | isAlgTyCon tycon = hsep [ ptext keyword, - ppr_decl_context sty (tyConTheta tycon), - ppr sty (getName tycon), - hsep (map (pprTyVarBndr sty) (tyConTyVars tycon)), + ppr_decl_context (tyConTheta tycon), + ppr (getName tycon), + pprTyVarBndrs (tyConTyVars tycon), ptext SLIT("="), hsep (punctuate (ptext SLIT(" | ")) (map ppr_con (tyConDataCons tycon))), semi @@ -436,12 +429,12 @@ ifaceTyCon sty tycon ppr_con data_con | null field_labels - = hsep [ ppr sty name, + = hsep [ ppr name, hsep (map ppr_arg_ty (strict_marks `zip` arg_tys)) ] | otherwise - = hsep [ ppr sty name, + = hsep [ ppr name, braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels)) ] where @@ -450,7 +443,7 @@ ifaceTyCon sty tycon strict_marks = dataConStrictMarks data_con name = getName data_con - ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType sty ty + ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty ppr_strict_mark NotMarkedStrict = empty ppr_strict_mark MarkedStrict = ptext SLIT("! ") @@ -459,25 +452,24 @@ ifaceTyCon sty tycon -- distinction, so "!a" is a valid identifier so far as it is concerned ppr_field (strict_mark, field_label) - = hsep [ ppr sty (fieldLabelName field_label), + = hsep [ ppr (fieldLabelName field_label), ptext SLIT("::"), - ppr_strict_mark strict_mark <> pprParendType sty (fieldLabelType field_label) + ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label) ] -ifaceTyCon sty tycon - = pprPanic "pprIfaceTyDecl" (ppr PprDebug tycon) +ifaceTyCon tycon + = pprPanic "pprIfaceTyDecl" (ppr tycon) -ifaceClass sty clas +ifaceClass clas = hsep [ptext SLIT("class"), - ppr_decl_context sty theta, - ppr sty clas, -- Print the name - pprTyVarBndr sty clas_tyvar, + ppr_decl_context sc_theta, + ppr clas, -- Print the name + pprTyVarBndrs clas_tyvars, pp_ops, semi ] where - (clas_tyvar, super_classes, _, sel_ids, defms) = classBigSig clas - theta = super_classes `zip` repeat (mkTyVarTy clas_tyvar) + (clas_tyvars, sc_theta, _, sel_ids, defms) = classBigSig clas pp_ops | null sel_ids = empty | otherwise = hsep [ptext SLIT("where"), @@ -485,23 +477,23 @@ ifaceClass sty clas ] ppr_classop sel_id maybe_defm - = ASSERT( sel_tyvars == [clas_tyvar]) - hsep [ppr sty (getOccName sel_id), + = ASSERT( sel_tyvars == clas_tyvars) + hsep [ppr (getOccName sel_id), if maybeToBool maybe_defm then equals else empty, ptext SLIT("::"), - ppr sty op_ty + ppr op_ty ] where (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id) -ppr_decl_context :: PprStyle -> [(Class,Type)] -> Doc -ppr_decl_context sty [] = empty -ppr_decl_context sty theta +ppr_decl_context :: ThetaType -> SDoc +ppr_decl_context [] = empty +ppr_decl_context theta = braces (hsep (punctuate comma (map (ppr_dict) theta))) <> ptext SLIT(" =>") where - ppr_dict (clas,ty) = hsep [ppr sty clas, ppr sty ty] + ppr_dict (clas,tys) = ppr clas <+> hsep (map pprParendType tys) \end{code} %************************************************************************ @@ -528,32 +520,13 @@ upp_avail (AvailTC name ns) = hcat [upp_occname (getOccName name), bang, upp_exp upp_export [] = empty upp_export names = parens (hsep (map (upp_occname . getOccName) names)) -upp_fixity (occ, (Fixity prec dir, prov)) = hcat [upp_dir dir, space, - int prec, space, - upp_occname occ, semi] -upp_dir InfixR = ptext SLIT("infixr") -upp_dir InfixL = ptext SLIT("infixl") -upp_dir InfixN = ptext SLIT("infix") +upp_fixity (occ, fixity) = hcat [ppr fixity, space, upp_occname occ, semi] -ppr_unqual_name :: NamedThing a => a -> Doc -- Just its occurrence name +ppr_unqual_name :: NamedThing a => a -> SDoc -- Just its occurrence name ppr_unqual_name name = upp_occname (getOccName name) -ppr_name :: NamedThing a => a -> Doc -- Its full name -ppr_name n = ptext (nameString (getName n)) - -upp_occname :: OccName -> Doc +upp_occname :: OccName -> SDoc upp_occname occ = ptext (occNameString occ) - -upp_module :: Module -> Doc -upp_module mod = ptext mod - -uppSemid x = ppr PprInterface x <> semi -- micro util - -ppr_ty ty = pprType PprInterface ty -ppr_tyvar tv = ppr PprInterface tv -ppr_tyvar_bndr tv = pprTyVarBndr PprInterface tv - -ppr_decl decl = ppr PprInterface decl <> semi \end{code} @@ -591,10 +564,10 @@ lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2 \begin{code} hPutCol :: Handle - -> (a -> Doc) + -> (a -> SDoc) -> [a] -> IO () -hPutCol hdl fmt xs = mapIO (printDoc OneLineMode hdl . fmt) xs +hPutCol hdl fmt xs = mapIO (printForIface hdl . fmt) xs mapIO :: (a -> IO b) -> [a] -> IO () mapIO f [] = return () diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index ee394ef5a2..759fedc73a 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -3,18 +3,15 @@ % \begin{code} -#include "HsVersions.h" - module AbsCStixGen ( genCodeAbstractC ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(Ratio(Rational)) +#include "HsVersions.h" + +import Ratio ( Rational ) import AbsCSyn import Stix - import MachMisc -import MachRegs import AbsCUtils ( getAmodeRep, mixedTypeLocn, nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList @@ -33,7 +30,7 @@ import PrimRep ( isFloatingRep, PrimRep(..) ) import StixInfo ( genCodeInfoTable ) import StixMacro ( macroCode ) import StixPrim ( primCode, amodeToStix, amodeToStix' ) -import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) ) +import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM ) import Util ( naturalMergeSortLe, panic ) #ifdef REALLY_HASKELL_1_3 diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index 5e1243e64d..1edfe9a515 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -3,12 +3,11 @@ % \begin{code} -#include "HsVersions.h" - module AsmCodeGen ( writeRealAsm, dumpRealAsm ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(IO(Handle)) +#include "HsVersions.h" + +import IO ( Handle ) import MachMisc import MachRegs @@ -23,9 +22,8 @@ import PrimOp ( commutableOp, PrimOp(..) ) import PrimRep ( PrimRep{-instance Eq-} ) import RegAllocInfo ( mkMRegsState, MRegsState ) import Stix ( StixTree(..), StixReg(..), CodeSegment ) -import UniqSupply ( returnUs, thenUs, mapUs, SYN_IE(UniqSM), UniqSupply ) -import Outputable ( printDoc ) -import Pretty ( Doc, vcat, Mode(..) ) +import UniqSupply ( returnUs, thenUs, mapUs, UniqSM, UniqSupply ) +import Outputable \end{code} The 96/03 native-code generator has machine-independent and @@ -77,9 +75,9 @@ So, here we go: \begin{code} writeRealAsm :: Handle -> AbstractC -> UniqSupply -> IO () writeRealAsm handle absC us - = _scc_ "writeRealAsm" (printDoc LeftMode handle (runNCG absC us)) + = _scc_ "writeRealAsm" (printForAsm handle (runNCG absC us)) -dumpRealAsm :: AbstractC -> UniqSupply -> Doc +dumpRealAsm :: AbstractC -> UniqSupply -> SDoc dumpRealAsm = runNCG runNCG absC @@ -92,7 +90,7 @@ runNCG absC @codeGen@ is the top-level code-generation function: \begin{code} -codeGen :: [[StixTree]] -> UniqSM Doc +codeGen :: [[StixTree]] -> UniqSM SDoc codeGen trees = mapUs genMachCode trees `thenUs` \ dynamic_codes -> diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs index 5d1055bc2d..16b84fefb2 100644 --- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs +++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs @@ -4,16 +4,13 @@ \section[AsmRegAlloc]{Register allocator} \begin{code} -#include "HsVersions.h" - module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import MachCode ( SYN_IE(InstrList) ) +import MachCode ( InstrList ) import MachMisc ( Instr ) import MachRegs - import RegAllocInfo import AbsCSyn ( MagicId ) @@ -26,6 +23,7 @@ import OrdList ( mkEmptyList, mkUnitList, mkSeqList, mkParList, import Stix ( StixTree ) import Unique ( mkBuiltinUnique ) import Util ( mapAccumB, panic ) +import GlaExts ( trace ) \end{code} This is the generic register allocator. diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 51e6197bed..66f6cf3392 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -9,13 +9,11 @@ This is a big module, but, if you pay attention to structure should not be too overwhelming. \begin{code} +module MachCode ( stmt2Instrs, asmVoid, InstrList ) where + #include "HsVersions.h" #include "nativeGen/NCG.h" -module MachCode ( stmt2Instrs, asmVoid, SYN_IE(InstrList) ) where - -IMP_Ubiq(){-uitious-} - import MachMisc -- may differ per-platform import MachRegs @@ -24,17 +22,15 @@ import AbsCUtils ( magicIdPrimRep ) import CLabel ( isAsmTemp, CLabel ) import Maybes ( maybeToBool, expectJust ) import OrdList -- quite a bit of it -import Outputable ( PprStyle(..) ) -import Pretty ( ptext, rational ) import PrimRep ( isFloatingRep, PrimRep(..) ) import PrimOp ( PrimOp(..), showPrimOp ) import Stix ( getUniqLabelNCG, StixTree(..), StixReg(..), CodeSegment(..) ) import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs, - mapAccumLUs, SYN_IE(UniqSM) + mapAccumLUs, UniqSM ) -import Util ( panic, assertPanic ) +import Outputable \end{code} Code extractor for an entire stix tree---stix statement level. @@ -755,7 +751,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps src1 = registerName register tmp src2 = ImmInt (fromInteger y) code__2 dst = code . - mkSeqInstr (LEA sz (OpAddr (Address (Just src1) Nothing src2)) (OpReg dst)) + mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst)) in returnUs (Any IntRep code__2) @@ -812,7 +808,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps code2 = registerCode register2 tmp2 asmVoid src2 = registerName register2 tmp2 code__2 dst = asmParThen [code1, code2] . - mkSeqInstr (LEA sz (OpAddr (Address (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst)) + mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst)) in returnUs (Any IntRep code__2) @@ -827,7 +823,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps src1 = registerName register tmp src2 = ImmInt (-(fromInteger y)) code__2 dst = code . - mkSeqInstr (LEA sz (OpAddr (Address (Just src1) Nothing src2)) (OpReg dst)) + mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst)) in returnUs (Any IntRep code__2) @@ -870,10 +866,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps src2 = ImmInt (fromInteger i) code__2 = asmParThen [code1] . mkSeqInstrs [-- we put src2 in (ebx) - MOV L (OpImm src2) (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1))), + MOV L (OpImm src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))), MOV L (OpReg src1) (OpReg eax), CLTD, - IDIV sz (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1)))] + IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))] in returnUs (Fixed IntRep (if is_division then eax else edx) code__2) @@ -893,10 +889,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps CLTD, IDIV sz (OpReg src2)] else mkSeqInstrs [ -- we put src2 in (ebx) - MOV L (OpReg src2) (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1))), + MOV L (OpReg src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))), MOV L (OpReg src1) (OpReg eax), CLTD, - IDIV sz (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1)))] + IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))] in returnUs (Fixed IntRep (if is_division then eax else edx) code__2) ----------------------- @@ -1011,7 +1007,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps DoubleSinhOp -> (False, SLIT("sinh")) DoubleCoshOp -> (False, SLIT("cosh")) DoubleTanhOp -> (False, SLIT("tanh")) - _ -> panic ("Monadic PrimOp not handled: " ++ showPrimOp PprDebug primop) + _ -> panic ("Monadic PrimOp not handled: " ++ showPrimOp primop) getRegister (StPrim primop [x, y]) -- dyadic PrimOps = case primop of @@ -1133,7 +1129,7 @@ getRegister leaf @Amode@s: Memory addressing modes passed up the tree. \begin{code} -data Amode = Amode Address InstrBlock +data Amode = Amode MachRegsAddr InstrBlock amodeAddr (Amode addr _) = addr amodeCode (Amode _ code) = code @@ -1197,7 +1193,7 @@ getAmode (StPrim IntSubOp [x, StInt i]) reg = registerName register tmp off = ImmInt (-(fromInteger i)) in - returnUs (Amode (Address (Just reg) Nothing off) code) + returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code) getAmode (StPrim IntAddOp [x, StInt i]) | maybeToBool imm @@ -1217,7 +1213,7 @@ getAmode (StPrim IntAddOp [x, StInt i]) reg = registerName register tmp off = ImmInt (fromInteger i) in - returnUs (Amode (Address (Just reg) Nothing off) code) + returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code) getAmode (StPrim IntAddOp [x, y]) = getNewRegNCG PtrRep `thenUs` \ tmp1 -> @@ -1231,7 +1227,7 @@ getAmode (StPrim IntAddOp [x, y]) reg2 = registerName register2 tmp2 code__2 = asmParThen [code1, code2] in - returnUs (Amode (Address (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2) + returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2) getAmode leaf | maybeToBool imm @@ -1251,7 +1247,7 @@ getAmode other reg = registerName register tmp off = Nothing in - returnUs (Amode (Address (Just reg) Nothing (ImmInt 0)) code) + returnUs (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2327,7 +2323,7 @@ genCCall fn kind [StInt i] call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax), MOV L (OpImm (ImmCLbl lbl)) -- this is hardwired - (OpAddr (Address (Just ebx) Nothing (ImmInt 104))), + (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 104))), JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))), LABEL lbl] in @@ -2338,11 +2334,12 @@ genCCall fn kind args = mapUs get_call_arg args `thenUs` \ argCode -> let nargs = length args + {- OLD: Since there's no attempt at stealing %esp at the moment, restoring %esp from MainRegTable.rCstkptr is not done. -- SOF 97/09 (ditto for saving away old-esp in MainRegTable.Hp (!!) ) - code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Address (Just ebx) Nothing (ImmInt 80))), - MOV L (OpAddr (Address (Just ebx) Nothing (ImmInt 100))) (OpReg esp) + code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))), + MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 100))) (OpReg esp) ] ] -} @@ -2352,7 +2349,7 @@ genCCall fn kind args ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp) --, -- Don't restore %esp (see above) - -- MOV L (OpAddr (Address (Just ebx) Nothing (ImmInt 80))) (OpReg esp) + -- MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))) (OpReg esp) ] in returnSeq (code2) call @@ -3149,8 +3146,8 @@ coerceInt2FP pk x code__2 dst = code . mkSeqInstrs [ -- to fix: should spill instead of using R1 - MOV L (OpReg src) (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1))), - FILD (primRepToSize pk) (Address (Just ebx) Nothing (ImmInt OFFSET_R1)) dst] + MOV L (OpReg src) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))), + FILD (primRepToSize pk) (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)) dst] in returnUs (Any pk code__2) @@ -3166,8 +3163,8 @@ coerceFP2Int x code__2 dst = let in code . mkSeqInstrs [ FRNDINT, - FIST L (Address (Just ebx) Nothing (ImmInt OFFSET_R1)), - MOV L (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)] + FIST L (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)), + MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)] in returnUs (Any IntRep code__2) diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index f3757ee60e..bc83dcf7d0 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -4,7 +4,6 @@ \section[MachMisc]{Description of various machine-specific things} \begin{code} -#include "HsVersions.h" #include "nativeGen/NCG.h" module MachMisc ( @@ -41,13 +40,7 @@ module MachMisc ( #endif ) where -IMPORT_1_3(Char(isDigit)) -IMP_Ubiq(){-uitous-} - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(AbsCLoop) ( fixedHdrSizeInWords, varHdrSizeInWords ) -- paranoia -IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl ) -- paranoia -#endif +#include "HsVersions.h" import AbsCSyn ( MagicId(..) ) import AbsCUtils ( magicIdPrimRep ) @@ -55,9 +48,9 @@ import CLabel ( CLabel ) import CmdLineOpts ( opt_SccProfilingOn ) import Literal ( mkMachInt, Literal(..) ) import MachRegs ( stgReg, callerSaves, RegLoc(..), - Imm(..), Reg(..), Address(..) + Imm(..), Reg(..), + MachRegsAddr(..) ) - import OrdList ( OrdList ) import PrimRep ( PrimRep(..) ) import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) @@ -65,10 +58,12 @@ import Stix ( StixTree(..), StixReg(..), sStLitLbl, CodeSegment ) import Util ( panic ) +import Char ( isDigit ) +import GlaExts ( word2Int#, int2Word#, shiftRA#, and#, (/=#) ) \end{code} \begin{code} -underscorePrefix :: Bool -- leading underscore on labels? +underscorePrefix :: Bool -- leading underscore on assembler labels? underscorePrefix = IF_ARCH_alpha(False @@ -449,12 +444,12 @@ data Instr -- Loads and stores. - | LD Size Reg Address -- size, dst, src - | LDA Reg Address -- dst, src - | LDAH Reg Address -- dst, src - | LDGP Reg Address -- dst, src + | LD Size Reg MachRegsAddr -- size, dst, src + | LDA Reg MachRegsAddr -- dst, src + | LDAH Reg MachRegsAddr -- dst, src + | LDGP Reg MachRegsAddr -- dst, src | LDI Size Reg Imm -- size, dst, src - | ST Size Reg Address -- size, src, dst + | ST Size Reg MachRegsAddr -- size, src, dst -- Int Arithmetic. @@ -509,9 +504,9 @@ data Instr | BI Cond Reg Imm | BF Cond Reg Imm | BR Imm - | JMP Reg Address Int + | JMP Reg MachRegsAddr Int | BSR Imm Int - | JSR Reg Address Int + | JSR Reg MachRegsAddr Int -- Alpha-specific pseudo-ops. @@ -572,25 +567,25 @@ data RI | FABS | FADD Size Operand -- src | FADDP - | FIADD Size Address -- src + | FIADD Size MachRegsAddr -- src | FCHS | FCOM Size Operand -- src | FCOS | FDIV Size Operand -- src | FDIVP - | FIDIV Size Address -- src + | FIDIV Size MachRegsAddr -- src | FDIVR Size Operand -- src | FDIVRP - | FIDIVR Size Address -- src - | FICOM Size Address -- src - | FILD Size Address Reg -- src, dst - | FIST Size Address -- dst + | FIDIVR Size MachRegsAddr -- src + | FICOM Size MachRegsAddr -- src + | FILD Size MachRegsAddr Reg -- src, dst + | FIST Size MachRegsAddr -- dst | FLD Size Operand -- src | FLD1 | FLDZ | FMUL Size Operand -- src | FMULP - | FIMUL Size Address -- src + | FIMUL Size MachRegsAddr -- src | FRNDINT | FSIN | FSQRT @@ -598,10 +593,10 @@ data RI | FSTP Size Operand -- dst | FSUB Size Operand -- src | FSUBP - | FISUB Size Address -- src + | FISUB Size MachRegsAddr -- src | FSUBR Size Operand -- src | FSUBRP - | FISUBR Size Address -- src + | FISUBR Size MachRegsAddr -- src | FTST | FCOMP Size Operand -- src | FUCOMPP @@ -633,7 +628,7 @@ data RI data Operand = OpReg Reg -- register | OpImm Imm -- immediate value - | OpAddr Address -- memory reference + | OpAddr MachRegsAddr -- memory reference #endif {- i386_TARGET_ARCH -} \end{code} @@ -645,8 +640,8 @@ data Operand -- Loads and stores. - | LD Size Address Reg -- size, src, dst - | ST Size Reg Address -- size, src, dst + | LD Size MachRegsAddr Reg -- size, src, dst + | ST Size Reg MachRegsAddr -- size, src, dst -- Int Arithmetic. @@ -688,7 +683,7 @@ data Operand | BI Cond Bool Imm -- cond, annul?, target | BF Cond Bool Imm -- cond, annul?, target - | JMP Address -- target + | JMP MachRegsAddr -- target | CALL Imm Int Bool -- target, args, terminal data RI = RIReg Reg diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs index d772c90667..0b01a618de 100644 --- a/ghc/compiler/nativeGen/MachRegs.lhs +++ b/ghc/compiler/nativeGen/MachRegs.lhs @@ -10,16 +10,15 @@ often/usually quite entangled with registers. modules --- the pleasure has been foregone.) \begin{code} -#include "HsVersions.h" #include "nativeGen/NCG.h" module MachRegs ( Reg(..), Imm(..), - Address(..), + MachRegsAddr(..), RegLoc(..), - SYN_IE(RegNo), + RegNo, addrOffset, argRegs, @@ -59,23 +58,21 @@ module MachRegs ( #endif ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import AbsCSyn ( MagicId(..) ) import AbsCUtils ( magicIdPrimRep ) import CLabel ( CLabel ) -import Outputable ( Outputable(..) ) -import Pretty ( Doc, text, rational ) import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) import Stix ( sStLitLbl, StixTree(..), StixReg(..), CodeSegment ) import Unique ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3, - Unique{-instance Ord3-}, Uniquable(..) + Uniquable(..), Unique ) -import UniqSupply ( getUnique, returnUs, thenUs, SYN_IE(UniqSM) ) -import Util ( panic, Ord3(..) ) +import UniqSupply ( getUnique, returnUs, thenUs, UniqSM ) +import Outputable \end{code} % - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -85,8 +82,8 @@ data Imm = ImmInt Int | ImmInteger Integer -- Sigh. | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLab Doc -- Simple string label (underscore-able) - | ImmLit Doc -- Simple string + | ImmLab SDoc -- Simple string label (underscore-able) + | ImmLit SDoc -- Simple string IF_ARCH_sparc( | LO Imm -- Possible restrictions... | HI Imm @@ -103,7 +100,7 @@ dblImmLit r % - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \begin{code} -data Address +data MachRegsAddr #if alpha_TARGET_ARCH = AddrImm Imm | AddrReg Reg @@ -111,8 +108,8 @@ data Address #endif #if i386_TARGET_ARCH - = Address Base Index Displacement - | ImmAddr Imm Int + = AddrBaseIndex Base Index Displacement + | ImmAddr Imm Int type Base = Maybe Reg type Index = Maybe (Reg, Int) -- Int is 2, 4 or 8 @@ -124,7 +121,7 @@ type Displacement = Imm | AddrRegImm Reg Imm #endif -addrOffset :: Address -> Int -> Maybe Address +addrOffset :: MachRegsAddr -> Int -> Maybe MachRegsAddr addrOffset addr off = case addr of @@ -132,10 +129,10 @@ addrOffset addr off _ -> panic "MachMisc.addrOffset not defined for Alpha" #endif #if i386_TARGET_ARCH - ImmAddr i off0 -> Just (ImmAddr i (off0 + off)) - Address r i (ImmInt n) -> Just (Address r i (ImmInt (n + off))) - Address r i (ImmInteger n) - -> Just (Address r i (ImmInt (fromInteger (n + toInteger off)))) + ImmAddr i off0 -> Just (ImmAddr i (off0 + off)) + AddrBaseIndex r i (ImmInt n) -> Just (AddrBaseIndex r i (ImmInt (n + off))) + AddrBaseIndex r i (ImmInteger n) + -> Just (AddrBaseIndex r i (ImmInt (fromInteger (n + toInteger off)))) _ -> Nothing #endif #if sparc_TARGET_ARCH @@ -251,17 +248,17 @@ applicable, is the same but for the frame pointer. \begin{code} spRel :: Int -- desired stack offset in words, positive or negative - -> Address + -> MachRegsAddr spRel n #if i386_TARGET_ARCH - = Address (Just esp) Nothing (ImmInt (n * BYTES_PER_WORD)) + = AddrBaseIndex (Just esp) Nothing (ImmInt (n * BYTES_PER_WORD)) #else = AddrRegImm sp (ImmInt (n * BYTES_PER_WORD)) #endif #if sparc_TARGET_ARCH -fpRel :: Int -> Address +fpRel :: Int -> MachRegsAddr -- Duznae work for offsets greater than 13 bits; we just hope for -- the best fpRel n @@ -313,43 +310,37 @@ instance Text Reg where #ifdef DEBUG instance Outputable Reg where - ppr sty r = text (show r) + ppr r = text (show r) #endif cmpReg (FixedReg i) (FixedReg i') = cmp_ihash i i' cmpReg (MappedReg i) (MappedReg i') = cmp_ihash i i' -cmpReg (MemoryReg i _) (MemoryReg i' _) = cmp_i i i' -cmpReg (UnmappedReg u _) (UnmappedReg u' _) = cmp u u' +cmpReg (MemoryReg i _) (MemoryReg i' _) = i `compare` i' +cmpReg (UnmappedReg u _) (UnmappedReg u' _) = compare u u' cmpReg r1 r2 = let tag1 = tagReg r1 tag2 = tagReg r2 in - if tag1 _LT_ tag2 then LT_ else GT_ + if tag1 _LT_ tag2 then LT else GT where tagReg (FixedReg _) = (ILIT(1) :: FAST_INT) tagReg (MappedReg _) = ILIT(2) tagReg (MemoryReg _ _) = ILIT(3) tagReg (UnmappedReg _ _) = ILIT(4) -cmp_i :: Int -> Int -> TAG_ -cmp_i a1 a2 = if a1 == a2 then EQ_ else if a1 < a2 then LT_ else GT_ - -cmp_ihash :: FAST_INT -> FAST_INT -> TAG_ -cmp_ihash a1 a2 = if a1 _EQ_ a2 then EQ_ else if a1 _LT_ a2 then LT_ else GT_ - -instance Ord3 Reg where - cmp = cmpReg +cmp_ihash :: FAST_INT -> FAST_INT -> Ordering +cmp_ihash a1 a2 = if a1 _EQ_ a2 then EQ else if a1 _LT_ a2 then LT else GT instance Eq Reg where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } instance Ord Reg where - a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpReg a b instance Uniquable Reg where uniqueOf (UnmappedReg u _) = u diff --git a/ghc/compiler/nativeGen/NCG.h b/ghc/compiler/nativeGen/NCG.h index c4e409ec0b..3e4d8c143c 100644 --- a/ghc/compiler/nativeGen/NCG.h +++ b/ghc/compiler/nativeGen/NCG.h @@ -1,3 +1,5 @@ +#define COMMA , + #ifndef NCG_H #define NCG_H #if 0 diff --git a/ghc/compiler/nativeGen/NcgLoop.lhi b/ghc/compiler/nativeGen/NcgLoop.lhi deleted file mode 100644 index 9086b31842..0000000000 --- a/ghc/compiler/nativeGen/NcgLoop.lhi +++ /dev/null @@ -1,16 +0,0 @@ -Breaks loops between Stix{Macro,Prim,Integer}.lhs. - -Also some CLabel dependencies on MachMisc. - -\begin{code} -interface NcgLoop where - -import AbsCSyn ( CAddrMode ) -import Stix ( StixTree ) -import MachMisc ( underscorePrefix, fmtAsmLbl ) -import StixPrim ( amodeToStix ) - -amodeToStix :: CAddrMode -> StixTree -underscorePrefix :: Bool -fmtAsmLbl :: [Char] -> [Char] -\end{code} diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 617ba89b29..bd242bf3e9 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -8,18 +8,11 @@ We start with the @pprXXX@s with some cross-platform commonality @pprInstr@. \begin{code} -#include "HsVersions.h" #include "nativeGen/NCG.h" module PprMach ( pprInstr ) where -IMPORT_1_3(Char(isPrint,isDigit)) -#if __GLASGOW_HASKELL__ == 201 -import qualified GHCbase(Addr(..)) -- to see innards -IMP_Ubiq(){-uitious-} -#else -IMP_Ubiq(){-uitious-} -#endif +#include "HsVersions.h" import MachRegs -- may differ per-platform import MachMisc @@ -30,15 +23,8 @@ import CStrings ( charToC ) import Maybes ( maybeToBool ) import OrdList ( OrdList ) import Stix ( CodeSegment(..), StixTree ) -import Pretty -- all of it - -#if __GLASGOW_HASKELL__ == 201 -a_HASH x = GHCbase.A# x -pACK_STR x = packCString x -#else -a_HASH x = A# x -pACK_STR x = mkFastCharString x --_packCString x -#endif +import Char ( isPrint, isDigit ) +import Outputable \end{code} %************************************************************************ @@ -50,7 +36,7 @@ pACK_STR x = mkFastCharString x --_packCString x For x86, the way we print a register name depends on which bit of it we care about. Yurgh. \begin{code} -pprReg :: IF_ARCH_i386(Size ->,) Reg -> Doc +pprReg :: IF_ARCH_i386(Size ->,) Reg -> SDoc pprReg IF_ARCH_i386(s,) r = case r of @@ -59,7 +45,7 @@ pprReg IF_ARCH_i386(s,) r other -> text (show other) -- should only happen when debugging where #if alpha_TARGET_ARCH - ppr_reg_no :: FAST_REG_NO -> Doc + ppr_reg_no :: FAST_REG_NO -> SDoc ppr_reg_no i = ptext (case i of { ILIT( 0) -> SLIT("$0"); ILIT( 1) -> SLIT("$1"); @@ -98,7 +84,7 @@ pprReg IF_ARCH_i386(s,) r }) #endif #if i386_TARGET_ARCH - ppr_reg_no :: Size -> FAST_REG_NO -> Doc + ppr_reg_no :: Size -> FAST_REG_NO -> SDoc ppr_reg_no B i = ptext (case i of { ILIT( 0) -> SLIT("%al"); ILIT( 1) -> SLIT("%bl"); @@ -156,7 +142,7 @@ pprReg IF_ARCH_i386(s,) r }) #endif #if sparc_TARGET_ARCH - ppr_reg_no :: FAST_REG_NO -> Doc + ppr_reg_no :: FAST_REG_NO -> SDoc ppr_reg_no i = ptext (case i of { ILIT( 0) -> SLIT("%g0"); ILIT( 1) -> SLIT("%g1"); @@ -203,7 +189,7 @@ pprReg IF_ARCH_i386(s,) r %************************************************************************ \begin{code} -pprSize :: Size -> Doc +pprSize :: Size -> SDoc pprSize x = ptext (case x of #if alpha_TARGET_ARCH @@ -237,7 +223,7 @@ pprSize x = ptext (case x of -- D -> SLIT("d") UNUSED DF -> SLIT("d") ) -pprStSize :: Size -> Doc +pprStSize :: Size -> SDoc pprStSize x = ptext (case x of B -> SLIT("b") BU -> SLIT("b") @@ -258,7 +244,7 @@ pprStSize x = ptext (case x of %************************************************************************ \begin{code} -pprCond :: Cond -> Doc +pprCond :: Cond -> SDoc pprCond c = ptext (case c of { #if alpha_TARGET_ARCH @@ -300,7 +286,7 @@ pprCond c = ptext (case c of { %************************************************************************ \begin{code} -pprImm :: Imm -> Doc +pprImm :: Imm -> SDoc pprImm (ImmInt i) = int i pprImm (ImmInteger i) = integer i @@ -314,12 +300,12 @@ pprImm (ImmLab s) | underscorePrefix = (<>) (char '_') s pprImm (LO i) = hcat [ pp_lo, pprImm i, rparen ] where - pp_lo = ptext (pACK_STR (a_HASH "%lo("#)) + pp_lo = ptext SLIT("%lo(") pprImm (HI i) = hcat [ pp_hi, pprImm i, rparen ] where - pp_hi = ptext (pACK_STR (a_HASH "%hi("#)) + pp_hi = ptext SLIT("%hi(") #endif \end{code} @@ -330,7 +316,7 @@ pprImm (HI i) %************************************************************************ \begin{code} -pprAddr :: Address -> Doc +pprAddr :: MachRegsAddr -> SDoc #if alpha_TARGET_ARCH pprAddr (AddrReg r) = parens (pprReg r) @@ -353,7 +339,7 @@ pprAddr (ImmAddr imm off) else hcat [pp_imm, char '+', int off] -pprAddr (Address base index displacement) +pprAddr (AddrBaseIndex base index displacement) = let pp_disp = ppr_disp displacement pp_off p = (<>) pp_disp (parens p) @@ -403,7 +389,7 @@ pprAddr (AddrRegImm r1 imm) %************************************************************************ \begin{code} -pprInstr :: Instr -> Doc +pprInstr :: Instr -> SDoc --pprInstr (COMMENT s) = (<>) (ptext SLIT("# ")) (ptext s) pprInstr (COMMENT s) = empty -- nuke 'em @@ -449,7 +435,7 @@ pprInstr (ASCII False{-no backslash conversion-} str) pprInstr (ASCII True str) = (<>) (text "\t.ascii \"") (asciify str 60) where - asciify :: String -> Int -> Doc + asciify :: String -> Int -> SDoc asciify [] _ = text "\\0\"" asciify s n | n <= 0 = (<>) (text "\"\n\t.ascii \"") (asciify s 60) @@ -834,8 +820,8 @@ pprInstr (FUNBEGIN clab) where pp_lab = pprCLabel_asm clab - pp_ldgp = ptext (pACK_STR (a_HASH ":\n\tldgp $29,0($27)\n"#)) - pp_frame = ptext (pACK_STR (a_HASH "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#)) + pp_ldgp = ptext SLIT(":\n\tldgp $29,0($27)\n") + pp_frame = ptext SLIT("..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1") pprInstr (FUNEND clab) = (<>) (ptext SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab) @@ -843,12 +829,12 @@ pprInstr (FUNEND clab) Continue with Alpha-only printing bits and bobs: \begin{code} -pprRI :: RI -> Doc +pprRI :: RI -> SDoc pprRI (RIReg r) = pprReg r pprRI (RIImm r) = pprImm r -pprRegRIReg :: FAST_STRING -> Reg -> RI -> Reg -> Doc +pprRegRIReg :: FAST_STRING -> Reg -> RI -> Reg -> SDoc pprRegRIReg name reg1 ri reg2 = hcat [ @@ -862,7 +848,7 @@ pprRegRIReg name reg1 ri reg2 pprReg reg2 ] -pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc +pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> SDoc pprSizeRegRegReg name size reg1 reg2 reg3 = hcat [ @@ -904,13 +890,13 @@ pprInstr (MOVSX size src dst) = pprSizeOpOpCoerce SLIT("movxs") L size src dst -- here we do some patching, since the physical registers are only set late -- in the code generation. -pprInstr (LEA size (OpAddr (Address src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3)) +pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3)) | reg1 == reg3 = pprSizeOpOp SLIT("add") size (OpReg reg2) dst -pprInstr (LEA size (OpAddr (Address src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3)) +pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3)) | reg2 == reg3 = pprSizeOpOp SLIT("add") size (OpReg reg1) dst -pprInstr (LEA size (OpAddr (Address src1@(Just reg1) Nothing displ)) dst@(OpReg reg3)) +pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) Nothing displ)) dst@(OpReg reg3)) | reg1 == reg3 = pprInstr (ADD size (OpImm displ) dst) pprInstr (LEA size src dst) = pprSizeOpOp SLIT("lea") size src dst @@ -1019,16 +1005,16 @@ pprInstr FNOP = ptext SLIT("") Continue with I386-only printing bits and bobs: \begin{code} -pprDollImm :: Imm -> Doc +pprDollImm :: Imm -> SDoc pprDollImm i = hcat [ ptext SLIT("$"), pprImm i] -pprOperand :: Size -> Operand -> Doc +pprOperand :: Size -> Operand -> SDoc pprOperand s (OpReg r) = pprReg s r pprOperand s (OpImm i) = pprDollImm i pprOperand s (OpAddr ea) = pprAddr ea -pprSizeOp :: FAST_STRING -> Size -> Operand -> Doc +pprSizeOp :: FAST_STRING -> Size -> Operand -> SDoc pprSizeOp name size op1 = hcat [ char '\t', @@ -1038,7 +1024,7 @@ pprSizeOp name size op1 pprOperand size op1 ] -pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc +pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> SDoc pprSizeOpOp name size op1 op2 = hcat [ char '\t', @@ -1050,7 +1036,7 @@ pprSizeOpOp name size op1 op2 pprOperand size op2 ] -pprSizeByteOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc +pprSizeByteOpOp :: FAST_STRING -> Size -> Operand -> Operand -> SDoc pprSizeByteOpOp name size op1 op2 = hcat [ char '\t', @@ -1062,7 +1048,7 @@ pprSizeByteOpOp name size op1 op2 pprOperand size op2 ] -pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> Doc +pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> SDoc pprSizeOpReg name size op1 reg = hcat [ char '\t', @@ -1074,7 +1060,7 @@ pprSizeOpReg name size op1 reg pprReg size reg ] -pprSizeAddr :: FAST_STRING -> Size -> Address -> Doc +pprSizeAddr :: FAST_STRING -> Size -> MachRegsAddr -> SDoc pprSizeAddr name size op = hcat [ char '\t', @@ -1084,7 +1070,7 @@ pprSizeAddr name size op pprAddr op ] -pprSizeAddrReg :: FAST_STRING -> Size -> Address -> Reg -> Doc +pprSizeAddrReg :: FAST_STRING -> Size -> MachRegsAddr -> Reg -> SDoc pprSizeAddrReg name size op dst = hcat [ char '\t', @@ -1096,7 +1082,7 @@ pprSizeAddrReg name size op dst pprReg size dst ] -pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc +pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> SDoc pprOpOp name size op1 op2 = hcat [ char '\t', @@ -1106,7 +1092,7 @@ pprOpOp name size op1 op2 pprOperand size op2 ] -pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> Doc +pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> SDoc pprSizeOpOpCoerce name size1 size2 op1 op2 = hcat [ char '\t', ptext name, space, pprOperand size1 op1, @@ -1114,7 +1100,7 @@ pprSizeOpOpCoerce name size1 size2 op1 op2 pprOperand size2 op2 ] -pprCondInstr :: FAST_STRING -> Cond -> Doc -> Doc +pprCondInstr :: FAST_STRING -> Cond -> SDoc -> SDoc pprCondInstr name cond arg = hcat [ char '\t', ptext name, pprCond cond, space, arg] @@ -1326,11 +1312,11 @@ pprInstr (CALL imm n _) Continue with SPARC-only printing bits and bobs: \begin{code} -pprRI :: RI -> Doc +pprRI :: RI -> SDoc pprRI (RIReg r) = pprReg r pprRI (RIImm r) = pprImm r -pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Doc +pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> SDoc pprSizeRegReg name size reg1 reg2 = hcat [ char '\t', @@ -1343,7 +1329,7 @@ pprSizeRegReg name size reg1 reg2 pprReg reg2 ] -pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc +pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> SDoc pprSizeRegRegReg name size reg1 reg2 reg3 = hcat [ char '\t', @@ -1358,7 +1344,7 @@ pprSizeRegRegReg name size reg1 reg2 reg3 pprReg reg3 ] -pprRegRIReg :: FAST_STRING -> Bool -> Reg -> RI -> Reg -> Doc +pprRegRIReg :: FAST_STRING -> Bool -> Reg -> RI -> Reg -> SDoc pprRegRIReg name b reg1 ri reg2 = hcat [ char '\t', @@ -1371,7 +1357,7 @@ pprRegRIReg name b reg1 ri reg2 pprReg reg2 ] -pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Doc +pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> SDoc pprRIReg name b ri reg1 = hcat [ char '\t', @@ -1382,10 +1368,10 @@ pprRIReg name b ri reg1 pprReg reg1 ] -pp_ld_lbracket = ptext (pACK_STR (a_HASH "\tld\t["#)) -pp_rbracket_comma = ptext (pACK_STR (a_HASH "],"#)) -pp_comma_lbracket = ptext (pACK_STR (a_HASH ",["#)) -pp_comma_a = ptext (pACK_STR (a_HASH ",a"#)) +pp_ld_lbracket = ptext SLIT("\tld\t[") +pp_rbracket_comma = ptext SLIT("],") +pp_comma_lbracket = ptext SLIT(",[") +pp_comma_a = ptext SLIT(",a") #endif {-sparc_TARGET_ARCH-} \end{code} diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs index f6f7e6f3f3..2c30b18394 100644 --- a/ghc/compiler/nativeGen/RegAllocInfo.lhs +++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs @@ -6,7 +6,6 @@ The (machine-independent) allocator itself is in @AsmRegAlloc@. \begin{code} -#include "HsVersions.h" #include "nativeGen/NCG.h" module RegAllocInfo ( @@ -24,8 +23,8 @@ module RegAllocInfo ( regUsage, FutureLive(..), - SYN_IE(RegAssignment), - SYN_IE(RegConflicts), + RegAssignment, + RegConflicts, RegFuture(..), RegHistory(..), RegInfo(..), @@ -37,7 +36,7 @@ module RegAllocInfo ( regLiveness, spillReg, - SYN_IE(RegSet), + RegSet, elementOfRegSet, emptyRegSet, isEmptyRegSet, @@ -51,18 +50,12 @@ module RegAllocInfo ( freeRegSet ) where -#if __GLASGOW_HASKELL__ >= 202 -import GlaExts -import FastString -#else -IMP_Ubiq(){-uitous-} -import Pretty ( Doc ) -#endif -IMPORT_1_3(List(partition)) +#include "HsVersions.h" +import List ( partition ) import MachMisc import MachRegs -import MachCode ( SYN_IE(InstrList) ) +import MachCode ( InstrList ) import AbsCSyn ( MagicId ) import BitSet ( unitBS, mkBS, minusBS, unionBS, listBS, BitSet ) @@ -72,6 +65,7 @@ import OrdList ( mkUnitList, OrdList ) import PrimRep ( PrimRep(..) ) import Stix ( StixTree, CodeSegment ) import UniqSet -- quite a bit of it +import Outputable \end{code} %************************************************************************ @@ -448,7 +442,7 @@ regUsage instr = case instr of opToReg (OpImm imm) = [] opToReg (OpAddr ea) = addrToRegs ea - addrToRegs (Address base index _) = baseToReg base ++ indexToReg index + addrToRegs (AddrBaseIndex base index _) = baseToReg base ++ indexToReg index where baseToReg Nothing = [] baseToReg (Just r) = [r] indexToReg Nothing = [] @@ -538,8 +532,8 @@ regLiveness instr info@(RL live future@(FL all env)) lookup lbl = case (lookupFM env lbl) of Just rs -> rs - Nothing -> trace ("Missing " ++ (show (pprCLabel_asm lbl)) ++ - " in future?") emptyRegSet + Nothing -> pprTrace "Missing" (pprCLabel_asm lbl <+> text "in future?") + emptyRegSet in case instr of -- the rest is machine-specific... @@ -715,8 +709,8 @@ patchRegs instr env = case instr of patchOp (OpAddr ea) = OpAddr (lookupAddr ea) lookupAddr (ImmAddr imm off) = ImmAddr imm off - lookupAddr (Address base index disp) - = Address (lookupBase base) (lookupIndex index) disp + lookupAddr (AddrBaseIndex base index disp) + = AddrBaseIndex (lookupBase base) (lookupIndex index) disp where lookupBase Nothing = Nothing lookupBase (Just r) = Just (env r) diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index 1dbd660615..2e7e64cc9f 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -3,10 +3,8 @@ % \begin{code} -#include "HsVersions.h" - module Stix ( - CodeSegment(..), StixReg(..), StixTree(..), SYN_IE(StixTreeList), + CodeSegment(..), StixReg(..), StixTree(..), StixTreeList, sStLitLbl, stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg, @@ -15,8 +13,9 @@ module Stix ( getUniqLabelNCG ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(Ratio(Rational)) +#include "HsVersions.h" + +import Ratio ( Rational ) import AbsCSyn ( node, infoptr, MagicId(..) ) import AbsCUtils ( magicIdPrimRep ) @@ -24,8 +23,8 @@ import CLabel ( mkAsmTempLabel, CLabel ) import PrimRep ( PrimRep ) import PrimOp ( PrimOp ) import Unique ( Unique ) -import UniqSupply ( returnUs, thenUs, getUnique, SYN_IE(UniqSM) ) -import Pretty ( ptext, Doc ) +import UniqSupply ( returnUs, thenUs, getUnique, UniqSM ) +import Outputable \end{code} Here is the tag at the nodes of our @StixTree@. Notice its @@ -42,7 +41,7 @@ data StixTree | StInt Integer -- ** add Kind at some point | StDouble Rational | StString FAST_STRING - | StLitLbl Doc -- literal labels + | StLitLbl SDoc -- literal labels -- (will be _-prefixed on some machines) | StLitLit FAST_STRING -- innards from CLitLit | StCLbl CLabel -- labels that we might index into diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs index 56daf99c6c..cb845305a0 100644 --- a/ghc/compiler/nativeGen/StixInfo.lhs +++ b/ghc/compiler/nativeGen/StixInfo.lhs @@ -3,11 +3,9 @@ % \begin{code} -#include "HsVersions.h" - module StixInfo ( genCodeInfoTable ) where -IMP_Ubiq(){-uitious-} +#include "HsVersions.h" import AbsCSyn ( AbstractC(..), CAddrMode, ReturnInfo, RegRelative, MagicId, CStmtMacro @@ -25,8 +23,8 @@ import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..), ) import Stix -- all of it import StixPrim ( amodeToStix ) -import UniqSupply ( returnUs, SYN_IE(UniqSM) ) -import Pretty ( hcat, ptext, int, char ) +import UniqSupply ( returnUs, UniqSM ) +import Outputable ( hcat, ptext, int, char ) \end{code} Generating code for info tables (arrays of data). diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index 1d81160181..5c2f571873 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -3,20 +3,15 @@ % \begin{code} -#include "HsVersions.h" - module StixInteger ( gmpTake1Return1, gmpTake2Return1, gmpTake2Return2, gmpCompare, gmpInteger2Int, gmpInt2Integer, gmpString2Integer, encodeFloatingKind, decodeFloatingKind ) where -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(NcgLoop) ( amodeToStix ) -#else +#include "HsVersions.h" + import {-# SOURCE #-} StixPrim ( amodeToStix ) -#endif import MachMisc import MachRegs @@ -28,11 +23,11 @@ import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind ) import Stix ( getUniqLabelNCG, sStLitLbl, stgHp, stgHpLim, - StixTree(..), SYN_IE(StixTreeList), + StixTree(..), StixTreeList, CodeSegment, StixReg ) import StixMacro ( macroCode, heapCheck ) -import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) ) +import UniqSupply ( returnUs, thenUs, UniqSM ) import Util ( panic ) \end{code} diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 19fc2a11ad..ab0ecc48be 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -3,21 +3,14 @@ % \begin{code} -#include "HsVersions.h" - module StixMacro ( macroCode, heapCheck ) where -IMP_Ubiq(){-uitious-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(NcgLoop) ( amodeToStix ) -#else +#include "HsVersions.h" + import {-# SOURCE #-} StixPrim ( amodeToStix ) -#endif import MachMisc - import MachRegs - import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode ) import Constants ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE, sTD_UF_SIZE @@ -26,7 +19,7 @@ import OrdList ( OrdList ) import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) import Stix -import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) ) +import UniqSupply ( returnUs, thenUs, UniqSM ) \end{code} The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 1537e264e0..192d5f3dd0 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -3,14 +3,9 @@ % \begin{code} -#include "HsVersions.h" - module StixPrim ( primCode, amodeToStix, amodeToStix' ) where -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(NcgLoop) -- paranoia checking only -#endif +#include "HsVersions.h" import MachMisc import MachRegs @@ -26,14 +21,12 @@ import PrimOp ( PrimOp(..), isCompareOp, showPrimOp, ) import PrimRep ( PrimRep(..), isFloatingRep ) import OrdList ( OrdList ) -import Outputable ( PprStyle(..) ) import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind ) import Stix import StixMacro ( heapCheck ) import StixInteger {- everything -} -import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) ) -import Pretty ( (<>), ptext, int ) -import Util ( panic ) +import UniqSupply ( returnUs, thenUs, UniqSM ) +import Outputable #ifdef REALLY_HASKELL_1_3 ord = fromEnum :: Char -> Int @@ -485,7 +478,7 @@ simplePrim [lhs] op rest simplePrim as op bs = simplePrim_error op simplePrim_error op - = error ("ERROR: primitive operation `"++showPrimOp PprDebug op++"'cannot be handled\nby the native-code generator. Workaround: use -fvia-C.\n(Perhaps you should report it as a GHC bug, also.)\n") + = error ("ERROR: primitive operation `"++showPrimOp op++"'cannot be handled\nby the native-code generator. Workaround: use -fvia-C.\n(Perhaps you should report it as a GHC bug, also.)\n") \end{code} %--------------------------------------------------------------------- diff --git a/ghc/compiler/parser/UgenAll.lhs b/ghc/compiler/parser/UgenAll.lhs index b17b849638..0ebadb95b2 100644 --- a/ghc/compiler/parser/UgenAll.lhs +++ b/ghc/compiler/parser/UgenAll.lhs @@ -1,36 +1,27 @@ Stuff the Ugenny things show to the parser. \begin{code} -#include "HsVersions.h" - module UgenAll ( - -- re-exported Prelude stuff - returnUgn, thenUgn, - -- stuff defined in utils module - EXP_MODULE(UgenUtil) , + module UgenUtil, -- re-exported ugen-generated stuff - EXP_MODULE(U_binding) , - EXP_MODULE(U_constr) , - EXP_MODULE(U_entidt) , - EXP_MODULE(U_list) , - EXP_MODULE(U_literal) , - EXP_MODULE(U_maybe) , - EXP_MODULE(U_either) , - EXP_MODULE(U_pbinding) , - EXP_MODULE(U_qid) , - EXP_MODULE(U_tree) , - EXP_MODULE(U_ttype) + module U_binding, + module U_constr, + module U_entidt, + module U_list, + module U_literal, + module U_maybe, + module U_either, + module U_pbinding, + module U_qid, + module U_tree, + module U_ttype ) where -#if __GLASGOW_HASKELL__ <= 201 -import PreludeGlaST -#else -import GlaExts -#endif +#include "HsVersions.h" -IMP_Ubiq(){-uitous-} +import GlaExts -- friends: import U_binding diff --git a/ghc/compiler/parser/UgenUtil.lhs b/ghc/compiler/parser/UgenUtil.lhs index 11f6c59b6e..10bcca358b 100644 --- a/ghc/compiler/parser/UgenUtil.lhs +++ b/ghc/compiler/parser/UgenUtil.lhs @@ -2,107 +2,76 @@ Glues lots of things together for ugen-generated .hs files here \begin{code} -#include "HsVersions.h" - module UgenUtil ( - -- re-exported Prelude stuff - returnPrimIO, thenPrimIO, - -- stuff defined here - EXP_MODULE(UgenUtil) + module UgenUtil, + Addr ) where -IMP_Ubiq() +#include "HsVersions.h" -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -import PreludeGlaST -#else import GlaExts import Name -#endif - -#if __GLASGOW_HASKELL__ == 201 -# define ADDR GHCbase.Addr -# define PACK_STR packCString -# define PACK_BYTES packCBytes -#elif __GLASGOW_HASKELL >= 202 -# define ADDR GHC.Addr -# define PACK_STR mkFastCharString -# define PACK_BYTES mkFastCharString2 -#else -# define ADDR _Addr -# define PACK_STR mkFastCharString -# define PACK_BYTES mkFastCharString2 -#endif - import RdrHsSyn ( RdrName(..) ) import BasicTypes ( IfaceFlavour ) import SrcLoc ( mkSrcLoc, noSrcLoc, SrcLoc ) +import FastString ( FastString, mkFastCharString, mkFastCharString2 ) \end{code} \begin{code} type UgnM a - = (FAST_STRING,Module,SrcLoc) -- file, module and src_loc carried down - -> PrimIO a + = (FastString,Module,SrcLoc) -- file, module and src_loc carried down + -> IO a {-# INLINE returnUgn #-} {-# INLINE thenUgn #-} -returnUgn x stuff = returnPrimIO x +returnUgn x stuff = return x thenUgn x y stuff - = x stuff `thenPrimIO` \ z -> + = x stuff >>= \ z -> y z stuff initUgn :: UgnM a -> IO a -initUgn action - = let - do_it = action (SLIT(""),SLIT(""),noSrcLoc) - in -#if __GLASGOW_HASKELL__ >= 200 - primIOToIO do_it -#else - do_it `thenPrimIO` \ result -> - return result -#endif - -ioToUgnM :: PrimIO a -> UgnM a +initUgn action = action (SLIT(""),SLIT(""),noSrcLoc) + +ioToUgnM :: IO a -> UgnM a ioToUgnM x stuff = x \end{code} \begin{code} -type ParseTree = ADDR +type ParseTree = Addr -type U_VOID_STAR = ADDR -rdU_VOID_STAR :: ADDR -> UgnM U_VOID_STAR +type U_VOID_STAR = Addr +rdU_VOID_STAR :: Addr -> UgnM U_VOID_STAR rdU_VOID_STAR x = returnUgn x type U_long = Int rdU_long :: Int -> UgnM U_long rdU_long x = returnUgn x -type U_stringId = FAST_STRING -rdU_stringId :: ADDR -> UgnM U_stringId +type U_stringId = FastString +rdU_stringId :: Addr -> UgnM U_stringId {-# INLINE rdU_stringId #-} -rdU_stringId s = returnUgn (PACK_STR s) +rdU_stringId s = returnUgn (mkFastCharString s) type U_numId = Int -- ToDo: Int -rdU_numId :: ADDR -> UgnM U_numId +rdU_numId :: Addr -> UgnM U_numId rdU_numId i = rdU_stringId i `thenUgn` \ y -> returnUgn ((read (_UNPK_ y))::Int) -type U_hstring = FAST_STRING -rdU_hstring :: ADDR -> UgnM U_hstring +type U_hstring = FastString +rdU_hstring :: Addr -> UgnM U_hstring rdU_hstring x = ioToUgnM (_ccall_ get_hstring_len x) `thenUgn` \ len -> ioToUgnM (_ccall_ get_hstring_bytes x) `thenUgn` \ bytes -> - returnUgn (PACK_BYTES bytes len) + returnUgn (mkFastCharString2 bytes len) \end{code} \begin{code} -setSrcFileUgn :: FAST_STRING -> UgnM a -> UgnM a +setSrcFileUgn :: FastString -> UgnM a -> UgnM a setSrcFileUgn file action stuff@(_,mod,loc) = action (file,mod,loc) -getSrcFileUgn :: UgnM FAST_STRING +getSrcFileUgn :: UgnM FastString getSrcFileUgn stuff@(file,mod,loc) = returnUgn file stuff setSrcModUgn :: Module -> UgnM a -> UgnM a diff --git a/ghc/compiler/parser/binding.ugn b/ghc/compiler/parser/binding.ugn index 2f6bccaa2d..76b067ced5 100644 --- a/ghc/compiler/parser/binding.ugn +++ b/ghc/compiler/parser/binding.ugn @@ -2,10 +2,10 @@ #include "hspincl.h" %} %{{ +module U_binding where + #include "HsVersions.h" -module U_binding where -IMP_Ubiq() -- debugging consistency check import UgenUtil import U_constr @@ -34,9 +34,7 @@ type binding; gfline : long; >; abind : < gabindfst : binding; gabindsnd : binding; >; - ibind : < gibindc : list; - gibindid : qid; - gibindi : ttype; + ibind : < gibindi : ttype; gibindw : binding; giline : long; >; dbind : < gdbindts : list; diff --git a/ghc/compiler/parser/constr.ugn b/ghc/compiler/parser/constr.ugn index 65b5b67233..d4e588bdfa 100644 --- a/ghc/compiler/parser/constr.ugn +++ b/ghc/compiler/parser/constr.ugn @@ -2,10 +2,11 @@ #include "hspincl.h" %} %{{ -#include "HsVersions.h" module U_constr where -IMP_Ubiq() -- debugging consistency check + +#include "HsVersions.h" + import UgenUtil import U_maybe diff --git a/ghc/compiler/parser/either.ugn b/ghc/compiler/parser/either.ugn index f59778cdba..1917c2ec8b 100644 --- a/ghc/compiler/parser/either.ugn +++ b/ghc/compiler/parser/either.ugn @@ -2,12 +2,14 @@ #include "hspincl.h" %} %{{ -#include "HsVersions.h" module U_either where -IMP_Ubiq() -- debugging consistency check + +#include "HsVersions.h" + import UgenUtil %}} + type either; left : < gleft : VOID_STAR; > ; right : < gright : VOID_STAR; > ; diff --git a/ghc/compiler/parser/entidt.ugn b/ghc/compiler/parser/entidt.ugn index 6ae01e2dc4..026bd06d16 100644 --- a/ghc/compiler/parser/entidt.ugn +++ b/ghc/compiler/parser/entidt.ugn @@ -2,10 +2,10 @@ #include "hspincl.h" %} %{{ +module U_entidt where + #include "HsVersions.h" -module U_entidt where -IMP_Ubiq() -- debugging consistency check import UgenUtil import U_list diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y index 72d4472b57..96252550e5 100644 --- a/ghc/compiler/parser/hsparser.y +++ b/ghc/compiler/parser/hsparser.y @@ -230,7 +230,7 @@ BOOLEAN inpat; constrs constr1 fields types atypes batypes types_and_maybe_ids - pats context context_list /* tyvar_list */ + pats simple_context simple_context_list export_list enames import_list inames impdecls maybeimpdecls impdecl @@ -270,10 +270,9 @@ BOOLEAN inpat; %type <upbinding> valrhs1 altrest -%type <uttype> simple ctype sigtype sigarrowtype type atype bigatype btype - gtyconvars +%type <uttype> ctype sigtype sigarrowtype type atype bigatype btype bbtype batype bxtype wierd_atype - class tyvar contype + simple_con_app simple_con_app1 tyvar contype inst_type %type <uconstr> constr constr_after_context field @@ -284,7 +283,7 @@ BOOLEAN inpat; %type <uentid> export import -%type <ulong> commas importkey +%type <ulong> commas importkey get_line_no /********************************************************************** * * @@ -451,8 +450,8 @@ fix : INFIXL INTEGER { Precedence = checkfixity($2); Fixity = INFIXL; } ops { $$ = $3; } ; -ops : op { $$ = lsing(mkfixop(mknoqual($1),infixint(Fixity),Precedence)); } - | ops COMMA op { $$ = lapp($1,mkfixop(mknoqual($3),infixint(Fixity),Precedence)); } +ops : op { $$ = lsing(mkfixop(mknoqual($1),infixint(Fixity),Precedence,startlineno)); } + | ops COMMA op { $$ = lapp($1,mkfixop(mknoqual($3),infixint(Fixity),Precedence,startlineno)); } ; topdecls: topdecl @@ -484,19 +483,19 @@ topdecl : typed { $$ = $1; FN = NULL; SAMEFN = 0; } | decl { $$ = $1; } ; -typed : typekey simple EQUAL type { $$ = mknbind($2,$4,startlineno); } +typed : typekey simple_con_app EQUAL type { $$ = mknbind($2,$4,startlineno); } ; -datad : datakey simple EQUAL constrs deriving +datad : datakey simple_con_app EQUAL constrs deriving { $$ = mktbind(Lnil,$2,$4,$5,startlineno); } - | datakey context DARROW simple EQUAL constrs deriving + | datakey simple_context DARROW simple_con_app EQUAL constrs deriving { $$ = mktbind($2,$4,$6,$7,startlineno); } ; -newtd : newtypekey simple EQUAL constr1 deriving +newtd : newtypekey simple_con_app EQUAL constr1 deriving { $$ = mkntbind(Lnil,$2,$4,$5,startlineno); } - | newtypekey context DARROW simple EQUAL constr1 deriving + | newtypekey simple_context DARROW simple_con_app EQUAL constr1 deriving { $$ = mkntbind($2,$4,$6,$7,startlineno); } ; @@ -504,9 +503,9 @@ deriving: /* empty */ { $$ = mknothing(); } | DERIVING dtyclses { $$ = mkjust($2); } ; -classd : classkey context DARROW class cbody +classd : classkey simple_context DARROW simple_con_app1 cbody { $$ = mkcbind($2,$4,$5,startlineno); } - | classkey class cbody + | classkey simple_con_app1 cbody { $$ = mkcbind(Lnil,$2,$3,startlineno); } ; @@ -515,39 +514,22 @@ cbody : /* empty */ { $$ = mknullbind(); } | WHERE vocurly decls vccurly { checkorder($3); $$ = $3; } ; -instd : instkey context DARROW gtycon atype rinst - { $$ = mkibind($2,$4,$5,$6,startlineno); } - | instkey gtycon atype rinst - { $$ = mkibind(Lnil,$2,$3,$4,startlineno); } +instd : instkey inst_type rinst { $$ = mkibind($2,$3,startlineno); } ; +/* Compare ctype */ +inst_type : type DARROW type { is_context_format( $3, 0 ); /* Check the instance head */ + $$ = mkcontext(type2context($1),$3); } + | type { is_context_format( $1, 0 ); /* Check the instance head */ + $$ = $1; } + ; + + rinst : /* empty */ { $$ = mknullbind(); } | WHERE ocurly instdefs ccurly { $$ = $3; } | WHERE vocurly instdefs vccurly { $$ = $3; } ; -/* I now allow a general type in instance declarations, relying - on the type checker to reject instance decls which are ill-formed. - Some (non-standard) extensions of Haskell may allow more general - types than the Report syntax permits, and in any case not all things - can be checked in the syntax (eg repeated type variables). - SLPJ Jan 97 - -restrict_inst : gtycon { $$ = mktname($1); } - | OPAREN gtyconvars CPAREN { $$ = $2; } - | OPAREN tyvar COMMA tyvar_list CPAREN { $$ = mkttuple(mklcons($2,$4)); } - | OBRACK tyvar CBRACK { $$ = mktllist($2); } - | OPAREN tyvar RARROW tyvar CPAREN { $$ = mktfun($2,$4); } - ; - -general_inst : gtycon { $$ = mktname($1); } - | OPAREN gtyconapp1 CPAREN { $$ = $2; } - | OPAREN type COMMA types CPAREN { $$ = mkttuple(mklcons($2,$4)); } - | OBRACK type CBRACK { $$ = mktllist($2); } - | OPAREN btype RARROW type CPAREN { $$ = mktfun($2,$4); } - ; -*/ - defaultd: defaultkey OPAREN types CPAREN { $$ = mkdbind($3,startlineno); } | defaultkey OPAREN CPAREN { $$ = mkdbind(Lnil,startlineno); } ; @@ -721,23 +703,22 @@ commas : COMMA { $$ = 1; } * * **********************************************************************/ -simple : gtycon { $$ = mktname($1); } - | gtyconvars { $$ = $1; } +/* C a b c, where a,b,c are type variables */ +/* C can be a class or tycon */ +simple_con_app: gtycon { $$ = mktname($1); } + | simple_con_app1 { $$ = $1; } ; - -gtyconvars: gtycon tyvar { $$ = mktapp(mktname($1),$2); } - | gtyconvars tyvar { $$ = mktapp($1,$2); } + +simple_con_app1: gtycon tyvar { $$ = mktapp(mktname($1),$2); } + | simple_con_app tyvar { $$ = mktapp($1, $2); } ; -context : OPAREN context_list CPAREN { $$ = $2; } - | class { $$ = lsing($1); } +simple_context : OPAREN simple_context_list CPAREN { $$ = $2; } + | simple_con_app1 { $$ = lsing($1); } ; -context_list: class { $$ = lsing($1); } - | context_list COMMA class { $$ = lapp($1,$3); } - ; - -class : gtycon tyvar { $$ = mktapp(mktname($1),$2); } +simple_context_list: simple_con_app1 { $$ = lsing($1); } + | simple_context_list COMMA simple_con_app1 { $$ = lapp($1,$3); } ; constrs : constr { $$ = lsing($1); } @@ -873,6 +854,7 @@ instdef : valdef : vallhs + { tree fn = function($1); PREVPATT = $1; @@ -897,22 +879,27 @@ valdef : vallhs #else fprintf(stderr,"%u\tvaldef\n",startlineno); #endif - } + } + + get_line_no valrhs { if ( lhs_is_patt($1) ) { - $$ = mkpbind($3, startlineno); + $$ = mkpbind($4, $3); FN = NULL; SAMEFN = 0; } else - $$ = mkfbind($3,startlineno); + $$ = mkfbind($4, $3); PREVPATT = NULL; } ; +get_line_no : { $$ = startlineno } + ; + vallhs : patk { $$ = $1; } | patk qvarop pat { $$ = mkinfixap($2,$1,$3); } | funlhs { $$ = $1; } @@ -1047,7 +1034,12 @@ kexpLno : LAMBDA /* SCC Expression */ | SCC STRING exp { if (ignoreSCC) { - $$ = $3; + $$ = mkpar($3); /* Note the mkpar(). If we don't have it, then + (x >> _scc_ y >> z) parses as (x >> (y >> z)), + right associated. But the precedence reorganiser expects + the parser to *left* associate all operators unless there + are explicit parens. The _scc_ acts like an explicit paren, + so if we omit it we'd better add explicit parens instead. */ } else { $$ = mkscc($2, $3); } diff --git a/ghc/compiler/parser/list.ugn b/ghc/compiler/parser/list.ugn index b6c5908e15..f0db649a23 100644 --- a/ghc/compiler/parser/list.ugn +++ b/ghc/compiler/parser/list.ugn @@ -2,10 +2,10 @@ #include "hspincl.h" %} %{{ +module U_list where + #include "HsVersions.h" -module U_list where -IMP_Ubiq() -- debugging consistency check import UgenUtil %}} type list; diff --git a/ghc/compiler/parser/literal.ugn b/ghc/compiler/parser/literal.ugn index 49c68b0803..292ad9d57b 100644 --- a/ghc/compiler/parser/literal.ugn +++ b/ghc/compiler/parser/literal.ugn @@ -2,10 +2,10 @@ #include "hspincl.h" %} %{{ +module U_literal where + #include "HsVersions.h" -module U_literal where -IMP_Ubiq() -- debugging consistency check import UgenUtil %}} type literal; diff --git a/ghc/compiler/parser/maybe.ugn b/ghc/compiler/parser/maybe.ugn index cfcf959131..72d2e15c8f 100644 --- a/ghc/compiler/parser/maybe.ugn +++ b/ghc/compiler/parser/maybe.ugn @@ -2,10 +2,10 @@ #include "hspincl.h" %} %{{ +module U_maybe where + #include "HsVersions.h" -module U_maybe where -IMP_Ubiq() -- debugging consistency check import UgenUtil %}} type maybe; diff --git a/ghc/compiler/parser/pbinding.ugn b/ghc/compiler/parser/pbinding.ugn index 2d734eaafd..73c4647a0a 100644 --- a/ghc/compiler/parser/pbinding.ugn +++ b/ghc/compiler/parser/pbinding.ugn @@ -2,10 +2,10 @@ #include "hspincl.h" %} %{{ +module U_pbinding where + #include "HsVersions.h" -module U_pbinding where -IMP_Ubiq() -- debugging consistency check import UgenUtil import U_constr ( U_constr ) -- interface only diff --git a/ghc/compiler/parser/printtree.c b/ghc/compiler/parser/printtree.c index 11184880f8..3484387584 100644 --- a/ghc/compiler/parser/printtree.c +++ b/ghc/compiler/parser/printtree.c @@ -464,8 +464,6 @@ prbind(b) case ibind : PUTTAG('%'); plineno(giline(b)); - plist(pttype,gibindc(b)); - pqid(gibindid(b)); pttype(gibindi(b)); prbind(gibindw(b)); /* ppragma(gipragma(b)); */ diff --git a/ghc/compiler/parser/qid.ugn b/ghc/compiler/parser/qid.ugn index 4ecd7cf370..2d3f228be4 100644 --- a/ghc/compiler/parser/qid.ugn +++ b/ghc/compiler/parser/qid.ugn @@ -2,10 +2,10 @@ #include "hspincl.h" %} %{{ +module U_qid where + #include "HsVersions.h" -module U_qid where -IMP_Ubiq() -- debugging consistency check import UgenUtil %}} type qid; diff --git a/ghc/compiler/parser/tree.ugn b/ghc/compiler/parser/tree.ugn index 98d67c2f4d..750ad2243c 100644 --- a/ghc/compiler/parser/tree.ugn +++ b/ghc/compiler/parser/tree.ugn @@ -2,10 +2,10 @@ #include "hspincl.h" %} %{{ +module U_tree where + #include "HsVersions.h" -module U_tree where -IMP_Ubiq() -- debugging consistency check import UgenUtil import U_constr ( U_constr ) -- interface only @@ -26,7 +26,8 @@ type tree; ghmodline : long; >; fixop : < gfixop : qid; gfixinfx : long; - gfixprec : long; >; + gfixprec : long; + gfixline : long; >; ident : < gident : qid; >; lit : < glit : literal; >; diff --git a/ghc/compiler/parser/ttype.ugn b/ghc/compiler/parser/ttype.ugn index 25d451393f..d32f5eb6fa 100644 --- a/ghc/compiler/parser/ttype.ugn +++ b/ghc/compiler/parser/ttype.ugn @@ -2,10 +2,10 @@ #include "hspincl.h" %} %{{ +module U_ttype where + #include "HsVersions.h" -module U_ttype where -IMP_Ubiq() -- debugging consistency check import UgenUtil import U_list diff --git a/ghc/compiler/parser/type2context.c b/ghc/compiler/parser/type2context.c index 029da1a2ce..cee8276b0f 100644 --- a/ghc/compiler/parser/type2context.c +++ b/ghc/compiler/parser/type2context.c @@ -12,8 +12,6 @@ #include "constants.h" #include "utils.h" -static void is_context_format PROTO((ttype, int)); /* forward */ - /* partain: see also the comment by "decl" in hsparser.y. @@ -75,7 +73,7 @@ type2context(t) /* is_context_format is the same as "type2context" except that it just performs checking */ /* ttype is either "tycon" [class] or "tycon (named)tvar" [class var] */ -static void +void is_context_format(t, tyvars) ttype t; int tyvars; @@ -89,18 +87,12 @@ is_context_format(t, tyvars) /* should be just: ":: C a =>" */ if (tyvars == 0) - hsperror("is_context_format: variable missing after class name"); - - else if (tyvars > 1) - hsperror ("is_context_format: too many variables after class name"); + hsperror("is_context_format: type missing after class name"); - /* tyvars == 1; everything is cool */ + /* tyvars > 0; everything is cool */ break; case tapp: - if (tttype(gtarg(t)) != namedtvar) - hsperror ("is_context_format: something wrong with variable after class name"); - is_context_format(gtapp(t), tyvars+1); break; @@ -124,3 +116,4 @@ is_context_format(t, tyvars) } } + diff --git a/ghc/compiler/parser/utils.h b/ghc/compiler/parser/utils.h index c4f60a9e75..1a682ecbd5 100644 --- a/ghc/compiler/parser/utils.h +++ b/ghc/compiler/parser/utils.h @@ -64,6 +64,7 @@ void pprogram PROTO((tree)); void format_string PROTO((FILE *, unsigned char *, int)); list type2context PROTO((ttype)); +void is_context_format PROTO((ttype, int)); pbinding createpat PROTO((pbinding, binding)); void process_args PROTO((int, char **)); void hash_init PROTO((void)); diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 4a894b80cc..60673c3bd2 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -4,12 +4,10 @@ \section[PrelInfo]{The @PrelInfo@ interface to the compiler's prelude knowledge} \begin{code} -#include "HsVersions.h" - module PrelInfo ( -- finite maps for built-in things (for the renamer and typechecker): builtinNames, derivingOccurrences, - SYN_IE(BuiltinNames), + BuiltinNames, maybeCharLikeTyCon, maybeIntLikeTyCon, @@ -37,13 +35,9 @@ module PrelInfo ( isNumericClass, isStandardClass, isCcallishClass ) where -IMP_Ubiq() +#include "HsVersions.h" -#if __GLASGOW_HASKELL__ >= 202 import IdUtils ( primOpName ) -#else -IMPORT_DELOOPER(PrelLoop) ( primOpName ) -#endif -- friends: import PrelMods -- Prelude module names @@ -54,13 +48,13 @@ import TysPrim -- TYPES import TysWiredIn -- others: -import SpecEnv ( SpecEnv ) import RdrHsSyn ( RdrName(..), varQual, tcQual, qual ) import BasicTypes ( IfaceFlavour ) -import Id ( GenId, SYN_IE(Id) ) +import Id ( GenId, Id ) import Name ( Name, OccName(..), Provenance(..), - getName, mkGlobalName, modAndOcc ) -import Class ( Class(..), GenClass, classKey ) + getName, mkGlobalName, modAndOcc + ) +import Class ( Class, classKey ) import TyCon ( tyConDataCons, mkFunTyCon, TyCon ) import Type import Bag @@ -254,7 +248,7 @@ Ids, Synonyms, Classes and ClassOps with builtin keys. \begin{code} mkKnownKeyGlobal :: (RdrName, Unique) -> Name mkKnownKeyGlobal (Qual mod occ hif, uniq) - = mkGlobalName uniq mod occ (Implicit hif) + = mkGlobalName uniq mod occ NoProvenance allClass_NAME = mkKnownKeyGlobal (allClass_RDR, allClassKey) ioTyCon_NAME = mkKnownKeyGlobal (ioTyCon_RDR, ioTyConKey) @@ -375,8 +369,8 @@ realFracClass_RDR = tcQual (pREL_NUM, SLIT("RealFrac")) realFloatClass_RDR = tcQual (pREL_NUM, SLIT("RealFloat")) readClass_RDR = tcQual (pREL_READ, SLIT("Read")) ixClass_RDR = tcQual (iX, SLIT("Ix")) -ccallableClass_RDR = tcQual (cCALL, SLIT("CCallable")) -creturnableClass_RDR = tcQual (cCALL, SLIT("CReturnable")) +ccallableClass_RDR = tcQual (gHC__, SLIT("CCallable")) +creturnableClass_RDR = tcQual (gHC__, SLIT("CReturnable")) fromInt_RDR = varQual (pREL_BASE, SLIT("fromInt")) fromInteger_RDR = varQual (pREL_BASE, SLIT("fromInteger")) @@ -541,7 +535,8 @@ cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ] -- Renamer always imports these data decls replete with constructors -- so that desugarer can always see the constructor. Ugh! -cCallishTyKeys = [ addrTyConKey, wordTyConKey, byteArrayTyConKey, mutableByteArrayTyConKey ] +cCallishTyKeys = [ addrTyConKey, wordTyConKey, byteArrayTyConKey, + mutableByteArrayTyConKey, foreignObjTyConKey ] standardClassKeys = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys diff --git a/ghc/compiler/prelude/PrelLoop.lhi b/ghc/compiler/prelude/PrelLoop.lhi deleted file mode 100644 index 9d5d407aba..0000000000 --- a/ghc/compiler/prelude/PrelLoop.lhi +++ /dev/null @@ -1,26 +0,0 @@ -Breaks the PrelVal loop and the PrelInfo loop caused by primOpNameInfo. - -\begin{code} -interface PrelLoop where - ---import PreludePS ( _PackedString ) -import FastString ( FastSring ) - -import Class ( GenClass ) -import CoreUnfold ( mkMagicUnfolding, Unfolding ) -import IdUtils ( primOpName ) -import Name ( Name, ExportFlag ) -import PrimOp ( PrimOp ) -import RnHsSyn ( RnName ) -import Type ( mkSigmaTy, mkFunTy, mkFunTys, GenType ) -import TyVar ( GenTyVar ) -import Unique ( Unique ) -import Usage ( GenUsage ) - -mkMagicUnfolding :: Unique -> Unfolding -mkSigmaTy :: [a] -> [(GenClass (GenTyVar (GenUsage Unique)) Unique, GenType a b)] -> GenType a b -> GenType a b -mkFunTys :: [GenType a b] -> GenType a b -> GenType a b -mkFunTy :: GenType a b -> GenType a b -> GenType a b - -primOpName :: PrimOp -> Name -\end{code} diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs index 4e20de102d..1973663de9 100644 --- a/ghc/compiler/prelude/PrelMods.lhs +++ b/ghc/compiler/prelude/PrelMods.lhs @@ -10,8 +10,6 @@ defined here so as to avod and gobbled whoever was writing the above :-) -- SOF ] \begin{code} -#include "HsVersions.h" - module PrelMods ( gHC__, pRELUDE, pREL_BASE, @@ -23,9 +21,9 @@ module PrelMods cCALL , aDDR ) where -CHK_Ubiq() -- debugging consistency check +#include "HsVersions.h" -import BasicTypes( SYN_IE(Module) ) +import BasicTypes( Module ) \end{code} \begin{code} diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index d5ecd9c8ac..5520a0b325 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -4,23 +4,14 @@ \section[PrelVals]{Prelude values the compiler ``knows about''} \begin{code} -#include "HsVersions.h" - module PrelVals where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..), mkUnfolding, nullSpecEnv, SpecEnv ) -#else -import {-# SOURCE #-} CoreUnfold ( UnfoldingGuidance(..), mkUnfolding ) -import {-# SOURCE #-} SpecEnv ( SpecEnv, nullSpecEnv ) -#endif +#include "HsVersions.h" -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(PrelLoop) -#endif +import {-# SOURCE #-} CoreUnfold ( UnfoldingGuidance(..), mkUnfolding ) -import Id ( SYN_IE(Id), GenId, mkImported, mkTemplateLocals ) +import Id ( Id, mkImported, mkTemplateLocals ) +import SpecEnv ( SpecEnv, emptySpecEnv ) -- friends: import PrelMods @@ -32,7 +23,7 @@ import CmdLineOpts ( maybe_CompilingGhcInternals ) import CoreSyn -- quite a bit import IdInfo -- quite a bit import Literal ( mkMachInt ) -import Name ( mkWiredInIdName, SYN_IE(Module) ) +import Name ( mkWiredInIdName, Module ) import PragmaInfo import PrimOp ( PrimOp(..) ) #if __GLASGOW_HASKELL__ >= 202 @@ -40,7 +31,7 @@ import Type #else import Type ( mkTyVarTy ) #endif -import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar, SYN_IE(TyVar) ) +import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar, TyVar ) import Unique -- lots of *Keys import Util ( panic ) \end{code} @@ -651,9 +642,9 @@ types passed to the pre-processor with the -genSPECS arg (see ghc.lprl). ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl \begin{code} -pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv +pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> IdSpecEnv pcGenerateSpecs key id info ty - = nullSpecEnv + = emptySpecEnv {- LATER: diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 72445f6d92..84af9e0a94 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -4,8 +4,6 @@ \section[PrimOp]{Primitive operations (machine-level)} \begin{code} -#include "HsVersions.h" - module PrimOp ( PrimOp(..), allThePrimOps, tagOf_PrimOp, -- ToDo: rm @@ -29,7 +27,7 @@ module PrimOp ( pprPrimOp, showPrimOp ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import PrimRep -- most of it import TysPrim @@ -38,17 +36,18 @@ import TysWiredIn import CStrings ( identToC ) import Constants ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE ) import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset ) -import Outputable ( PprStyle, Outputable(..), codeStyle, ifaceStyle ) +import Outputable import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} ) -import Pretty import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) import TyCon ( TyCon{-instances-} ) -import Type ( mkForAllTys, mkFunTy, mkFunTys, applyTyCon, typePrimRep, - getAppDataTyConExpandingDicts, SYN_IE(Type) +import Type ( mkForAllTys, mkFunTy, mkFunTys, mkTyConApp, typePrimRep, + splitAlgTyConApp, Type ) import TyVar --( alphaTyVar, betaTyVar, gammaTyVar, GenTyVar{-instance Eq-} ) import Unique ( Unique{-instance Eq-} ) import Util ( panic#, assoc, panic{-ToDo:rm-} ) + +import GlaExts ( Int(..), Int#, (==#) ) \end{code} %************************************************************************ @@ -1404,7 +1403,7 @@ primOpInfo ErrorIOPrimOp primOpInfo (CCallOp _ _ _ arg_tys result_ty) = AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied where - (result_tycon, tys_applied, _) = getAppDataTyConExpandingDicts result_ty + (result_tycon, tys_applied, _) = splitAlgTyConApp result_ty #ifdef DEBUG primOpInfo op = panic ("primOpInfo:"++ show (I# (tagOf_PrimOp op))) @@ -1728,10 +1727,10 @@ primOpType op Coercing str ty1 ty2 -> mkFunTy ty1 ty2 PrimResult str tyvars arg_tys prim_tycon kind res_tys -> - mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)) + mkForAllTys tyvars (mkFunTys arg_tys (mkTyConApp prim_tycon res_tys)) AlgResult str tyvars arg_tys tycon res_tys -> - mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)) + mkForAllTys tyvars (mkFunTys arg_tys (mkTyConApp tycon res_tys)) \end{code} \begin{code} @@ -1798,12 +1797,12 @@ compare_fun_ty ty = mkFunTys [ty, ty] boolTy Output stuff: \begin{code} -pprPrimOp :: PprStyle -> PrimOp -> Doc -showPrimOp :: PprStyle -> PrimOp -> String +pprPrimOp :: PrimOp -> SDoc +showPrimOp :: PrimOp -> String -showPrimOp sty op = render (pprPrimOp sty op) +showPrimOp op = showSDoc (pprPrimOp op) -pprPrimOp sty (CCallOp fun is_casm may_gc arg_tys res_ty) +pprPrimOp (CCallOp fun is_casm may_gc arg_tys res_ty) = let before = if is_casm then @@ -1815,24 +1814,22 @@ pprPrimOp sty (CCallOp fun is_casm may_gc arg_tys res_ty) = if is_casm then text "''" else empty pp_tys - = hsep (map (pprParendGenType sty) (res_ty:arg_tys)) + = hsep (map pprParendGenType (res_ty:arg_tys)) in hcat [text before, ptext fun, after, space, brackets pp_tys] -pprPrimOp sty other_op - | codeStyle sty -- For C just print the primop itself - = identToC str - - | ifaceStyle sty -- For interfaces Print it qualified with GHC. - = ptext SLIT("GHC.") <> ptext str - - | otherwise -- Unqualified is good enough - = ptext str +pprPrimOp other_op + = getPprStyle $ \ sty -> + if codeStyle sty then -- For C just print the primop itself + identToC str + else if ifaceStyle sty then -- For interfaces Print it qualified with GHC. + ptext SLIT("GHC.") <> ptext str + else -- Unqualified is good enough + ptext str where str = primOp_str other_op - instance Outputable PrimOp where - ppr sty op = pprPrimOp sty op + ppr op = pprPrimOp op \end{code} diff --git a/ghc/compiler/prelude/PrimRep.lhs b/ghc/compiler/prelude/PrimRep.lhs index 6317a13b76..f0c128d517 100644 --- a/ghc/compiler/prelude/PrimRep.lhs +++ b/ghc/compiler/prelude/PrimRep.lhs @@ -8,8 +8,6 @@ At various places in the back end, we want to be to tag things with a types. \begin{code} -#include "HsVersions.h" - module PrimRep ( PrimRep(..), @@ -19,13 +17,10 @@ module PrimRep ( guessPrimRep, decodePrimRep ) where -IMP_Ubiq() +#include "HsVersions.h" -import Pretty -- pretty-printing code import Util -#if __GLASGOW_HASKELL__ >= 202 import Outputable -#endif -- Oh dear. #include "../../includes/GhcConstants.h" @@ -152,11 +147,11 @@ retPrimRepSize = getPrimRepSize RetRep \begin{code} instance Outputable PrimRep where - ppr sty kind = text (showPrimRep kind) + ppr kind = text (showPrimRep kind) showPrimRep :: PrimRep -> String -- dumping PrimRep tag for unfoldings -ppPrimRep :: PrimRep -> Doc +ppPrimRep :: PrimRep -> SDoc guessPrimRep :: String -> PrimRep -- a horrible "inverse" function decodePrimRep :: Char -> PrimRep -- of equal nature diff --git a/ghc/compiler/prelude/StdIdInfo.lhs b/ghc/compiler/prelude/StdIdInfo.lhs index 53e81c7c74..58c2811861 100644 --- a/ghc/compiler/prelude/StdIdInfo.lhs +++ b/ghc/compiler/prelude/StdIdInfo.lhs @@ -12,17 +12,14 @@ have a standard form, namely: * primitive operations \begin{code} -#include "HsVersions.h" - module StdIdInfo ( addStandardIdInfo ) where -IMP_Ubiq() +#include "HsVersions.h" import Type import TyVar ( alphaTyVar ) -import CmdLineOpts ( opt_PprUserLength ) import CoreSyn import Literal import CoreUnfold ( mkUnfolding, PragmaInfo(..) ) @@ -34,19 +31,16 @@ import Id ( GenId, mkTemplateLocals, idType, isAlgCon, isMethodSelId_maybe, isSuperDictSelId_maybe, isRecordSelector, isPrimitiveId_maybe, addIdUnfolding, addIdArity, - SYN_IE(Id) + Id ) import IdInfo ( ArityInfo, exactArity ) -import Class ( GenClass, classBigSig, classDictArgTys ) -import TyCon ( isNewTyCon, isDataTyCon, isAlgTyCon ) +import Class ( classBigSig, classTyCon ) +import TyCon ( isNewTyCon, isDataTyCon, isAlgTyCon, tyConDataCons ) import FieldLabel ( FieldLabel ) import PrelVals ( pAT_ERROR_ID ) import Maybes -import Outputable ( PprStyle(..), Outputable(..) ) -import Pretty -import Util ( assertPanic, pprTrace, - assoc - ) +import Outputable +import Util ( assoc ) \end{code} @@ -93,10 +87,10 @@ addStandardIdInfo con_id (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) = dataConSig con_id - dict_tys = [mkDictTy clas ty | (clas,ty) <- theta] - con_dict_tys = [mkDictTy clas ty | (clas,ty) <- con_theta] + dict_tys = [mkDictTy clas tys | (clas,tys) <- theta] + con_dict_tys = [mkDictTy clas tys | (clas,tys) <- con_theta] n_dicts = length dict_tys - result_ty = applyTyCon tycon (mkTyVarTys tyvars) + result_ty = mkTyConApp tycon (mkTyVarTys tyvars) locals = mkTemplateLocals (dict_tys ++ con_dict_tys ++ arg_tys) data_args = drop n_dicts locals @@ -116,7 +110,7 @@ addStandardIdInfo con_id mkValLam locals $ foldr mk_case con_app strict_args - mk_case arg body | isUnboxedType (idType arg) + mk_case arg body | isUnpointedType (idType arg) = body -- "!" on unboxed arg does nothing | otherwise = Case (Var arg) (AlgAlts [] (BindDefault arg body)) @@ -153,9 +147,9 @@ addStandardIdInfo sel_id (tyvars, theta, tau) = splitSigmaTy (idType sel_id) field_lbl = recordSelectorFieldLabel sel_id - (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (getFunTy_maybe tau) + (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau) -- tau is of form (T a b c -> field-type) - (tycon, _, data_cons) = getAppDataTyCon data_ty + (tycon, _, data_cons) = splitAlgTyConApp data_ty tyvar_tys = mkTyVarTys tyvars [data_id] = mkTemplateLocals [data_ty] @@ -173,15 +167,15 @@ addStandardIdInfo sel_id field_lbls = dataConFieldLabels data_con maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_lbl - error_expr = mkApp (Var pAT_ERROR_ID) [] [rhs_ty] [LitArg msg_lit] - full_msg = show (sep [text "No match in record selector", ppr (PprForUser opt_PprUserLength) sel_id]) + error_expr = mkApp (Var pAT_ERROR_ID) [rhs_ty] [LitArg msg_lit] + full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id]) msg_lit = NoRepStr (_PK_ full_msg) \end{code} %************************************************************************ %* * -\subsection{Super selectors} +\subsection{Dictionary selectors} %* * %************************************************************************ @@ -219,8 +213,8 @@ addStandardIdInfo prim_id unfolding = mkUnfolding IWantToBeINLINEd {- Always inline PrimOps -} rhs - (tyvars, tau) = splitForAllTy (idType prim_id) - (arg_tys, _) = splitFunTy tau + (tyvars, tau) = splitForAllTys (idType prim_id) + (arg_tys, _) = splitFunTys tau args = mkTemplateLocals arg_tys rhs = mkLam tyvars args $ @@ -238,7 +232,7 @@ addStandardIdInfo prim_id \begin{code} addStandardIdInfo id - = pprTrace "addStandardIdInfo missing:" (ppr PprDebug id) id + = pprTrace "addStandardIdInfo missing:" (ppr id) id \end{code} @@ -256,21 +250,19 @@ mk_selector_unfolding clas sel_id = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs -- The always-inline thing means we don't need any other IdInfo where - rhs = mk_dict_selector [alphaTyVar] dict_id arg_ids the_arg_id - tyvar_ty = mkTyVarTy alphaTyVar - [dict_id] = mkTemplateLocals [mkDictTy clas tyvar_ty] - arg_tys = classDictArgTys clas tyvar_ty - arg_ids = mkTemplateLocals arg_tys - the_arg_id = assoc "StdIdInfo:mk_sel" ((sc_sel_ids ++ op_sel_ids) `zip` arg_ids) sel_id + (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas - (_, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas + tycon = classTyCon clas + [data_con] = tyConDataCons tycon + tyvar_tys = mkTyVarTys tyvars + arg_tys = dataConArgTys data_con tyvar_tys + the_arg_id = assoc "StdIdInfo:mk_sel" ((sc_sel_ids ++ op_sel_ids) `zip` arg_ids) sel_id -mk_dict_selector tyvars dict_id [arg_id] the_arg_id - = mkLam tyvars [dict_id] (Var dict_id) + (dict_id:arg_ids) = mkTemplateLocals (mkDictTy clas tyvar_tys : arg_tys) -mk_dict_selector tyvars dict_id arg_ids the_arg_id - = mkLam tyvars [dict_id] $ - Case (Var dict_id) (AlgAlts [(tup_con, arg_ids, Var the_arg_id)] NoDefault) - where - tup_con = tupleCon (length arg_ids) + rhs | isNewTyCon tycon = mkLam tyvars [dict_id] $ + Coerce (CoerceOut data_con) (head arg_tys) (Var dict_id) + | otherwise = mkLam tyvars [dict_id] $ + Case (Var dict_id) $ + AlgAlts [(data_con, arg_ids, Var the_arg_id)] NoDefault \end{code} diff --git a/ghc/compiler/prelude/TysPrim.hi-boot b/ghc/compiler/prelude/TysPrim.hi-boot index deb8bf07a1..3cd8184ee4 100644 --- a/ghc/compiler/prelude/TysPrim.hi-boot +++ b/ghc/compiler/prelude/TysPrim.hi-boot @@ -2,4 +2,5 @@ _interface_ TysPrim 1 _exports_ TysPrim voidTy; _declarations_ -1 voidTy _:_ Type.Type ;; +-- Not needed by Type.lhs any more +-- 1 voidTy _:_ Type.Type ;; diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 36134a2099..660b2a591c 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -7,20 +7,17 @@ This module tracks the ``state interface'' document, ``GHC prelude: types and operations.'' \begin{code} -#include "HsVersions.h" - module TysPrim where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind ) import Name ( mkWiredInTyConName ) import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn import TyCon ( mkPrimTyCon, mkDataTyCon, TyCon ) -import BasicTypes ( NewOrData(..) ) -import Type ( applyTyCon, mkTyVarTys, mkTyConTy, SYN_IE(Type) ) +import BasicTypes ( NewOrData(..), RecFlag(..) ) +import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, Type ) import TyVar ( GenTyVar(..), alphaTyVars ) -import Usage ( usageOmega ) import PrelMods ( gHC__ ) import Unique \end{code} @@ -47,22 +44,22 @@ pcPrimTyCon key str arity primrep the_tycon = mkPrimTyCon name arity primrep -charPrimTy = applyTyCon charPrimTyCon [] +charPrimTy = mkTyConTy charPrimTyCon charPrimTyCon = pcPrimTyCon charPrimTyConKey SLIT("Char#") 0 CharRep -intPrimTy = applyTyCon intPrimTyCon [] +intPrimTy = mkTyConTy intPrimTyCon intPrimTyCon = pcPrimTyCon intPrimTyConKey SLIT("Int#") 0 IntRep -wordPrimTy = applyTyCon wordPrimTyCon [] +wordPrimTy = mkTyConTy wordPrimTyCon wordPrimTyCon = pcPrimTyCon wordPrimTyConKey SLIT("Word#") 0 WordRep -addrPrimTy = applyTyCon addrPrimTyCon [] +addrPrimTy = mkTyConTy addrPrimTyCon addrPrimTyCon = pcPrimTyCon addrPrimTyConKey SLIT("Addr#") 0 AddrRep -floatPrimTy = applyTyCon floatPrimTyCon [] +floatPrimTy = mkTyConTy floatPrimTyCon floatPrimTyCon = pcPrimTyCon floatPrimTyConKey SLIT("Float#") 0 FloatRep -doublePrimTy = applyTyCon doublePrimTyCon [] +doublePrimTy = mkTyConTy doublePrimTyCon doublePrimTyCon = pcPrimTyCon doublePrimTyConKey SLIT("Double#") 0 DoubleRep \end{code} @@ -100,7 +97,7 @@ where s is a type variable. The only purpose of the type parameter is to keep different state threads separate. It is represented by nothing at all. \begin{code} -mkStatePrimTy ty = applyTyCon statePrimTyCon [ty] +mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty] statePrimTyCon = pcPrimTyCon statePrimTyConKey SLIT("State#") 1 VoidRep \end{code} @@ -110,7 +107,7 @@ We never manipulate values of type RealWorld; it's only used in the type system, to parameterise State#. \begin{code} -realWorldTy = applyTyCon realWorldTyCon [] +realWorldTy = mkTyConTy realWorldTyCon realWorldTyCon = mk_no_constr_tycon realWorldTyConKey SLIT("RealWorld") realWorldStatePrimTy = mkStatePrimTy realWorldTy \end{code} @@ -137,11 +134,13 @@ mk_no_constr_tycon key str where name = mkWiredInTyConName key gHC__ str the_tycon the_tycon = mkDataTyCon name mkBoxedTypeKind - [{-no tyvars-}] - [{-no context-}] - [{-no data cons!-}] -- we tell you *nothing* about this guy - [{-no derivings-}] + [] -- No tyvars + [] -- No context + [] -- No constructors; we tell you *nothing* about this guy + [] -- No derivings + Nothing -- Not a dictionary DataType + NonRecursive \end{code} %************************************************************************ @@ -159,10 +158,10 @@ mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConKey SLIT("MutableArray# mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConKey SLIT("MutableByteArray#") 1 ByteArrayRep -mkArrayPrimTy elt = applyTyCon arrayPrimTyCon [elt] -byteArrayPrimTy = applyTyCon byteArrayPrimTyCon [] -mkMutableArrayPrimTy s elt = applyTyCon mutableArrayPrimTyCon [s, elt] -mkMutableByteArrayPrimTy s = applyTyCon mutableByteArrayPrimTyCon [s] +mkArrayPrimTy elt = mkTyConApp arrayPrimTyCon [elt] +byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon +mkMutableArrayPrimTy s elt = mkTyConApp mutableArrayPrimTyCon [s, elt] +mkMutableByteArrayPrimTy s = mkTyConApp mutableByteArrayPrimTyCon [s] \end{code} %************************************************************************ @@ -174,7 +173,7 @@ mkMutableByteArrayPrimTy s = applyTyCon mutableByteArrayPrimTyCon [s] \begin{code} synchVarPrimTyCon = pcPrimTyCon synchVarPrimTyConKey SLIT("SynchVar#") 2 PtrRep -mkSynchVarPrimTy s elt = applyTyCon synchVarPrimTyCon [s, elt] +mkSynchVarPrimTy s elt = mkTyConApp synchVarPrimTyCon [s, elt] \end{code} %************************************************************************ @@ -186,7 +185,7 @@ mkSynchVarPrimTy s elt = applyTyCon synchVarPrimTyCon [s, elt] \begin{code} stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConKey SLIT("StablePtr#") 1 StablePtrRep -mkStablePtrPrimTy ty = applyTyCon stablePtrPrimTyCon [ty] +mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty] \end{code} %************************************************************************ @@ -210,6 +209,6 @@ There are no primitive operations on @ForeignObj#@s (although equality could possibly be added?) \begin{code} -foreignObjPrimTy = applyTyCon foreignObjPrimTyCon [] +foreignObjPrimTy = mkTyConTy foreignObjPrimTyCon foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConKey SLIT("ForeignObj#") 0 ForeignObjRep \end{code} diff --git a/ghc/compiler/prelude/TysWiredIn.hi-boot b/ghc/compiler/prelude/TysWiredIn.hi-boot index c808a8e739..11753ec2e4 100644 --- a/ghc/compiler/prelude/TysWiredIn.hi-boot +++ b/ghc/compiler/prelude/TysWiredIn.hi-boot @@ -1,6 +1,11 @@ _interface_ TysWiredIn 1 _exports_ -TysWiredIn tupleCon tupleTyCon; +TysWiredIn tupleCon ; _declarations_ -1 tupleCon _:_ BasicTypes.Arity -> Id.Id ;; -1 tupleTyCon _:_ BasicTypes.Arity -> TyCon.TyCon ;; +-- Let's try not having this either! +-- 1 tupleTyCon _:_ BasicTypes.Arity -> TyCon.TyCon ;; + +-- Needed by TyCon.lhs +1 tupleCon _:_ BasicTypes.Arity -> Id!Id ;; + + diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 2c39168334..2f78305668 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -10,8 +10,6 @@ This module tracks the ``state interface'' document, ``GHC prelude: types and operations.'' \begin{code} -#include "HsVersions.h" - module TysWiredIn ( addrDataCon, addrTy, @@ -92,65 +90,53 @@ module TysWiredIn ( wordTyCon ) where ---ToDo:rm ---import Pretty ---import Util ---import PprType ---import Kind - -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(TyLoop) ( mkDataCon, mkTupleCon, StrictnessMark(..) ) -IMPORT_DELOOPER(IdLoop) ( SpecEnv, nullSpecEnv, - mkTupleCon, mkDataCon, - StrictnessMark(..) ) -#else +#include "HsVersions.h" + import {-# SOURCE #-} Id ( Id, mkDataCon, mkTupleCon, StrictnessMark(..) ) -import {-# SOURCE #-} SpecEnv ( SpecEnv, nullSpecEnv ) -#endif -- friends: import PrelMods import TysPrim -- others: -import FieldLabel () -- import Kind ( mkBoxedTypeKind, mkArrowKind ) import Name ( mkWiredInTyConName, mkWiredInIdName ) import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon, - TyCon, SYN_IE(Arity) + TyCon, Arity ) -import BasicTypes ( SYN_IE(Module), NewOrData(..) ) -import Type ( SYN_IE(Type), mkTyConTy, applyTyCon, mkSigmaTy, mkTyVarTys, - mkFunTy, mkFunTys, maybeAppTyCon, maybeAppDataTyCon, - GenType(..), SYN_IE(ThetaType), SYN_IE(TauType) ) -import TyVar ( GenTyVar, SYN_IE(TyVar), tyVarKind, alphaTyVars, alphaTyVar, betaTyVar ) +import BasicTypes ( Module, NewOrData(..), RecFlag(..) ) +import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys, + mkFunTy, mkFunTys, splitTyConApp_maybe, splitAlgTyConApp_maybe, + GenType(..), ThetaType, TauType ) +import TyVar ( GenTyVar, TyVar, tyVarKind, alphaTyVars, alphaTyVar, betaTyVar ) import Lex ( mkTupNameStr ) import Unique import Util ( assoc, panic ) ---nullSpecEnv = error "TysWiredIn:nullSpecEnv = " -addOneToSpecEnv = error "TysWiredIn:addOneToSpecEnv = " -pc_gen_specs = error "TysWiredIn:pc_gen_specs " -mkSpecInfo = error "TysWiredIn:SpecInfo" - alpha_tyvar = [alphaTyVar] alpha_ty = [alphaTy] alpha_beta_tyvars = [alphaTyVar, betaTyVar] -pcDataTyCon, pcNewTyCon +pcRecDataTyCon, pcNonRecDataTyCon, pcNonRecNewTyCon :: Unique{-TyConKey-} -> Module -> FAST_STRING -> [TyVar] -> [Id] -> TyCon -pcDataTyCon = pc_tycon DataType -pcNewTyCon = pc_tycon NewType +pcRecDataTyCon = pc_tycon DataType Recursive +pcNonRecDataTyCon = pc_tycon DataType NonRecursive +pcNonRecNewTyCon = pc_tycon NewType NonRecursive -pc_tycon new_or_data key mod str tyvars cons +pc_tycon new_or_data is_rec key mod str tyvars cons = tycon where tycon = mkDataTyCon name tycon_kind - tyvars [{-no context-}] cons [{-no derivings-}] + tyvars + [] -- No context + cons + [] -- No derivings + Nothing -- Not a dictionary new_or_data + is_rec + name = mkWiredInTyConName key mod str tycon tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind tyvars @@ -161,8 +147,8 @@ pcSynTyCon key mod str kind arity tyvars expansion name = mkWiredInTyConName key mod str tycon pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING - -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id -pcDataCon key mod str tyvars context arg_tys tycon specenv + -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> Id +pcDataCon key mod str tyvars context arg_tys tycon = data_con where data_con = mkDataCon name @@ -170,12 +156,6 @@ pcDataCon key mod str tyvars context arg_tys tycon specenv [ {- no labelled fields -} ] tyvars context [] [] arg_tys tycon name = mkWiredInIdName key mod str data_con - -pcGenerateDataSpecs :: Type -> SpecEnv -pcGenerateDataSpecs ty - = pc_gen_specs --False err err err ty - where - err = panic "PrelUtils:GenerateDataSpecs" \end{code} %************************************************************************ @@ -204,7 +184,7 @@ tupleCon arity name = mkWiredInIdName uniq mod_name (mkTupNameStr arity) tuple_con mod_name | arity == 0 = pREL_BASE | otherwise = pREL_TUP - ty = mkSigmaTy tyvars [] (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys)) + ty = mkSigmaTy tyvars [] (mkFunTys tyvar_tys (mkTyConApp tycon tyvar_tys)) tyvars = take arity alphaTyVars tyvar_tys = mkTyVarTys tyvars tycon = tupleTyCon arity @@ -226,8 +206,8 @@ pairDataCon = tupleCon 2 \begin{code} charTy = mkTyConTy charTyCon -charTyCon = pcDataTyCon charTyConKey pREL_BASE SLIT("Char") [] [charDataCon] -charDataCon = pcDataCon charDataConKey pREL_BASE SLIT("C#") [] [] [charPrimTy] charTyCon nullSpecEnv +charTyCon = pcNonRecDataTyCon charTyConKey pREL_BASE SLIT("Char") [] [charDataCon] +charDataCon = pcDataCon charDataConKey pREL_BASE SLIT("C#") [] [] [charPrimTy] charTyCon stringTy = mkListTy charTy -- convenience only \end{code} @@ -235,12 +215,12 @@ stringTy = mkListTy charTy -- convenience only \begin{code} intTy = mkTyConTy intTyCon -intTyCon = pcDataTyCon intTyConKey pREL_BASE SLIT("Int") [] [intDataCon] -intDataCon = pcDataCon intDataConKey pREL_BASE SLIT("I#") [] [] [intPrimTy] intTyCon nullSpecEnv +intTyCon = pcNonRecDataTyCon intTyConKey pREL_BASE SLIT("Int") [] [intDataCon] +intDataCon = pcDataCon intDataConKey pREL_BASE SLIT("I#") [] [] [intPrimTy] intTyCon -isIntTy :: GenType (GenTyVar flexi) uvar -> Bool +isIntTy :: GenType flexi -> Bool isIntTy ty - = case (maybeAppDataTyCon ty) of + = case (splitAlgTyConApp_maybe ty) of Just (tycon, [], _) -> uniqueOf tycon == intTyConKey _ -> False @@ -255,59 +235,59 @@ min_int = toInteger minInt \begin{code} wordTy = mkTyConTy wordTyCon -wordTyCon = pcDataTyCon wordTyConKey fOREIGN SLIT("Word") [] [wordDataCon] -wordDataCon = pcDataCon wordDataConKey fOREIGN SLIT("W#") [] [] [wordPrimTy] wordTyCon nullSpecEnv +wordTyCon = pcNonRecDataTyCon wordTyConKey fOREIGN SLIT("Word") [] [wordDataCon] +wordDataCon = pcDataCon wordDataConKey fOREIGN SLIT("W#") [] [] [wordPrimTy] wordTyCon \end{code} \begin{code} addrTy = mkTyConTy addrTyCon -addrTyCon = pcDataTyCon addrTyConKey aDDR SLIT("Addr") [] [addrDataCon] -addrDataCon = pcDataCon addrDataConKey aDDR SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv +addrTyCon = pcNonRecDataTyCon addrTyConKey aDDR SLIT("Addr") [] [addrDataCon] +addrDataCon = pcDataCon addrDataConKey aDDR SLIT("A#") [] [] [addrPrimTy] addrTyCon \end{code} \begin{code} floatTy = mkTyConTy floatTyCon -floatTyCon = pcDataTyCon floatTyConKey pREL_BASE SLIT("Float") [] [floatDataCon] -floatDataCon = pcDataCon floatDataConKey pREL_BASE SLIT("F#") [] [] [floatPrimTy] floatTyCon nullSpecEnv +floatTyCon = pcNonRecDataTyCon floatTyConKey pREL_BASE SLIT("Float") [] [floatDataCon] +floatDataCon = pcDataCon floatDataConKey pREL_BASE SLIT("F#") [] [] [floatPrimTy] floatTyCon \end{code} \begin{code} doubleTy = mkTyConTy doubleTyCon -doubleTyCon = pcDataTyCon doubleTyConKey pREL_BASE SLIT("Double") [] [doubleDataCon] -doubleDataCon = pcDataCon doubleDataConKey pREL_BASE SLIT("D#") [] [] [doublePrimTy] doubleTyCon nullSpecEnv +doubleTyCon = pcNonRecDataTyCon doubleTyConKey pREL_BASE SLIT("Double") [] [doubleDataCon] +doubleDataCon = pcDataCon doubleDataConKey pREL_BASE SLIT("D#") [] [] [doublePrimTy] doubleTyCon \end{code} \begin{code} -mkStateTy ty = applyTyCon stateTyCon [ty] +mkStateTy ty = mkTyConApp stateTyCon [ty] realWorldStateTy = mkStateTy realWorldTy -- a common use -stateTyCon = pcDataTyCon stateTyConKey sT_BASE SLIT("State") alpha_tyvar [stateDataCon] +stateTyCon = pcNonRecDataTyCon stateTyConKey sT_BASE SLIT("State") alpha_tyvar [stateDataCon] stateDataCon = pcDataCon stateDataConKey sT_BASE SLIT("S#") - alpha_tyvar [] [mkStatePrimTy alphaTy] stateTyCon nullSpecEnv + alpha_tyvar [] [mkStatePrimTy alphaTy] stateTyCon \end{code} \begin{code} stablePtrTyCon - = pcDataTyCon stablePtrTyConKey fOREIGN SLIT("StablePtr") + = pcNonRecDataTyCon stablePtrTyConKey fOREIGN SLIT("StablePtr") alpha_tyvar [stablePtrDataCon] where stablePtrDataCon = pcDataCon stablePtrDataConKey fOREIGN SLIT("StablePtr") - alpha_tyvar [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon nullSpecEnv + alpha_tyvar [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon \end{code} \begin{code} foreignObjTyCon - = pcDataTyCon foreignObjTyConKey fOREIGN SLIT("ForeignObj") + = pcNonRecDataTyCon foreignObjTyConKey fOREIGN SLIT("ForeignObj") [] [foreignObjDataCon] where foreignObjDataCon = pcDataCon foreignObjDataConKey fOREIGN SLIT("ForeignObj") - [] [] [foreignObjPrimTy] foreignObjTyCon nullSpecEnv + [] [] [foreignObjPrimTy] foreignObjTyCon \end{code} %************************************************************************ @@ -318,37 +298,37 @@ foreignObjTyCon @Integer@ and its pals are not really primitive. @Integer@ itself, first: \begin{code} -integerTy :: GenType t u +integerTy :: GenType t integerTy = mkTyConTy integerTyCon -integerTyCon = pcDataTyCon integerTyConKey pREL_BASE SLIT("Integer") [] [integerDataCon] +integerTyCon = pcNonRecDataTyCon integerTyConKey pREL_BASE SLIT("Integer") [] [integerDataCon] integerDataCon = pcDataCon integerDataConKey pREL_BASE SLIT("J#") - [] [] [intPrimTy, intPrimTy, byteArrayPrimTy] integerTyCon nullSpecEnv + [] [] [intPrimTy, intPrimTy, byteArrayPrimTy] integerTyCon -isIntegerTy :: GenType (GenTyVar flexi) uvar -> Bool +isIntegerTy :: GenType flexi -> Bool isIntegerTy ty - = case (maybeAppDataTyCon ty) of + = case (splitAlgTyConApp_maybe ty) of Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey _ -> False \end{code} And the other pairing types: \begin{code} -return2GMPsTyCon = pcDataTyCon return2GMPsTyConKey +return2GMPsTyCon = pcNonRecDataTyCon return2GMPsTyConKey pREL_NUM SLIT("Return2GMPs") [] [return2GMPsDataCon] return2GMPsDataCon = pcDataCon return2GMPsDataConKey pREL_NUM SLIT("Return2GMPs") [] [] [intPrimTy, intPrimTy, byteArrayPrimTy, - intPrimTy, intPrimTy, byteArrayPrimTy] return2GMPsTyCon nullSpecEnv + intPrimTy, intPrimTy, byteArrayPrimTy] return2GMPsTyCon -returnIntAndGMPTyCon = pcDataTyCon returnIntAndGMPTyConKey +returnIntAndGMPTyCon = pcNonRecDataTyCon returnIntAndGMPTyConKey pREL_NUM SLIT("ReturnIntAndGMP") [] [returnIntAndGMPDataCon] returnIntAndGMPDataCon = pcDataCon returnIntAndGMPDataConKey pREL_NUM SLIT("ReturnIntAndGMP") [] [] - [intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy] returnIntAndGMPTyCon nullSpecEnv + [intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy] returnIntAndGMPTyCon \end{code} %************************************************************************ @@ -366,120 +346,120 @@ We fish one of these \tr{StateAnd<blah>#} things with \begin{code} stateAndPtrPrimTyCon - = pcDataTyCon stateAndPtrPrimTyConKey sT_BASE SLIT("StateAndPtr#") + = pcNonRecDataTyCon stateAndPtrPrimTyConKey sT_BASE SLIT("StateAndPtr#") alpha_beta_tyvars [stateAndPtrPrimDataCon] stateAndPtrPrimDataCon = pcDataCon stateAndPtrPrimDataConKey sT_BASE SLIT("StateAndPtr#") alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy] - stateAndPtrPrimTyCon nullSpecEnv + stateAndPtrPrimTyCon stateAndCharPrimTyCon - = pcDataTyCon stateAndCharPrimTyConKey sT_BASE SLIT("StateAndChar#") + = pcNonRecDataTyCon stateAndCharPrimTyConKey sT_BASE SLIT("StateAndChar#") alpha_tyvar [stateAndCharPrimDataCon] stateAndCharPrimDataCon = pcDataCon stateAndCharPrimDataConKey sT_BASE SLIT("StateAndChar#") alpha_tyvar [] [mkStatePrimTy alphaTy, charPrimTy] - stateAndCharPrimTyCon nullSpecEnv + stateAndCharPrimTyCon stateAndIntPrimTyCon - = pcDataTyCon stateAndIntPrimTyConKey sT_BASE SLIT("StateAndInt#") + = pcNonRecDataTyCon stateAndIntPrimTyConKey sT_BASE SLIT("StateAndInt#") alpha_tyvar [stateAndIntPrimDataCon] stateAndIntPrimDataCon = pcDataCon stateAndIntPrimDataConKey sT_BASE SLIT("StateAndInt#") alpha_tyvar [] [mkStatePrimTy alphaTy, intPrimTy] - stateAndIntPrimTyCon nullSpecEnv + stateAndIntPrimTyCon stateAndWordPrimTyCon - = pcDataTyCon stateAndWordPrimTyConKey sT_BASE SLIT("StateAndWord#") + = pcNonRecDataTyCon stateAndWordPrimTyConKey sT_BASE SLIT("StateAndWord#") alpha_tyvar [stateAndWordPrimDataCon] stateAndWordPrimDataCon = pcDataCon stateAndWordPrimDataConKey sT_BASE SLIT("StateAndWord#") alpha_tyvar [] [mkStatePrimTy alphaTy, wordPrimTy] - stateAndWordPrimTyCon nullSpecEnv + stateAndWordPrimTyCon stateAndAddrPrimTyCon - = pcDataTyCon stateAndAddrPrimTyConKey sT_BASE SLIT("StateAndAddr#") + = pcNonRecDataTyCon stateAndAddrPrimTyConKey sT_BASE SLIT("StateAndAddr#") alpha_tyvar [stateAndAddrPrimDataCon] stateAndAddrPrimDataCon = pcDataCon stateAndAddrPrimDataConKey sT_BASE SLIT("StateAndAddr#") alpha_tyvar [] [mkStatePrimTy alphaTy, addrPrimTy] - stateAndAddrPrimTyCon nullSpecEnv + stateAndAddrPrimTyCon stateAndStablePtrPrimTyCon - = pcDataTyCon stateAndStablePtrPrimTyConKey fOREIGN SLIT("StateAndStablePtr#") + = pcNonRecDataTyCon stateAndStablePtrPrimTyConKey fOREIGN SLIT("StateAndStablePtr#") alpha_beta_tyvars [stateAndStablePtrPrimDataCon] stateAndStablePtrPrimDataCon = pcDataCon stateAndStablePtrPrimDataConKey fOREIGN SLIT("StateAndStablePtr#") alpha_beta_tyvars [] - [mkStatePrimTy alphaTy, applyTyCon stablePtrPrimTyCon [betaTy]] - stateAndStablePtrPrimTyCon nullSpecEnv + [mkStatePrimTy alphaTy, mkTyConApp stablePtrPrimTyCon [betaTy]] + stateAndStablePtrPrimTyCon stateAndForeignObjPrimTyCon - = pcDataTyCon stateAndForeignObjPrimTyConKey fOREIGN SLIT("StateAndForeignObj#") + = pcNonRecDataTyCon stateAndForeignObjPrimTyConKey fOREIGN SLIT("StateAndForeignObj#") alpha_tyvar [stateAndForeignObjPrimDataCon] stateAndForeignObjPrimDataCon = pcDataCon stateAndForeignObjPrimDataConKey fOREIGN SLIT("StateAndForeignObj#") alpha_tyvar [] - [mkStatePrimTy alphaTy, applyTyCon foreignObjPrimTyCon []] - stateAndForeignObjPrimTyCon nullSpecEnv + [mkStatePrimTy alphaTy, mkTyConTy foreignObjPrimTyCon] + stateAndForeignObjPrimTyCon stateAndFloatPrimTyCon - = pcDataTyCon stateAndFloatPrimTyConKey sT_BASE SLIT("StateAndFloat#") + = pcNonRecDataTyCon stateAndFloatPrimTyConKey sT_BASE SLIT("StateAndFloat#") alpha_tyvar [stateAndFloatPrimDataCon] stateAndFloatPrimDataCon = pcDataCon stateAndFloatPrimDataConKey sT_BASE SLIT("StateAndFloat#") alpha_tyvar [] [mkStatePrimTy alphaTy, floatPrimTy] - stateAndFloatPrimTyCon nullSpecEnv + stateAndFloatPrimTyCon stateAndDoublePrimTyCon - = pcDataTyCon stateAndDoublePrimTyConKey sT_BASE SLIT("StateAndDouble#") + = pcNonRecDataTyCon stateAndDoublePrimTyConKey sT_BASE SLIT("StateAndDouble#") alpha_tyvar [stateAndDoublePrimDataCon] stateAndDoublePrimDataCon = pcDataCon stateAndDoublePrimDataConKey sT_BASE SLIT("StateAndDouble#") alpha_tyvar [] [mkStatePrimTy alphaTy, doublePrimTy] - stateAndDoublePrimTyCon nullSpecEnv + stateAndDoublePrimTyCon \end{code} \begin{code} stateAndArrayPrimTyCon - = pcDataTyCon stateAndArrayPrimTyConKey aRR_BASE SLIT("StateAndArray#") + = pcNonRecDataTyCon stateAndArrayPrimTyConKey aRR_BASE SLIT("StateAndArray#") alpha_beta_tyvars [stateAndArrayPrimDataCon] stateAndArrayPrimDataCon = pcDataCon stateAndArrayPrimDataConKey aRR_BASE SLIT("StateAndArray#") alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkArrayPrimTy betaTy] - stateAndArrayPrimTyCon nullSpecEnv + stateAndArrayPrimTyCon stateAndMutableArrayPrimTyCon - = pcDataTyCon stateAndMutableArrayPrimTyConKey aRR_BASE SLIT("StateAndMutableArray#") + = pcNonRecDataTyCon stateAndMutableArrayPrimTyConKey aRR_BASE SLIT("StateAndMutableArray#") alpha_beta_tyvars [stateAndMutableArrayPrimDataCon] stateAndMutableArrayPrimDataCon = pcDataCon stateAndMutableArrayPrimDataConKey aRR_BASE SLIT("StateAndMutableArray#") alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkMutableArrayPrimTy alphaTy betaTy] - stateAndMutableArrayPrimTyCon nullSpecEnv + stateAndMutableArrayPrimTyCon stateAndByteArrayPrimTyCon - = pcDataTyCon stateAndByteArrayPrimTyConKey aRR_BASE SLIT("StateAndByteArray#") + = pcNonRecDataTyCon stateAndByteArrayPrimTyConKey aRR_BASE SLIT("StateAndByteArray#") alpha_tyvar [stateAndByteArrayPrimDataCon] stateAndByteArrayPrimDataCon = pcDataCon stateAndByteArrayPrimDataConKey aRR_BASE SLIT("StateAndByteArray#") alpha_tyvar [] [mkStatePrimTy alphaTy, byteArrayPrimTy] - stateAndByteArrayPrimTyCon nullSpecEnv + stateAndByteArrayPrimTyCon stateAndMutableByteArrayPrimTyCon - = pcDataTyCon stateAndMutableByteArrayPrimTyConKey aRR_BASE SLIT("StateAndMutableByteArray#") + = pcNonRecDataTyCon stateAndMutableByteArrayPrimTyConKey aRR_BASE SLIT("StateAndMutableByteArray#") alpha_tyvar [stateAndMutableByteArrayPrimDataCon] stateAndMutableByteArrayPrimDataCon = pcDataCon stateAndMutableByteArrayPrimDataConKey aRR_BASE SLIT("StateAndMutableByteArray#") - alpha_tyvar [] [mkStatePrimTy alphaTy, applyTyCon mutableByteArrayPrimTyCon alpha_ty] - stateAndMutableByteArrayPrimTyCon nullSpecEnv + alpha_tyvar [] [mkStatePrimTy alphaTy, mkTyConApp mutableByteArrayPrimTyCon alpha_ty] + stateAndMutableByteArrayPrimTyCon stateAndSynchVarPrimTyCon - = pcDataTyCon stateAndSynchVarPrimTyConKey cONC_BASE SLIT("StateAndSynchVar#") + = pcNonRecDataTyCon stateAndSynchVarPrimTyConKey cONC_BASE SLIT("StateAndSynchVar#") alpha_beta_tyvars [stateAndSynchVarPrimDataCon] stateAndSynchVarPrimDataCon = pcDataCon stateAndSynchVarPrimDataConKey cONC_BASE SLIT("StateAndSynchVar#") alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkSynchVarPrimTy alphaTy betaTy] - stateAndSynchVarPrimTyCon nullSpecEnv + stateAndSynchVarPrimTyCon \end{code} The ccall-desugaring mechanism uses this function to figure out how to @@ -493,12 +473,12 @@ getStatePairingConInfo Type) -- type of state pair getStatePairingConInfo prim_ty - = case (maybeAppTyCon prim_ty) of + = case (splitTyConApp_maybe prim_ty) of Nothing -> panic "getStatePairingConInfo:1" Just (prim_tycon, tys_applied) -> let (pair_con, pair_tycon, num_tys) = assoc "getStatePairingConInfo" tbl prim_tycon - pair_ty = applyTyCon pair_tycon (realWorldTy : drop num_tys tys_applied) + pair_ty = mkTyConApp pair_tycon (realWorldTy : drop num_tys tys_applied) in (pair_con, pair_ty) where @@ -530,24 +510,24 @@ The only reason this is wired in is because we have to represent the type of runST. \begin{code} -mkStateTransformerTy s a = applyTyCon stTyCon [s, a] +mkStateTransformerTy s a = mkTyConApp stTyCon [s, a] -stTyCon = pcNewTyCon stTyConKey sT_BASE SLIT("ST") alpha_beta_tyvars [stDataCon] +stTyCon = pcNonRecNewTyCon stTyConKey sT_BASE SLIT("ST") alpha_beta_tyvars [stDataCon] stDataCon = pcDataCon stDataConKey sT_BASE SLIT("ST") - alpha_beta_tyvars [] [ty] stTyCon nullSpecEnv + alpha_beta_tyvars [] [ty] stTyCon where ty = mkFunTy (mkStatePrimTy alphaTy) (mkSTretTy alphaTy betaTy) -mkSTretTy alpha beta = applyTyCon stRetTyCon [alpha,beta] +mkSTretTy alpha beta = mkTyConApp stRetTyCon [alpha,beta] stRetTyCon - = pcDataTyCon stRetTyConKey sT_BASE SLIT("STret") + = pcNonRecDataTyCon stRetTyConKey sT_BASE SLIT("STret") alpha_beta_tyvars [stRetDataCon] stRetDataCon = pcDataCon stRetDataConKey sT_BASE SLIT("STret") alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy] - stRetTyCon nullSpecEnv + stRetTyCon \end{code} %************************************************************************ @@ -601,10 +581,10 @@ primitive counterpart. \begin{code} boolTy = mkTyConTy boolTyCon -boolTyCon = pcDataTyCon boolTyConKey pREL_BASE SLIT("Bool") [] [falseDataCon, trueDataCon] +boolTyCon = pcNonRecDataTyCon boolTyConKey pREL_BASE SLIT("Bool") [] [falseDataCon, trueDataCon] -falseDataCon = pcDataCon falseDataConKey pREL_BASE SLIT("False") [] [] [] boolTyCon nullSpecEnv -trueDataCon = pcDataCon trueDataConKey pREL_BASE SLIT("True") [] [] [] boolTyCon nullSpecEnv +falseDataCon = pcDataCon falseDataConKey pREL_BASE SLIT("False") [] [] [] boolTyCon +trueDataCon = pcDataCon trueDataConKey pREL_BASE SLIT("True") [] [] [] boolTyCon \end{code} %************************************************************************ @@ -623,19 +603,17 @@ data (,) a b = (,,) a b \end{verbatim} \begin{code} -mkListTy :: GenType t u -> GenType t u -mkListTy ty = applyTyCon listTyCon [ty] +mkListTy :: GenType t -> GenType t +mkListTy ty = mkTyConApp listTyCon [ty] -alphaListTy = mkSigmaTy alpha_tyvar [] (applyTyCon listTyCon alpha_ty) +alphaListTy = mkSigmaTy alpha_tyvar [] (mkTyConApp listTyCon alpha_ty) -listTyCon = pcDataTyCon listTyConKey pREL_BASE SLIT("[]") +listTyCon = pcRecDataTyCon listTyConKey pREL_BASE SLIT("[]") alpha_tyvar [nilDataCon, consDataCon] nilDataCon = pcDataCon nilDataConKey pREL_BASE SLIT("[]") alpha_tyvar [] [] listTyCon - (pcGenerateDataSpecs alphaListTy) consDataCon = pcDataCon consDataConKey pREL_BASE SLIT(":") - alpha_tyvar [] [alphaTy, applyTyCon listTyCon alpha_ty] listTyCon - (pcGenerateDataSpecs alphaListTy) + alpha_tyvar [] [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon -- Interesting: polymorphic recursion would help here. -- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy -- gets the over-specific type (Type -> Type) @@ -688,9 +666,9 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}. \end{itemize} \begin{code} -mkTupleTy :: Int -> [GenType t u] -> GenType t u +mkTupleTy :: Int -> [GenType t] -> GenType t -mkTupleTy arity tys = applyTyCon (tupleTyCon arity) tys +mkTupleTy arity tys = mkTyConApp (tupleTyCon arity) tys unitTy = mkTupleTy 0 [] \end{code} @@ -704,16 +682,16 @@ unitTy = mkTupleTy 0 [] Again, deeply turgid: \tr{data _Lift a = _Lift a}. \begin{code} -mkLiftTy ty = applyTyCon liftTyCon [ty] +mkLiftTy ty = mkTyConApp liftTyCon [ty] {- mkLiftTy ty - = mkSigmaTy tvs theta (applyTyCon liftTyCon [tau]) + = mkSigmaTy tvs theta (mkTyConApp liftTyCon [tau]) where (tvs, theta, tau) = splitSigmaTy ty isLiftTy ty - = case (maybeAppDataTyConExpandingDicts tau) of + = case (splitAlgTyConApp_maybeExpandingDicts tau) of Just (tycon, tys, _) -> tycon == liftTyCon Nothing -> False where @@ -721,16 +699,14 @@ isLiftTy ty -} -alphaLiftTy = mkSigmaTy alpha_tyvar [] (applyTyCon liftTyCon alpha_ty) +alphaLiftTy = mkSigmaTy alpha_tyvar [] (mkTyConApp liftTyCon alpha_ty) liftTyCon - = pcDataTyCon liftTyConKey pREL_BASE SLIT("Lift") alpha_tyvar [liftDataCon] + = pcNonRecDataTyCon liftTyConKey pREL_BASE SLIT("Lift") alpha_tyvar [liftDataCon] liftDataCon = pcDataCon liftDataConKey pREL_BASE SLIT("Lift") alpha_tyvar [] alpha_ty liftTyCon - ((pcGenerateDataSpecs alphaLiftTy) `addOneToSpecEnv` - (mkSpecInfo [Just realWorldStatePrimTy] 0 bottom)) where bottom = panic "liftDataCon:State# _RealWorld" \end{code} diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index e48c058894..4d1cfcddc8 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -4,8 +4,6 @@ \section[CostCentre]{The @CostCentre@ data type} \begin{code} -#include "HsVersions.h" - module CostCentre ( CostCentre, CcKind, IsDupdCC{-ToDo:rm-}, IsCafCC(..), noCostCentre, subsumedCosts, @@ -28,15 +26,13 @@ module CostCentre ( cmpCostCentre -- used for removing dups in a list ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import Id ( externallyVisibleId, GenId, showId, SYN_IE(Id) ) +import Id ( externallyVisibleId, GenId, showId, Id ) import CStrings ( identToC, stringToC ) import Name ( OccName, getOccString, moduleString, nameString ) -import Outputable ( PprStyle(..), codeStyle, ifaceStyle ) -import Pretty -import Util ( panic, panic#, assertPanic, cmpPString, thenCmp, Ord3(..) ) -import CmdLineOpts ( all_toplev_ids_visible ) +import Outputable +import Util ( panic, panic#, assertPanic, thenCmp ) pprIdInUnfolding = panic "Whoops" \end{code} @@ -191,13 +187,13 @@ cafifyCC (NormalCC kind m g is_dupd is_caf) where not_a_calf_already IsCafCC = False not_a_calf_already _ = True -cafifyCC cc = panic ("cafifyCC"++(showCostCentre PprDebug False cc)) +cafifyCC cc = panic ("cafifyCC"++(showCostCentre False cc)) dupifyCC (AllDictsCC m g _) = AllDictsCC m g ADupdCC dupifyCC (PreludeDictsCC _) = PreludeDictsCC ADupdCC dupifyCC (NormalCC kind m g is_dupd is_caf) = NormalCC kind m g ADupdCC is_caf -dupifyCC cc = panic ("dupifyCC"++(showCostCentre PprDebug False cc)) +dupifyCC cc = panic ("dupifyCC"++(showCostCentre False cc)) isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool @@ -265,26 +261,26 @@ ccMentionsId other = Nothing \end{code} \begin{code} -cmpCostCentre :: CostCentre -> CostCentre -> TAG_ +cmpCostCentre :: CostCentre -> CostCentre -> Ordering -cmpCostCentre (AllCafsCC m1 _) (AllCafsCC m2 _) = _CMP_STRING_ m1 m2 -cmpCostCentre (AllDictsCC m1 _ _) (AllDictsCC m2 _ _) = _CMP_STRING_ m1 m2 -cmpCostCentre PreludeCafsCC PreludeCafsCC = EQ_ -cmpCostCentre (PreludeDictsCC _) (PreludeDictsCC _) = EQ_ -cmpCostCentre OverheadCC OverheadCC = EQ_ -cmpCostCentre DontCareCC DontCareCC = EQ_ +cmpCostCentre (AllCafsCC m1 _) (AllCafsCC m2 _) = m1 `compare` m2 +cmpCostCentre (AllDictsCC m1 _ _) (AllDictsCC m2 _ _) = m1 `compare` m2 +cmpCostCentre PreludeCafsCC PreludeCafsCC = EQ +cmpCostCentre (PreludeDictsCC _) (PreludeDictsCC _) = EQ +cmpCostCentre OverheadCC OverheadCC = EQ +cmpCostCentre DontCareCC DontCareCC = EQ cmpCostCentre (NormalCC k1 m1 _ _ c1) (NormalCC k2 m2 _ _ c2) -- first key is module name, then we use "kinds" (which include -- names) and finally the caf flag - = _CMP_STRING_ m1 m2 `thenCmp` cmp_kind k1 k2 `thenCmp` cmp_caf c1 c2 + = (m1 `compare` m2) `thenCmp` (k1 `cmp_kind` k2) `thenCmp` (c1 `cmp_caf` c2) cmpCostCentre other_1 other_2 = let tag1 = tag_CC other_1 tag2 = tag_CC other_2 in - if tag1 _LT_ tag2 then LT_ else GT_ + if tag1 _LT_ tag2 then LT else GT where tag_CC (NormalCC _ _ _ _ _) = (ILIT(1) :: FAST_INT) tag_CC (AllCafsCC _ _) = ILIT(2) @@ -300,30 +296,30 @@ cmpCostCentre other_1 other_2 tag_CC CurrentCC = panic# "tag_CC:SubsumedCosts" -cmp_kind (UserCC n1) (UserCC n2) = _CMP_STRING_ n1 n2 -cmp_kind (AutoCC i1) (AutoCC i2) = cmp i1 i2 -cmp_kind (DictCC i1) (DictCC i2) = cmp i1 i2 +cmp_kind (UserCC n1) (UserCC n2) = n1 `compare` n2 +cmp_kind (AutoCC i1) (AutoCC i2) = i1 `compare` i2 +cmp_kind (DictCC i1) (DictCC i2) = i1 `compare` i2 cmp_kind other_1 other_2 = let tag1 = tag_CcKind other_1 tag2 = tag_CcKind other_2 in - if tag1 _LT_ tag2 then LT_ else GT_ + if tag1 _LT_ tag2 then LT else GT where tag_CcKind (UserCC _) = (ILIT(1) :: FAST_INT) tag_CcKind (AutoCC _) = ILIT(2) tag_CcKind (DictCC _) = ILIT(3) -cmp_caf IsNotCafCC IsCafCC = LT_ -cmp_caf IsNotCafCC IsNotCafCC = EQ_ -cmp_caf IsCafCC IsCafCC = EQ_ -cmp_caf IsCafCC IsNotCafCC = GT_ +cmp_caf IsNotCafCC IsCafCC = LT +cmp_caf IsNotCafCC IsNotCafCC = EQ +cmp_caf IsCafCC IsCafCC = EQ +cmp_caf IsCafCC IsNotCafCC = GT \end{code} \begin{code} -showCostCentre :: PprStyle -> Bool -> CostCentre -> String -uppCostCentre :: PprStyle -> Bool -> CostCentre -> Doc -uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Doc +showCostCentre :: Bool -> CostCentre -> String +uppCostCentre :: Bool -> CostCentre -> SDoc +uppCostCentreDecl :: Bool -> CostCentre -> SDoc {- PprUnfolding is gone now showCostCentre PprUnfolding print_as_string cc @@ -333,34 +329,32 @@ showCostCentre PprUnfolding print_as_string cc uppShow 80 (upp_cc_uf cc) -} -showCostCentre sty print_as_string cc - = show (uppCostCentre sty print_as_string cc) +showCostCentre print_as_string cc + = showSDoc (uppCostCentre print_as_string cc) -uppCostCentre sty print_as_string NoCostCentre - | friendly_style sty = empty +uppCostCentre print_as_string NoCostCentre | print_as_string = text "\"NO_CC\"" | otherwise = ptext SLIT("NO_CC") -uppCostCentre sty print_as_string SubsumedCosts +uppCostCentre print_as_string SubsumedCosts | print_as_string = text "\"SUBSUMED\"" | otherwise = ptext SLIT("CC_SUBSUMED") -uppCostCentre sty print_as_string CurrentCC +uppCostCentre print_as_string CurrentCC | print_as_string = text "\"CURRENT_CC\"" | otherwise = ptext SLIT("CCC") -uppCostCentre sty print_as_string OverheadCC +uppCostCentre print_as_string OverheadCC | print_as_string = text "\"OVERHEAD\"" | otherwise = ptext SLIT("CC_OVERHEAD") -uppCostCentre sty print_as_string cc - = let - prefix_CC = ptext SLIT("CC_") - - basic_thing = do_cc cc - - basic_thing_string - = if friendly_sty then basic_thing else stringToC basic_thing +uppCostCentre print_as_string cc + = getPprStyle $ \ sty -> + let + friendly_sty = userStyle sty || debugStyle sty -- i.e. probably for human consumption + prefix_CC = ptext SLIT("CC_") + basic_thing = do_cc friendly_sty cc + basic_thing_string = stringToC basic_thing in if print_as_string then hcat [char '"', text basic_thing_string, char '"'] @@ -370,26 +364,23 @@ uppCostCentre sty print_as_string cc else hcat [prefix_CC, identToC (_PK_ basic_thing)] where - friendly_sty = friendly_style sty - - ---------------- - do_cc DontCareCC = "DONT_CARE" - do_cc (AllCafsCC m _) = if print_as_string - then "CAFs_in_..." - else "CAFs." ++ _UNPK_ m - do_cc (AllDictsCC m _ d) = do_dupd d ( - if print_as_string - then "DICTs_in_..." - else "DICTs." ++ _UNPK_ m) - do_cc PreludeCafsCC = if print_as_string - then "CAFs_in_..." - else "CAFs" - do_cc (PreludeDictsCC d) = do_dupd d ( - if print_as_string - then "DICTs_in_..." - else "DICTs") - - do_cc (NormalCC kind mod_name grp_name is_dupd is_caf) + do_cc friendly_sty DontCareCC = "DONT_CARE" + do_cc friendly_sty (AllCafsCC m _) = if print_as_string + then "CAFs_in_..." + else "CAFs." ++ _UNPK_ m + do_cc friendly_sty (AllDictsCC m _ d) = do_dupd friendly_sty d ( + if print_as_string + then "DICTs_in_..." + else "DICTs." ++ _UNPK_ m) + do_cc friendly_sty PreludeCafsCC = if print_as_string + then "CAFs_in_..." + else "CAFs" + do_cc friendly_sty (PreludeDictsCC d) = do_dupd friendly_sty d ( + if print_as_string + then "DICTs_in_..." + else "DICTs") + + do_cc friendly_sty (NormalCC kind mod_name grp_name is_dupd is_caf) = let basic_kind = do_kind kind module_kind = do_caf is_caf (moduleString mod_name ++ '/': @@ -401,7 +392,7 @@ uppCostCentre sty print_as_string cc ('/' : basic_kind)) in if friendly_sty then - do_dupd is_dupd full_kind + do_dupd friendly_sty is_dupd full_kind else module_kind where @@ -420,19 +411,8 @@ uppCostCentre sty print_as_string cc do_id id = getOccString id --------------- - do_dupd ADupdCC str = if friendly_sty then str ++ "/DUPD" else str - do_dupd _ str = str - -friendly_style sty -- i.e., probably for human consumption - = case sty of - PprForUser _ -> True - PprDebug -> True - PprShowAll -> True - _ -> False -{- -friendly_style sty -- i.e., probably for human consumption - = not (codeStyle sty || ifaceStyle sty) --} + do_dupd friendly_sty ADupdCC str = if friendly_sty then str ++ "/DUPD" else str + do_dupd _ _ str = str \end{code} Printing unfoldings is sufficiently weird that we do it separately. @@ -467,7 +447,7 @@ upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf) pp_caf IsNotCafCC = ptext SLIT("_N_") #ifdef DEBUG -upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre PprDebug True other)) +upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre True other)) #endif upp_dupd AnOriginalCC = ptext SLIT("_N_") @@ -475,7 +455,7 @@ upp_dupd ADupdCC = ptext SLIT("_D_") \end{code} \begin{code} -uppCostCentreDecl sty is_local cc +uppCostCentreDecl is_local cc #ifdef DEBUG | noCostCentreAttached cc || currentOrSubsumedCosts cc = panic "uppCostCentreDecl: no cost centre!" @@ -485,16 +465,20 @@ uppCostCentreDecl sty is_local cc hcat [ ptext SLIT("CC_DECLARE"),char '(', upp_ident, comma, - uppCostCentre sty True {-as String!-} cc, comma, + uppCostCentre True {-as String!-} cc, comma, pp_str mod_name, comma, pp_str grp_name, comma, text is_subsumed, comma, - if externally_visible || all_toplev_ids_visible then empty else ptext SLIT("static"), + if externally_visible {- || all_toplev_ids_visible -} + -- all_toplev stuff removed SLPJ Sept 97; + -- not sure this is right. + then empty + else ptext SLIT("static"), text ");"] else hcat [ ptext SLIT("CC_EXTERN"),char '(', upp_ident, text ");" ] where - upp_ident = uppCostCentre sty False{-as identifier!-} cc + upp_ident = uppCostCentre False{-as identifier!-} cc pp_str s = doubleQuotes (ptext s) diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index c3ae40a4c5..0b644dcd8b 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -23,23 +23,22 @@ This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg. * "Distributes" given cost-centres to all as-yet-unmarked RHSs. \begin{code} -#include "HsVersions.h" - module SCCfinal ( stgMassageForProfiling ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import StgSyn import CmdLineOpts ( opt_AutoSccsOnIndividualCafs ) import CostCentre -- lots of things -import Id ( idType, mkSysLocal, emptyIdSet, SYN_IE(Id) ) +import Id ( idType, mkSysLocal, emptyIdSet, Id ) import SrcLoc ( noSrcLoc ) -import Type ( splitSigmaTy, getFunTy_maybe ) +import Type ( splitSigmaTy, splitFunTy_maybe ) import UniqSupply ( getUnique, splitUniqSupply, UniqSupply ) import Unique ( Unique ) import Util ( removeDups, assertPanic ) import Outputable +import GlaExts ( trace ) infixr 9 `thenMM`, `thenMM_` \end{code} @@ -125,7 +124,7 @@ stgMassageForProfiling mod_name grp_name us stg_binds do_top_rhs binder (StgRhsClosure cc bi fv u [] body) -- Top level CAF with cost centre attached -- Should this be a CAF cc ??? Does this ever occur ??? - = trace ("SCCfinal: CAF with cc: " ++ showCostCentre PprDebug False cc) $ + = trace ("SCCfinal: CAF with cc: " ++ showCostCentre False cc) $ collectCC cc `thenMM_` set_prevailing_cc cc (do_expr body) `thenMM` \ body' -> returnMM (StgRhsClosure cc bi fv u [] body') diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs index 8a384906b3..f04e4cecb8 100644 --- a/ghc/compiler/reader/Lex.lhs +++ b/ghc/compiler/reader/Lex.lhs @@ -4,8 +4,6 @@ \section[Lexical analysis]{Lexical analysis} \begin{code} -#include "HsVersions.h" - module Lex ( isLexCon, isLexVar, isLexId, isLexSym, @@ -13,57 +11,33 @@ module Lex ( mkTupNameStr, ifaceParseErr, -- Monad for parser - IfaceToken(..), lexIface, SYN_IE(IfM), thenIf, returnIf, happyError, + IfaceToken(..), lexIface, IfM, thenIf, returnIf, getSrcLocIf, + happyError, StringBuffer ) where +#include "HsVersions.h" -IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper,isLower, isSpace, ord)) +import Char (isDigit, isAlpha, isAlphanum, isUpper,isLower, isSpace, ord ) -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(Ubiq) -IMPORT_DELOOPER(IdLoop) -- get the CostCentre type&constructors from here -#else import {-# SOURCE #-} CostCentre -# if __GLASGOW_HASKELL__ == 202 -import PrelBase ( Char(..) ) -# endif -# if __GLASGOW_HASKELL__ >= 209 -import Addr ( Addr(..) ) -import ST ( runST ) -# endif -#endif import CmdLineOpts ( opt_IgnoreIfacePragmas ) import Demand ( Demand(..) {- instance Read -} ) import UniqFM ( UniqFM, listToUFM, lookupUFM) import BasicTypes ( NewOrData(..), IfaceFlavour(..) ) +import SrcLoc ( SrcLoc, incSrcLine ) -#if __GLASGOW_HASKELL__ >= 202 import Maybes ( MaybeErr(..) ) -#else -import Maybes ( Maybe(..), MaybeErr(..) ) -#endif -import Pretty - - - -import ErrUtils ( Error(..) ) -import Outputable ( Outputable(..), PprStyle(..) ) +import ErrUtils ( ErrMsg(..) ) +import Outputable import Util ( nOfThem, panic ) import FastString import StringBuffer - -#if __GLASGOW_HASKELL__ <= 201 -import PreludeGlaST -#else import GlaExts -#if __GLASGOW_HASKELL__ < 209 -import ST ( thenST, seqST ) -#endif -#endif +import ST ( runST ) \end{code} %************************************************************************ @@ -257,7 +231,7 @@ lexIface cont buf = -- whitespace and comments, ignore. ' '# -> lexIface cont (stepOn buf) '\t'# -> lexIface cont (stepOn buf) - '\n'# -> \line -> lexIface cont (stepOn buf) (line+1) + '\n'# -> \ loc -> lexIface cont (stepOn buf) (incSrcLine loc) -- Numbers and comments '-'# -> @@ -542,26 +516,29 @@ lex_tuple cont module_dot buf = -- Similarly ' itself is ok inside an identifier, but not at the start -id_arr :: _ByteArray Int +-- id_arr is an array of bytes, indexed by characters, +-- containing 0 if the character isn't a valid character from an identifier +-- and 1 if it is. It's just a memo table for is_id_char. +id_arr :: ByteArray Int id_arr = - unsafePerformST ( - newCharArray (0,255) `thenStrictlyST` \ barr -> + runST ( + newCharArray (0,255) >>= \ barr -> let - loop 256# = returnStrictlyST () + loop 256# = return () loop i# = if isAlphanum (C# (chr# i#)) || is_sym (chr# i#) then - writeCharArray barr (I# i#) '\1' `seqStrictlyST` + writeCharArray barr (I# i#) '\1' >> loop (i# +# 1#) else - writeCharArray barr (I# i#) '\0' `seqStrictlyST` + writeCharArray barr (I# i#) '\0' >> loop (i# +# 1#) in - loop 0# `seqStrictlyST` + loop 0# >> unsafeFreezeByteArray barr) is_id_char (C# c#) = let - _ByteArray _ arr# = id_arr + ByteArray _ arr# = id_arr in case ord# (indexCharArray# arr# (ord# c#)) of 0# -> False @@ -581,27 +558,30 @@ is_sym c# = --isAlphanum c || c `elem` ":_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic -mod_arr :: _ByteArray Int +-- mod_arr is an array of bytes, indexed by characters, +-- containing 0 if the character isn't a valid character from a module name, +-- and 1 if it is. +mod_arr :: ByteArray Int mod_arr = - unsafePerformST ( - newCharArray (0,255) `thenStrictlyST` \ barr -> + runST ( + newCharArray (0,255) >>= \ barr -> let - loop 256# = returnStrictlyST () + loop 256# = return () loop i# = if isAlphanum (C# (chr# i#)) || i# ==# (ord# '_'#) || i# ==# (ord# '\''#) then - writeCharArray barr (I# i#) '\1' `seqStrictlyST` + writeCharArray barr (I# i#) '\1' >> loop (i# +# 1#) else - writeCharArray barr (I# i#) '\0' `seqStrictlyST` + writeCharArray barr (I# i#) '\0' >> loop (i# +# 1#) in - loop 0# `seqStrictlyST` + loop 0# >> unsafeFreezeByteArray barr) is_mod_char (C# c#) = let - _ByteArray _ arr# = mod_arr + ByteArray _ arr# = mod_arr in case ord# (indexCharArray# arr# (ord# c#)) of 0# -> False @@ -860,7 +840,9 @@ end{code} %************************************************************************ \begin{code} -type IfM a = StringBuffer -> Int -> MaybeErr a Error +type IfM a = StringBuffer -- Input string + -> SrcLoc + -> MaybeErr a ErrMsg returnIf :: a -> IfM a returnIf a s l = Succeeded a @@ -871,11 +853,15 @@ m `thenIf` k = \s l -> Succeeded a -> k a s l Failed err -> Failed err +getSrcLocIf :: IfM SrcLoc +getSrcLocIf s l = Succeeded l + happyError :: IfM a happyError s l = Failed (ifaceParseErr l ([]::[IfaceToken]){-Todo-}) ----------------------------------------------------------------- -ifaceParseErr l toks sty - = hsep [ptext SLIT("Interface-file parse error: line"), int l, ptext SLIT("toks="), text (show (take 10 toks))] +ifaceParseErr l toks + = hsep [ppr l, ptext SLIT("Interface-file parse error;"), + ptext SLIT("toks="), text (show (take 10 toks))] \end{code} diff --git a/ghc/compiler/reader/PrefixSyn.lhs b/ghc/compiler/reader/PrefixSyn.lhs index b61c178cbd..4091903467 100644 --- a/ghc/compiler/reader/PrefixSyn.lhs +++ b/ghc/compiler/reader/PrefixSyn.lhs @@ -8,32 +8,26 @@ string from the current Haskell parser is converted. Given in an order that follows the \tr{Prefix_Form} document. \begin{code} -#include "HsVersions.h" - module PrefixSyn ( RdrBinding(..), - SYN_IE(RdrId), + RdrId, RdrMatch(..), - SYN_IE(SigConverter), - SYN_IE(SrcFile), - SYN_IE(SrcFun), - SYN_IE(SrcLine), + SigConverter, + SrcFile, + SrcFun, + SrcLine, readInteger ) where -IMP_Ubiq() -IMPORT_1_3(Char(isDigit)) +#include "HsVersions.h" import HsSyn import RdrHsSyn import BasicTypes ( IfaceFlavour ) import Util ( panic ) import SrcLoc ( SrcLoc ) - -#ifdef REALLY_HASKELL_1_3 -ord = fromEnum :: Char -> Int -#endif +import Char ( isDigit, ord ) type RdrId = RdrName type SrcLine = Int diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs index a8efe1abcc..5e166093ca 100644 --- a/ghc/compiler/reader/PrefixToHs.lhs +++ b/ghc/compiler/reader/PrefixToHs.lhs @@ -6,8 +6,6 @@ Support routines for reading prefix-form from the Lex/Yacc parser. \begin{code} -#include "HsVersions.h" - module PrefixToHs ( cvValSig, cvClassOpSig, @@ -19,13 +17,14 @@ module PrefixToHs ( cvOtherDecls ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import PrefixSyn -- and various syntaxen. import HsSyn import RdrHsSyn import HsPragmas ( noGenPragmas, noClassOpPragmas ) +import BasicTypes ( RecFlag(..) ) import SrcLoc ( mkSrcLoc ) import Util ( mapAndUnzip, panic, assertPanic ) \end{code} @@ -66,7 +65,7 @@ analyser. cvBinds :: SrcFile -> SigConverter -> RdrBinding -> RdrNameHsBinds cvBinds sf sig_cvtr binding = case (cvMonoBindsAndSigs sf sig_cvtr binding) of { (mbs, sigs) -> - MonoBind mbs sigs recursive + MonoBind mbs sigs Recursive } \end{code} @@ -130,7 +129,7 @@ cvMonoBindsAndSigs sf sig_cvtr fb cvPatMonoBind :: SrcFile -> RdrMatch -> (RdrNamePat, [RdrNameGRHS], RdrNameHsBinds) cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding) - = (pat, [OtherwiseGRHS expr (mkSrcLoc sf srcline)], cvBinds sf cvValSig binding) + = (pat, unguardedRHS expr (mkSrcLoc sf srcline), cvBinds sf cvValSig binding) cvPatMonoBind sf (RdrMatch_Guards srcline srcfun pat guardedexprs binding) = (pat, map (cvGRHS sf srcline) guardedexprs, cvBinds sf cvValSig binding) @@ -175,7 +174,7 @@ cvMatch sf is_case rdr_match where (pat, binding, guarded_exprs) = case rdr_match of - RdrMatch_NoGuard ln b c expr d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc sf ln)]) + RdrMatch_NoGuard ln b c expr d -> (c,d, unguardedRHS expr (mkSrcLoc sf ln)) RdrMatch_Guards ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps) cvGRHS :: SrcFile -> SrcLine -> ([RdrNameStmt], RdrNameHsExpr) -> RdrNameGRHS diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index 22827fa4e1..5cd65ddca1 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -7,43 +7,40 @@ they are used somewhat later on in the compiler...) \begin{code} -#include "HsVersions.h" - module RdrHsSyn ( - SYN_IE(RdrNameArithSeqInfo), - SYN_IE(RdrNameBangType), - SYN_IE(RdrNameClassDecl), - SYN_IE(RdrNameClassOpSig), - SYN_IE(RdrNameConDecl), - SYN_IE(RdrNameContext), - SYN_IE(RdrNameSpecDataSig), - SYN_IE(RdrNameDefaultDecl), - SYN_IE(RdrNameFixityDecl), - SYN_IE(RdrNameGRHS), - SYN_IE(RdrNameGRHSsAndBinds), - SYN_IE(RdrNameHsBinds), - SYN_IE(RdrNameHsDecl), - SYN_IE(RdrNameHsExpr), - SYN_IE(RdrNameHsModule), - SYN_IE(RdrNameIE), - SYN_IE(RdrNameImportDecl), - SYN_IE(RdrNameInstDecl), - SYN_IE(RdrNameMatch), - SYN_IE(RdrNameMonoBinds), - SYN_IE(RdrNamePat), - SYN_IE(RdrNameHsType), - SYN_IE(RdrNameSig), - SYN_IE(RdrNameSpecInstSig), - SYN_IE(RdrNameStmt), - SYN_IE(RdrNameTyDecl), - - SYN_IE(RdrNameClassOpPragmas), - SYN_IE(RdrNameClassPragmas), - SYN_IE(RdrNameDataPragmas), - SYN_IE(RdrNameGenPragmas), - SYN_IE(RdrNameInstancePragmas), - SYN_IE(RdrNameCoreExpr), - extractHsTyVars, + RdrNameArithSeqInfo, + RdrNameBangType, + RdrNameClassDecl, + RdrNameClassOpSig, + RdrNameConDecl, + RdrNameContext, + RdrNameSpecDataSig, + RdrNameDefaultDecl, + RdrNameFixityDecl, + RdrNameGRHS, + RdrNameGRHSsAndBinds, + RdrNameHsBinds, + RdrNameHsDecl, + RdrNameHsExpr, + RdrNameHsModule, + RdrNameIE, + RdrNameImportDecl, + RdrNameInstDecl, + RdrNameMatch, + RdrNameMonoBinds, + RdrNamePat, + RdrNameHsType, + RdrNameSig, + RdrNameSpecInstSig, + RdrNameStmt, + RdrNameTyDecl, + + RdrNameClassOpPragmas, + RdrNameClassPragmas, + RdrNameDataPragmas, + RdrNameGenPragmas, + RdrNameInstancePragmas, + extractHsTyVars, extractHsCtxtTyVars, RdrName(..), qual, varQual, tcQual, varUnqual, lexVarQual, lexTcQual, @@ -51,55 +48,52 @@ module RdrHsSyn ( isUnqual, isQual, showRdr, rdrNameOcc, ieOcc, cmpRdr, prefixRdrName, - mkOpApp + mkOpApp, mkClassDecl ) where -IMP_Ubiq() +#include "HsVersions.h" import HsSyn import Lex import PrelMods ( pRELUDE ) -import BasicTypes ( Module(..), NewOrData, IfaceFlavour(..) ) +import BasicTypes ( Module(..), NewOrData, IfaceFlavour(..), Unused ) import Name ( ExportFlag(..), pprModule, OccName(..), pprOccName, - prefixOccName, SYN_IE(NamedThing) ) -import Pretty -import Outputable ( PprStyle(..) ) -import Util --( cmpPString, panic, thenCmp ) + prefixOccName, NamedThing ) +import Util ( thenCmp ) +import CoreSyn ( GenCoreExpr ) +import HsPragmas ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas ) +import List ( nub ) import Outputable -#if __GLASGOW_HASKELL__ >= 202 -import CoreSyn ( GenCoreExpr ) -import HsPragmas ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas ) -#endif \end{code} \begin{code} -type RdrNameArithSeqInfo = ArithSeqInfo Fake Fake RdrName RdrNamePat +type RdrNameArithSeqInfo = ArithSeqInfo Unused RdrName RdrNamePat type RdrNameBangType = BangType RdrName -type RdrNameClassDecl = ClassDecl Fake Fake RdrName RdrNamePat +type RdrNameClassDecl = ClassDecl Unused RdrName RdrNamePat type RdrNameClassOpSig = Sig RdrName type RdrNameConDecl = ConDecl RdrName type RdrNameContext = Context RdrName -type RdrNameHsDecl = HsDecl Fake Fake RdrName RdrNamePat +type RdrNameHsDecl = HsDecl Unused RdrName RdrNamePat type RdrNameSpecDataSig = SpecDataSig RdrName type RdrNameDefaultDecl = DefaultDecl RdrName type RdrNameFixityDecl = FixityDecl RdrName -type RdrNameGRHS = GRHS Fake Fake RdrName RdrNamePat -type RdrNameGRHSsAndBinds = GRHSsAndBinds Fake Fake RdrName RdrNamePat -type RdrNameHsBinds = HsBinds Fake Fake RdrName RdrNamePat -type RdrNameHsExpr = HsExpr Fake Fake RdrName RdrNamePat -type RdrNameHsModule = HsModule Fake Fake RdrName RdrNamePat +type RdrNameGRHS = GRHS Unused RdrName RdrNamePat +type RdrNameGRHSsAndBinds = GRHSsAndBinds Unused RdrName RdrNamePat +type RdrNameHsBinds = HsBinds Unused RdrName RdrNamePat +type RdrNameHsExpr = HsExpr Unused RdrName RdrNamePat +type RdrNameHsModule = HsModule Unused RdrName RdrNamePat type RdrNameIE = IE RdrName type RdrNameImportDecl = ImportDecl RdrName -type RdrNameInstDecl = InstDecl Fake Fake RdrName RdrNamePat -type RdrNameMatch = Match Fake Fake RdrName RdrNamePat -type RdrNameMonoBinds = MonoBinds Fake Fake RdrName RdrNamePat +type RdrNameInstDecl = InstDecl Unused RdrName RdrNamePat +type RdrNameMatch = Match Unused RdrName RdrNamePat +type RdrNameMonoBinds = MonoBinds Unused RdrName RdrNamePat type RdrNamePat = InPat RdrName type RdrNameHsType = HsType RdrName type RdrNameSig = Sig RdrName type RdrNameSpecInstSig = SpecInstSig RdrName -type RdrNameStmt = Stmt Fake Fake RdrName RdrNamePat +type RdrNameStmt = Stmt Unused RdrName RdrNamePat type RdrNameTyDecl = TyDecl RdrName type RdrNameClassOpPragmas = ClassOpPragmas RdrName @@ -107,7 +101,6 @@ type RdrNameClassPragmas = ClassPragmas RdrName type RdrNameDataPragmas = DataPragmas RdrName type RdrNameGenPragmas = GenPragmas RdrName type RdrNameInstancePragmas = InstancePragmas RdrName -type RdrNameCoreExpr = GenCoreExpr RdrName RdrName RdrName RdrName \end{code} @extractHsTyVars@ looks just for things that could be type variables. @@ -115,33 +108,39 @@ It's used when making the for-alls explicit. \begin{code} extractHsTyVars :: HsType RdrName -> [RdrName] -extractHsTyVars ty - = get ty [] - where - get (MonoTyApp ty1 ty2) acc = get ty1 (get ty2 acc) - get (MonoListTy tc ty) acc = get ty acc - get (MonoTupleTy tc tys) acc = foldr get acc tys - get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc) - get (MonoDictTy cls ty) acc = get ty acc - get (MonoTyVar tv) acc = insert tv acc +extractHsTyVars ty = nub (extract_ty ty []) + +extractHsCtxtTyVars :: Context RdrName -> [RdrName] +extractHsCtxtTyVars ty = nub (extract_ctxt ty []) + +extract_ctxt ctxt acc = foldr extract_ass [] ctxt + where + extract_ass (cls, tys) acc = foldr extract_ty acc tys + +extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (MonoListTy tc ty) acc = extract_ty ty acc +extract_ty (MonoTupleTy tc tys) acc = foldr extract_ty acc tys +extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (MonoDictTy cls tys) acc = foldr extract_ty acc tys +extract_ty (MonoTyVar tv) acc = insert tv acc -- In (All a => a -> a) -> Int, there are no free tyvars -- We just assume that we quantify over all type variables mentioned in the context. - get (HsPreForAllTy ctxt ty) acc = - foldr insert acc (filter (`notElem` locals) (get ty [])) - where - locals = foldr (get . snd) [] ctxt - - get (HsForAllTy tvs ctxt ty) acc = - foldr insert acc (filter (`notElem` locals) $ - foldr (get . snd) (get ty []) ctxt) - where - locals = map getTyVarName tvs - - insert (Qual _ _ _) acc = acc - insert (Unqual (TCOcc _)) acc = acc - insert other acc | other `elem` acc = acc - | otherwise = other : acc +extract_ty (HsPreForAllTy ctxt ty) acc = filter (`notElem` locals) (extract_ty ty []) + ++ acc + where + locals = extract_ctxt ctxt [] + +extract_ty (HsForAllTy tvs ctxt ty) acc = acc ++ + (filter (`notElem` locals) $ + extract_ctxt ctxt (extract_ty ty [])) + where + locals = map getTyVarName tvs + + +insert (Qual _ _ _) acc = acc +insert (Unqual (TCOcc _)) acc = acc +insert other acc = other : acc \end{code} @@ -152,6 +151,25 @@ and we don't know the fixity yet. mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2 \end{code} +mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon +by deriving them from the name of the class. + +\begin{code} +mkClassDecl cxt cname tyvars sigs mbinds prags loc + = ClassDecl cxt cname tyvars sigs mbinds prags tname dname loc + where + -- The datacon and tycon are called ":C" where the class is C + -- This prevents name clashes with user-defined tycons or datacons C + (dname, tname) = case cname of + Qual m (TCOcc s) hif -> (Qual m (VarOcc s1) hif, Qual m (TCOcc s1) hif) + where + s1 = SLIT(":") _APPEND_ s + + Unqual (TCOcc s) -> (Unqual (VarOcc s1), Unqual (TCOcc s1)) + where + s1 = SLIT(":") _APPEND_ s + +\end{code} %************************************************************************ %* * @@ -193,10 +211,10 @@ prefixRdrName :: FAST_STRING -> RdrName -> RdrName prefixRdrName prefix (Qual m n hif) = Qual m (prefixOccName prefix n) hif prefixRdrName prefix (Unqual n) = Unqual (prefixOccName prefix n) -cmpRdr (Unqual n1) (Unqual n2) = n1 `cmp` n2 -cmpRdr (Unqual n1) (Qual m2 n2 _) = LT_ -cmpRdr (Qual m1 n1 _) (Unqual n2) = GT_ -cmpRdr (Qual m1 n1 _) (Qual m2 n2 _) = (n1 `cmp` n2) `thenCmp` (_CMP_STRING_ m1 m2) +cmpRdr (Unqual n1) (Unqual n2) = n1 `compare` n2 +cmpRdr (Unqual n1) (Qual m2 n2 _) = LT +cmpRdr (Qual m1 n1 _) (Unqual n2) = GT +cmpRdr (Qual m1 n1 _) (Qual m2 n2 _) = (n1 `compare` n2) `thenCmp` (m1 `compare` m2) -- always compare module-names *second* rdrNameOcc :: RdrName -> OccName @@ -207,29 +225,27 @@ ieOcc :: RdrNameIE -> OccName ieOcc ie = rdrNameOcc (ieName ie) instance Text RdrName where -- debugging - showsPrec _ rn = showString (show (ppr PprDebug rn)) + showsPrec _ rn = showString (showSDoc (ppr rn)) instance Eq RdrName where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } instance Ord RdrName where - a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } - -instance Ord3 RdrName where - cmp = cmpRdr + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpRdr a b instance Outputable RdrName where - ppr sty (Unqual n) = pprQuote sty $ \ sty -> pprOccName sty n - ppr sty (Qual m n _) = pprQuote sty $ \ sty -> hcat [pprModule sty m, char '.', pprOccName sty n] + ppr (Unqual n) = pprOccName n + ppr (Qual m n _) = hcat [pprModule m, char '.', pprOccName n] instance NamedThing RdrName where -- Just so that pretty-printing of expressions works getOccName = rdrNameOcc getName = panic "no getName for RdrNames" -showRdr sty rdr = render (ppr sty rdr) +showRdr rdr = showSDoc (ppr rdr) \end{code} diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index 5c057fe2ee..d2b2f0746f 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -4,19 +4,9 @@ \section{Read parse tree built by Yacc parser} \begin{code} -#include "HsVersions.h" - module ReadPrefix ( rdModule ) where -IMP_Ubiq() -IMPORT_1_3(IO(hPutStr, stderr)) -#if __GLASGOW_HASKELL__ == 201 -import GHCio(stThen) -#elif __GLASGOW_HASKELL__ >= 202 -import GlaExts -import IOBase -import PrelRead -#endif +#include "HsVersions.h" import UgenAll -- all Yacc parser gumpff... import PrefixSyn -- and various syntaxen. @@ -27,16 +17,16 @@ import RdrHsSyn import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) ) import PrefixToHs -import CmdLineOpts ( opt_PprUserLength, opt_NoImplicitPrelude ) -import ErrUtils ( addErrLoc, ghcExit ) +import CmdLineOpts ( opt_NoImplicitPrelude ) import FiniteMap ( elemFM, FiniteMap ) -import Name ( OccName(..), SYN_IE(Module) ) +import Name ( OccName(..), Module ) import Lex ( isLexConId ) -import Outputable ( Outputable(..), PprStyle(..) ) +import Outputable import PrelMods ( pRELUDE ) -import Pretty -import SrcLoc ( mkGeneratedSrcLoc, noSrcLoc, SrcLoc ) -import Util ( nOfThem, pprError, panic ) +import Util ( nOfThem ) +import FastString ( mkFastCharString ) +import IO ( hPutStr, stderr ) +import PrelRead ( readRational__ ) \end{code} %************************************************************************ @@ -113,21 +103,13 @@ cvFlag 1 = True %************************************************************************ \begin{code} -#if __GLASGOW_HASKELL__ == 201 -# define PACK_STR packCString -#elif __GLASGOW_HASKELL__ >= 202 -# define PACK_STR mkFastCharString -#else -# define PACK_STR mkFastCharString -#endif - rdModule :: IO (Module, -- this module's name RdrNameHsModule) -- the main goods rdModule - = _ccall_ hspmain `CCALL_THEN` \ pt -> -- call the Yacc parser! + = _ccall_ hspmain >>= \ pt -> -- call the Yacc parser! let - srcfile = PACK_STR ``input_filename'' -- What A Great Hack! (TM) + srcfile = mkFastCharString ``input_filename'' -- What A Great Hack! (TM) in initUgn $ rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist @@ -210,7 +192,7 @@ wlkExpr expr returnUgn ( HsLam (foldr PatMatch (GRHSMatch (GRHSsAndBindsIn - [OtherwiseGRHS body src_loc] + (unguardedRHS body src_loc) EmptyBinds)) pats) ) @@ -330,7 +312,7 @@ wlkExpr expr U_record con rbinds -> -- record construction wlkDataId con `thenUgn` \ rcon -> wlkList rdRbind rbinds `thenUgn` \ recbinds -> - returnUgn (RecordCon rcon recbinds) + returnUgn (RecordCon rcon (HsVar rcon) recbinds) U_rupdate updexp updbinds -> -- record update wlkExpr updexp `thenUgn` \ aexp -> @@ -348,7 +330,7 @@ wlkExpr expr U_dobind _ _ _ -> error "U_dobind" U_doexp _ _ -> error "U_doexp" U_rbind _ _ -> error "U_rbind" - U_fixop _ _ _ -> error "U_fixop" + U_fixop _ _ _ _ -> error "U_fixop" #endif rdRbind pt @@ -450,22 +432,8 @@ wlkPat pat ConPatIn x [] -> returnUgn (x, lpats) ConOpPatIn x op _ y -> returnUgn (op, x:y:lpats) _ -> getSrcLocUgn `thenUgn` \ loc -> - let - err = addErrLoc loc "Illegal pattern `application'" - (\sty -> hsep (map (ppr sty) (lpat:lpats))) - msg = show (err (PprForUser opt_PprUserLength)) - in -#if __GLASGOW_HASKELL__ == 201 - ioToUgnM (GHCbase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ -> - ioToUgnM (GHCbase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ -> -#elif __GLASGOW_HASKELL__ >= 202 && __GLASGOW_HASKELL__ < 209 - ioToUgnM (IOBase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ -> - ioToUgnM (IOBase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ -> -#else - ioToUgnM (hPutStr stderr msg) `thenUgn` \ _ -> - ioToUgnM (ghcExit 1) `thenUgn` \ _ -> -#endif - returnUgn (error "ReadPrefix") + pprPanic "Illegal pattern `application'" + (ppr loc <> colon <+> hsep (map ppr (lpat:lpats))) ) `thenUgn` \ (n, arg_pats) -> returnUgn (ConPatIn n arg_pats) @@ -533,16 +501,8 @@ wlkLiteral ulit where as_char s = _HEAD_ s as_integer s = readInteger (_UNPK_ s) -#if __GLASGOW_HASKELL__ == 201 - as_rational s = GHCbase.readRational__ (_UNPK_ s) -- non-std -#elif __GLASGOW_HASKELL__ == 202 - as_rational s = case readRational (_UNPK_ s) of { [(a,_)] -> a } -#elif __GLASGOW_HASKELL__ >= 203 as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__ -- to handle rationals with leading '-' -#else - as_rational s = _readRational (_UNPK_ s) -- non-std -#endif as_string s = s \end{code} @@ -571,7 +531,7 @@ wlkBinding binding U_tbind tctxt ttype tcons tderivs srcline -> mkSrcLocUgn srcline $ \ src_loc -> wlkContext tctxt `thenUgn` \ ctxt -> - wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) -> + wlkConAndTyVars ttype `thenUgn` \ (tycon, tyvars) -> wlkList rdConDecl tcons `thenUgn` \ cons -> wlkDerivings tderivs `thenUgn` \ derivings -> returnUgn (RdrTyDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc)) @@ -580,7 +540,7 @@ wlkBinding binding U_ntbind ntctxt nttype ntcon ntderivs srcline -> mkSrcLocUgn srcline $ \ src_loc -> wlkContext ntctxt `thenUgn` \ ctxt -> - wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) -> + wlkConAndTyVars nttype `thenUgn` \ (tycon, tyvars) -> wlkList rdConDecl ntcon `thenUgn` \ cons -> wlkDerivings ntderivs `thenUgn` \ derivings -> returnUgn (RdrTyDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc)) @@ -588,7 +548,7 @@ wlkBinding binding -- "type" declaration U_nbind nbindid nbindas srcline -> mkSrcLocUgn srcline $ \ src_loc -> - wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) -> + wlkConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) -> wlkMonoType nbindas `thenUgn` \ expansion -> returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc)) @@ -606,29 +566,29 @@ wlkBinding binding -- "class" declaration U_cbind cbindc cbindid cbindw srcline -> - mkSrcLocUgn srcline $ \ src_loc -> - wlkContext cbindc `thenUgn` \ ctxt -> - wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)-> - wlkBinding cbindw `thenUgn` \ binding -> - getSrcFileUgn `thenUgn` \ sf -> + mkSrcLocUgn srcline $ \ src_loc -> + wlkContext cbindc `thenUgn` \ ctxt -> + wlkConAndTyVars cbindid `thenUgn` \ (clas, tyvars) -> + wlkBinding cbindw `thenUgn` \ binding -> + getSrcFileUgn `thenUgn` \ sf -> let (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding in returnUgn (RdrClassDecl - (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc)) + (mkClassDecl ctxt clas tyvars final_sigs final_methods noClassPragmas src_loc)) -- "instance" declaration - U_ibind ibindc iclas ibindi ibindw srcline -> + U_ibind ty ibindw srcline -> + -- The "ty" contains the instance context too + -- So for "instance Eq a => Eq [a]" the type will be + -- Eq a => Eq [a] mkSrcLocUgn srcline $ \ src_loc -> - wlkContext ibindc `thenUgn` \ ctxt -> - wlkTCId iclas `thenUgn` \ clas -> - wlkMonoType ibindi `thenUgn` \ at_ty -> - wlkBinding ibindw `thenUgn` \ binding -> - getSrcModUgn `thenUgn` \ modname -> - getSrcFileUgn `thenUgn` \ sf -> + wlkInstType ty `thenUgn` \ inst_ty -> + wlkBinding ibindw `thenUgn` \ binding -> + getSrcModUgn `thenUgn` \ modname -> + getSrcFileUgn `thenUgn` \ sf -> let (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding - inst_ty = HsPreForAllTy ctxt (MonoDictTy clas at_ty) in returnUgn (RdrInstDecl (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc)) @@ -765,38 +725,49 @@ wlkMonoType ttype wlkMonoType targ `thenUgn` \ ty2 -> returnUgn (MonoFunTy ty1 ty2) +wlkInstType ttype + = case ttype of + U_context tcontextl tcontextt -> -- context + wlkContext tcontextl `thenUgn` \ ctxt -> + wlkConAndTys tcontextt `thenUgn` \ (clas, tys) -> + returnUgn (HsPreForAllTy ctxt (MonoDictTy clas tys)) + + other -> -- something else + wlkConAndTys other `thenUgn` \ (clas, tys) -> + returnUgn (HsPreForAllTy [{-no context-}] (MonoDictTy clas tys)) \end{code} \begin{code} -wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName]) -wlkContext :: U_list -> UgnM RdrNameContext -wlkClassAssertTy :: U_ttype -> UgnM (RdrName, HsTyVar RdrName) - -wlkTyConAndTyVars ttype +wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName]) +wlkConAndTyVars ttype = wlkMonoType ttype `thenUgn` \ ty -> let split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args) split (MonoTyVar tycon) args = (tycon,args) + split other args = pprPanic "ERROR: malformed type: " + (ppr other) in returnUgn (split ty []) -wlkContext list - = wlkList rdMonoType list `thenUgn` \ tys -> - returnUgn (map mk_class_assertion tys) -wlkClassAssertTy xs - = wlkMonoType xs `thenUgn` \ mono_ty -> - returnUgn (case mk_class_assertion mono_ty of - (clas, MonoTyVar tyvar) -> (clas, UserTyVar tyvar) - ) +wlkContext :: U_list -> UgnM RdrNameContext +rdConAndTys :: ParseTree -> UgnM (RdrName, [HsType RdrName]) -mk_class_assertion :: RdrNameHsType -> (RdrName, RdrNameHsType) +wlkContext list = wlkList rdConAndTys list -mk_class_assertion (MonoTyApp (MonoTyVar name) ty@(MonoTyVar tyname)) = (name, ty) -mk_class_assertion other - = pprError "ERROR: malformed type context: " (ppr (PprForUser opt_PprUserLength) other) - -- regrettably, the parser does let some junk past - -- e.g., f :: Num {-nothing-} => a -> ... +rdConAndTys pt + = rdU_ttype pt `thenUgn` \ ttype -> + wlkConAndTys ttype + +wlkConAndTys ttype + = wlkMonoType ttype `thenUgn` \ ty -> + let + split (MonoTyApp fun ty) tys = split fun (ty : tys) + split (MonoTyVar tycon) tys = (tycon, tys) + split other tys = pprPanic "ERROR: malformed type: " + (ppr other) + in + returnUgn (split ty []) \end{code} \begin{code} @@ -899,9 +870,9 @@ rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl rdFixOp pt = rdU_tree pt `thenUgn` \ fix -> case fix of - U_fixop op dir_n prec -> wlkVarId op `thenUgn` \ op -> - returnUgn (FixityDecl op (Fixity prec dir) noSrcLoc) - -- ToDo: add SrcLoc! + U_fixop op dir_n prec srcline -> wlkVarId op `thenUgn` \ op -> + mkSrcLocUgn srcline $ \ src_loc -> + returnUgn (FixityDecl op (Fixity prec dir) src_loc) where dir = case dir_n of (-1) -> InfixL diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index ae6faae95e..27f444dac5 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -1,32 +1,30 @@ { -#include "HsVersions.h" -module ParseIface ( parseIface ) where +module ParseIface ( parseIface, IfaceStuff(..) ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import HsSyn -- quite a bit of stuff import RdrHsSyn -- oodles of synonyms -import HsDecls ( HsIdInfo(..), HsStrictnessInfo ) +import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) ) import HsTypes ( mkHsForAllTy ) import HsCore import Literal import BasicTypes ( IfaceFlavour(..), Fixity(..), FixityDirection(..), NewOrData(..), Version(..) ) import HsPragmas ( noDataPragmas, noClassPragmas ) -import Kind ( Kind, mkArrowKind, mkBoxedTypeKind ) -import IdInfo ( ArgUsageInfo, FBTypeInfo ) +import Kind ( Kind, mkArrowKind, mkBoxedTypeKind, mkTypeKind ) +import IdInfo ( ArgUsageInfo, FBTypeInfo, ArityInfo, exactArity ) +import PrimRep ( decodePrimRep ) import Lex -import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..), - SYN_IE(RdrNamePragma), SYN_IE(ExportItem), SYN_IE(RdrAvailInfo), GenAvailInfo(..) +import RnMonad ( ImportVersion, LocalVersion, ParsedIface(..), WhatsImported(..), + RdrNamePragma, ExportItem, RdrAvailInfo, GenAvailInfo(..) ) import Bag ( emptyBag, unitBag, snocBag ) import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) import Name ( OccName(..), isTCOcc, Provenance, SYN_IE(Module) ) -import SrcLoc ( mkIfaceSrcLoc ) ---import Util ( panic{-, pprPanic ToDo:rm-} ) -import ParseType ( parseType ) -import ParseUnfolding ( parseUnfolding ) +import SrcLoc ( SrcLoc ) import Maybes +import Outputable } @@ -81,9 +79,9 @@ import Maybes QVARSYM { ITqvarsym $$ } QCONSYM { ITqconsym $$ } + STRICT_PART { ITstrict $$ } TYPE_PART { ITtysig _ _ } ARITY_PART { ITarity } - STRICT_PART { ITstrict $$ } UNFOLD_PART { ITunfold $$ } BOTTOM { ITbottom } LAM { ITlam } @@ -115,6 +113,17 @@ import Maybes UNKNOWN { ITunknown $$ } %% +-- iface_stuff is the main production. +-- It recognises (a) a whole interface file +-- (b) a type (so that type sigs can be parsed lazily) +-- (c) the IdInfo part of a signature (same reason) + +iface_stuff :: { IfaceStuff } +iface_stuff : iface { PIface $1 } + | type { PType $1 } + | id_info { PIdInfo $1 } + + iface :: { ParsedIface } iface : INTERFACE CONID INTEGER inst_modules_part @@ -143,9 +152,13 @@ module_stuff_pairs : { [] } | module_stuff_pair module_stuff_pairs { $1 : $2 } module_stuff_pair :: { ImportVersion OccName } -module_stuff_pair : mod_name opt_bang INTEGER DCOLON name_version_pairs SEMI +module_stuff_pair : mod_name opt_bang INTEGER DCOLON whats_imported SEMI { ($1, $2, fromInteger $3, $5) } +whats_imported :: { WhatsImported OccName } +whats_imported : { Everything } + | name_version_pair name_version_pairs { Specifically ($1:$2) } + versions_part :: { [LocalVersion OccName] } versions_part : VERSIONS_PART name_version_pairs { $2 } | { [] } @@ -224,26 +237,32 @@ version :: { Version } version : INTEGER { fromInteger $1 } topdecl :: { RdrNameHsDecl } -topdecl : TYPE tc_name tv_bndrs EQUAL type SEMI - { TyD (TySynonym $2 $3 $5 mkIfaceSrcLoc) } - | DATA decl_context tc_name tv_bndrs constrs deriving SEMI - { TyD (TyData DataType $2 $3 $4 $5 $6 noDataPragmas mkIfaceSrcLoc) } - | NEWTYPE decl_context tc_name tv_bndrs newtype_constr deriving SEMI - { TyD (TyData NewType $2 $3 $4 $5 $6 noDataPragmas mkIfaceSrcLoc) } - | CLASS decl_context tc_name tv_bndr csigs SEMI - { ClD (ClassDecl $2 $3 $4 $5 EmptyMonoBinds noClassPragmas mkIfaceSrcLoc) } - | var_name TYPE_PART +topdecl : src_loc TYPE tc_name tv_bndrs EQUAL type SEMI + { TyD (TySynonym $3 $4 $6 $1) } + | src_loc DATA decl_context tc_name tv_bndrs constrs deriving SEMI + { TyD (TyData DataType $3 $4 $5 $6 $7 noDataPragmas $1) } + | src_loc NEWTYPE decl_context tc_name tv_bndrs newtype_constr deriving SEMI + { TyD (TyData NewType $3 $4 $5 $6 $7 noDataPragmas $1) } + | src_loc CLASS decl_context tc_name tv_bndrs csigs SEMI + { ClD (mkClassDecl $3 $4 $5 $6 EmptyMonoBinds noClassPragmas $1) } + | src_loc var_name TYPE_PART { - case $2 of - ITtysig sig idinfo_part -> + case $3 of + ITtysig sig idinfo_part -> -- Parse type and idinfo lazily let info = case idinfo_part of Nothing -> [] - Just s -> - let { (Succeeded id_info) = parseUnfolding s } in id_info - (Succeeded tp) = parseType sig + Just s -> case parseIface s $1 of + Succeeded (PIdInfo id_info) -> id_info + other -> pprPanic "IdInfo parse failed" + (ppr $2) + + tp = case parseIface sig $1 of + Succeeded (PType tp) -> tp + other -> pprPanic "Id type parse failed" + (ppr $2) in - SigD (IfaceSig $1 tp info mkIfaceSrcLoc) } + SigD (IfaceSig $2 tp info $1) } decl_context :: { RdrNameContext } decl_context : { [] } @@ -259,11 +278,12 @@ csigs1 : csig { [$1] } | csig SEMI csigs1 { $1 : $3 } csig :: { RdrNameSig } -csig : var_name DCOLON type { ClassOpSig $1 Nothing $3 mkIfaceSrcLoc } - | var_name EQUAL DCOLON type { ClassOpSig $1 (Just (error "Un-filled-in default method")) - $4 mkIfaceSrcLoc +csig : src_loc var_name DCOLON type { ClassOpSig $2 Nothing $4 $1 } + | src_loc var_name EQUAL DCOLON type { ClassOpSig $2 + (Just (error "Un-filled-in default method")) + $5 $1 } ---------------------------------------------------------------- - } + constrs :: { [RdrNameConDecl] {- empty for handwritten abstract -} } : { [] } @@ -274,12 +294,12 @@ constrs1 : constr { [$1] } | constr VBAR constrs1 { $1 : $3 } constr :: { RdrNameConDecl } -constr : data_name batypes { ConDecl $1 [] (VanillaCon $2) mkIfaceSrcLoc } - | data_name OCURLY fields1 CCURLY { ConDecl $1 [] (RecCon $3) mkIfaceSrcLoc } +constr : src_loc data_name batypes { ConDecl $2 [] (VanillaCon $3) $1 } + | src_loc data_name OCURLY fields1 CCURLY { ConDecl $2 [] (RecCon $4) $1 } newtype_constr :: { [RdrNameConDecl] {- Empty if handwritten abstract -} } -newtype_constr : { [] } - | EQUAL data_name atype { [ConDecl $2 [] (NewCon $3) mkIfaceSrcLoc] } +newtype_constr : { [] } + | src_loc EQUAL data_name atype { [ConDecl $3 [] (NewCon $4) $1] } deriving :: { Maybe [RdrName] } : { Nothing } @@ -299,9 +319,13 @@ fields1 : field { [$1] } field :: { ([RdrName], RdrNameBangType) } field : var_names1 DCOLON type { ($1, Unbanged $3) } - | var_names1 DCOLON BANG type { ($1, Banged $4) + | var_names1 DCOLON BANG type { ($1, Banged $4) } -------------------------------------------------------------------------- - } + +type :: { RdrNameHsType } +type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 } + | btype RARROW type { MonoFunTy $1 $3 } + | btype { $1 } forall :: { [HsTyVar RdrName] } forall : OBRACK tv_bndrs CBRACK { $2 } @@ -314,13 +338,8 @@ context_list1 :: { RdrNameContext } context_list1 : class { [$1] } | class COMMA context_list1 { $1 : $3 } -class :: { (RdrName, RdrNameHsType) } -class : tc_name atype { ($1, $2) } - -type :: { RdrNameHsType } -type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 } - | btype RARROW type { MonoFunTy $1 $3 } - | btype { $1 } +class :: { (RdrName, [RdrNameHsType]) } +class : tc_name atypes { ($1, $2) } types2 :: { [RdrNameHsType] {- Two or more -} } types2 : type COMMA type { [$1,$3] } @@ -335,14 +354,13 @@ atype : tc_name { MonoTyVar $1 } | tv_name { MonoTyVar $1 } | OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 } | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 } - | OCURLY tc_name atype CCURLY { MonoDictTy $2 $3 } + | OCURLY tc_name atypes CCURLY { MonoDictTy $2 $3 } | OPAREN type CPAREN { $2 } atypes :: { [RdrNameHsType] {- Zero or more -} } atypes : { [] } - | atype atypes { $1 : $2 + | atype atypes { $1 : $2 } --------------------------------------------------------------------- - } mod_name :: { Module } : CONID { $1 } @@ -375,23 +393,40 @@ val_occs1 :: { [OccName] } var_name :: { RdrName } var_name : var_occ { Unqual $1 } +qvar_name :: { RdrName } +qvar_name : var_name { $1 } + | QVARID { lexVarQual $1 } + | QVARSYM { lexVarQual $1 } + +var_names :: { [RdrName] } +var_names : { [] } + | var_name var_names { $1 : $2 } + var_names1 :: { [RdrName] } -var_names1 : var_name { [$1] } - | var_name var_names1 { $1 : $2 } +var_names1 : var_name var_names { $1 : $2 } data_name :: { RdrName } data_name : CONID { Unqual (VarOcc $1) } | CONSYM { Unqual (VarOcc $1) } -tc_names1 :: { [RdrName] } - : tc_name { [$1] } - | tc_name COMMA tc_names1 { $1 : $3 } +qdata_name :: { RdrName } +qdata_name : data_name { $1 } + | QCONID { lexVarQual $1 } + | QCONSYM { lexVarQual $1 } + +qdata_names :: { [RdrName] } +qdata_names : { [] } + | qdata_name qdata_names { $1 : $2 } tc_name :: { RdrName } tc_name : tc_occ { Unqual $1 } | QCONID { lexTcQual $1 } | QCONSYM { lexTcQual $1 } +tc_names1 :: { [RdrName] } + : tc_name { [$1] } + | tc_name COMMA tc_names1 { $1 : $3 } + tv_name :: { RdrName } tv_name : VARID { Unqual (TvOcc $1) } | VARSYM { Unqual (TvOcc $1) {- Allow t2 as a tyvar -} } @@ -413,10 +448,14 @@ kind :: { Kind } | akind RARROW kind { mkArrowKind $1 $3 } akind :: { Kind } - : VARSYM { mkBoxedTypeKind {- ToDo: check that it's "*" -} } - | OPAREN kind CPAREN { $2 --------------------------------------------------------------------------- + : VARSYM { if $1 == SLIT("*") then + mkBoxedTypeKind + else if $1 == SLIT("**") then + mkTypeKind + else panic "ParseInterface: akind" } + | OPAREN kind CPAREN { $2 } +-------------------------------------------------------------------------- instances_part :: { [RdrNameInstDecl] } @@ -428,11 +467,159 @@ instdecls : { [] } | instd instdecls { $1 : $2 } instd :: { RdrNameInstDecl } -instd : INSTANCE type EQUAL var_name SEMI - { InstDecl $2 +instd : src_loc INSTANCE type EQUAL var_name SEMI + { InstDecl $3 EmptyMonoBinds {- No bindings -} [] {- No user pragmas -} - (Just $4) {- Dfun id -} - mkIfaceSrcLoc --------------------------------------------------------------------------- + (Just $5) {- Dfun id -} + $1 } +-------------------------------------------------------------------------- + +id_info :: { [HsIdInfo RdrName] } +id_info : { [] } + | id_info_item id_info { $1 : $2 } + +id_info_item :: { HsIdInfo RdrName } +id_info_item : ARITY_PART arity_info { HsArity $2 } + | strict_info { HsStrictness $1 } + | BOTTOM { HsStrictness HsBottom } + | UNFOLD_PART core_expr { HsUnfold $1 $2 } + +arity_info :: { ArityInfo } +arity_info : INTEGER { exactArity (fromInteger $1) } + +strict_info :: { HsStrictnessInfo RdrName } +strict_info : STRICT_PART qvar_name OCURLY qdata_names CCURLY { HsStrictnessInfo $1 (Just ($2,$4)) } + | STRICT_PART qvar_name { HsStrictnessInfo $1 (Just ($2,[])) } + | STRICT_PART { HsStrictnessInfo $1 Nothing } + +core_expr :: { UfExpr RdrName } +core_expr : qvar_name { UfVar $1 } + | qdata_name { UfVar $1 } + | core_lit { UfLit $1 } + | OPAREN core_expr CPAREN { $2 } + | qdata_name OCURLY data_args CCURLY { UfCon $1 $3 } + + | core_expr ATSIGN atype { UfApp $1 (UfTyArg $3) } + | core_expr core_arg { UfApp $1 $2 } + | LAM core_val_bndrs RARROW core_expr { foldr UfLam $4 $2 } + | BIGLAM core_tv_bndrs RARROW core_expr { foldr UfLam $4 $2 } + + | CASE core_expr OF + OCURLY alg_alts core_default CCURLY { UfCase $2 (UfAlgAlts $5 $6) } + | PRIM_CASE core_expr OF + OCURLY prim_alts core_default CCURLY { UfCase $2 (UfPrimAlts $5 $6) } + + + | LET OCURLY core_val_bndr EQUAL core_expr CCURLY + IN core_expr { UfLet (UfNonRec $3 $5) $8 } + | LETREC OCURLY rec_binds CCURLY + IN core_expr { UfLet (UfRec $3) $6 } + + | coerce atype core_expr { UfCoerce $1 $2 $3 } + + | CCALL ccall_string + OBRACK atype atypes CBRACK core_args { let + (is_casm, may_gc) = $1 + in + UfPrim (UfCCallOp $2 is_casm may_gc $5 $4) + $7 + } + | SCC core_expr { UfSCC $1 $2 } + +rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] } + : { [] } + | core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 } + +coerce :: { UfCoercion RdrName } +coerce : COERCE_IN qdata_name { UfIn $2 } + | COERCE_OUT qdata_name { UfOut $2 } + +prim_alts :: { [(Literal,UfExpr RdrName)] } + : { [] } + | core_lit RARROW core_expr SEMI prim_alts { ($1,$3) : $5 } + +alg_alts :: { [(RdrName, [RdrName], UfExpr RdrName)] } + : { [] } + | qdata_name var_names RARROW + core_expr SEMI alg_alts { ($1,$2,$4) : $6 } + +core_default :: { UfDefault RdrName } + : { UfNoDefault } + | var_name RARROW core_expr SEMI { UfBindDefault $1 $3 } + +core_arg :: { UfArg RdrName } + : qvar_name { UfVarArg $1 } + | qdata_name { UfVarArg $1 } + | core_lit { UfLitArg $1 } + +core_args :: { [UfArg RdrName] } + : { [] } + | core_arg core_args { $1 : $2 } + +data_args :: { [UfArg RdrName] } + : { [] } + | ATSIGN atype data_args { UfTyArg $2 : $3 } + | core_arg data_args { $1 : $2 } + +core_lit :: { Literal } +core_lit : INTEGER { MachInt $1 True } + | CHAR { MachChar $1 } + | STRING { MachStr $1 } + | STRING_LIT STRING { NoRepStr $2 } + | DOUBLE { MachDouble (toRational $1) } + | FLOAT_LIT DOUBLE { MachFloat (toRational $2) } + + | INTEGER_LIT INTEGER { NoRepInteger $2 (panic "NoRepInteger type") + -- The type checker will add the types + } + + | RATIONAL_LIT INTEGER INTEGER { NoRepRational ($2 % $3) + (panic "NoRepRational type") + -- The type checker will add the type + } + + | ADDR_LIT INTEGER { MachAddr $2 } + | LIT_LIT prim_rep STRING { MachLitLit $3 (decodePrimRep $2) } + +core_val_bndr :: { UfBinder RdrName } +core_val_bndr : var_name DCOLON atype { UfValBinder $1 $3 } + +core_val_bndrs :: { [UfBinder RdrName] } +core_val_bndrs : { [] } + | core_val_bndr core_val_bndrs { $1 : $2 } + +core_tv_bndr :: { UfBinder RdrName } +core_tv_bndr : tv_name DCOLON akind { UfTyBinder $1 $3 } + | tv_name { UfTyBinder $1 mkBoxedTypeKind } + +core_tv_bndrs :: { [UfBinder RdrName] } +core_tv_bndrs : { [] } + | core_tv_bndr core_tv_bndrs { $1 : $2 } + +ccall_string :: { FAST_STRING } + : STRING { $1 } + | VARID { $1 } + | CONID { $1 } + +prim_rep :: { Char } + : VARID { head (_UNPK_ $1) } + | CONID { head (_UNPK_ $1) } + + +------------------------------------------------------------------- + +src_loc :: { SrcLoc } +src_loc : {% getSrcLocIf } + +------------------------------------------------------------------- + +-- Haskell code +{ + +data IfaceStuff = PIface ParsedIface + | PIdInfo [HsIdInfo RdrName] + | PType RdrNameHsType + +} diff --git a/ghc/compiler/rename/ParseType.y b/ghc/compiler/rename/ParseType.y deleted file mode 100644 index 8799da46b4..0000000000 --- a/ghc/compiler/rename/ParseType.y +++ /dev/null @@ -1,145 +0,0 @@ -{ -#include "HsVersions.h" -module ParseType ( parseType ) where - -IMP_Ubiq(){-uitous-} - -import HsSyn -- quite a bit of stuff -import RdrHsSyn -- oodles of synonyms -import HsDecls ( HsIdInfo(..), HsStrictnessInfo ) -import HsTypes ( mkHsForAllTy ) -import HsCore -import Literal -import HsPragmas ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas ) -import IdInfo ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo, - ArgUsageInfo, FBTypeInfo - ) -import Kind ( Kind, mkArrowKind, mkBoxedTypeKind ) -import Lex - -import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..), - SYN_IE(RdrNamePragma), SYN_IE(ExportItem), GenAvailInfo - ) -import Bag ( emptyBag, unitBag, snocBag ) -import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) -import Name ( OccName(..), isTCOcc, Provenance ) -import SrcLoc ( mkIfaceSrcLoc ) -import Util ( panic{-, pprPanic ToDo:rm-} ) -import Pretty ( Doc ) -import Outputable ( PprStyle(..) ) -import Maybes ( MaybeErr(..) ) - ------------------------------------------------------------------- - -parseType :: StringBuffer -> MaybeErr RdrNameHsType (PprStyle -> Doc) -parseType ls = - let - res = - case parseT ls 1 of - v@(Succeeded _) -> v - Failed err -> panic (show (err PprDebug)) - in - res - -} - -%name parseT -%tokentype { IfaceToken } -%monad { IfM }{ thenIf }{ returnIf } -%lexer { lexIface } { ITeof } - -%token - FORALL { ITforall } - DCOLON { ITdcolon } - COMMA { ITcomma } - DARROW { ITdarrow } - OCURLY { ITocurly } - OBRACK { ITobrack } - OPAREN { IToparen } - RARROW { ITrarrow } - CCURLY { ITccurly } - CBRACK { ITcbrack } - CPAREN { ITcparen } - - VARID { ITvarid $$ } - CONID { ITconid $$ } - VARSYM { ITvarsym $$ } - CONSYM { ITconsym $$ } - QCONID { ITqconid $$ } - QCONSYM { ITqconsym $$ } - - UNKNOWN { ITunknown $$ } -%% - -type :: { RdrNameHsType } -type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 } - | btype RARROW type { MonoFunTy $1 $3 } - | btype { $1 } - -forall : OBRACK tv_bndrs CBRACK { $2 } - -context :: { RdrNameContext } -context : { [] } - | OCURLY context_list1 CCURLY { $2 } - -context_list1 :: { RdrNameContext } -context_list1 : class { [$1] } - | class COMMA context_list1 { $1 : $3 } - -class :: { (RdrName, RdrNameHsType) } -class : tc_name atype { ($1, $2) } - - -types2 :: { [RdrNameHsType] {- Two or more -} } -types2 : type COMMA type { [$1,$3] } - | type COMMA types2 { $1 : $3 } - -btype :: { RdrNameHsType } -btype : atype { $1 } - | btype atype { MonoTyApp $1 $2 } - -atype :: { RdrNameHsType } -atype : tc_name { MonoTyVar $1 } - | tv_name { MonoTyVar $1 } - | OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 } - | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 } - | OCURLY tc_name atype CCURLY { MonoDictTy $2 $3 } - | OPAREN type CPAREN { $2 } - -atypes :: { [RdrNameHsType] {- Zero or more -} } -atypes : { [] } - | atype atypes { $1 : $2 ---------------------------------------------------------------------- - } - -tv_bndr :: { HsTyVar RdrName } -tv_bndr : tv_name DCOLON akind { IfaceTyVar $1 $3 } - | tv_name { UserTyVar $1 } - -tv_bndrs :: { [HsTyVar RdrName] } - : { [] } - | tv_bndr tv_bndrs { $1 : $2 } - -kind :: { Kind } - : akind { $1 } - | akind RARROW kind { mkArrowKind $1 $3 } - -akind :: { Kind } - : VARSYM { mkBoxedTypeKind {- ToDo: check that it's "*" -} } - | OPAREN kind CPAREN { $2 } - -tv_name :: { RdrName } -tv_name : VARID { Unqual (TvOcc $1) } - | VARSYM { Unqual (TvOcc $1) {- Allow t2 as a tyvar -} } - -tv_names :: { [RdrName] } - : { [] } - | tv_name tv_names { $1 : $2 } - -tc_name :: { RdrName } -tc_name : QCONID { lexTcQual $1 } - | QCONSYM { lexTcQual $1 } - | CONID { Unqual (TCOcc $1) } - | CONSYM { Unqual (TCOcc $1) } - | OPAREN RARROW CPAREN { Unqual (TCOcc SLIT("->")) } - diff --git a/ghc/compiler/rename/ParseUnfolding.y b/ghc/compiler/rename/ParseUnfolding.y deleted file mode 100644 index 5c180eb4fa..0000000000 --- a/ghc/compiler/rename/ParseUnfolding.y +++ /dev/null @@ -1,353 +0,0 @@ -{ -#include "HsVersions.h" -module ParseUnfolding ( parseUnfolding ) where - -IMP_Ubiq(){-uitous-} - -import HsSyn -- quite a bit of stuff -import RdrHsSyn -- oodles of synonyms -import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) ) -import HsTypes ( mkHsForAllTy ) -import HsCore -import Literal -import PrimRep ( decodePrimRep ) -import HsPragmas ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas ) -import IdInfo ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo, - ArgUsageInfo, FBTypeInfo, ArityInfo, StrictnessInfo - ) -import Kind ( Kind, mkArrowKind, mkBoxedTypeKind ) -import Lex - -import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..), - SYN_IE(RdrNamePragma), SYN_IE(ExportItem), GenAvailInfo - ) -import Bag ( emptyBag, unitBag, snocBag ) -import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) -import Name ( OccName(..), isTCOcc, Provenance, SYN_IE(Module) ) -import SrcLoc ( mkIfaceSrcLoc ) -import Util ( panic{-, pprPanic ToDo:rm-} ) -import Pretty ( Doc ) -import Outputable ( PprStyle(..) ) -import Maybes ( MaybeErr(..) ) - ------------------------------------------------------------------- - -parseUnfolding ls = - let - res = - case parseUnfold ls 1 of -- Todo: correct line number - v@(Succeeded _) -> v - -- ill-formed unfolding, crash and burn. - Failed err -> panic (show (err PprDebug)) - in - res -} - -%name parseUnfold -%tokentype { IfaceToken } -%monad { IfM }{ thenIf }{ returnIf } -%lexer { lexIface } { ITeof } - -%token - PRAGMAS_PART { ITpragmas } - DATA { ITdata } - TYPE { ITtype } - NEWTYPE { ITnewtype } - DERIVING { ITderiving } - CLASS { ITclass } - WHERE { ITwhere } - INSTANCE { ITinstance } - FORALL { ITforall } - BANG { ITbang } - VBAR { ITvbar } - DCOLON { ITdcolon } - COMMA { ITcomma } - DARROW { ITdarrow } - DOTDOT { ITdotdot } - EQUAL { ITequal } - OCURLY { ITocurly } - OBRACK { ITobrack } - OPAREN { IToparen } - RARROW { ITrarrow } - CCURLY { ITccurly } - CBRACK { ITcbrack } - CPAREN { ITcparen } - SEMI { ITsemi } - - VARID { ITvarid $$ } - CONID { ITconid $$ } - VARSYM { ITvarsym $$ } - CONSYM { ITconsym $$ } - QVARID { ITqvarid $$ } - QCONID { ITqconid $$ } - QVARSYM { ITqvarsym $$ } - QCONSYM { ITqconsym $$ } - - ARITY_PART { ITarity } - DEMAND { ITstrict $$ } - UNFOLD_PART { ITunfold $$ } - BOTTOM { ITbottom } - LAM { ITlam } - BIGLAM { ITbiglam } - CASE { ITcase } - PRIM_CASE { ITprim_case } - LET { ITlet } - LETREC { ITletrec } - IN { ITin } - OF { ITof } - COERCE_IN { ITcoerce_in } - COERCE_OUT { ITcoerce_out } - ATSIGN { ITatsign } - CCALL { ITccall $$ } - SCC { ITscc $$ } - - CHAR { ITchar $$ } - STRING { ITstring $$ } - INTEGER { ITinteger $$ } - DOUBLE { ITdouble $$ } - - INTEGER_LIT { ITinteger_lit } - FLOAT_LIT { ITfloat_lit } - RATIONAL_LIT { ITrational_lit } - ADDR_LIT { ITaddr_lit } - LIT_LIT { ITlit_lit } - STRING_LIT { ITstring_lit } - - UNKNOWN { ITunknown $$ } -%% - -id_info :: { [HsIdInfo RdrName] } -id_info : { [] } - | id_info_item id_info { $1 : $2 } - -id_info_item :: { HsIdInfo RdrName } -id_info_item : ARITY_PART arity_info { HsArity $2 } - | strict_info { HsStrictness $1 } - | BOTTOM { HsStrictness HsBottom } - | UNFOLD_PART core_expr { HsUnfold $1 $2 } - -arity_info :: { ArityInfo } -arity_info : INTEGER { exactArity (fromInteger $1) } - -strict_info :: { HsStrictnessInfo RdrName } -strict_info : DEMAND any_var_name OCURLY data_names CCURLY { HsStrictnessInfo $1 (Just ($2,$4)) } - | DEMAND any_var_name { HsStrictnessInfo $1 (Just ($2,[])) } - | DEMAND { HsStrictnessInfo $1 Nothing } - -core_expr :: { UfExpr RdrName } -core_expr : any_var_name { UfVar $1 } - | data_name { UfVar $1 } - | core_lit { UfLit $1 } - | OPAREN core_expr CPAREN { $2 } - | data_name OCURLY data_args CCURLY { UfCon $1 $3 } - - | core_expr ATSIGN atype { UfApp $1 (UfTyArg $3) } - | core_expr core_arg { UfApp $1 $2 } - | LAM core_val_bndrs RARROW core_expr { foldr UfLam $4 $2 } - | BIGLAM core_tv_bndrs RARROW core_expr { foldr UfLam $4 $2 } - - | CASE core_expr OF - OCURLY alg_alts core_default CCURLY { UfCase $2 (UfAlgAlts $5 $6) } - | PRIM_CASE core_expr OF - OCURLY prim_alts core_default CCURLY { UfCase $2 (UfPrimAlts $5 $6) } - - - | LET OCURLY core_val_bndr EQUAL core_expr CCURLY - IN core_expr { UfLet (UfNonRec $3 $5) $8 } - | LETREC OCURLY rec_binds CCURLY - IN core_expr { UfLet (UfRec $3) $6 } - - | coerce atype core_expr { UfCoerce $1 $2 $3 } - - | CCALL ccall_string - OBRACK atype atypes CBRACK core_args { let - (is_casm, may_gc) = $1 - in - UfPrim (UfCCallOp $2 is_casm may_gc $5 $4) - $7 - } - | SCC core_expr { UfSCC $1 $2 } - -rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] } - : { [] } - | core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 } - -coerce :: { UfCoercion RdrName } -coerce : COERCE_IN data_name { UfIn $2 } - | COERCE_OUT data_name { UfOut $2 } - -prim_alts :: { [(Literal,UfExpr RdrName)] } - : { [] } - | core_lit RARROW core_expr SEMI prim_alts { ($1,$3) : $5 } - -alg_alts :: { [(RdrName, [RdrName], UfExpr RdrName)] } - : { [] } - | data_name var_names RARROW - core_expr SEMI alg_alts { ($1,$2,$4) : $6 } - -core_default :: { UfDefault RdrName } - : { UfNoDefault } - | var_name RARROW core_expr SEMI { UfBindDefault $1 $3 } - -core_arg :: { UfArg RdrName } - : any_var_name { UfVarArg $1 } - | data_name { UfVarArg $1 } - | core_lit { UfLitArg $1 } - -core_args :: { [UfArg RdrName] } - : { [] } - | core_arg core_args { $1 : $2 } - -data_args :: { [UfArg RdrName] } - : { [] } - | ATSIGN atype data_args { UfTyArg $2 : $3 } - | core_arg data_args { $1 : $2 } - -core_lit :: { Literal } -core_lit : INTEGER { MachInt $1 True } - | CHAR { MachChar $1 } - | STRING { MachStr $1 } - | STRING_LIT STRING { NoRepStr $2 } - | DOUBLE { MachDouble (toRational $1) } - | FLOAT_LIT DOUBLE { MachFloat (toRational $2) } - - | INTEGER_LIT INTEGER { NoRepInteger $2 (panic "NoRepInteger type") - -- The type checker will add the types - } - - | RATIONAL_LIT INTEGER INTEGER { NoRepRational ($2 % $3) - (panic "NoRepRational type") - -- The type checker will add the type - } - - | ADDR_LIT INTEGER { MachAddr $2 } - | LIT_LIT prim_rep STRING { MachLitLit $3 (decodePrimRep $2) } - -core_val_bndr :: { UfBinder RdrName } -core_val_bndr : var_name DCOLON atype { UfValBinder $1 $3 } - -core_val_bndrs :: { [UfBinder RdrName] } -core_val_bndrs : { [] } - | core_val_bndr core_val_bndrs { $1 : $2 } - -core_tv_bndr :: { UfBinder RdrName } -core_tv_bndr : tv_name DCOLON akind { UfTyBinder $1 $3 } - | tv_name { UfTyBinder $1 mkBoxedTypeKind } - -core_tv_bndrs :: { [UfBinder RdrName] } -core_tv_bndrs : { [] } - | core_tv_bndr core_tv_bndrs { $1 : $2 } - -ccall_string :: { FAST_STRING } - : STRING { $1 } - | VARID { $1 } - | CONID { $1 } - -prim_rep :: { Char } - : VARID { head (_UNPK_ $1) } - | CONID { head (_UNPK_ $1) - ----variable names----------------------------------------------------- - } -var_occ :: { OccName } -var_occ : VARID { VarOcc $1 } - | VARSYM { VarOcc $1 } - | BANG { VarOcc SLIT("!") {-sigh, double-sigh-} } - -data_name :: { RdrName } -data_name : QCONID { lexVarQual $1 } - | QCONSYM { lexVarQual $1 } - | CONID { Unqual (VarOcc $1) } - | CONSYM { Unqual (VarOcc $1) } - -qvar_name :: { RdrName } - : QVARID { lexVarQual $1 } - | QVARSYM { lexVarQual $1 } - -var_name :: { RdrName } -var_name : var_occ { Unqual $1 } - -any_var_name :: {RdrName} -any_var_name : var_name { $1 } - | qvar_name { $1 } - -var_names :: { [RdrName] } -var_names : { [] } - | var_name var_names { $1 : $2 } - -data_names :: { [RdrName] } -data_names : { [] } - | data_name data_names { $1 : $2 - ---productions-for-types-------------------------------- - } -forall : OBRACK tv_bndrs CBRACK { $2 } - -context :: { RdrNameContext } -context : { [] } - | OCURLY context_list1 CCURLY { $2 } - -context_list1 :: { RdrNameContext } -context_list1 : class { [$1] } - | class COMMA context_list1 { $1 : $3 } - -class :: { (RdrName, RdrNameHsType) } -class : tc_name atype { ($1, $2) } - -type :: { RdrNameHsType } -type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 } - | btype RARROW type { MonoFunTy $1 $3 } - | btype { $1 } - -types2 :: { [RdrNameHsType] {- Two or more -} } -types2 : type COMMA type { [$1,$3] } - | type COMMA types2 { $1 : $3 } - -btype :: { RdrNameHsType } -btype : atype { $1 } - | btype atype { MonoTyApp $1 $2 } - -atype :: { RdrNameHsType } -atype : tc_name { MonoTyVar $1 } - | tv_name { MonoTyVar $1 } - | OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 } - | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 } - | OCURLY tc_name atype CCURLY { MonoDictTy $2 $3 } - | OPAREN type CPAREN { $2 } - -atypes :: { [RdrNameHsType] {- Zero or more -} } -atypes : { [] } - | atype atypes { $1 : $2 ---------------------------------------------------------------------- - } - -tv_bndr :: { HsTyVar RdrName } -tv_bndr : tv_name DCOLON akind { IfaceTyVar $1 $3 } - | tv_name { UserTyVar $1 } - -tv_bndrs :: { [HsTyVar RdrName] } - : { [] } - | tv_bndr tv_bndrs { $1 : $2 } - -kind :: { Kind } - : akind { $1 } - | akind RARROW kind { mkArrowKind $1 $3 } - -akind :: { Kind } - : VARSYM { mkBoxedTypeKind {- ToDo: check that it's "*" -} } - | OPAREN kind CPAREN { $2 } - -tv_name :: { RdrName } -tv_name : VARID { Unqual (TvOcc $1) } - | VARSYM { Unqual (TvOcc $1) {- Allow t2 as a tyvar -} } - -tv_names :: { [RdrName] } - : { [] } - | tv_name tv_names { $1 : $2 } - -tc_name :: { RdrName } -tc_name : QCONID { lexTcQual $1 } - | QCONSYM { lexTcQual $1 } - | CONID { Unqual (TCOcc $1) } - | CONSYM { Unqual (TCOcc $1) } - | OPAREN RARROW CPAREN { Unqual (TCOcc SLIT("->")) } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index bd51090149..614882a528 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -4,27 +4,17 @@ \section[Rename]{Renaming and dependency analysis passes} \begin{code} -#include "HsVersions.h" - module Rename ( renameModule ) where -#if __GLASGOW_HASKELL__ <= 201 -import PreludeGlaST ( thenPrimIO ) -#else -import GlaExts -import IO -#endif - -IMP_Ubiq() -IMPORT_1_3(List(partition)) +#include "HsVersions.h" import HsSyn -import RdrHsSyn ( RdrName(..), SYN_IE(RdrNameHsModule), SYN_IE(RdrNameImportDecl) ) -import RnHsSyn ( SYN_IE(RenamedHsModule), SYN_IE(RenamedHsDecl), extractHsTyNames ) +import RdrHsSyn ( RdrName(..), RdrNameHsModule, RdrNameImportDecl ) +import RnHsSyn ( RenamedHsModule, RenamedHsDecl, extractHsTyNames ) import CmdLineOpts ( opt_HiMap, opt_WarnNameShadowing, opt_D_show_rn_trace, opt_D_dump_rn, opt_D_show_rn_stats, - opt_D_show_unused_imports, opt_PprUserLength + opt_WarnUnusedNames ) import RnMonad import RnNames ( getGlobalNames ) @@ -33,10 +23,10 @@ import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getSpeci getDeferredDataDecls, mkSearchPath, getSlurpedNames, getRnStats ) -import RnEnv ( availsToNameSet, addAvailToNameSet, +import RnEnv ( availsToNameSet, addAvailToNameSet, addImplicitOccsRn, lookupImplicitOccRn ) -import Id ( GenId {- instance NamedThing -} ) -import Name ( Name, Provenance, ExportFlag(..), isLocallyDefined, +import Name ( Name, PrintUnqualified, Provenance, ExportFlag(..), + isLocallyDefined, NameSet(..), elemNameSet, mkNameSet, unionNameSets, nameSetToList, minusNameSet, NamedThing(..), nameModule, pprModule, pprOccName, nameOccName @@ -45,19 +35,16 @@ import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon ) import TyCon ( TyCon ) import PrelMods ( mAIN, gHC_MAIN ) import PrelInfo ( ioTyCon_NAME ) -import ErrUtils ( SYN_IE(Error), SYN_IE(Warning), pprBagOfErrors, +import ErrUtils ( pprBagOfErrors, pprBagOfWarnings, doIfSet, dumpIfSet, ghcExit ) import FiniteMap ( emptyFM, eltsFM, fmToList, addToFM, FiniteMap ) -import Pretty -import Outputable ( Outputable(..), PprStyle(..), - pprErrorsStyle, pprDumpStyle, printErrs - ) import Bag ( isEmptyBag ) -import Util ( cmpPString, equivClasses, panic, assertPanic, pprTrace ) -#if __GLASGOW_HASKELL__ >= 202 -import UniqSupply -#endif +import UniqSupply ( UniqSupply ) +import Util ( equivClasses ) +import Maybes ( maybeToBool ) +import List ( partition ) +import Outputable \end{code} @@ -78,11 +65,11 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ -- Check for warnings doIfSet (not (isEmptyBag rn_warns_bag)) - (print_errs rn_warns_bag) >> + (printErrs (pprBagOfWarnings rn_warns_bag)) >> -- Check for errors; exit if so doIfSet (not (isEmptyBag rn_errs_bag)) - (print_errs rn_errs_bag >> + (printErrs (pprBagOfErrors rn_errs_bag) >> ghcExit 1 ) >> @@ -91,29 +78,28 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ Nothing -> return () Just results@(rn_mod, _, _, _) -> dumpIfSet opt_D_dump_rn "Renamer:" - (ppr pprDumpStyle rn_mod) + (ppr rn_mod) ) >> -- Return results return maybe_rn_stuff - - -print_errs errs = printErrs (pprBagOfErrors pprErrorsStyle errs) \end{code} \begin{code} rename this_mod@(HsModule mod_name vers exports imports fixities local_decls loc) - = -- FIND THE GLOBAL NAME ENVIRONMENT - getGlobalNames this_mod `thenRn` \ global_name_info -> - - case global_name_info of { - Nothing -> -- Everything is up to date; no need to recompile further - rnStats [] `thenRn_` - returnRn Nothing ; - - -- Otherwise, just carry on - Just (export_env, rn_env, explicit_names) -> + = -- FIND THE GLOBAL NAME ENVIRONMENT + getGlobalNames this_mod `thenRn` \ maybe_stuff -> + + -- CHECK FOR EARLY EXIT + if not (maybeToBool maybe_stuff) then + -- Everything is up to date; no need to recompile further + rnStats [] `thenRn_` + returnRn Nothing + else + let + Just (export_env, rn_env, explicit_names, print_unqual) = maybe_stuff + in -- RENAME THE SOURCE initRnMS rn_env mod_name SourceMode ( @@ -122,8 +108,15 @@ rename this_mod@(HsModule mod_name vers exports imports fixities local_decls loc ) `thenRn` \ rn_local_decls -> -- SLURP IN ALL THE NEEDED DECLARATIONS - slurpDecls rn_local_decls `thenRn` \ rn_all_decls -> + slurpDecls print_unqual rn_local_decls `thenRn` \ rn_all_decls -> + -- EXIT IF ERRORS FOUND + checkErrsRn `thenRn` \ no_errs_so_far -> + if not no_errs_so_far then + -- Found errors already, so exit now + rnStats [] `thenRn_` + returnRn Nothing + else -- GENERATE THE VERSION/USAGE INFO getImportVersions mod_name exports `thenRn` \ import_versions -> @@ -160,7 +153,6 @@ rename this_mod@(HsModule mod_name vers exports imports fixities local_decls loc (import_versions, export_env, special_inst_mods), name_supply, import_mods)) - } where trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing trashed_imports = {-trace "rnSource:trashed_imports"-} [] @@ -188,21 +180,24 @@ addImplicits mod_name \begin{code} -slurpDecls decls +slurpDecls print_unqual decls = -- First of all, get all the compulsory decls slurp_compulsories decls `thenRn` \ decls1 -> -- Next get the optional ones - closeDecls Optional decls1 `thenRn` \ decls2 -> + closeDecls optional_mode decls1 `thenRn` \ decls2 -> -- Finally get those deferred data type declarations - getDeferredDataDecls `thenRn` \ data_decls -> - mapRn rn_data_decl data_decls `thenRn` \ rn_data_decls -> + getDeferredDataDecls `thenRn` \ data_decls -> + mapRn (rn_data_decl compulsory_mode) data_decls `thenRn` \ rn_data_decls -> -- Done returnRn (rn_data_decls ++ decls2) where + compulsory_mode = InterfaceMode Compulsory print_unqual + optional_mode = InterfaceMode Optional print_unqual + -- The "slurp_compulsories" function is a loop that alternates -- between slurping compulsory decls and slurping the instance -- decls thus made relavant. @@ -215,7 +210,7 @@ slurpDecls decls -- whose decl we must slurp, which might let in some new instance decls, -- and so on. Example: instance Foo a => Baz [a] where ... slurp_compulsories decls - = closeDecls Compulsory decls `thenRn` \ decls1 -> + = closeDecls compulsory_mode decls `thenRn` \ decls1 -> -- Instance decls still pending? getImportedInstDecls `thenRn` \ inst_decls -> @@ -225,55 +220,53 @@ slurpDecls decls else -- Yes, there are some, so rename them and loop traceRn (sep [ptext SLIT("Slurped"), int (length inst_decls), ptext SLIT("instance decls")]) - `thenRn_` - mapRn rn_inst_decl inst_decls `thenRn` \ new_inst_decls -> + `thenRn_` + mapRn (rn_inst_decl compulsory_mode) inst_decls `thenRn` \ new_inst_decls -> slurp_compulsories (new_inst_decls ++ decls1) \end{code} \begin{code} -closeDecls :: Necessity +closeDecls :: RnSMode -> [RenamedHsDecl] -- Declarations got so far -> RnMG [RenamedHsDecl] -- input + extra decls slurped -- The monad includes a list of possibly-unresolved Names -- This list is empty when closeDecls returns -closeDecls necessity decls - = popOccurrenceName necessity `thenRn` \ maybe_unresolved -> +closeDecls mode decls + = popOccurrenceName mode `thenRn` \ maybe_unresolved -> case maybe_unresolved of -- No more unresolved names Nothing -> returnRn decls -- An unresolved name - Just name + Just name_w_loc -> -- Slurp its declaration, if any --- traceRn (sep [ptext SLIT("Considering"), ppr PprDebug name]) `thenRn_` - importDecl name necessity `thenRn` \ maybe_decl -> +-- traceRn (sep [ptext SLIT("Considering"), ppr name_w_loc]) `thenRn_` + importDecl name_w_loc mode `thenRn` \ maybe_decl -> case maybe_decl of -- No declaration... (wired in thing or optional) - Nothing -> closeDecls necessity decls + Nothing -> closeDecls mode decls -- Found a declaration... rename it - Just decl -> rn_iface_decl mod_name necessity decl `thenRn` \ new_decl -> - closeDecls necessity (new_decl : decls) + Just decl -> rn_iface_decl mod_name mode decl `thenRn` \ new_decl -> + closeDecls mode (new_decl : decls) where - mod_name = nameModule name - + mod_name = nameModule (fst name_w_loc) -rn_iface_decl mod_name necessity decl -- Notice that the rnEnv starts empty - = initRnMS emptyRnEnv mod_name (InterfaceMode necessity) (rnDecl decl) +rn_iface_decl mod_name mode decl + = initRnMS emptyRnEnv mod_name mode (rnDecl decl) -rn_inst_decl (mod_name,decl) = rn_iface_decl mod_name Compulsory (InstD decl) - -rn_data_decl (tycon_name,ty_decl) = rn_iface_decl mod_name Compulsory (TyD ty_decl) - where - mod_name = nameModule tycon_name +rn_inst_decl mode (mod_name,decl) = rn_iface_decl mod_name mode (InstD decl) +rn_data_decl mode (tycon_name,ty_decl) = rn_iface_decl mod_name mode (TyD ty_decl) + where + mod_name = nameModule tycon_name \end{code} \begin{code} reportUnusedNames explicit_avail_names - | not opt_D_show_unused_imports + | not opt_WarnUnusedNames = returnRn () | otherwise @@ -282,15 +275,15 @@ reportUnusedNames explicit_avail_names unused = explicit_avail_names `minusNameSet` slurped_names (local_unused, imported_unused) = partition isLocallyDefined (nameSetToList unused) imports_by_module = equivClasses cmp imported_unused - name1 `cmp` name2 = nameModule name1 `_CMP_STRING_` nameModule name2 + name1 `cmp` name2 = nameModule name1 `compare` nameModule name2 - pp_imp sty = sep [text "For information: the following unqualified imports are unused:", - nest 4 (vcat (map (pp_group sty) imports_by_module))] - pp_group sty (n:ns) = sep [hcat [text "Module ", pprModule (PprForUser opt_PprUserLength) (nameModule n), char ':'], - nest 4 (sep (map (pprOccName sty . nameOccName) (n:ns)))] + pp_imp = sep [text "For information: the following unqualified imports are unused:", + nest 4 (vcat (map pp_group imports_by_module))] + pp_group (n:ns) = sep [hcat [text "Module ", pprModule (nameModule n), char ':'], + nest 4 (sep (map (pprOccName . nameOccName) (n:ns)))] - pp_local sty = sep [text "For information: the following local top-level definitions are unused:", - nest 4 (sep (map (pprOccName sty . nameOccName) local_unused))] + pp_local = sep [text "For information: the following local top-level definitions are unused:", + nest 4 (sep (map (pprOccName . nameOccName) local_unused))] in (if null imported_unused then returnRn () diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index b3a776fb77..18d47c0fea 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -9,20 +9,15 @@ type-synonym declarations; those cannot be done at this stage because they may be affected by renaming (which isn't fully worked out yet). \begin{code} -#include "HsVersions.h" - module RnBinds ( rnTopBinds, rnTopMonoBinds, rnMethodBinds, rnBinds, rnMonoBinds ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(RnLoop) -- break the RnPass/RnExpr/RnBinds loops -#else +#include "HsVersions.h" + import {-# SOURCE #-} RnSource ( rnHsSigType ) -#endif import HsSyn import HsPragmas ( isNoGenPragmas, noGenPragmas ) @@ -30,25 +25,24 @@ import RdrHsSyn import RnHsSyn import RnMonad import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch ) -import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, newLocalNames, isUnboundName ) - +import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, + newLocalNames, isUnboundName, warnUnusedNames + ) import CmdLineOpts ( opt_SigsRequired ) import Digraph ( stronglyConnComp, SCC(..) ) -import ErrUtils ( addErrLoc, addShortErrLocLine ) import Name ( OccName(..), Provenance, - Name {- instance Eq -}, + Name, isExportedName, NameSet(..), emptyNameSet, mkNameSet, unionNameSets, minusNameSet, unionManyNameSets, elemNameSet, unitNameSet, nameSetToList ) +import BasicTypes ( RecFlag(..), TopLevelFlag(..) ) import Maybes ( catMaybes ) -import Pretty -import Util ( Ord3(..), thenCmp, isIn, removeDups, panic, panic#, assertPanic, assocDefault ) -import UniqSet ( SYN_IE(UniqSet) ) +import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic, assocDefault ) +import UniqSet ( UniqSet ) import ListSetOps ( minusList ) import Bag ( bagToList ) import UniqFM ( UniqFM ) -import ErrUtils ( SYN_IE(Error) ) -import Outputable ( Outputable(..) ) +import Outputable \end{code} -- ToDo: Put the annotations into the monad, so that they arrive in the proper @@ -179,10 +173,15 @@ rnTopMonoBinds EmptyMonoBinds sigs rnTopMonoBinds mbinds sigs = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names -> let - binder_set = mkNameSet binder_names + binder_set = mkNameSet binder_names + exported_binders = mkNameSet (filter isExportedName binder_names) in - rn_mono_binds True {- top level -} + rn_mono_binds TopLevel binder_set mbinds sigs `thenRn` \ (new_binds, fv_set) -> + let + unused_binders = binder_set `minusNameSet` (fv_set `unionNameSets` exported_binders) + in + warnUnusedNames unused_binders `thenRn_` returnRn new_binds where binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds)) @@ -220,16 +219,22 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds = -- Extract all the binders in this group, -- and extend current scope, inventing new names for the new binders -- This also checks that the names form a set - bindLocatedLocalsRn (\_ -> text "binding group") mbinders_w_srclocs $ \ new_mbinders -> + bindLocatedLocalsRn (text "binding group") mbinders_w_srclocs $ \ new_mbinders -> let binder_set = mkNameSet new_mbinders in - rn_mono_binds False {- not top level -} + rn_mono_binds NotTopLevel binder_set mbinds sigs `thenRn` \ (binds,bind_fvs) -> -- Now do the "thing inside", and deal with the free-variable calculations thing_inside binds `thenRn` \ (result,result_fvs) -> - returnRn (result, (result_fvs `unionNameSets` bind_fvs) `minusNameSet` binder_set) + let + all_fvs = result_fvs `unionNameSets` bind_fvs + net_fvs = all_fvs `minusNameSet` binder_set + unused_binders = binder_set `minusNameSet` all_fvs + in + warnUnusedNames unused_binders `thenRn_` + returnRn (result, net_fvs) where mbinders_w_srclocs = bagToList (collectMonoBinders mbinds) \end{code} @@ -247,19 +252,19 @@ This is done *either* by pass 3 (for the top-level bindings), *or* by @rnNestedMonoBinds@ (for the nested ones). \begin{code} -rn_mono_binds :: Bool -- True <=> top level +rn_mono_binds :: TopLevelFlag -> NameSet -- Binders of this group -> RdrNameMonoBinds -> [RdrNameSig] -- Signatures attached to this group -> RnMS s (RenamedHsBinds, -- FreeVars) -- Free variables -rn_mono_binds is_top_lev binders mbinds sigs +rn_mono_binds top_lev binders mbinds sigs = -- Rename the bindings, returning a MonoBindsInfo -- which is a list of indivisible vertices so far as -- the strongly-connected-components (SCC) analysis is concerned - rnBindSigs is_top_lev binders sigs `thenRn` \ siglist -> + rnBindSigs top_lev binders sigs `thenRn` \ siglist -> flattenMonoBinds 0 siglist mbinds `thenRn` \ (_, mbinds_info) -> -- Do the SCC analysis @@ -392,10 +397,10 @@ reconstructCycle :: SCC FlatMonoBindsInfo -> RenamedHsBinds reconstructCycle (AcyclicSCC (_, _, _, binds, sigs)) - = MonoBind binds sigs nonRecursive + = MonoBind binds sigs NonRecursive reconstructCycle (CyclicSCC cycle) - = MonoBind this_gp_binds this_gp_sigs recursive + = MonoBind this_gp_binds this_gp_sigs Recursive where this_gp_binds = foldr1 AndMonoBinds [binds | (_, _, _, binds, _) <- cycle] this_gp_sigs = foldr1 (++) [sigs | (_, _, _, _, sigs) <- cycle] @@ -448,12 +453,12 @@ mkEdges flat_info flaggery, that all top-level things have type signatures. \begin{code} -rnBindSigs :: Bool -- True <=> top-level binders - -> NameSet -- Set of names bound in this group - -> [RdrNameSig] - -> RnMS s [RenamedSig] -- List of Sig constructors +rnBindSigs :: TopLevelFlag + -> NameSet -- Set of names bound in this group + -> [RdrNameSig] + -> RnMS s [RenamedSig] -- List of Sig constructors -rnBindSigs is_toplev binders sigs +rnBindSigs top_lev binders sigs = -- Rename the signatures mapRn renameSig sigs `thenRn` \ sigs' -> @@ -464,9 +469,9 @@ rnBindSigs is_toplev binders sigs (goodies, dups) = removeDups cmp_sig (filter (not.isUnboundName.sig_name) sigs') not_this_group = filter (\sig -> not (sig_name sig `elemNameSet` binders)) goodies type_sig_vars = [n | Sig n _ _ <- goodies] - un_sigd_binders - | is_toplev && opt_SigsRequired = nameSetToList binders `minusList` type_sig_vars - | otherwise = [] + sigs_required = case top_lev of {TopLevel -> opt_SigsRequired; NotTopLevel -> False} + un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars + | otherwise = [] in mapRn dupSigDeclErr dups `thenRn_` mapRn unknownSigErr not_this_group `thenRn_` @@ -479,13 +484,13 @@ rnBindSigs is_toplev binders sigs renameSig (Sig v ty src_loc) = pushSrcLocRn src_loc $ lookupBndrRn v `thenRn` \ new_v -> - rnHsSigType (\ sty -> ppr sty v) ty `thenRn` \ new_ty -> + rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty -> returnRn (Sig new_v new_ty src_loc) renameSig (SpecSig v ty using src_loc) = pushSrcLocRn src_loc $ lookupBndrRn v `thenRn` \ new_v -> - rnHsSigType (\ sty -> ppr sty v) ty `thenRn` \ new_ty -> + rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty -> rn_using using `thenRn` \ new_using -> returnRn (SpecSig new_v new_ty new_using src_loc) where @@ -507,18 +512,18 @@ renameSig (MagicUnfoldingSig v str src_loc) Checking for distinct signatures; oh, so boring \begin{code} -cmp_sig :: RenamedSig -> RenamedSig -> TAG_ -cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `cmp` n2 -cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `cmp` n2 -cmp_sig (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2 +cmp_sig :: RenamedSig -> RenamedSig -> Ordering +cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2 +cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2 +cmp_sig (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `compare` n2 cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _) = -- may have many specialisations for one value; -- but not ones that are exactly the same... - thenCmp (n1 `cmp` n2) (cmpHsType cmp ty1 ty2) + thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2) cmp_sig other_1 other_2 -- Tags *must* be different - | (sig_tag other_1) _LT_ (sig_tag other_2) = LT_ - | otherwise = GT_ + | (sig_tag other_1) _LT_ (sig_tag other_2) = LT + | otherwise = GT sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT) sig_tag (SpecSig n1 _ _ _) = ILIT(2) @@ -542,16 +547,16 @@ sig_name (MagicUnfoldingSig n _ _) = n \begin{code} dupSigDeclErr (sig:sigs) = pushSrcLocRn loc $ - addErrRn (\sty -> sep [ptext SLIT("more than one"), - ptext what_it_is, ptext SLIT("given for"), - ppr sty (sig_name sig)]) + addErrRn (sep [ptext SLIT("more than one"), + ptext what_it_is, ptext SLIT("given for"), + quotes (ppr (sig_name sig))]) where (what_it_is, loc) = sig_doc sig unknownSigErr sig = pushSrcLocRn loc $ - addErrRn (\sty -> sep [ptext flavour, ptext SLIT("but no definition for"), - ppr sty (sig_name sig)]) + addErrRn (sep [ptext flavour, ptext SLIT("but no definition for"), + quotes (ppr (sig_name sig))]) where (flavour, loc) = sig_doc sig @@ -561,10 +566,10 @@ sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALIZE pragma"),loc) sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc) sig_doc (MagicUnfoldingSig _ _ loc) = (SLIT("MAGIC_UNFOLDING pragma"),loc) -missingSigErr var sty - = sep [ptext SLIT("a definition but no type signature for"), ppr sty var] +missingSigErr var + = sep [ptext SLIT("a definition but no type signature for"), quotes (ppr var)] -methodBindErr mbind sty +methodBindErr mbind = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding")) - 4 (ppr sty mbind) + 4 (ppr mbind) \end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 577b795df0..89ecdf97dd 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -4,27 +4,25 @@ \section[RnEnv]{Environment manipulation for the renamer monad} \begin{code} -#include "HsVersions.h" - module RnEnv where -- Export everything -IMPORT_1_3(List (nub)) -IMP_Ubiq() +#include "HsVersions.h" -import CmdLineOpts ( opt_WarnNameShadowing ) +import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedNames ) import HsSyn -import RdrHsSyn ( RdrName(..), SYN_IE(RdrNameIE), +import RdrHsSyn ( RdrName(..), RdrNameIE, rdrNameOcc, ieOcc, isQual, qual ) import HsTypes ( getTyVarName, replaceTyVarName ) import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..), pprModule ) import RnMonad import Name ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..), - occNameString, occNameFlavour, - SYN_IE(NameSet), emptyNameSet, addListToNameSet, + occNameString, occNameFlavour, getSrcLoc, + NameSet, emptyNameSet, addListToNameSet, nameSetToList, mkLocalName, mkGlobalName, modAndOcc, isLocallyDefinedName, - isWiredInName, nameOccName, setNameProvenance, isVarOcc, getNameProvenance, - pprProvenance, pprOccName, pprModule, pprNameProvenance + nameOccName, setNameProvenance, isVarOcc, getNameProvenance, + pprProvenance, pprOccName, pprModule, pprNameProvenance, + isLocalName ) import TyCon ( TyCon ) import TysWiredIn ( tupleTyCon, listTyCon, charTyCon, intTyCon ) @@ -34,10 +32,9 @@ import UniqFM ( listToUFM, plusUFM_C ) import Maybes ( maybeToBool ) import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) -import Pretty -import Outputable ( Outputable(..), PprStyle(..) ) -import Util ( Ord3(..), panic, removeDups, pprTrace, assertPanic ) - +import Outputable +import Util ( removeDups ) +import List ( nub ) \end{code} @@ -49,29 +46,56 @@ import Util ( Ord3(..), panic, removeDups, pprTrace, assertPanic ) %********************************************************* \begin{code} -newGlobalName :: Module -> OccName -> IfaceFlavour -> RnM s d Name -newGlobalName mod occ iface_flavour +newImportedGlobalName :: Module -> OccName + -> IfaceFlavour + -> RnM s d Name +newImportedGlobalName mod occ hif = -- First check the cache getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - let key = (mod,occ) in + let + key = (mod,occ) + prov = NonLocalDef noSrcLoc hif False + in case lookupFM cache key of - -- A hit in the cache! Return it, but change the src loc - -- of the thing we've found if this is a second definition site - -- (that is, if loc /= NoSrcLoc) - Just name -> returnRn name - - -- Miss in the cache, so build a new original name, - -- And put it in the cache - Nothing -> + -- A hit in the cache! + -- If it has no provenance at the moment then set its provenance + -- so that it has the right HiFlag component. + -- (This is necessary + -- for known-key things. For example, GHCmain.lhs imports as SOURCE + -- Main; but Main.main is a known-key thing.) + -- Don't fiddle with the provenance if it already has one + Just name -> case getNameProvenance name of + NoProvenance -> let + new_name = setNameProvenance name prov + new_cache = addToFM cache key new_name + in + setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` + returnRn new_name + other -> returnRn name + + Nothing -> -- Miss in the cache! + -- Build a new original name, and put it in the cache + let + (us', us1) = splitUniqSupply us + uniq = getUnique us1 + name = mkGlobalName uniq mod occ prov + new_cache = addToFM cache key name + in + setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` + returnRn name + +{- let - (us', us1) = splitUniqSupply us - uniq = getUnique us1 - name = mkGlobalName uniq mod occ (Implicit iface_flavour) - cache' = addToFM cache key name + pprC ((mod,occ),name) = pprModule mod <> text "." <> pprOccName occ <+> text "--->" + <+> ppr name in - setNameSupplyRn (us', inst_ns, cache') `thenRn_` - returnRn name + pprTrace "ng" (vcat [text "newGlobalName miss" <+> pprModule mod <+> pprOccName occ, + brackets (sep (map pprC (fmToList cache))), + text "" + ]) $ +-} + newLocallyDefinedGlobalName :: Module -> OccName -> (Name -> ExportFlag) -> SrcLoc @@ -79,41 +103,34 @@ newLocallyDefinedGlobalName :: Module -> OccName newLocallyDefinedGlobalName mod occ rec_exp_fn loc = -- First check the cache getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - - -- We are at the binding site for a locally-defined thing, so - -- you might think it can't be in the cache, but it can if it's a - -- wired in thing. In that case we need to use the correct unique etc... - -- so all we do is replace its provenance. - -- If it's not in the cache we put it there with the correct provenance. - -- The idea is that, after all this, the cache - -- will contain a Name with the correct Provenance (i.e. Local) - - -- OLD (now wrong) COMMENT: - -- "Actually, there's a catch. If this is the *second* binding for something - -- we want to allocate a *fresh* unique, rather than using the same Name as before. - -- Otherwise we don't detect conflicting definitions of the same top-level name! - -- So the only time we re-use a Name already in the cache is when it's one of - -- the Implicit magic-unique ones mentioned in the previous para" - - -- This (incorrect) patch doesn't work for record decls, when we have - -- the same field declared in multiple constructors. With the above patch, - -- each occurrence got a new Name --- aargh! - -- - -- So I reverted to the simple caching method (no "second-binding" thing) - -- The multiple-local-binding case is now handled by improving the conflict - -- detection in plusNameEnv. - let - provenance = LocalDef (rec_exp_fn new_name) loc - (us', us1) = splitUniqSupply us - uniq = getUnique us1 - key = (mod,occ) - new_name = case lookupFM cache key of - Just name -> setNameProvenance name provenance - other -> mkGlobalName uniq mod occ provenance - new_cache = addToFM cache key new_name + let + key = (mod,occ) in - setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` - returnRn new_name + case lookupFM cache key of + + -- A hit in the cache! + -- Overwrite whatever provenance is in the cache already; + -- this updates WiredIn things and known-key things, + -- which are there from the start, to LocalDef. + Just name -> let + new_name = setNameProvenance name (LocalDef loc (rec_exp_fn new_name)) + new_cache = addToFM cache key new_name + in + setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` + returnRn new_name + + -- Miss in the cache! + -- Build a new original name, and put it in the cache + Nothing -> let + provenance = LocalDef loc (rec_exp_fn new_name) + (us', us1) = splitUniqSupply us + uniq = getUnique us1 + new_name = mkGlobalName uniq mod occ provenance + new_cache = addToFM cache key new_name + in + setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` + returnRn new_name + -- newDfunName is a variant, specially for dfuns. -- When renaming derived definitions we are in *interface* mode (because we can trip @@ -131,7 +148,7 @@ newDfunName Nothing src_loc -- Local instance decls have a "Nothing" newDfunName (Just n) src_loc -- Imported ones have "Just n" = getModuleRn `thenRn` \ mod_name -> - newGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -} + newImportedGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -} newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name] @@ -158,14 +175,14 @@ isUnboundName name = uniqueOf name == unboundKey \end{code} \begin{code} -bindLocatedLocalsRn :: (PprStyle -> Doc) -- Documentation string for error message +bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [(RdrName,SrcLoc)] -> ([Name] -> RnMS s a) -> RnMS s a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` - getNameEnv `thenRn` \ name_env -> + getLocalNameEnv `thenRn` \ name_env -> (if opt_WarnNameShadowing then mapRn (check_shadow name_env) rdr_names_w_loc @@ -177,7 +194,7 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope let new_name_env = addListToFM name_env (map fst rdr_names_w_loc `zip` names) in - setNameEnv new_name_env (enclosed_scope names) + setLocalNameEnv new_name_env (enclosed_scope names) where check_shadow name_env (rdr_name,loc) = case lookupFM name_env rdr_name of @@ -187,7 +204,7 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope bindLocalsRn doc_str rdr_names enclosed_scope = getSrcLocRn `thenRn` \ loc -> - bindLocatedLocalsRn (\_ -> text doc_str) + bindLocatedLocalsRn (text doc_str) (rdr_names `zip` repeat loc) enclosed_scope @@ -200,7 +217,7 @@ bindTyVarsRn doc_str tyvar_names enclosed_scope enclosed_scope (zipWith replaceTyVarName tyvar_names names) -- Works in any variant of the renamer monad -checkDupOrQualNames, checkDupNames :: (PprStyle -> Doc) +checkDupOrQualNames, checkDupNames :: SDoc -> [(RdrName, SrcLoc)] -> RnM s d () @@ -216,14 +233,13 @@ checkDupNames doc_str rdr_names_w_loc mapRn (dupNamesErr doc_str) dups `thenRn_` returnRn () where - (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `cmp` n2) rdr_names_w_loc + (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc -- Yuk! ifaceFlavour name = case getNameProvenance name of - Imported _ _ hif -> hif - Implicit hif -> hif - other -> HiFile -- Shouldn't happen + NonLocalDef _ hif _ -> hif + other -> HiFile -- Shouldn't happen \end{code} @@ -236,37 +252,69 @@ ifaceFlavour name = case getNameProvenance name of Looking up a name in the RnEnv. \begin{code} -lookupRn :: NameEnv -> RdrName -> RnMS s Name -lookupRn name_env rdr_name - = case lookupFM name_env rdr_name of - - -- Found it! - Just name -> returnRn name - - -- Not found - Nothing -> getModeRn `thenRn` \ mode -> - case mode of - -- Not found when processing source code; so fail - SourceMode -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) - - -- Not found when processing an imported declaration, - -- so we create a new name for the purpose - InterfaceMode _ -> - case rdr_name of - - Qual mod_name occ hif -> newGlobalName mod_name occ hif - - -- An Unqual is allowed; interface files contain - -- unqualified names for locally-defined things, such as - -- constructors of a data type. - Unqual occ -> getModuleRn `thenRn ` \ mod_name -> - newGlobalName mod_name occ HiFile - +lookupRn :: RdrName + -> Maybe Name -- Result of environment lookup + -> RnMS s Name + +lookupRn rdr_name (Just name) + = -- Found the name in the envt + returnRn name -- In interface mode the only things in + -- the environment are things in local (nested) scopes + +lookupRn rdr_name Nothing + = -- We didn't find the name in the environment + getModeRn `thenRn` \ mode -> + case mode of { + SourceMode -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) ; + -- Souurce mode; lookup failure is an error + + InterfaceMode _ _ -> + + + ---------------------------------------------------- + -- OK, so we're in interface mode + -- An Unqual is allowed; interface files contain + -- unqualified names for locally-defined things, such as + -- constructors of a data type. + -- So, qualify the unqualified name with the + -- module of the interface file, and try again + case rdr_name of + Unqual occ -> getModuleRn `thenRn` \ mod -> + newImportedGlobalName mod occ HiFile + Qual mod occ hif -> newImportedGlobalName mod occ hif + + } lookupBndrRn rdr_name - = getNameEnv `thenRn` \ name_env -> - lookupRn name_env rdr_name + = lookupNameRn rdr_name `thenRn` \ maybe_name -> + lookupRn rdr_name maybe_name `thenRn` \ name -> + + if isLocalName name then + returnRn name + else + + ---------------------------------------------------- + -- OK, so we're at the binding site of a top-level defn + -- Check to see whether its an imported decl + getModeRn `thenRn` \ mode -> + case mode of { + SourceMode -> returnRn name ; + + InterfaceMode _ print_unqual_fn -> + + ---------------------------------------------------- + -- OK, the binding site of an *imported* defn + -- so we can make the provenance more informative + getSrcLocRn `thenRn` \ src_loc -> + let + name' = case getNameProvenance name of + NonLocalDef _ hif _ -> setNameProvenance name + (NonLocalDef src_loc hif (print_unqual_fn name')) + other -> name + in + returnRn name' + } -- Just like lookupRn except that we record the occurrence too -- Perhaps surprisingly, even wired-in names are recorded. @@ -274,19 +322,38 @@ lookupBndrRn rdr_name -- deciding which instance declarations to import. lookupOccRn :: RdrName -> RnMS s Name lookupOccRn rdr_name - = getNameEnv `thenRn` \ name_env -> - lookupRn name_env rdr_name `thenRn` \ name -> - addOccurrenceName name + = lookupNameRn rdr_name `thenRn` \ maybe_name -> + lookupRn rdr_name maybe_name `thenRn` \ name -> + let + name' = mungePrintUnqual rdr_name name + in + addOccurrenceName name' -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global --- environment. It's used for record field names only. +-- environment only. It's used for record field names only. lookupGlobalOccRn :: RdrName -> RnMS s Name lookupGlobalOccRn rdr_name - = getGlobalNameEnv `thenRn` \ name_env -> - lookupRn name_env rdr_name `thenRn` \ name -> - addOccurrenceName name - - + = lookupGlobalNameRn rdr_name `thenRn` \ maybe_name -> + lookupRn rdr_name maybe_name `thenRn` \ name -> + let + name' = mungePrintUnqual rdr_name name + in + addOccurrenceName name' + +-- mungePrintUnqual is used to make *imported* *occurrences* print unqualified +-- if they were mentioned unqualified in the source code. +-- This improves error messages from the type checker. +-- NB: the binding site is treated differently; see lookupBndrRn +-- After the type checker all occurrences are replaced by the one +-- at the binding site. +mungePrintUnqual (Qual _ _ _) name = name +mungePrintUnqual (Unqual _) name = case new_prov of + Nothing -> name + Just prov' -> setNameProvenance name prov' + where + new_prov = case getNameProvenance name of + NonLocalDef loc hif False -> Just (NonLocalDef loc hif True) + other -> Nothing -- lookupImplicitOccRn takes an RdrName representing an *original* name, and -- adds it to the occurrence pool so that it'll be loaded later. This is @@ -298,6 +365,7 @@ lookupGlobalOccRn rdr_name -- we don't check for this case: it does no harm to record an "extra" occurrence -- and lookupImplicitOccRn isn't used much in interface mode (it's only the -- Nothing clause of rnDerivs that calls it at all I think). +-- [Jan 98: this comment is wrong: rnHsType uses it quite a bit.] -- -- For List and Tuple types it's important to get the correct -- isLocallyDefined flag, which is used in turn when deciding @@ -306,7 +374,7 @@ lookupGlobalOccRn rdr_name lookupImplicitOccRn :: RdrName -> RnMS s Name lookupImplicitOccRn (Qual mod occ hif) - = newGlobalName mod occ hif `thenRn` \ name -> + = newImportedGlobalName mod occ hif `thenRn` \ name -> addOccurrenceName name addImplicitOccRn :: Name -> RnMS s Name @@ -330,7 +398,20 @@ lookupFixity rdr_name returnRn (lookupFixityEnv fixity_env rdr_name) \end{code} +mkImportFn returns a function that takes a Name and tells whether +its unqualified name is in scope. This is put as a boolean flag in +the Name's provenance to guide whether or not to print the name qualified +in error messages. +\begin{code} +mkImportFn :: RnEnv -> Name -> Bool +mkImportFn (RnEnv env _) + = lookup + where + lookup name = case lookupFM env (Unqual (nameOccName name)) of + Just (name', _) -> name == name' + Nothing -> False +\end{code} %************************************************************************ %* * @@ -341,20 +422,21 @@ lookupFixity rdr_name =============== RnEnv ================ \begin{code} plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2) - = plusNameEnvRn n1 n2 `thenRn` \ n -> - plusFixityEnvRn f1 f2 `thenRn` \ f -> + = plusGlobalNameEnvRn n1 n2 `thenRn` \ n -> + plusFixityEnvRn f1 f2 `thenRn` \ f -> returnRn (RnEnv n f) \end{code} + =============== NameEnv ================ \begin{code} -plusNameEnvRn :: NameEnv -> NameEnv -> RnM s d NameEnv -plusNameEnvRn env1 env2 +plusGlobalNameEnvRn :: GlobalNameEnv -> GlobalNameEnv -> RnM s d GlobalNameEnv +plusGlobalNameEnvRn env1 env2 = mapRn (addErrRn.nameClashErr) (conflictsFM conflicting_name env1 env2) `thenRn_` returnRn (env1 `plusFM` env2) -addOneToNameEnv :: NameEnv -> RdrName -> Name -> RnM s d NameEnv -addOneToNameEnv env rdr_name name +addOneToGlobalNameEnv :: GlobalNameEnv -> RdrName -> (Name, HowInScope) -> RnM s d GlobalNameEnv +addOneToGlobalNameEnv env rdr_name name = case lookupFM env rdr_name of Just name2 | conflicting_name name name2 -> addErrRn (nameClashErr (rdr_name, (name, name2))) `thenRn_` @@ -362,8 +444,12 @@ addOneToNameEnv env rdr_name name other -> returnRn (addToFM env rdr_name name) -conflicting_name n1 n2 = (n1 /= n2) || - (isLocallyDefinedName n1 && isLocallyDefinedName n2) +delOneFromGlobalNameEnv :: GlobalNameEnv -> RdrName -> GlobalNameEnv +delOneFromGlobalNameEnv env rdr_name = delFromFM env rdr_name + +conflicting_name (n1,h1) (n2,h2) + = (n1 /= n2) || + (isLocallyDefinedName n1 && isLocallyDefinedName n2) -- We complain of a conflict if one RdrName maps to two different Names, -- OR if one RdrName maps to the same *locally-defined* Name. The latter -- case is to catch two separate, local definitions of the same thing. @@ -374,9 +460,6 @@ conflicting_name n1 n2 = (n1 /= n2) || lookupNameEnv :: NameEnv -> RdrName -> Maybe Name lookupNameEnv = lookupFM - -delOneFromNameEnv :: NameEnv -> RdrName -> NameEnv -delOneFromNameEnv env rdr_name = delFromFM env rdr_name \end{code} =============== FixityEnv ================ @@ -392,11 +475,11 @@ lookupFixityEnv env rdr_name Just (fixity,_) -> fixity Nothing -> Fixity 9 InfixL -- Default case -bad_fix :: (Fixity, Provenance) -> (Fixity, Provenance) -> Bool +bad_fix :: (Fixity, HowInScope) -> (Fixity, HowInScope) -> Bool bad_fix (f1,_) (f2,_) = f1 /= f2 -pprFixityProvenance :: PprStyle -> (Fixity,Provenance) -> Doc -pprFixityProvenance sty (fixity, prov) = pprProvenance sty prov +pprFixityProvenance :: (Fixity, HowInScope) -> SDoc +pprFixityProvenance (fixity, how_in_scope) = ppr how_in_scope \end{code} @@ -428,7 +511,7 @@ plusAvail a NotAvailable = a plusAvail NotAvailable a = a -- Added SOF 4/97 #ifdef DEBUG -plusAvail a1 a2 = panic ("RnEnv.plusAvail " ++ (show (hsep [pprAvail PprDebug a1,pprAvail PprDebug a2]))) +plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2]) #endif addAvailToNameSet :: NameSet -> AvailInfo -> NameSet @@ -465,7 +548,7 @@ filterAvail :: RdrNameIE -- Wanted filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) | sub_names_ok = AvailTC n (filter is_wanted ns) - | otherwise = pprTrace "filterAvail" (hsep [ppr PprDebug ie, pprAvail PprDebug avail]) $ + | otherwise = pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $ NotAvailable where is_wanted name = nameOccName name `elem` wanted_occs @@ -493,8 +576,11 @@ filterAvail ie avail = NotAvailable -- In interfaces, pprAvail gets given the OccName of the "host" thing -pprAvail PprInterface avail = ppr_avail (pprOccName PprInterface . nameOccName) avail -pprAvail sty avail = ppr_avail (ppr sty) avail +pprAvail avail = getPprStyle $ \ sty -> + if ifaceStyle sty then + ppr_avail (pprOccName . nameOccName) avail + else + ppr_avail ppr avail ppr_avail pp_name NotAvailable = ptext SLIT("NotAvailable") ppr_avail pp_name (AvailTC n ns) = hsep [ @@ -545,37 +631,48 @@ conflictFM bad fm key elt \begin{code} -nameClashErr (rdr_name, (name1,name2)) sty - = hang (hsep [ptext SLIT("Conflicting definitions for:"), ppr sty rdr_name]) - 4 (vcat [pprNameProvenance sty name1, - pprNameProvenance sty name2]) +warnUnusedNames :: NameSet -> RnM s d () +warnUnusedNames names + | not opt_WarnUnusedNames = returnRn () + | otherwise = mapRn warn (nameSetToList names) `thenRn_` + returnRn () + where + warn name = pushSrcLocRn (getSrcLoc name) $ + addWarnRn (unusedNameWarn name) + +unusedNameWarn name = quotes (ppr name) <+> ptext SLIT("is bound but not used") + +nameClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) + = hang (hsep [ptext SLIT("Conflicting definitions for"), quotes (ppr rdr_name)]) + 4 (vcat [ppr how_in_scope1, + ppr how_in_scope2]) -fixityClashErr (rdr_name, (fp1,fp2)) sty - = hang (hsep [ptext SLIT("Conflicting fixities for:"), ppr sty rdr_name]) - 4 (vcat [pprFixityProvenance sty fp1, - pprFixityProvenance sty fp2]) +fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) + = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)]) + 4 (vcat [ppr how_in_scope1, + ppr how_in_scope2]) -shadowedNameWarn shadow sty +shadowedNameWarn shadow = hcat [ptext SLIT("This binding for"), - ppr sty shadow, + quotes (ppr shadow), ptext SLIT("shadows an existing binding")] -unknownNameErr name sty - = sep [text flavour, ptext SLIT("not in scope:"), ppr sty name] +unknownNameErr name + = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)] where flavour = occNameFlavour (rdrNameOcc name) qualNameErr descriptor (name,loc) = pushSrcLocRn loc $ - addErrRn (\sty -> hsep [ ptext SLIT("Invalid use of qualified name"), - ppr sty name, - ptext SLIT("in"), - descriptor sty]) + addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"), + quotes (ppr name), + ptext SLIT("in"), + descriptor]) dupNamesErr descriptor ((name,loc) : dup_things) = pushSrcLocRn loc $ - addErrRn (\sty -> hsep [ptext SLIT("Conflicting definitions for"), - ppr sty name, - ptext SLIT("in"), descriptor sty]) + addErrRn (hsep [ptext SLIT("Conflicting definitions for"), + quotes (ppr name), + ptext SLIT("in"), descriptor]) \end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 62d0b9a7ff..a4d82304cb 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -10,20 +10,15 @@ general, all of these functions return a renamed thing, and a set of free variables. \begin{code} -#include "HsVersions.h" - module RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(RnLoop) -- break the RnPass/RnExpr/RnBinds loops -#else +#include "HsVersions.h" + import {-# SOURCE #-} RnBinds import {-# SOURCE #-} RnSource ( rnHsSigType ) -#endif import HsSyn import RdrHsSyn @@ -41,19 +36,14 @@ import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) -import TyCon ( TyCon ) -import Id ( GenId ) -import ErrUtils ( addErrLoc, addShortErrLocLine ) import Name -import Pretty import UniqFM ( lookupUFM, {- ToDo:rm-} isNullUFM ) import UniqSet ( emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, - SYN_IE(UniqSet) + UniqSet ) -import Util ( Ord3(..), removeDups, panic, pprPanic, assertPanic ) +import Util ( removeDups ) import Outputable - \end{code} @@ -153,9 +143,16 @@ rnMatch, rnMatch1 :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars) -- f x x = 1 rnMatch match - = bindLocalsRn "pattern" (get_binders match) $ \ new_binders -> + = pushSrcLocRn (getMatchLoc match) $ + bindLocalsRn "pattern" (get_binders match) $ \ new_binders -> rnMatch1 match `thenRn` \ (match', fvs) -> - returnRn (match', fvs `minusNameSet` mkNameSet new_binders) + let + binder_set = mkNameSet new_binders + unused_binders = binder_set `minusNameSet` fvs + net_fvs = fvs `minusNameSet` binder_set + in + warnUnusedNames unused_binders `thenRn_` + returnRn (match', net_fvs) where get_binders (GRHSMatch _) = [] get_binders (PatMatch pat match) = collectPatBinders pat ++ get_binders match @@ -207,14 +204,10 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) rnExpr expr `thenRn` \ (expr', fvse) -> returnRn (GRHS guard' expr' locn, fvse)) - rnGRHS (OtherwiseGRHS expr locn) - = pushSrcLocRn locn $ - rnExpr expr `thenRn` \ (expr', fvs) -> - returnRn (GRHS [] expr' locn, fvs) - -- Standard Haskell 1.4 guards are just a single boolean -- expression, rather than a list of qualifiers as in the -- Glasgow extension + is_standard_guard [] = True is_standard_guard [GuardStmt _ _] = True is_standard_guard other = False \end{code} @@ -287,8 +280,8 @@ rnExpr (OpApp e1 op@(HsVar op_name) _ e2) lookupFixity op_name `thenRn` \ fixity -> getModeRn `thenRn` \ mode -> (case mode of - SourceMode -> mkOpAppRn e1' op' fixity e2' - InterfaceMode _ -> returnRn (OpApp e1' op' fixity e2') + SourceMode -> mkOpAppRn e1' op' fixity e2' + InterfaceMode _ _ -> returnRn (OpApp e1' op' fixity e2') ) `thenRn` \ final_e -> returnRn (final_e, @@ -315,6 +308,7 @@ rnExpr (SectionR op expr) returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr) rnExpr (CCall fun args may_gc is_casm fake_result_ty) + -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls = lookupImplicitOccRn ccallableClass_RDR `thenRn_` lookupImplicitOccRn creturnableClass_RDR `thenRn_` lookupImplicitOccRn ioDataCon_RDR `thenRn_` @@ -353,10 +347,10 @@ rnExpr (ExplicitTuple exps) rnExprs exps `thenRn` \ (exps', fvExps) -> returnRn (ExplicitTuple exps', fvExps) -rnExpr (RecordCon con rbinds) - = lookupOccRn con `thenRn` \ conname -> +rnExpr (RecordCon con_id _ rbinds) + = lookupOccRn con_id `thenRn` \ conname -> rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) -> - returnRn (RecordCon conname rbinds', fvRbinds) + returnRn (RecordCon conname (error "rnExpr:RecordCon") rbinds', fvRbinds) rnExpr (RecordUpd expr rbinds) = rnExpr expr `thenRn` \ (expr', fvExpr) -> @@ -364,8 +358,8 @@ rnExpr (RecordUpd expr rbinds) returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds) rnExpr (ExprWithTySig expr pty) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnHsSigType (\ sty -> text "an expression") pty `thenRn` \ pty' -> + = rnExpr expr `thenRn` \ (expr', fvExpr) -> + rnHsSigType (text "an expression") pty `thenRn` \ pty' -> returnRn (ExprWithTySig expr' pty', fvExpr) rnExpr (HsIf p b1 b2 src_loc) @@ -414,7 +408,7 @@ rnRbinds str rbinds mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) -> returnRn (rbinds', unionManyNameSets fvRbind_s) where - (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ] + (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ] field_dup_err dups = addErrRn (dupFieldErr str dups) @@ -427,7 +421,7 @@ rnRpats rpats = mapRn field_dup_err dup_fields `thenRn_` mapRn rn_rpat rpats where - (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ] + (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ] field_dup_err dups = addErrRn (dupFieldErr "pattern" dups) @@ -550,7 +544,9 @@ mkOpAppRn e1@(NegApp neg_arg neg_op) (nofix_error, rearrange_me) = compareFixity fix_neg fix2 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment - = ASSERT( right_op_ok fix e2 ) + = ASSERT( if right_op_ok fix e2 then True + else pprPanic "mkOpAppRn" (vcat [ppr e1, text "---", ppr op, text "---", ppr fix, text "---", ppr e2]) + ) returnRn (OpApp e1 op fix e2) get (HsVar n) = n @@ -656,10 +652,10 @@ compareFixity :: Fixity -> Fixity -> (Bool, -- Error please Bool) -- Associate to the right: a op1 (b op2 c) compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2) - = case prec1 `cmp` prec2 of - GT_ -> left - LT_ -> right - EQ_ -> case (dir1, dir2) of + = case prec1 `compare` prec2 of + GT -> left + LT -> right + EQ -> case (dir1, dir2) of (InfixR, InfixR) -> right (InfixL, InfixL) -> left _ -> error_please @@ -700,7 +696,9 @@ litOccurrence (HsFrac _) lookupImplicitOccRn ratioDataCon_RDR -- We have to make sure that the Ratio type is imported with -- its constructor, because literals of type Ratio t are - -- built with that constructor. + -- built with that constructor. + -- The Rational type is needed too, but that will come in + -- when fractionalClass does. litOccurrence (HsIntPrim _) = addImplicitOccRn (getName intPrimTyCon) @@ -723,28 +721,29 @@ litOccurrence (HsLitLit _) %************************************************************************ \begin{code} -dupFieldErr str (dup:rest) sty - = hcat [ptext SLIT("duplicate field name `"), - ppr sty dup, - ptext SLIT("' in record "), text str] +dupFieldErr str (dup:rest) + = hsep [ptext SLIT("duplicate field name"), + quotes (ppr dup), + ptext SLIT("in record"), text str] -negPatErr pat sty - = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat] +negPatErr pat + = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), quotes (ppr pat)] -precParseNegPatErr op sty +precParseNegPatErr op = hang (ptext SLIT("precedence parsing error")) - 4 (hcat [ptext SLIT("prefix `-' has lower precedence than "), - pp_op sty op, - ptext SLIT(" in pattern")]) + 4 (hsep [ptext SLIT("prefix `-' has lower precedence than"), + quotes (pp_op op), + ptext SLIT("in pattern")]) -precParseErr op1 op2 sty +precParseErr op1 op2 = hang (ptext SLIT("precedence parsing error")) - 4 (hcat [ptext SLIT("cannot mix "), pp_op sty op1, ptext SLIT(" and "), pp_op sty op2, - ptext SLIT(" in the same infix expression")]) + 4 (hsep [ptext SLIT("cannot mix"), quotes (pp_op op1), ptext SLIT("and"), + quotes (pp_op op2), + ptext SLIT("in the same infix expression")]) -nonStdGuardErr guard sty +nonStdGuardErr guard = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")) - 4 (ppr sty guard) + 4 (ppr guard) -pp_op sty (op, fix) = hcat [ppr sty op, space, parens (ppr sty fix)] +pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)] \end{code} diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 9768563c88..3dd375f31b 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -4,55 +4,48 @@ \section[RnHsSyn]{Specialisations of the @HsSyn@ syntax for the renamer} \begin{code} -#include "HsVersions.h" - module RnHsSyn where -IMP_Ubiq() +#include "HsVersions.h" import HsSyn -#if __GLASGOW_HASKELL__ >= 202 -import HsPragmas -#endif +import HsPragmas ( InstancePragmas, GenPragmas, DataPragmas, ClassPragmas, ClassOpPragmas ) -import Id ( GenId, SYN_IE(Id) ) -import BasicTypes ( NewOrData, IfaceFlavour ) +import Id ( GenId, Id ) +import BasicTypes ( Unused, NewOrData, IfaceFlavour ) import Name ( Name ) -import Outputable ( PprStyle(..), Outputable(..){-instance * []-} ) -import PprType ( GenType, GenTyVar, TyCon ) -import Pretty -import Name ( SYN_IE(NameSet), unitNameSet, mkNameSet, minusNameSet, unionNameSets, emptyNameSet ) -import TyCon ( TyCon ) +import Name ( NameSet, unitNameSet, mkNameSet, minusNameSet, unionNameSets, emptyNameSet ) import TyVar ( GenTyVar ) import Unique ( Unique ) -import Util ( panic, pprPanic{-, pprTrace ToDo:rm-} ) +import Util +import Outputable \end{code} \begin{code} -type RenamedArithSeqInfo = ArithSeqInfo Fake Fake Name RenamedPat -type RenamedClassDecl = ClassDecl Fake Fake Name RenamedPat +type RenamedArithSeqInfo = ArithSeqInfo Unused Name RenamedPat +type RenamedClassDecl = ClassDecl Unused Name RenamedPat type RenamedClassOpSig = Sig Name type RenamedConDecl = ConDecl Name type RenamedContext = Context Name -type RenamedHsDecl = HsDecl Fake Fake Name RenamedPat +type RenamedHsDecl = HsDecl Unused Name RenamedPat type RenamedSpecDataSig = SpecDataSig Name type RenamedDefaultDecl = DefaultDecl Name type RenamedFixityDecl = FixityDecl Name -type RenamedGRHS = GRHS Fake Fake Name RenamedPat -type RenamedGRHSsAndBinds = GRHSsAndBinds Fake Fake Name RenamedPat -type RenamedHsBinds = HsBinds Fake Fake Name RenamedPat -type RenamedHsExpr = HsExpr Fake Fake Name RenamedPat -type RenamedHsModule = HsModule Fake Fake Name RenamedPat -type RenamedInstDecl = InstDecl Fake Fake Name RenamedPat -type RenamedMatch = Match Fake Fake Name RenamedPat -type RenamedMonoBinds = MonoBinds Fake Fake Name RenamedPat +type RenamedGRHS = GRHS Unused Name RenamedPat +type RenamedGRHSsAndBinds = GRHSsAndBinds Unused Name RenamedPat +type RenamedHsBinds = HsBinds Unused Name RenamedPat +type RenamedHsExpr = HsExpr Unused Name RenamedPat +type RenamedHsModule = HsModule Unused Name RenamedPat +type RenamedInstDecl = InstDecl Unused Name RenamedPat +type RenamedMatch = Match Unused Name RenamedPat +type RenamedMonoBinds = MonoBinds Unused Name RenamedPat type RenamedPat = InPat Name type RenamedHsType = HsType Name -type RenamedRecordBinds = HsRecordBinds Fake Fake Name RenamedPat +type RenamedRecordBinds = HsRecordBinds Unused Name RenamedPat type RenamedSig = Sig Name type RenamedSpecInstSig = SpecInstSig Name -type RenamedStmt = Stmt Fake Fake Name RenamedPat +type RenamedStmt = Stmt Unused Name RenamedPat type RenamedTyDecl = TyDecl Name type RenamedClassOpPragmas = ClassOpPragmas Name @@ -68,23 +61,29 @@ type RenamedInstancePragmas = InstancePragmas Name %* * %************************************************************************ -\begin{code} -extractCtxtTyNames :: RenamedContext -> NameSet -extractCtxtTyNames ctxt = foldr (unionNameSets . extractHsTyNames . snd) emptyNameSet ctxt +These free-variable finders returns tycons and classes too. -extractHsTyNames :: RenamedHsType -> NameSet +\begin{code} +extractHsTyNames :: RenamedHsType -> NameSet extractHsTyNames ty = get ty where get (MonoTyApp ty1 ty2) = get ty1 `unionNameSets` get ty2 get (MonoListTy tc ty) = unitNameSet tc `unionNameSets` get ty - get (MonoTupleTy tc tys) = foldr (unionNameSets . get) (unitNameSet tc) tys + get (MonoTupleTy tc tys) = unitNameSet tc `unionNameSets` extractHsTyNames_s tys get (MonoFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2 - get (MonoDictTy cls ty) = unitNameSet cls `unionNameSets` get ty + get (MonoDictTy cls tys) = unitNameSet cls `unionNameSets` extractHsTyNames_s tys get (MonoTyVar tv) = unitNameSet tv - get (HsForAllTy tvs ctxt ty) = foldr (unionNameSets . get . snd) (get ty) ctxt + get (HsForAllTy tvs ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty) `minusNameSet` mkNameSet (map getTyVarName tvs) +extractHsTyNames_s :: [RenamedHsType] -> NameSet +extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys + +extractHsCtxtTyNames :: RenamedContext -> NameSet +extractHsCtxtTyNames ctxt = foldr (unionNameSets . get) emptyNameSet ctxt + where + get (cls, tys) = unitNameSet cls `unionNameSets` extractHsTyNames_s tys \end{code} diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index ed0014f95b..9a3bbc2ea3 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -4,8 +4,6 @@ \section[RnIfaces]{Cacheing and Renaming of Interfaces} \begin{code} -#include "HsVersions.h" - module RnIfaces ( getInterfaceExports, getImportedInstDecls, @@ -19,35 +17,28 @@ module RnIfaces ( mkSearchPath ) where -IMP_Ubiq() -#if __GLASGOW_HASKELL__ >= 202 -import GlaExts (trace) -- TEMP -import IO -#endif - +#include "HsVersions.h" import CmdLineOpts ( opt_PruneTyDecls, opt_PruneInstDecls, - opt_PprUserLength, opt_IgnoreIfacePragmas + opt_IgnoreIfacePragmas ) -import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, HsExpr, Sig(..), HsType(..), - HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), ConDetails(..), BangType, IfaceSig(..), - FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), HsIdInfo, - IE(..), hsDeclName +import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), InstDecl(..), IfaceSig(..), + HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..), + hsDeclName ) import HsPragmas ( noGenPragmas ) -import BasicTypes ( SYN_IE(Version), NewOrData(..), IfaceFlavour(..) ) -import RdrHsSyn ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl), SYN_IE(RdrNameTyDecl), - RdrName, rdrNameOcc +import BasicTypes ( Version, NewOrData(..), IfaceFlavour(..) ) +import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyDecl, + RdrName(..), rdrNameOcc ) -import RnEnv ( newGlobalName, addImplicitOccsRn, ifaceFlavour, +import RnEnv ( newImportedGlobalName, addImplicitOccsRn, ifaceFlavour, availName, availNames, addAvailToNameSet, pprAvail ) import RnSource ( rnHsSigType ) import RnMonad -import RnHsSyn ( SYN_IE(RenamedHsDecl) ) -import ParseIface ( parseIface ) +import RnHsSyn ( RenamedHsDecl ) +import ParseIface ( parseIface, IfaceStuff(..) ) -import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) ) import FiniteMap ( FiniteMap, sizeFM, emptyFM, unitFM, delFromFM, lookupFM, addToFM, addToFM_C, addListToFM, fmToList, eltsFM @@ -63,21 +54,20 @@ import Id ( GenId, Id(..), idType, dataConTyCon, isAlgCon ) import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn ) import Type ( namesOfType ) import TyVar ( GenTyVar ) -import SrcLoc ( mkIfaceSrcLoc, SrcLoc ) +import SrcLoc ( mkSrcLoc, SrcLoc ) import PrelMods ( gHC__ ) import PrelInfo ( cCallishTyKeys ) import Bag import Maybes ( MaybeErr(..), expectJust, maybeToBool ) import ListSetOps ( unionLists ) -import Pretty -import Outputable ( PprStyle(..) ) +import Outputable import Unique ( Unique ) -import Util ( pprPanic, pprTrace, Ord3(..) ) import StringBuffer ( StringBuffer, hGetStringBuffer, freeStringBuffer ) +import FastString ( mkFastString ) import Outputable -#if __GLASGOW_HASKELL__ >= 202 -import List (nub) -#endif + +import IO ( isDoesNotExistError ) +import List ( nub ) \end{code} @@ -89,7 +79,7 @@ import List (nub) %********************************************************* \begin{code} -getRnStats :: [RenamedHsDecl] -> RnMG Doc +getRnStats :: [RenamedHsDecl] -> RnMG SDoc getRnStats all_decls = getIfacesRn `thenRn` \ ifaces -> let @@ -134,12 +124,12 @@ is_imported_decl (ValD _) = False is_imported_decl decl = not (isLocallyDefined (hsDeclName decl)) count_decls decls - = -- pprTrace "count_decls" (ppr PprDebug decls + = -- pprTrace "count_decls" (ppr decls -- -- $$ -- text "=========" -- $$ - -- ppr PprDebug imported_decls + -- ppr imported_decls -- ) $ (class_decls, data_decls, abstract_data_decls, @@ -166,7 +156,7 @@ count_decls decls %********************************************************* \begin{code} -loadInterface :: Doc -> Module -> IfaceFlavour -> RnMG Ifaces +loadInterface :: SDoc -> Module -> IfaceFlavour -> RnMG Ifaces loadInterface doc_str load_mod as_source = getIfacesRn `thenRn` \ ifaces -> let @@ -234,7 +224,7 @@ loadExport :: ExportItem -> RnMG [AvailInfo] loadExport (mod, hif, entities) = mapRn load_entity entities where - new_name occ = newGlobalName mod occ hif + new_name occ = newImportedGlobalName mod occ hif load_entity (Avail occ) = new_name occ `thenRn` \ name -> @@ -273,7 +263,8 @@ loadDecl mod as_source decls_map (version, decl) SigD (IfaceSig name tp [] loc) _ -> decl - new_implicit_name rdr_name loc = newGlobalName mod (rdrNameOcc rdr_name) as_source + new_implicit_name rdr_name loc = newImportedGlobalName mod (rdrNameOcc rdr_name) as_source + from_hi_boot = case as_source of HiBootFile -> True other -> False @@ -301,10 +292,12 @@ loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_lo in -- We find the gates by renaming the instance type with in a -- and returning the occurrence pool. - initRnMS emptyRnEnv mod_name (InterfaceMode Compulsory) ( - findOccurrencesRn (rnHsSigType (\sty -> text "an instance decl") munged_inst_ty) + initRnMS emptyRnEnv mod_name vanillaInterfaceMode ( + findOccurrencesRn (rnHsSigType (text "an instance decl") munged_inst_ty) ) `thenRn` \ gate_names -> returnRn (((mod_name, decl), gate_names) `consBag` insts) + +vanillaInterfaceMode = InterfaceMode Compulsory (\_ -> False) \end{code} @@ -323,7 +316,7 @@ checkUpToDate mod_name case read_result of Nothing -> -- Old interface file not found, so we'd better bail out traceRn (sep [ptext SLIT("Didnt find old iface"), - pprModule PprDebug mod_name]) `thenRn_` + pprModule mod_name]) `thenRn_` returnRn False Just (ParsedIface _ _ usages _ _ _ _ _) @@ -331,11 +324,11 @@ checkUpToDate mod_name checkModUsage usages where -- Only look in current directory, with suffix .hi - doc_str = sep [ptext SLIT("need usage info from"), pprModule PprDebug mod_name] + doc_str = sep [ptext SLIT("need usage info from"), pprModule mod_name] checkModUsage [] = returnRn True -- Yes! Everything is up to date! -checkModUsage ((mod, hif, old_mod_vers, old_local_vers) : rest) +checkModUsage ((mod, hif, old_mod_vers, whats_imported) : rest) = loadInterface doc_str mod hif `thenRn` \ ifaces -> let Ifaces _ mod_map decls _ _ _ _ _ = ifaces @@ -345,37 +338,49 @@ checkModUsage ((mod, hif, old_mod_vers, old_local_vers) : rest) -- If we can't find a version number for the old module then -- bail out saying things aren't up to date if not (maybeToBool maybe_new_mod_vers) then - traceRn (sep [ptext SLIT("Can't find version number for module"), pprModule PprDebug mod]) `thenRn_` + traceRn (sep [ptext SLIT("Can't find version number for module"), pprModule mod]) `thenRn_` returnRn False else -- If the module version hasn't changed, just move on if new_mod_vers == old_mod_vers then - traceRn (sep [ptext SLIT("Module version unchanged:"), pprModule PprDebug mod]) `thenRn_` + traceRn (sep [ptext SLIT("Module version unchanged:"), pprModule mod]) `thenRn_` checkModUsage rest else - traceRn (sep [ptext SLIT("Module version has changed:"), pprModule PprDebug mod]) `thenRn_` + traceRn (sep [ptext SLIT("Module version has changed:"), pprModule mod]) `thenRn_` + + -- Module version changed, so check entities inside + + -- If the usage info wants to say "I imported everything from this module" + -- it does so by making whats_imported equal to Everything + -- In that case, we must recompile + case whats_imported of { + Everything -> traceRn (ptext SLIT("...and I needed the whole module")) `thenRn_` + returnRn False; -- Bale out + + Specifically old_local_vers -> - -- New module version, so check entities inside + -- Non-empty usage list, so check item by item checkEntityUsage mod decls old_local_vers `thenRn` \ up_to_date -> if up_to_date then traceRn (ptext SLIT("...but the bits I use haven't.")) `thenRn_` checkModUsage rest -- This one's ok, so check the rest else returnRn False -- This one failed, so just bail out now + } where - doc_str = sep [ptext SLIT("need version info for"), pprModule PprDebug mod] + doc_str = sep [ptext SLIT("need version info for"), pprModule mod] checkEntityUsage mod decls [] = returnRn True -- Yes! All up to date! checkEntityUsage mod decls ((occ_name,old_vers) : rest) - = newGlobalName mod occ_name HiFile {- ?? -} `thenRn` \ name -> + = newImportedGlobalName mod occ_name HiFile `thenRn` \ name -> case lookupFM decls name of Nothing -> -- We used it before, but it ain't there now - putDocRn (sep [ptext SLIT("No longer exported:"), ppr PprDebug name]) `thenRn_` + putDocRn (sep [ptext SLIT("No longer exported:"), ppr name]) `thenRn_` returnRn False Just (new_vers,_,_) -- It's there, but is it up to date? @@ -385,7 +390,7 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) | otherwise -- Out of date, so bale out - -> putDocRn (sep [ptext SLIT("Out of date:"), ppr PprDebug name]) `thenRn_` + -> putDocRn (sep [ptext SLIT("Out of date:"), ppr name]) `thenRn_` returnRn False \end{code} @@ -397,17 +402,17 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) %********************************************************* \begin{code} -importDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl) +importDecl :: Occurrence -> RnSMode -> RnMG (Maybe RdrNameHsDecl) -- Returns Nothing for a wired-in or already-slurped decl -importDecl name necessity +importDecl (name, loc) mode = checkSlurped name `thenRn` \ already_slurped -> if already_slurped then --- traceRn (sep [text "Already slurped:", ppr PprDebug name]) `thenRn_` +-- traceRn (sep [text "Already slurped:", ppr name]) `thenRn_` returnRn Nothing -- Already dealt with else if isWiredInName name then - getWiredInDecl name necessity + getWiredInDecl name mode else getIfacesRn `thenRn` \ ifaces -> let @@ -415,16 +420,16 @@ importDecl name necessity mod = nameModule name in if mod == this_mod then -- Don't bring in decls from - pprTrace "importDecl wierdness:" (ppr PprDebug name) $ + pprTrace "importDecl wierdness:" (ppr name) $ returnRn Nothing -- the renamed module's own interface file -- else - getNonWiredInDecl name necessity + getNonWiredInDecl name loc mode \end{code} \begin{code} -getNonWiredInDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl) -getNonWiredInDecl needed_name necessity +getNonWiredInDecl :: Name -> SrcLoc -> RnSMode -> RnMG (Maybe RdrNameHsDecl) +getNonWiredInDecl needed_name loc mode = traceRn doc_str `thenRn_` loadInterface doc_str mod (ifaceFlavour needed_name) `thenRn` \ (Ifaces _ _ decls _ _ _ _ _) -> case lookupFM decls needed_name of @@ -441,12 +446,13 @@ getNonWiredInDecl needed_name necessity Nothing -> -- Can happen legitimately for "Optional" occurrences case necessity of { - Optional -> addWarnRn (getDeclWarn needed_name); - other -> addErrRn (getDeclErr needed_name) + Optional -> addWarnRn (getDeclWarn needed_name loc); + other -> addErrRn (getDeclErr needed_name loc) } `thenRn_` returnRn Nothing where - doc_str = sep [ptext SLIT("need decl for"), ppr PprDebug needed_name] + necessity = modeToNecessity mode + doc_str = sep [ptext SLIT("need decl for"), ppr needed_name, ptext SLIT("needed at"), ppr loc] mod = nameModule needed_name is_data_or_newtype (TyData _ _ _ _ _ _ _ _) = True @@ -474,8 +480,8 @@ All this is necessary so that we know all types that are "in play", so that we know just what instances to bring into scope. \begin{code} -getWiredInDecl name necessity - = initRnMS emptyRnEnv mod_name (InterfaceMode necessity) +getWiredInDecl name mode + = initRnMS emptyRnEnv mod_name new_mode get_wired `thenRn` \ avail -> recordSlurp Nothing necessity avail `thenRn_` @@ -501,7 +507,7 @@ getWiredInDecl name necessity main_name = availName avail main_is_tc = case avail of { AvailTC _ _ -> True; Avail _ -> False } mod = nameModule main_name - doc_str = sep [ptext SLIT("need home module for wired in thing"), ppr PprDebug name] + doc_str = sep [ptext SLIT("need home module for wired in thing"), ppr name] in (if not main_is_tc || mod == gHC__ then returnRn () @@ -512,6 +518,10 @@ getWiredInDecl name necessity returnRn Nothing -- No declaration to process further where + necessity = modeToNecessity mode + new_mode = case mode of + InterfaceMode _ _ -> mode + SourceMode -> vanillaInterfaceMode get_wired | is_tycon -- ... a type constructor = get_wired_tycon the_tycon @@ -577,7 +587,7 @@ getInterfaceExports mod as_source Just (_, _, avails, fixities) -> returnRn (avails, fixities) where - doc_str = sep [pprModule PprDebug mod, ptext SLIT("is directly imported")] + doc_str = sep [pprModule mod, ptext SLIT("is directly imported")] \end{code} @@ -609,14 +619,19 @@ getNonWiredDataDecl needed_name ty_decl@(TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc) | needed_name == tycon_name && opt_PruneTyDecls - && not (nameUnique needed_name `elem` cCallishTyKeys) -- Hack! Don't prune these tycons whose constructors - -- the desugarer must be able to see when desugaring - -- a CCall. Ugh! + && not (nameUnique needed_name `elem` cCallishTyKeys) + -- Hack! Don't prune these tycons whose constructors + -- the desugarer must be able to see when desugaring + -- a CCall. Ugh! + = -- Need the type constructor; so put it in the deferred set for now getIfacesRn `thenRn` \ ifaces -> let - Ifaces this_mod mod_map decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces - new_ifaces = Ifaces this_mod mod_map decls_fm slurped_names imp_names unslurped_insts new_deferred_data_decls inst_mods + Ifaces this_mod mod_map decls_fm slurped_names imp_names + unslurped_insts deferred_data_decls inst_mods = ifaces + + new_ifaces = Ifaces this_mod mod_map decls_fm slurped_names imp_names + unslurped_insts new_deferred_data_decls inst_mods no_constr_ty_decl = TyData new_or_data [] tycon tyvars [] derivings pragmas src_loc new_deferred_data_decls = addToFM deferred_data_decls tycon_name no_constr_ty_decl @@ -633,8 +648,11 @@ getNonWiredDataDecl needed_name = -- Need a data constructor, so delete the data decl from the deferred set if it's there getIfacesRn `thenRn` \ ifaces -> let - Ifaces this_mod mod_map decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces - new_ifaces = Ifaces this_mod mod_map decls_fm slurped_names imp_names unslurped_insts new_deferred_data_decls inst_mods + Ifaces this_mod mod_map decls_fm slurped_names imp_names + unslurped_insts deferred_data_decls inst_mods = ifaces + + new_ifaces = Ifaces this_mod mod_map decls_fm slurped_names imp_names + unslurped_insts new_deferred_data_decls inst_mods new_deferred_data_decls = delFromFM deferred_data_decls tycon_name in @@ -649,7 +667,7 @@ getDeferredDataDecls let deferred_list = fmToList deferred_data_decls trace_msg = hang (text "Slurping abstract data/newtype decls for: ") - 4 (ppr PprDebug (map fst deferred_list)) + 4 (ppr (map fst deferred_list)) in traceRn trace_msg `thenRn_` returnRn deferred_list @@ -700,12 +718,12 @@ getImportedInstDecls deferred_data_decls inst_mods in - traceRn (sep [text "getInstDecls:", fsep (map (ppr PprDebug) (nameSetToList tycls_names))]) `thenRn_` + traceRn (sep [text "getInstDecls:", fsep (map ppr (nameSetToList tycls_names))]) `thenRn_` setIfacesRn new_ifaces `thenRn_` returnRn un_gated_insts where load_it mod = loadInterface (doc_str mod) mod HiFile - doc_str mod = sep [pprModule PprDebug mod, ptext SLIT("is a special-instance module")] + doc_str mod = sep [pprModule mod, ptext SLIT("is a special-instance module")] getSpecialInstModules :: RnMG [Module] @@ -772,11 +790,11 @@ getImportVersions this_mod exports Ifaces _ mod_map _ _ imp_names _ _ _ = ifaces -- mv_map groups together all the things imported from a particular module. - mv_map, mv_map_mod :: FiniteMap Module [LocalVersion Name] + mv_map, mv_map_mod :: FiniteMap Module (WhatsImported Name) mv_map_mod = foldl add_mod emptyFM export_mods -- mv_map_mod records all the modules that have a "module M" - -- in this module's export list + -- in this module's export list with an "Everything" mv_map = foldl add_mv mv_map_mod imp_names -- mv_map adds the version numbers of things exported individually @@ -792,11 +810,14 @@ getImportVersions this_mod exports Just es -> [mod | IEModuleContents mod <- es, mod /= this_mod] add_mv mv_map v@(name, version) - = addToFM_C (\ ls _ -> (v:ls)) mv_map mod [v] + = addToFM_C add_item mv_map mod (Specifically [v]) where mod = nameModule name - add_mod mv_map mod = addToFM mv_map mod [] + add_item Everything _ = Everything + add_item (Specifically xs) _ = Specifically (v:xs) + + add_mod mv_map mod = addToFM mv_map mod Everything \end{code} \begin{code} @@ -813,14 +834,16 @@ getSlurpedNames returnRn slurped_names recordSlurp maybe_version necessity avail - = {- traceRn (hsep [text "Record slurp:", pprAvail (PprForUser opt_PprUserLength) avail, + = {- traceRn (hsep [text "Record slurp:", pprAvail avail, -- NB PprForDebug prints export flag, which is too -- strict; it's a knot-tied thing in RnNames case necessity of {Compulsory -> text "comp"; Optional -> text "opt" } ]) `thenRn_` -} getIfacesRn `thenRn` \ ifaces -> let - Ifaces this_mod mod_map decls slurped_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces + Ifaces this_mod mod_map decls slurped_names imp_names + (insts, tycls_names) deferred_data_decls inst_mods = ifaces + new_slurped_names = addAvailToNameSet slurped_names avail new_imp_names = case maybe_version of @@ -876,10 +899,15 @@ getDeclBinders new_name (TyD (TySynonym tycon _ _ src_loc)) = new_name tycon src_loc `thenRn` \ tycon_name -> returnRn (AvailTC tycon_name [tycon_name]) -getDeclBinders new_name (ClD (ClassDecl _ cname _ sigs _ _ src_loc)) +getDeclBinders new_name (ClD (ClassDecl _ cname _ sigs _ _ tname dname src_loc)) = new_name cname src_loc `thenRn` \ class_name -> + new_name dname src_loc `thenRn` \ datacon_name -> + new_name tname src_loc `thenRn` \ tycon_name -> + + -- Record the names for the class ops mapRn (getClassOpNames new_name) sigs `thenRn` \ sub_names -> - returnRn (AvailTC class_name (class_name : sub_names)) + + returnRn (AvailTC class_name (class_name : datacon_name : tycon_name : sub_names)) getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc)) = new_name var src_loc `thenRn` \ var_name -> @@ -914,7 +942,7 @@ getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc %********************************************************* \begin{code} -findAndReadIface :: Doc -> Module +findAndReadIface :: SDoc -> Module -> IfaceFlavour -> RnMG (Maybe ParsedIface) -- Nothing <=> file not found, or unreadable, or illegible @@ -961,29 +989,17 @@ readIface file_path --traceRn (hcat[ptext SLIT("Opening...."), text file_path]) `thenRn_` case read_result of Right contents -> - case parseIface contents 1 of + case parseIface contents (mkSrcLoc (mkFastString file_path) 1) of Failed err -> - --traceRn (ptext SLIT("parse err")) `thenRn_` failWithRn Nothing err - Succeeded iface -> - --traceRn (ptext SLIT("parse cool")) `thenRn_` + Succeeded (PIface iface) -> returnRn (Just iface) -#if __GLASGOW_HASKELL__ >= 202 Left err -> if isDoesNotExistError err then - --traceRn (ptext SLIT("no file")) `thenRn_` returnRn Nothing else - --traceRn (ptext SLIT("uh-oh..")) `thenRn_` failWithRn Nothing (cannaeReadFile file_path err) -#else /* 2.01 and 0.2x */ - Left (NoSuchThing _) -> returnRn Nothing - - Left err -> failWithRn Nothing - (cannaeReadFile file_path err) -#endif - \end{code} mkSearchPath takes a string consisting of a colon-separated list @@ -1017,22 +1033,21 @@ mkSearchPath (Just s) %********************************************************* \begin{code} -noIfaceErr filename sty +noIfaceErr filename = hcat [ptext SLIT("Could not find valid interface file "), - quotes (pprModule sty filename)] + quotes (pprModule filename)] -cannaeReadFile file err sty +cannaeReadFile file err = hcat [ptext SLIT("Failed in reading file: "), text file, ptext SLIT("; error="), text (show err)] -getDeclErr name sty +getDeclErr name loc = sep [ptext SLIT("Failed to find interface decl for"), - ppr sty name] + quotes (ppr name), ptext SLIT("needed at"), ppr loc] -getDeclWarn name sty +getDeclWarn name loc = sep [ptext SLIT("Warning: failed to find (optional) interface decl for"), - ppr sty name] - + quotes (ppr name), ptext SLIT("desired at"), ppr loc] \end{code} diff --git a/ghc/compiler/rename/RnLoop.lhi b/ghc/compiler/rename/RnLoop.lhi deleted file mode 100644 index a2cb7e2c7e..0000000000 --- a/ghc/compiler/rename/RnLoop.lhi +++ /dev/null @@ -1,23 +0,0 @@ -Breaks the RnSource/RnExpr/RnBinds loops. - -\begin{code} -interface RnLoop where - -import RdrHsSyn ( RdrNameHsBinds(..), RdrNameHsType(..) ) -import RnHsSyn ( RenamedHsBinds(..), RenamedHsType(..) ) -import RnBinds ( rnBinds ) -import RnMonad ( RnMS(..), FreeVars ) -import RnSource ( rnHsSigType ) -import UniqSet ( UniqSet(..) ) -import Outputable ( PprStyle ) -import Pretty ( Doc ) -import Name ( Name ) - -rnBinds :: RdrNameHsBinds - -> (RenamedHsBinds -> RnMS s (result, FreeVars)) - -> RnMS s (result, FreeVars) - -rnHsSigType :: (PprStyle -> Doc) - -> RdrNameHsType - -> RnMS s RenamedHsType -\end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index be7fda3da0..09cecfab78 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -4,68 +4,48 @@ \section[RnMonad]{The monad used by the renamer} \begin{code} -#include "HsVersions.h" - module RnMonad( - EXP_MODULE(RnMonad), - -- close it up (partly done to allow unfoldings) - EXP_MODULE(SST), - SYN_IE(Module), + module RnMonad, + Module, FiniteMap, Bag, Name, - SYN_IE(RdrNameHsDecl), - SYN_IE(RdrNameInstDecl), - SYN_IE(Version), - SYN_IE(NameSet), + RdrNameHsDecl, + RdrNameInstDecl, + Version, + NameSet, OccName, Fixity ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import SST -#if __GLASGOW_HASKELL__ <= 201 -import PreludeGlaST ( SYN_IE(ST), thenStrictlyST, returnStrictlyST ) -#define MkIO -#else -import GlaExts -import IO -import ST -import IOBase -# if __GLASGOW_HASKELL__ >= 209 -import STBase (ST(..), STret(..) ) -# endif -#define IOError13 IOError -#define MkIO IO -#endif +import GlaExts ( RealWorld, stToIO ) import HsSyn import RdrHsSyn -import BasicTypes ( SYN_IE(Version), NewOrData ) -import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine, - pprBagOfErrors, SYN_IE(Error), SYN_IE(Warning) +import BasicTypes ( Version, NewOrData, pprModule ) +import SrcLoc ( noSrcLoc ) +import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, + pprBagOfErrors, ErrMsg, WarnMsg ) -import Name ( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet), emptyNameSet, +import Name ( Module, Name, OccName, PrintUnqualified, NameSet, emptyNameSet, isLocallyDefinedName, modAndOcc, NamedThing(..) ) import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas ) import PrelInfo ( builtinNames ) -import TyCon ( TyCon {- instance NamedThing -} ) import TysWiredIn ( boolTyCon ) -import Pretty -import Outputable ( PprStyle(..), printErrs ) import SrcLoc ( SrcLoc, mkGeneratedSrcLoc ) import Unique ( Unique ) import UniqFM ( UniqFM ) -import FiniteMap ( FiniteMap, emptyFM, bagToFM ) +import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM ) import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag ) import UniqSet -import Util -#if __GLASGOW_HASKELL__ >= 202 import UniqSupply -#endif +import Util +import Outputable infixr 9 `thenRn`, `thenRn_` \end{code} @@ -78,46 +58,17 @@ infixr 9 `thenRn`, `thenRn_` %************************************************************************ \begin{code} -#if __GLASGOW_HASKELL__ >= 200 -# define REAL_WORLD RealWorld -#else -# define REAL_WORLD _RealWorld -#endif -\end{code} +sstToIO :: SST RealWorld r -> IO r +sstToIO sst = stToIO (sstToST sst) -\begin{code} -sstToIO :: SST REAL_WORLD r -> IO r -#if __GLASGOW_HASKELL__ < 209 -sstToIO sst = - MkIO ( - sstToST sst `thenStrictlyST` \ r -> - returnStrictlyST (Right r)) -#else -sstToIO sst = - IO (\ s -> - let (ST st_act) = sstToST sst in - case st_act s of - STret s' v -> IOok s' v) -#endif - -ioToRnMG :: IO r -> RnMG (Either IOError13 r) -#if __GLASGOW_HASKELL__ < 209 -ioToRnMG (MkIO io) rn_down g_down = stToSST io -#else -ioToRnMG (IO io) rn_down g_down - = stToSST (ST io') - where - io' st = - case io st of - IOok st' v -> STret st' (Right v) - IOfail st' e -> STret st' (Left e) -#endif - -traceRn :: Doc -> RnMG () +ioToRnMG :: IO r -> RnMG (Either IOError r) +ioToRnMG io rn_down g_down = ioToSST io + +traceRn :: SDoc -> RnMG () traceRn msg | opt_D_show_rn_trace = putDocRn msg | otherwise = returnRn () -putDocRn :: Doc -> RnMG () +putDocRn :: SDoc -> RnMG () putDocRn msg = ioToRnMG (printErrs msg) `thenRn_` returnRn () \end{code} @@ -135,16 +86,18 @@ putDocRn msg = ioToRnMG (printErrs msg) `thenRn_` \begin{code} type RnM s d r = RnDown s -> d -> SST s r -type RnMS s r = RnM s (SDown s) r -- Renaming source -type RnMG r = RnM REAL_WORLD GDown r -- Getting global names etc -type MutVar a = MutableVar REAL_WORLD a -- ToDo: there ought to be a standard defn of this +type RnMS s r = RnM s (SDown s) r -- Renaming source +type RnMG r = RnM RealWorld GDown r -- Getting global names etc +type SSTRWRef a = SSTRef RealWorld a -- ToDo: there ought to be a standard defn of this -- Common part data RnDown s = RnDown SrcLoc - (MutableVar s RnNameSupply) - (MutableVar s (Bag Warning, Bag Error)) - (MutableVar s ([Name],[Name])) -- Occurrences: compulsory and optional resp + (SSTRef s RnNameSupply) + (SSTRef s (Bag WarnMsg, Bag ErrMsg)) + (SSTRef s ([Occurrence],[Occurrence])) -- Occurrences: compulsory and optional resp + +type Occurrence = (Name, SrcLoc) -- The srcloc is the occurrence site data Necessity = Compulsory | Optional -- We *must* find definitions for -- compulsory occurrences; we *may* find them @@ -153,7 +106,7 @@ data Necessity = Compulsory | Optional -- We *must* find definitions for -- For getting global names data GDown = GDown SearchPath - (MutVar Ifaces) + (SSTRWRef Ifaces) -- For renaming source code data SDown s = SDown @@ -165,12 +118,15 @@ data SDown s = SDown data RnSMode = SourceMode -- Renaming source code - | InterfaceMode Necessity -- Renaming interface declarations. The "necessity" + | InterfaceMode -- Renaming interface declarations. + Necessity -- The "necessity" -- flag says free variables *must* be found and slurped -- or whether they need not be. For value signatures of -- things that are themselves compulsorily imported - -- we arrange that the type signature is read in compulsory mode, + -- we arrange that the type signature is read + -- in compulsory mode, -- but the pragmas in optional mode. + (Name -> PrintUnqualified) -- Tells whether the thing can be printed unqualified type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search -- for interface files. @@ -187,13 +143,20 @@ type RnNameSupply = (UniqSupply, Int, FiniteMap (Module,OccName) Name) -- The Int is used to give a number to each instance declaration; -- it's really a separate name supply. -data RnEnv = RnEnv NameEnv FixityEnv -emptyRnEnv = RnEnv emptyNameEnv emptyFixityEnv +data RnEnv = RnEnv GlobalNameEnv FixityEnv +emptyRnEnv = RnEnv emptyNameEnv emptyFixityEnv + +type GlobalNameEnv = FiniteMap RdrName (Name, HowInScope) +emptyGlobalNameEnv = emptyFM + +data HowInScope -- Used for error messages only + = FromLocalDefn SrcLoc + | FromImportDecl Module SrcLoc type NameEnv = FiniteMap RdrName Name emptyNameEnv = emptyFM -type FixityEnv = FiniteMap RdrName (Fixity, Provenance) +type FixityEnv = FiniteMap RdrName (Fixity, HowInScope) emptyFixityEnv = emptyFM -- It's possible to have a different fixity for B.op than for op: -- @@ -204,11 +167,8 @@ emptyFixityEnv = emptyFM data ExportEnv = ExportEnv Avails Fixities type Avails = [AvailInfo] -type Fixities = [(OccName, (Fixity, Provenance))] - -- Can contain duplicates, if one module defines the same fixity, - -- or the same type/class/id, more than once. Hence a boring old list. - -- This allows us to report duplicates in just one place, namely plusRnEnv. - +type Fixities = [(OccName, Fixity)] + type ExportAvails = (FiniteMap Module Avails, -- Used to figure out "module M" export specifiers -- Includes avails only from *unqualified* imports -- (see 1.4 Report Section 5.1.1) @@ -236,7 +196,16 @@ type RdrAvailInfo = GenAvailInfo OccName \begin{code} type ExportItem = (Module, IfaceFlavour, [RdrAvailInfo]) type VersionInfo name = [ImportVersion name] -type ImportVersion name = (Module, IfaceFlavour, Version, [LocalVersion name]) + +type ImportVersion name = (Module, IfaceFlavour, Version, WhatsImported name) +data WhatsImported name = Everything + | Specifically [LocalVersion name] -- List guaranteed non-empty + + -- ("M", hif, ver, Everything) means there was a "module M" in + -- this module's export list, so we just have to go by M's version, "ver", + -- not the list of LocalVersions. + + type LocalVersion name = (name, Version) data ParsedIface @@ -250,7 +219,7 @@ data ParsedIface [(Version, RdrNameHsDecl)] -- Local definitions [RdrNameInstDecl] -- Local instance declarations -type InterfaceDetails = (VersionInfo Name, -- Version information +type InterfaceDetails = (VersionInfo Name, -- Version information for what this module imports ExportEnv, -- What this module exports [Module]) -- Instance modules @@ -306,7 +275,7 @@ type IfaceInst = ((Module, RdrNameInstDecl), -- Instance decl \begin{code} initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc -> RnMG r - -> IO (r, Bag Error, Bag Warning) + -> IO (r, Bag ErrMsg, Bag WarnMsg) initRn mod us dirs loc do_rn = sstToIO $ @@ -326,10 +295,10 @@ initRn mod us dirs loc do_rn returnSST (res, errs, warns) -initRnMS :: RnEnv -> Module -> RnSMode -> RnMS REAL_WORLD r -> RnMG r +initRnMS :: RnEnv -> Module -> RnSMode -> RnMS RealWorld r -> RnMG r initRnMS rn_env@(RnEnv name_env _) mod_name mode m rn_down g_down = let - s_down = SDown rn_env name_env mod_name mode + s_down = SDown rn_env emptyNameEnv mod_name mode in m rn_down s_down @@ -341,8 +310,8 @@ builtins :: FiniteMap (Module,OccName) Name builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames) -- Initial value for the occurrence pool. -initOccs :: ([Name],[Name]) -- Compulsory and optional respectively -initOccs = ([getName boolTyCon], []) +initOccs :: ([Occurrence],[Occurrence]) -- Compulsory and optional respectively +initOccs = ([(getName boolTyCon, noSrcLoc)], []) -- Booleans occur implicitly a lot, so it's tiresome to keep recording the fact, and -- rather implausible that not one will be used in the module. -- We could add some other common types, notably lists, but the general idea is @@ -363,7 +332,7 @@ once you must either split it, or install a fresh unique supply. \begin{code} renameSourceCode :: Module -> RnNameSupply - -> RnMS REAL_WORLD r + -> RnMS RealWorld r -> r -- Alas, we can't use the real runST, with the desired signature: @@ -377,23 +346,23 @@ renameSourceCode mod_name name_supply m newMutVarSST ([],[]) `thenSST` \ occs_var -> let rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var - s_down = SDown emptyRnEnv emptyNameEnv mod_name (InterfaceMode Compulsory) + s_down = SDown emptyRnEnv emptyNameEnv mod_name (InterfaceMode Compulsory (\_ -> False)) in m rn_down s_down `thenSST` \ result -> readMutVarSST errs_var `thenSST` \ (warns,errs) -> (if not (isEmptyBag errs) then - trace ("Urk! renameSourceCode found errors" ++ display errs) + pprTrace "Urk! renameSourceCode found errors" (display errs) else if not (isEmptyBag warns) then - trace ("Urk! renameSourceCode found warnings" ++ display warns) + pprTrace "Urk! renameSourceCode found warnings" (display warns) else id) $ returnSST result ) where - display errs = show (pprBagOfErrors PprDebug errs) + display errs = pprBagOfErrors errs {-# INLINE thenRn #-} {-# INLINE thenRn_ #-} @@ -463,7 +432,7 @@ mapMaybeRn f def (Just v) = f v ================ Errors and warnings ===================== \begin{code} -failWithRn :: a -> Error -> RnM s d a +failWithRn :: a -> ErrMsg -> RnM s d a failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down = readMutVarSST errs_var `thenSST` \ (warns,errs) -> writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_` @@ -471,7 +440,7 @@ failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down where err = addShortErrLocLine loc msg -warnWithRn :: a -> Warning -> RnM s d a +warnWithRn :: a -> WarnMsg -> RnM s d a warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down = readMutVarSST errs_var `thenSST` \ (warns,errs) -> writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_` @@ -479,14 +448,14 @@ warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down where warn = addShortWarnLocLine loc msg -addErrRn :: Error -> RnM s d () +addErrRn :: ErrMsg -> RnM s d () addErrRn err = failWithRn () err -checkRn :: Bool -> Error -> RnM s d () -- Check that a condition is true +checkRn :: Bool -> ErrMsg -> RnM s d () -- Check that a condition is true checkRn False err = addErrRn err checkRn True err = returnRn () -addWarnRn :: Warning -> RnM s d () +addWarnRn :: WarnMsg -> RnM s d () addWarnRn warn = warnWithRn () warn checkErrsRn :: RnM s d Bool -- True <=> no errors so far @@ -565,15 +534,13 @@ addOccurrenceName name (RnDown loc names_var errs_var occs_var) = readMutVarSST occs_var `thenSST` \ (comp_occs, opt_occs) -> let new_occ_pair = case necessity of - Optional -> (comp_occs, name:opt_occs) - Compulsory -> (name:comp_occs, opt_occs) + Optional -> (comp_occs, (name,loc):opt_occs) + Compulsory -> ((name,loc):comp_occs, opt_occs) in writeMutVarSST occs_var new_occ_pair `thenSST_` returnSST name where - necessity = case mode of - SourceMode -> Compulsory - InterfaceMode necessity -> necessity + necessity = modeToNecessity mode addOccurrenceNames :: [Name] -> RnMS s () @@ -586,34 +553,34 @@ addOccurrenceNames names (RnDown loc names_var errs_var occs_var) = readMutVarSST occs_var `thenSST` \ (comp_occs, opt_occs) -> let new_occ_pair = case necessity of - Optional -> (comp_occs, non_local_names ++ opt_occs) - Compulsory -> (non_local_names ++ comp_occs, opt_occs) + Optional -> (comp_occs, non_local_occs ++ opt_occs) + Compulsory -> (non_local_occs ++ comp_occs, opt_occs) in writeMutVarSST occs_var new_occ_pair where - non_local_names = filter (not . isLocallyDefinedName) names - necessity = case mode of - SourceMode -> Compulsory - InterfaceMode necessity -> necessity + non_local_occs = [(name, loc) | name <- names, not (isLocallyDefinedName name)] + necessity = modeToNecessity mode -- Never look for optional things if we're -- ignoring optional input interface information not_necessary Compulsory = False not_necessary Optional = opt_IgnoreIfacePragmas -popOccurrenceName :: Necessity -> RnM s d (Maybe Name) -popOccurrenceName necessity (RnDown loc names_var errs_var occs_var) l_down +popOccurrenceName :: RnSMode -> RnM s d (Maybe Occurrence) +popOccurrenceName mode (RnDown loc names_var errs_var occs_var) l_down = readMutVarSST occs_var `thenSST` \ occs -> - case (necessity, occs) of + case (mode, occs) of -- Find a compulsory occurrence - (Compulsory, (comp:comps, opts)) -> writeMutVarSST occs_var (comps, opts) `thenSST_` - returnSST (Just comp) + (InterfaceMode Compulsory _, (comp:comps, opts)) + -> writeMutVarSST occs_var (comps, opts) `thenSST_` + returnSST (Just comp) -- Find an optional occurrence -- We shouldn't be looking unless we've done all the compulsories - (Optional, (comps, opt:opts)) -> ASSERT( null comps ) - writeMutVarSST occs_var (comps, opts) `thenSST_` - returnSST (Just opt) + (InterfaceMode Optional _, (comps, opt:opts)) + -> ASSERT( null comps ) + writeMutVarSST occs_var (comps, opts) `thenSST_` + returnSST (Just opt) -- No suitable occurrence other -> returnSST Nothing @@ -629,7 +596,7 @@ findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down = newMutVarSST ([],[]) `thenSST` \ new_occs_var -> enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down `thenSST_` readMutVarSST new_occs_var `thenSST` \ (occs,_) -> - returnSST occs + returnSST (map fst occs) \end{code} @@ -642,16 +609,30 @@ findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down ================ RnEnv ===================== \begin{code} -getGlobalNameEnv :: RnMS s NameEnv -getGlobalNameEnv rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode) - = returnSST global_env - -getNameEnv :: RnMS s NameEnv -getNameEnv rn_down (SDown rn_env local_env mod_name mode) +-- Look in global env only +lookupGlobalNameRn :: RdrName -> RnMS s (Maybe Name) +lookupGlobalNameRn rdr_name rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode) + = case lookupFM global_env rdr_name of + Just (name, _) -> returnSST (Just name) + Nothing -> returnSST Nothing + +-- Look in both local and global env +lookupNameRn :: RdrName -> RnMS s (Maybe Name) +lookupNameRn rdr_name rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode) + = case lookupFM global_env rdr_name of + Just (name, _) -> returnSST (Just name) + Nothing -> returnSST (lookupFM local_env rdr_name) + +getNameEnvs :: RnMS s (GlobalNameEnv, NameEnv) +getNameEnvs rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode) + = returnSST (global_env, local_env) + +getLocalNameEnv :: RnMS s NameEnv +getLocalNameEnv rn_down (SDown rn_env local_env mod_name mode) = returnSST local_env -setNameEnv :: NameEnv -> RnMS s a -> RnMS s a -setNameEnv local_env' m rn_down (SDown rn_env local_env mod_name mode) +setLocalNameEnv :: NameEnv -> RnMS s a -> RnMS s a +setLocalNameEnv local_env' m rn_down (SDown rn_env local_env mod_name mode) = m rn_down (SDown rn_env local_env' mod_name mode) getFixityEnv :: RnMS s FixityEnv @@ -697,3 +678,22 @@ getSearchPathRn :: RnMG SearchPath getSearchPathRn rn_down (GDown dirs iface_var) = returnSST dirs \end{code} + +%************************************************************************ +%* * +\subsection{HowInScope} +%* * +%************************************************************************ + +\begin{code} +instance Outputable HowInScope where + ppr (FromLocalDefn loc) = ptext SLIT("Defined at") <+> ppr loc + ppr (FromImportDecl mod loc) = ptext SLIT("Imported from") <+> quotes (pprModule mod) <+> + ptext SLIT("at") <+> ppr loc +\end{code} + + +\begin{code} +modeToNecessity SourceMode = Compulsory +modeToNecessity (InterfaceMode necessity _) = necessity +\end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index d81847503c..0574301763 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -4,28 +4,27 @@ \section[RnNames]{Extracting imported and top-level names in scope} \begin{code} -#include "HsVersions.h" - module RnNames ( getGlobalNames ) where -IMP_Ubiq() +#include "HsVersions.h" + +import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports, + opt_SourceUnchanged + ) -import CmdLineOpts ( opt_SourceUnchanged, opt_NoImplicitPrelude, - opt_WarnDuplicateExports - ) -import HsSyn ( HsModule(..), HsDecl(..), FixityDecl(..), Fixity, Fake, InPat, IE(..), HsTyVar, - TyDecl, ClassDecl, InstDecl, DefaultDecl, ImportDecl(..), HsBinds, IfaceSig, +import HsSyn ( HsModule(..), ImportDecl(..), HsDecl(..), + IE(..), ieName, + FixityDecl(..), collectTopBinders ) -import HsImpExp ( ieName ) -import RdrHsSyn ( RdrNameHsDecl(..), RdrName(..), RdrNameIE(..), SYN_IE(RdrNameImportDecl), - SYN_IE(RdrNameHsModule), SYN_IE(RdrNameFixityDecl), +import RdrHsSyn ( RdrNameHsDecl(..), RdrName(..), RdrNameIE(..), RdrNameImportDecl, + RdrNameHsModule, RdrNameFixityDecl, rdrNameOcc, ieOcc ) import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) ) -import RnIfaces ( getInterfaceExports, getDeclBinders, checkUpToDate, recordSlurp ) +import RnIfaces ( getInterfaceExports, getDeclBinders, recordSlurp, checkUpToDate ) import BasicTypes ( IfaceFlavour(..) ) import RnEnv import RnMonad @@ -36,9 +35,8 @@ import UniqFM ( UniqFM, emptyUFM, addListToUFM_C, lookupUFM ) import Bag ( Bag, bagToList ) import Maybes ( maybeToBool, expectJust ) import Name -import Pretty -import Outputable ( Outputable(..), PprStyle(..) ) -import Util ( panic, pprTrace, assertPanic, removeDups, cmpPString ) +import Outputable +import Util ( removeDups ) \end{code} @@ -51,11 +49,11 @@ import Util ( panic, pprTrace, assertPanic, removeDups, cmpPString ) \begin{code} getGlobalNames :: RdrNameHsModule - -> RnMG (Maybe (ExportEnv, RnEnv, NameSet)) - -- Nothing <=> no need to recompile + -> RnMG (Maybe (ExportEnv, RnEnv, NameSet, Name -> PrintUnqualified)) -- The NameSet is the set of names that are -- either locally defined, -- or explicitly imported + -- Nothing => no need to recompile getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc) = fixRn (\ ~(rec_exp_fn, _) -> @@ -69,17 +67,34 @@ getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc) mapAndUnzip3Rn importsFromImportDecl all_imports `thenRn` \ (imp_rn_envs, imp_avails_s, explicit_imports_s) -> - -- CHECK FOR EARLY EXIT - checkEarlyExit this_mod `thenRn` \ early_exit -> - if early_exit then - returnRn (junk_exp_fn, Nothing) - else - -- COMBINE RESULTS -- We put the local env second, so that a local provenance -- "wins", even if a module imports itself. foldlRn plusRnEnv emptyRnEnv imp_rn_envs `thenRn` \ imp_rn_env -> plusRnEnv imp_rn_env local_rn_env `thenRn` \ rn_env -> + + -- TRY FOR EARLY EXIT + -- We can't go for an early exit before this because we have to check + -- for name clashes. Consider: + -- + -- module A where module B where + -- import B h = True + -- f = h + -- + -- Suppose I've compiled everything up, and then I add a + -- new definition to module B, that defines "f". + -- + -- Then I must detect the name clash in A before going for an early + -- exit. The early-exit code checks what's actually needed from B + -- to compile A, and of course that doesn't include B.f. That's + -- why we wait till after the plusRnEnv stuff to do the early-exit. + checkEarlyExit this_mod `thenRn` \ up_to_date -> + if up_to_date then + returnRn (error "early exit", Nothing) + else + + + -- PROCESS EXPORT LISTS let export_avails :: ExportAvails export_avails = foldr plusExportAvails local_mod_avails imp_avails_s @@ -88,15 +103,19 @@ getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc) explicit_names = foldr add_on emptyNameSet (local_avails : explicit_imports_s) add_on avails names = foldr (unionNameSets . mkNameSet . availNames) names avails in - - -- PROCESS EXPORT LISTS exportsFromAvail this_mod exports export_avails rn_env `thenRn` \ (export_fn, export_env) -> -- RECORD THAT LOCALLY DEFINED THINGS ARE AVAILABLE mapRn (recordSlurp Nothing Compulsory) local_avails `thenRn_` - returnRn (export_fn, Just (export_env, rn_env, explicit_names)) + -- BUILD THE "IMPORT FN". It just tells whether a name is in + -- scope in an unqualified form. + let + print_unqual = mkImportFn imp_rn_env + in + + returnRn (export_fn, Just (export_env, rn_env, explicit_names, print_unqual)) ) `thenRn` \ (_, result) -> returnRn result where @@ -130,22 +149,23 @@ checkEarlyExit mod -- Found errors already, so exit now returnRn True else + traceRn (text "Considering whether compilation is required...") `thenRn_` if not opt_SourceUnchanged then -- Source code changed and no errors yet... carry on traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_` returnRn False else + -- Unchanged source, and no errors yet; see if usage info -- up to date, and exit if so - checkUpToDate mod `thenRn` \ up_to_date -> - putDocRn (text "Compilation" <+> - text (if up_to_date then "IS NOT" else "IS") <+> - text "required") `thenRn_` - returnRn up_to_date + checkUpToDate mod `thenRn` \ up_to_date -> + putDocRn (text "Compilation" <+> + text (if up_to_date then "IS NOT" else "IS") <+> + text "required") `thenRn_` + returnRn up_to_date \end{code} - \begin{code} importsFromImportDecl :: RdrNameImportDecl -> RnMG (RnEnv, ExportAvails, [AvailInfo]) @@ -155,24 +175,17 @@ importsFromImportDecl (ImportDecl mod qual_only as_source as_mod import_spec loc getInterfaceExports mod as_source `thenRn` \ (avails, fixities) -> filterImports mod import_spec avails `thenRn` \ (filtered_avails, hides, explicits) -> let - filtered_avails' = map set_avail_prov filtered_avails - fixities' = [ (occ,(fixity,provenance)) | (occ,fixity) <- fixities ] + how_in_scope = FromImportDecl mod loc in qualifyImports mod True -- Want qualified names (not qual_only) -- Maybe want unqualified names as_mod - (ExportEnv filtered_avails' fixities') hides + filtered_avails (\n -> how_in_scope) + [ (occ,(fixity,how_in_scope)) | (occ,fixity) <- fixities ] `thenRn` \ (rn_env, mod_avails) -> returnRn (rn_env, mod_avails, explicits) - where - set_avail_prov NotAvailable = NotAvailable - set_avail_prov (Avail n) = Avail (set_name_prov n) - set_avail_prov (AvailTC n ns) = AvailTC (set_name_prov n) (map set_name_prov ns) - set_name_prov name | isWiredInName name = name - | otherwise = setNameProvenance name provenance - provenance = Imported mod loc as_source \end{code} @@ -184,8 +197,9 @@ importsFromLocalDecls rec_exp_fn (HsModule mod _ _ _ fix_decls decls _) False -- Don't want qualified names True -- Want unqualified names Nothing -- No "as M" part - (ExportEnv avails fixities) [] -- Hide nothing + avails (\n -> FromLocalDefn (getSrcLoc n)) + fixities `thenRn` \ (rn_env, mod_avails) -> returnRn (rn_env, mod_avails, avails) where @@ -279,16 +293,18 @@ qualifyImports :: Module -- Imported module -> Bool -- True <=> want qualified import -> Bool -- True <=> want unqualified import -> Maybe Module -- Optional "as M" part - -> ExportEnv -- What's imported -> [AvailInfo] -- What's to be hidden + -> Avails -> (Name -> HowInScope) -- Whats imported and how + -> [(OccName, (Fixity, HowInScope))] -- Ditto for fixities -> RnMG (RnEnv, ExportAvails) -qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities) hides +qualifyImports this_mod qual_imp unqual_imp as_mod hides + avails name_to_his fixities = -- Make the name environment. Even though we're talking about a -- single import module there might still be name clashes, -- because it might be the module being compiled. - foldlRn add_avail emptyNameEnv avails `thenRn` \ name_env1 -> + foldlRn add_avail emptyGlobalNameEnv avails `thenRn` \ name_env1 -> let -- Delete things that are hidden name_env2 = foldl del_avail name_env1 hides @@ -305,26 +321,27 @@ qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities) h Nothing -> this_mod Just another_name -> another_name + add_avail :: GlobalNameEnv -> AvailInfo -> RnMG GlobalNameEnv add_avail env avail = foldlRn add_name env (availNames avail) add_name env name = add qual_imp env (Qual qual_mod occ err_hif) `thenRn` \ env1 -> add unqual_imp env1 (Unqual occ) where add False env rdr_name = returnRn env - add True env rdr_name = addOneToNameEnv env rdr_name name + add True env rdr_name = addOneToGlobalNameEnv env rdr_name (name, name_to_his name) occ = nameOccName name - del_avail env avail = foldl delOneFromNameEnv env rdr_names + del_avail env avail = foldl delOneFromGlobalNameEnv env rdr_names where rdr_names = map (Unqual . nameOccName) (availNames avail) - add_fixity name_env fix_env (occ_name, (fixity, provenance)) + add_fixity name_env fix_env (occ_name, fixity) = add qual $ add unqual $ fix_env where qual = Qual qual_mod occ_name err_hif unqual = Unqual occ_name add rdr_name fix_env | maybeToBool (lookupFM name_env rdr_name) - = addOneToFixityEnv fix_env rdr_name (fixity,provenance) + = addOneToFixityEnv fix_env rdr_name fixity | otherwise = fix_env @@ -346,10 +363,10 @@ unQualify fm = addListToFM fm [(Unqual occ, elt) | (Qual _ occ _, elt) <- fmToLi \begin{code} -fixityFromFixDecl :: RdrNameFixityDecl -> RnMG (OccName, (Fixity, Provenance)) +fixityFromFixDecl :: RdrNameFixityDecl -> RnMG (OccName, (Fixity, HowInScope)) fixityFromFixDecl (FixityDecl rdr_name fixity loc) - = returnRn (rdrNameOcc rdr_name, (fixity, LocalDef (panic "export-flag") loc)) + = returnRn (rdrNameOcc rdr_name, (fixity, FromLocalDefn loc)) \end{code} @@ -405,7 +422,6 @@ dup_avail (ie1,avail1,r1) (ie2,avail2,r2) = availName avail1 == availName avail2 -- Same OccName & avail. add_avail (ie1,a1,r1) (ie2,a2,r2) = (ie1, a1 `plusAvail` a2, r1 + r2) - \end{code} Processing the export list. @@ -431,7 +447,7 @@ exportsFromAvail this_mod Nothing export_avails rn_env exportsFromAvail this_mod (Just export_items) (mod_avail_env, entity_avail_env) - (RnEnv name_env fixity_env) + (RnEnv global_name_env fixity_env) = checkForModuleExportDups export_items `thenRn` \ export_items' -> foldlRn exports_from_item emptyAvailEnv export_items' `thenRn` \ export_avail_env -> let @@ -460,7 +476,7 @@ exportsFromAvail this_mod (Just export_items) -- I can't see why this should ever happen; if the thing is in scope -- at all it ought to have some availability | not (maybeToBool maybe_avail) - = pprTrace "exportsFromAvail: curious Nothing:" (ppr PprDebug name) + = pprTrace "exportsFromAvail: curious Nothing:" (ppr name) returnRn export_avail_env #endif @@ -470,31 +486,31 @@ exportsFromAvail this_mod (Just export_items) | otherwise -- Phew! It's OK! = addAvailEnv opt_WarnDuplicateExports ie export_avail_env export_avail where - maybe_in_scope = lookupNameEnv name_env (ieName ie) - Just name = maybe_in_scope + maybe_in_scope = lookupFM global_name_env (ieName ie) + Just (name,_) = maybe_in_scope maybe_avail = lookupUFM entity_avail_env name Just avail = maybe_avail export_avail = filterAvail ie avail enough_avail = case export_avail of {NotAvailable -> False; other -> True} -- We export a fixity iff we export a thing with the same (qualified) RdrName - mk_exported_fixities :: NameSet -> [(OccName, (Fixity, Provenance))] + mk_exported_fixities :: NameSet -> [(OccName, Fixity)] mk_exported_fixities exports = fmToList (foldr (perhaps_add_fixity exports) emptyFM (fmToList fixity_env)) - perhaps_add_fixity :: NameSet -> (RdrName, (Fixity, Provenance)) - -> FiniteMap OccName (Fixity,Provenance) - -> FiniteMap OccName (Fixity,Provenance) - perhaps_add_fixity exports (rdr_name, (fixity, prov)) fix_env + perhaps_add_fixity :: NameSet -> (RdrName, (Fixity, HowInScope)) + -> FiniteMap OccName Fixity + -> FiniteMap OccName Fixity + perhaps_add_fixity exports (rdr_name, (fixity, how_in_scope)) fix_env = let do_nothing = fix_env -- The default is to pass on the env unchanged in -- Step 1: check whether the rdr_name is in scope; if so find its Name - case lookupFM name_env rdr_name of { - Nothing -> do_nothing; - Just fixity_name -> + case lookupFM global_name_env rdr_name of { + Nothing -> do_nothing; + Just (fixity_name,_) -> -- Step 2: check whether the fixity thing is exported if not (fixity_name `elemNameSet` exports) then @@ -510,13 +526,13 @@ exportsFromAvail this_mod (Just export_items) occ_name = rdrNameOcc rdr_name in case lookupFM fix_env occ_name of { - Just (fixity1, prov1) -> -- Got it already - ASSERT( fixity == fixity1 ) - do_nothing; + Just fixity1 -> -- Got it already + ASSERT( fixity == fixity1 ) + do_nothing; Nothing -> -- Step 3: add it to the outgoing fix_env - addToFM fix_env occ_name (fixity,prov) + addToFM fix_env occ_name fixity }} {- warn and weed out duplicate module entries from export list. -} @@ -542,7 +558,7 @@ checkForModuleExportDups ls (no_module_dups, dups) = removeDups cmp_mods modules - cmp_mods (IEModuleContents m1) (IEModuleContents m2) = m1 `cmpPString` m2 + cmp_mods (IEModuleContents m1) (IEModuleContents m2) = m1 `compare` m2 mk_export_fn :: [AvailInfo] -> (Name -> ExportFlag) mk_export_fn avails @@ -561,39 +577,33 @@ mk_export_fn avails %************************************************************************ \begin{code} -badImportItemErr mod ie sty - = sep [ptext SLIT("Module"), pprModule sty mod, ptext SLIT("does not export"), ppr sty ie] +badImportItemErr mod ie + = sep [ptext SLIT("Module"), quotes (pprModule mod), + ptext SLIT("does not export"), quotes (ppr ie)] -modExportErr mod sty - = hsep [ ptext SLIT("Unknown module in export list: module"), ptext mod] +modExportErr mod + = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModule mod)] -exportItemErr export_item NotAvailable sty - = sep [ ptext SLIT("Export item not in scope:"), ppr sty export_item ] +exportItemErr export_item NotAvailable + = sep [ ptext SLIT("Export item not in scope:"), quotes (ppr export_item)] -exportItemErr export_item avail sty +exportItemErr export_item avail = hang (ptext SLIT("Export item not fully in scope:")) - 4 (vcat [hsep [ptext SLIT("Wanted: "), ppr sty export_item], - hsep [ptext SLIT("Available:"), ppr sty (ieOcc export_item), pprAvail sty avail]]) + 4 (vcat [hsep [ptext SLIT("Wanted: "), ppr export_item], + hsep [ptext SLIT("Available:"), ppr (ieOcc export_item), pprAvail avail]]) -availClashErr (occ_name, ((ie1,avail1,_), (ie2,avail2,_))) sty - = hsep [ptext SLIT("The export items"), ppr sty ie1, ptext SLIT("and"), ppr sty ie2, - ptext SLIT("create conflicting exports for"), ppr sty occ_name] +availClashErr (occ_name, ((ie1,avail1,_), (ie2,avail2,_))) + = hsep [ptext SLIT("The export items"), quotes (ppr ie1), ptext SLIT("and"), quotes (ppr ie2), + ptext SLIT("create conflicting exports for"), quotes (ppr occ_name)] -dupExportWarn (occ_name, (_,_,times)) sty - = hsep [ppr sty occ_name, - ptext SLIT("mentioned"), text (speak_times (times+1)), +dupExportWarn (occ_name, (_,_,times)) + = hsep [quotes (ppr occ_name), + ptext SLIT("mentioned"), speakNTimes (times+1), ptext SLIT("in export list")] -dupModuleExport mod times sty - = hsep [ptext SLIT("Module"), pprModule sty mod, - ptext SLIT("mentioned"), text (speak_times times), +dupModuleExport mod times + = hsep [ptext SLIT("Module"), quotes (pprModule mod), + ptext SLIT("mentioned"), speakNTimes times, ptext SLIT("in export list")] - -speak_times :: Int{- >=1 -} -> String -speak_times t | t == 1 = "once" - | t == 2 = "twice" - | otherwise = show t ++ " times" - - \end{code} diff --git a/ghc/compiler/rename/RnSource.hi-boot b/ghc/compiler/rename/RnSource.hi-boot index 24d8add5a5..85604e8e9c 100644 --- a/ghc/compiler/rename/RnSource.hi-boot +++ b/ghc/compiler/rename/RnSource.hi-boot @@ -2,7 +2,7 @@ _interface_ RnSource 1 _exports_ RnSource rnHsSigType; _declarations_ -1 rnHsSigType _:_ _forall_ [a] => (Outputable.PprStyle -> Pretty.Doc) +1 rnHsSigType _:_ _forall_ [a] => (Outputable.SDoc) -> RdrHsSyn.RdrNameHsType -> RnMonad.RnMS a RnHsSyn.RenamedHsType ;; diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 33d156de53..4a64569092 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -4,24 +4,15 @@ \section[RnSource]{Main pass of renamer} \begin{code} -#include "HsVersions.h" - module RnSource ( rnDecl, rnHsType, rnHsSigType ) where -IMPORT_1_3(List(partition)) -IMP_Ubiq() +#include "HsVersions.h" -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(RnLoop) -- *check* the RnPass/RnExpr/RnBinds loop-breaking -#else import RnExpr ---import {-# SOURCE #-} RnExpr -#endif - import HsSyn import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) ) import HsPragmas -import HsTypes ( getTyVarName ) +import HsTypes ( getTyVarName, pprClassAssertion, cmpHsTypes ) import RdrHsSyn import RnHsSyn import HsCore @@ -30,7 +21,7 @@ import CmdLineOpts ( opt_IgnoreIfacePragmas ) import RnBinds ( rnTopBinds, rnMethodBinds ) import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn, newDfunName, checkDupOrQualNames, checkDupNames, - newLocallyDefinedGlobalName, newGlobalName, ifaceFlavour, + newLocallyDefinedGlobalName, newImportedGlobalName, ifaceFlavour, listType_RDR, tupleType_RDR ) import RnMonad @@ -38,14 +29,12 @@ import Name ( Name, isLocallyDefined, OccName(..), occNameString, prefixOccName, ExportFlag(..), Provenance(..), getNameProvenance, - SYN_IE(NameSet), unionNameSets, emptyNameSet, mkNameSet, unitNameSet, - elemNameSet + NameSet, unionNameSets, emptyNameSet, mkNameSet, unitNameSet, + elemNameSet, nameSetToList ) -import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine ) import FiniteMap ( emptyFM, lookupFM, addListToFM_C ) import Id ( GenId{-instance NamedThing-} ) import IdInfo ( IdInfo, StrictnessInfo(..), FBTypeInfo, DemandInfo, ArgUsageInfo ) -import SpecEnv ( SpecEnv ) import Lex ( isLexCon ) import CoreUnfold ( Unfolding(..), SimpleUnfolding ) import MagicUFs ( MagicUnfoldingFun ) @@ -53,14 +42,13 @@ import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NA import ListSetOps ( unionLists, minusList ) import Maybes ( maybeToBool, catMaybes ) import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList ) -import Outputable ( PprStyle(..), Outputable(..){-instances-}, pprQuote ) -import Pretty +import Outputable import SrcLoc ( SrcLoc ) import Unique ( Unique ) -import UniqSet ( SYN_IE(UniqSet) ) +import UniqSet ( UniqSet ) import UniqFM ( UniqFM, lookupUFM ) import Util -IMPORT_1_3(List(nub)) +import List ( partition, nub ) \end{code} rnDecl `renames' declarations. @@ -94,8 +82,10 @@ rnDecl (SigD (IfaceSig name ty id_infos loc)) = pushSrcLocRn loc $ lookupBndrRn name `thenRn` \ name' -> rnHsType ty `thenRn` \ ty' -> + -- Get the pragma info (if any). - setModeRn (InterfaceMode Optional) $ + getModeRn `thenRn` \ (InterfaceMode _ print_unqual) -> + setModeRn (InterfaceMode Optional print_unqual) $ -- In all the rest of the signature we read in optional mode, -- so that (a) we don't die mapRn rnIdInfo id_infos `thenRn` \ id_infos' -> @@ -132,7 +122,7 @@ rnDecl (TyD (TyData new_or_data context tycon tyvars condecls derivings pragmas ASSERT(isNoDataPragmas pragmas) returnRn (TyD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)) where - data_doc sty = text "the data type declaration for" <+> ppr sty tycon + data_doc = text "the data type declaration for" <+> ppr tycon con_names = map conDeclName condecls rnDecl (TyD (TySynonym name tyvars ty src_loc)) @@ -142,7 +132,7 @@ rnDecl (TyD (TySynonym name tyvars ty src_loc)) rnHsType ty `thenRn` \ ty' -> returnRn (TyD (TySynonym name' tyvars' ty' src_loc)) where - syn_doc sty = text "the declaration for type synonym" <+> ppr sty name + syn_doc = text "the declaration for type synonym" <+> ppr name \end{code} %********************************************************* @@ -156,18 +146,24 @@ class declaration in which local names have been replaced by their original names, reporting any unknown names. \begin{code} -rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)) +rnDecl (ClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_loc)) = pushSrcLocRn src_loc $ - bindTyVarsRn cls_doc [tyvar] ( \ [tyvar'] -> + lookupBndrRn cname `thenRn` \ cname' -> + lookupBndrRn tname `thenRn` \ tname' -> + lookupBndrRn dname `thenRn` \ dname' -> + + bindTyVarsRn cls_doc tyvars ( \ tyvars' -> rnContext context `thenRn` \ context' -> - lookupBndrRn cname `thenRn` \ cname' -> -- Check the signatures + let + clas_tyvar_names = map getTyVarName tyvars' + in checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` - mapRn (rn_op cname' (getTyVarName tyvar')) sigs `thenRn` \ sigs' -> - returnRn (tyvar', context', cname', sigs') - ) `thenRn` \ (tyvar', context', cname', sigs') -> + mapRn (rn_op cname' clas_tyvar_names) sigs `thenRn` \ sigs' -> + returnRn (tyvars', context', sigs') + ) `thenRn` \ (tyvars', context', sigs') -> -- Check the methods checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_` @@ -179,20 +175,20 @@ rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)) -- for instance decls. ASSERT(isNoClassPragmas pragmas) - returnRn (ClD (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)) + returnRn (ClD (ClassDecl context' cname' tyvars' sigs' mbinds' NoClassPragmas tname' dname' src_loc)) where - cls_doc sty = text "the declaration for class" <+> ppr sty cname - sig_doc sty = text "the signatures for class" <+> ppr sty cname - meth_doc sty = text "the default-methods for class" <+> ppr sty cname + cls_doc = text "the declaration for class" <+> ppr cname + sig_doc = text "the signatures for class" <+> ppr cname + meth_doc = text "the default-methods for class" <+> ppr cname sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs] meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds) meth_rdr_names = map fst meth_rdr_names_w_locs - rn_op clas clas_tyvar sig@(ClassOpSig op maybe_dm ty locn) + rn_op clas clas_tyvars sig@(ClassOpSig op maybe_dm ty locn) = pushSrcLocRn locn $ lookupBndrRn op `thenRn` \ op_name -> - rnHsSigType (\sty -> ppr sty op) ty `thenRn` \ new_ty -> + rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty -> -- Make the default-method name let @@ -207,28 +203,27 @@ rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)) (\_ -> Exported) locn `thenRn` \ dm_name -> returnRn (Just dm_name) - (InterfaceMode _, Just _) + (InterfaceMode _ _, Just _) -> -- Imported class that has a default method decl - newGlobalName mod_name dm_occ (ifaceFlavour clas) `thenRn` \ dm_name -> - addOccurrenceName dm_name `thenRn_` + newImportedGlobalName mod_name dm_occ (ifaceFlavour clas) `thenRn` \ dm_name -> + addOccurrenceName dm_name `thenRn_` returnRn (Just dm_name) other -> returnRn Nothing ) `thenRn` \ maybe_dm_name -> - -- Checks..... + -- Check that each class tyvar appears in op_ty let (ctxt, op_ty) = case new_ty of HsForAllTy tvs ctxt op_ty -> (ctxt, op_ty) other -> ([], new_ty) - ctxt_fvs = extractCtxtTyNames ctxt - op_ty_fvs = extractHsTyNames op_ty -- Includes tycons/classes but we - -- don't care about that + ctxt_fvs = extractHsCtxtTyNames ctxt -- Includes tycons/classes but we + op_ty_fvs = extractHsTyNames op_ty -- don't care about that + + check_in_op_ty clas_tyvar = checkRn (clas_tyvar `elemNameSet` op_ty_fvs) + (classTyVarNotInOpTyErr clas_tyvar sig) in - -- Check that class tyvar appears in op_ty - checkRn (clas_tyvar `elemNameSet` op_ty_fvs) - (classTyVarNotInOpTyErr clas_tyvar sig) - `thenRn_` + mapRn check_in_op_ty clas_tyvars `thenRn_` returnRn (ClassOpSig op_name maybe_dm_name new_ty locn) \end{code} @@ -243,7 +238,7 @@ rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)) \begin{code} rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) = pushSrcLocRn src_loc $ - rnHsSigType (\sty -> text "an instance decl") inst_ty `thenRn` \ inst_ty' -> + rnHsSigType (text "an instance decl") inst_ty `thenRn` \ inst_ty' -> -- Rename the bindings @@ -260,13 +255,13 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) -- The typechecker checks that all the bindings are for the right class. returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc)) where - meth_doc sty = text "the bindings in an instance declaration" + meth_doc = text "the bindings in an instance declaration" meth_names = bagToList (collectMonoBinders mbinds) rn_uprag (SpecSig op ty using locn) = pushSrcLocRn src_loc $ lookupBndrRn op `thenRn` \ op_name -> - rnHsSigType (\sty -> ppr sty op) ty `thenRn` \ new_ty -> + rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty -> rn_using using `thenRn` \ new_using -> returnRn (SpecSig op_name new_ty new_using locn) @@ -362,7 +357,7 @@ rnConDetails con locn (RecCon fields) mapRn rnField fields `thenRn` \ new_fields -> returnRn (RecCon new_fields) where - fld_doc sty = text "the fields of constructor" <> ppr sty con + fld_doc = text "the fields of constructor" <> ppr con field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds] rnField (names, ty) @@ -401,7 +396,7 @@ checkConName name %********************************************************* \begin{code} -rnHsSigType :: (PprStyle -> Doc) -> RdrNameHsType -> RnMS s RenamedHsType +rnHsSigType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType -- rnHsSigType is used for source-language type signatures, -- which use *implicit* universal quantification. @@ -412,13 +407,13 @@ rnHsSigType :: (PprStyle -> Doc) -> RdrNameHsType -> RnMS s RenamedHsType -- no type variables that don't appear free in the tau-type part. rnHsSigType doc_str full_ty@(HsPreForAllTy ctxt ty) -- From source code (no kinds on tyvars) - = getNameEnv `thenRn` \ name_env -> + = getLocalNameEnv `thenRn` \ name_env -> let mentioned_tyvars = extractHsTyVars ty forall_tyvars = filter (not . in_scope) mentioned_tyvars in_scope tv = maybeToBool (lookupFM name_env tv) - constrained_tyvars = nub (concat (map (extractHsTyVars . snd) ctxt)) + constrained_tyvars = extractHsCtxtTyVars ctxt constrained_and_in_scope = filter in_scope constrained_tyvars constrained_and_not_mentioned = filter (not . (`elem` mentioned_tyvars)) constrained_tyvars @@ -437,7 +432,7 @@ rnHsSigType doc_str full_ty@(HsPreForAllTy ctxt ty) -- From source code (no kind returnRn (HsForAllTy new_tyvars new_ctxt new_ty) ) where - sig_doc sty = text "the type signature for" <+> doc_str sty + sig_doc = text "the type signature for" <+> doc_str rnHsSigType doc_str other_ty = rnHsType other_ty @@ -448,9 +443,9 @@ rnHsType (HsForAllTy tvs ctxt ty) -- From an interface file (tyvars may be kind rnHsType full_ty@(HsPreForAllTy ctxt ty) -- A (context => ty) embedded in a type. -- Universally quantify over tyvars in context - = getNameEnv `thenRn` \ name_env -> + = getLocalNameEnv `thenRn` \ name_env -> let - forall_tyvars = foldr unionLists [] (map (extractHsTyVars . snd) ctxt) + forall_tyvars = extractHsCtxtTyVars ctxt in rn_poly_help (map UserTyVar forall_tyvars) ctxt ty @@ -476,10 +471,10 @@ rnHsType (MonoTyApp ty1 ty2) rnHsType ty2 `thenRn` \ ty2' -> returnRn (MonoTyApp ty1' ty2') -rnHsType (MonoDictTy clas ty) +rnHsType (MonoDictTy clas tys) = lookupOccRn clas `thenRn` \ clas' -> - rnHsType ty `thenRn` \ ty' -> - returnRn (MonoDictTy clas' ty') + mapRn rnHsType tys `thenRn` \ tys' -> + returnRn (MonoDictTy clas' tys') rn_poly_help :: [HsTyVar RdrName] -- Universally quantified tyvars -> RdrNameContext @@ -491,7 +486,7 @@ rn_poly_help tyvars ctxt ty rnHsType ty `thenRn` \ new_ty -> returnRn (HsForAllTy new_tyvars new_ctxt new_ty) where - sig_doc sty = text "a nested for-all type" + sig_doc = text "a nested for-all type" \end{code} @@ -503,22 +498,21 @@ rnContext ctxt let (_, dup_asserts) = removeDups cmp_assert result (alls, theta) = partition (\(c,_) -> c == allClass_NAME) result - non_tyvar_alls = [(c,t) | (c,t) <- alls, not (is_tyvar t)] in -- Check for duplicate assertions -- If this isn't an error, then it ought to be: - mapRn (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_` + mapRn (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_` -- Check for All constraining a non-type-variable - mapRn (addWarnRn . allOfNonTyVar) non_tyvar_alls `thenRn_` + mapRn check_All alls `thenRn_` -- Done. Return a theta omitting all the "All" constraints. -- They have done done their work by ensuring that we universally -- quantify over their tyvar. returnRn theta where - rn_ctxt (clas, ty) + rn_ctxt (clas, tys) = -- Mini hack here. If the class is our pseudo-class "All", -- then we don't want to record it as an occurrence, otherwise -- we try to slurp it in later and it doesn't really exist at all. @@ -529,14 +523,15 @@ rnContext ctxt else returnRn clas_name ) `thenRn_` - rnHsType ty `thenRn` \ ty' -> - returnRn (clas_name, ty') + mapRn rnHsType tys `thenRn` \ tys' -> + returnRn (clas_name, tys') + - cmp_assert (c1,ty1) (c2,ty2) - = (c1 `cmp` c2) `thenCmp` (cmpHsType cmp ty1 ty2) + cmp_assert (c1,tys1) (c2,tys2) + = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2) - is_tyvar (MonoTyVar _) = True - is_tyvar other = False + check_All (c, [MonoTyVar _]) = returnRn () -- OK! + check_All assertion = addErrRn (wierdAllErr assertion) \end{code} @@ -640,10 +635,6 @@ rnCoreBndr (UfTyBinder name kind) thing_inside = bindLocalsRn "unfolding tyvar" [name] $ \ [name'] -> thing_inside (UfTyBinder name' kind) -rnCoreBndr (UfUsageBinder name) thing_inside - = bindLocalsRn "unfolding usage" [name] $ \ [name'] -> - thing_inside (UfUsageBinder name') - rnCoreBndrs bndrs thing_inside -- Expect them all to be ValBinders = mapRn rnHsType tys `thenRn` \ tys' -> bindLocalsRn "unfolding value" names $ \ names' -> @@ -659,8 +650,7 @@ rnCoreBndrNamess names thing_inside \begin{code} rnCoreArg (UfVarArg v) = lookupOccRn v `thenRn` \ v' -> returnRn (UfVarArg v') -rnCoreArg (UfUsageArg u) = lookupOccRn u `thenRn` \ u' -> returnRn (UfUsageArg u') -rnCoreArg (UfTyArg ty) = rnHsType ty `thenRn` \ ty' -> returnRn (UfTyArg ty') +rnCoreArg (UfTyArg ty) = rnHsType ty `thenRn` \ ty' -> returnRn (UfTyArg ty') rnCoreArg (UfLitArg lit) = returnRn (UfLitArg lit) rnCoreAlts (UfAlgAlts alts deflt) @@ -706,37 +696,37 @@ rnCorePrim (UfCCallOp str casm gc arg_tys res_ty) %********************************************************* \begin{code} -derivingNonStdClassErr clas sty - = hsep [ptext SLIT("non-standard class"), ppr sty clas, ptext SLIT("in deriving clause")] +derivingNonStdClassErr clas + = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")] -classTyVarNotInOpTyErr clas_tyvar sig sty - = hang (hsep [ptext SLIT("Class type variable"), - ppr sty clas_tyvar, +classTyVarNotInOpTyErr clas_tyvar sig + = hang (hsep [ptext SLIT("Class type variable"), + quotes (ppr clas_tyvar), ptext SLIT("does not appear in method signature")]) - 4 (ppr sty sig) + 4 (ppr sig) -dupClassAssertWarn ctxt ((clas,ty) : dups) sty +dupClassAssertWarn ctxt (assertion : dups) = sep [hsep [ptext SLIT("Duplicated class assertion"), - pprQuote sty $ \ sty -> ppr sty clas <+> ppr sty ty, - ptext SLIT("in context:")], - nest 4 (pprQuote sty $ \ sty -> pprContext sty ctxt)] + quotes (pprClassAssertion assertion), + ptext SLIT("in the context:")], + nest 4 (pprContext ctxt)] -badDataCon name sty - = hsep [ptext SLIT("Illegal data constructor name"), ppr sty name] +badDataCon name + = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] -allOfNonTyVar ty sty - = hsep [ptext SLIT("`All' applied to a non-type variable"), ppr sty ty] +wierdAllErr assertion + = ptext SLIT("Mal-formed use of `All':") <+> pprClassAssertion assertion -ctxtErr1 doc tyvars sty +ctxtErr1 doc tyvars = hsep [ptext SLIT("Context constrains in-scope type variable(s)"), - hsep (punctuate comma (map (ppr sty) tyvars))] + pprQuotedList tyvars] $$ - nest 4 (ptext SLIT("in") <+> doc sty) + nest 4 (ptext SLIT("in") <+> doc) -ctxtErr2 doc tyvars ty sty +ctxtErr2 doc tyvars ty = (ptext SLIT("Context constrains type variable(s)") - <+> hsep (punctuate comma (map (ppr sty) tyvars))) + <+> pprQuotedList tyvars) $$ - nest 4 (vcat [ptext SLIT("that do not appear in") <+> ppr sty ty, - ptext SLIT("in") <+> doc sty]) + nest 4 (vcat [ptext SLIT("that do not appear in") <+> quotes (ppr ty), + ptext SLIT("in") <+> doc]) \end{code} diff --git a/ghc/compiler/simplCore/AnalFBWW.lhs b/ghc/compiler/simplCore/AnalFBWW.lhs index 33ee877eef..f635585cf3 100644 --- a/ghc/compiler/simplCore/AnalFBWW.lhs +++ b/ghc/compiler/simplCore/AnalFBWW.lhs @@ -4,13 +4,11 @@ \section[AnalFBWW]{Spoting good functions for splitting into workers/wrappers} \begin{code} -#include "HsVersions.h" - module AnalFBWW ( analFBWW ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import CoreSyn ( SYN_IE(CoreBinding) ) +import CoreSyn ( CoreBinding ) import Util ( panic{-ToDo:rm-} ) --import Util @@ -104,7 +102,7 @@ analExprFBWW (App (App (App (CoTyApp (CoTyApp (Var foldr_id) _) _) (VarArg c)) _) _) env | pprTrace ("FOLDR:" ++ show (foldr_id == foldrId,isCons c)) - (ppr PprDebug foldr_id) + (ppr foldr_id) (foldr_id == foldrId && isCons c) = goodProdFBType where isCons c = case lookupIdEnv env c of @@ -188,7 +186,7 @@ analBind (NonRec (v,bnd) e) env = analBind (Rec binds) env = let first_set = [ (v,IsFB (FBType [FBBadConsum | _ <- args ] FBGoodProd)) | ((v,_),e) <- binds, - (_,_,args,_) <- [collectBinders e]] + (_,args,_) <- [collectBinders e]] env' = delManyFromIdEnv env (map (fst.fst) binds) in growIdEnvList env' (fixpoint 0 binds env' first_set) @@ -252,7 +250,7 @@ annotateBindingFBWW env bnds = (env',bnds') fixId v = (case lookupIdEnv env' v of Just (IsFB ty@(FBType xs p)) - | not (null xs) -> pprTrace "ADDED to:" (ppr PprDebug v) + | not (null xs) -> pprTrace "ADDED to:" (ppr v) (addIdFBTypeInfo v (mkFBTypeInfo ty)) _ -> v) -} diff --git a/ghc/compiler/simplCore/BinderInfo.lhs b/ghc/compiler/simplCore/BinderInfo.lhs index 39e436d8c3..6737103e7a 100644 --- a/ghc/compiler/simplCore/BinderInfo.lhs +++ b/ghc/compiler/simplCore/BinderInfo.lhs @@ -8,8 +8,6 @@ %************************************************************************ \begin{code} -#include "HsVersions.h" - module BinderInfo ( BinderInfo(..), FunOrArg, DuplicationDanger, InsideSCC, -- NB: all abstract (yay!) @@ -27,13 +25,11 @@ module BinderInfo ( isFun, isDupDanger -- for Simon Marlow deforestation ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import Pretty import Util ( panic ) -#if __GLASGOW_HASKELL__ >= 202 -import Outputable -#endif +import GlaExts ( Int(..), (+#) ) +import Outputable \end{code} @@ -286,9 +282,9 @@ getBinderInfoArity (OneOcc _ _ _ _ i) = i \begin{code} instance Outputable BinderInfo where - ppr sty DeadCode = ptext SLIT("Dead") - ppr sty (ManyOcc ar) = hcat [ ptext SLIT("Many-"), int ar ] - ppr sty (OneOcc posn dup_danger in_scc n_alts ar) + ppr DeadCode = ptext SLIT("Dead") + ppr (ManyOcc ar) = hcat [ ptext SLIT("Many-"), int ar ] + ppr (OneOcc posn dup_danger in_scc n_alts ar) = hcat [ ptext SLIT("One-"), pp_posn posn, char '-', pp_danger dup_danger, char '-', pp_scc in_scc, char '-', int n_alts, char '-', int ar ] diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs index 5e7478d060..aa2a490794 100644 --- a/ghc/compiler/simplCore/ConFold.lhs +++ b/ghc/compiler/simplCore/ConFold.lhs @@ -8,11 +8,9 @@ ToDo: (i1 + i2) only if it results in a valid Float. \begin{code} -#include "HsVersions.h" - module ConFold ( completePrim ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CoreSyn import CoreUnfold ( Unfolding, SimpleUnfolding ) @@ -24,9 +22,7 @@ import SimplEnv import SimplMonad import TysWiredIn ( trueDataCon, falseDataCon ) -#ifdef REALLY_HASKELL_1_3 -import Char(ord,chr) -#endif +import Char ( ord, chr ) \end{code} \begin{code} diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 9356bb2e94..8db461af79 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -12,18 +12,16 @@ case, so that we don't allocate things, save them on the stack, and then discover that they aren't needed in the chosen branch. \begin{code} -#include "HsVersions.h" - module FloatIn ( floatInwards ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import AnnCoreSyn import CoreSyn import FreeVars import Id ( emptyIdSet, unionIdSets, unionManyIdSets, - elementOfIdSet, SYN_IE(IdSet), GenId, SYN_IE(Id) + elementOfIdSet, IdSet, GenId, Id ) import Util ( nOfThem, panic, zipEqual ) \end{code} @@ -141,9 +139,6 @@ fiExpr to_drop (_,AnnPrim c atoms) Here we are not floating inside lambda (type lambdas are OK): \begin{code} -fiExpr to_drop (_,AnnLam (UsageBinder binder) body) - = panic "FloatIn.fiExpr:AnnLam UsageBinder" - fiExpr to_drop (_,AnnLam b@(ValBinder binder) body) = mkCoLets' to_drop (Lam b (fiExpr [] body)) diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs index a4d051fb59..c687716ff7 100644 --- a/ghc/compiler/simplCore/FloatOut.lhs +++ b/ghc/compiler/simplCore/FloatOut.lhs @@ -6,30 +6,26 @@ ``Long-distance'' floating of bindings towards the top level. \begin{code} -#include "HsVersions.h" - module FloatOut ( floatOutwards ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(List(partition)) +#include "HsVersions.h" import CoreSyn import CmdLineOpts ( opt_D_verbose_core2core, opt_D_simplifier_stats ) import CostCentre ( dupifyCC, CostCentre ) -import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList, SYN_IE(IdEnv), - GenId{-instance Outputable-}, SYN_IE(Id) +import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList, IdEnv, + GenId{-instance Outputable-}, Id ) -import Outputable ( PprStyle(..), Outputable(..){-instance (,)-} ) import PprCore import PprType ( GenTyVar ) -import Pretty ( Doc, int, ptext, hcat, vcat ) import SetLevels -- all of it -import TyVar ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) ) +import BasicTypes ( Unused ) +import TyVar ( GenTyVar{-instance Eq-}, TyVar ) import Unique ( Unique{-instance Eq-} ) import UniqSupply ( UniqSupply ) -import Usage ( SYN_IE(UVar) ) -import Util ( pprTrace, panic ) +import List ( partition ) +import Outputable \end{code} Random comments @@ -65,8 +61,8 @@ which might usefully be separated to Well, maybe. We don't do this at the moment. \begin{code} -type LevelledExpr = GenCoreExpr (Id, Level) Id TyVar UVar -type LevelledBind = GenCoreBinding (Id, Level) Id TyVar UVar +type LevelledExpr = GenCoreExpr (Id, Level) Id Unused +type LevelledBind = GenCoreBinding (Id, Level) Id Unused type FloatingBind = (Level, Floater) type FloatingBinds = [FloatingBind] @@ -96,7 +92,7 @@ floatOutwards us pgm (if opt_D_verbose_core2core then pprTrace "Levels added:\n" - (vcat (map (ppr PprDebug) annotated_w_levels)) + (vcat (map (ppr) annotated_w_levels)) else id ) ( if not (opt_D_simplifier_stats) then @@ -214,9 +210,6 @@ floatExpr env lvl (App e a) = case (floatExpr env lvl e) of { (fs, floating_defns, e') -> (fs, floating_defns, App e' a) } -floatExpr env lvl (Lam (UsageBinder _) e) - = panic "FloatOut.floatExpr: Lam UsageBinder" - floatExpr env lvl (Lam (TyBinder tv) e) = let incd_lvl = incMinorLvl lvl diff --git a/ghc/compiler/simplCore/FoldrBuildWW.lhs b/ghc/compiler/simplCore/FoldrBuildWW.lhs index f7fc933906..73c440670c 100644 --- a/ghc/compiler/simplCore/FoldrBuildWW.lhs +++ b/ghc/compiler/simplCore/FoldrBuildWW.lhs @@ -4,13 +4,11 @@ \section[FoldrBuildWW]{Spliting suitable functions into Workers and Wrappers} \begin{code} -#include "HsVersions.h" - module FoldrBuildWW ( mkFoldrBuildWW ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import CoreSyn ( SYN_IE(CoreBinding) ) +import CoreSyn ( CoreBinding ) import UniqSupply ( UniqSupply ) import Util ( panic{-ToDo:rm?-} ) @@ -19,7 +17,7 @@ import Util ( panic{-ToDo:rm?-} ) --import TysPrim ( alphaTy ) --import TyVar ( alphaTyVar ) -- ---import Type ( SYN_IE(Type) ) -- **** CAN SEE THE CONSTRUCTORS **** +--import Type ( Type ) -- **** CAN SEE THE CONSTRUCTORS **** --import UniqSupply ( runBuiltinUs ) --import WwLib -- share the same monad (is this eticit ?) --import PrelInfo ( listTyCon, mkListTy, nilDataCon, consDataCon, @@ -117,7 +115,7 @@ try_split_bind id expr = | FBGoodProd == prod -> {- || any (== FBGoodConsum) consum -} let - (use_args,big_args,args,body) = collectBinders expr' + (big_args,args,body) = collectBinders expr' in if length args /= length consum -- funny number of arguments then returnWw [(id,expr')] @@ -127,7 +125,7 @@ try_split_bind id expr = -- f_wrk /\ t1 .. tn t_new \ v1 .. vn c n -> foldr <exprTy> <nTy> c n e -- f /\ t1 .. tn \ v1 .. vn -- -> build exprTy (\ c n -> f_wrk t1 .. tn t_new v1 .. vn c n) - pprTrace "WW:" (ppr PprDebug id) (returnWw ()) + pprTrace "WW:" (ppr id) (returnWw ()) `thenWw` \ () -> getUniqueWw `thenWw` \ ty_new_uq -> getUniqueWw `thenWw` \ worker_new_uq -> diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs index 7c183b143c..8d21ed02aa 100644 --- a/ghc/compiler/simplCore/LiberateCase.lhs +++ b/ghc/compiler/simplCore/LiberateCase.lhs @@ -6,11 +6,10 @@ 96/03: We aren't using this at the moment \begin{code} -#include "HsVersions.h" - module LiberateCase ( liberateCase ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" + import Util ( panic ) liberateCase = panic "LiberateCase.liberateCase: ToDo" @@ -20,7 +19,6 @@ import CoreUnfold ( UnfoldingGuidance(..), PragmaInfo(..) ) import Id ( localiseId ) import Maybes import Outputable -import Pretty import Util \end{code} diff --git a/ghc/compiler/simplCore/MagicUFs.lhs b/ghc/compiler/simplCore/MagicUFs.lhs index 73b803cb1e..9df17ead3c 100644 --- a/ghc/compiler/simplCore/MagicUFs.lhs +++ b/ghc/compiler/simplCore/MagicUFs.lhs @@ -4,8 +4,6 @@ \section[MagicUFs]{Magic unfoldings that the simplifier knows about} \begin{code} -#include "HsVersions.h" - module MagicUFs ( MagicUnfoldingFun, -- absolutely abstract @@ -13,15 +11,12 @@ module MagicUFs ( applyMagicUnfoldingFun ) where -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(IdLoop) -- paranoia checking -#endif +#include "HsVersions.h" import Id ( addInlinePragma ) import CoreSyn import SimplEnv ( SimplEnv ) -import SimplMonad ( SYN_IE(SmplM), SimplCount ) +import SimplMonad ( SmplM, SimplCount ) import Type ( mkFunTys ) import TysWiredIn ( mkListTy ) import Unique ( Unique{-instances-} ) diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 5796cd4e96..61ade109a8 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -11,45 +11,37 @@ The occurrence analyser re-typechecks a core expression, returning a new core expression with (hopefully) improved usage information. \begin{code} -#include "HsVersions.h" - module OccurAnal ( occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(List(partition)) +#include "HsVersions.h" import BinderInfo import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) ) import CoreSyn import Digraph ( stronglyConnComp, stronglyConnCompR, SCC(..) ) import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma, - idType, idUnique, SYN_IE(Id), + idType, idUnique, Id, emptyIdSet, unionIdSets, mkIdSet, unitIdSet, elementOfIdSet, - addOneToIdSet, SYN_IE(IdSet), + addOneToIdSet, IdSet, nullIdEnv, unitIdEnv, combineIdEnvs, delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv, - mapIdEnv, lookupIdEnv, SYN_IE(IdEnv), + mapIdEnv, lookupIdEnv, IdEnv, GenId{-instance Eq-} ) import Name ( isExported, isLocallyDefined ) -import Type ( getFunTy_maybe, splitForAllTy ) +import Type ( splitFunTy_maybe, splitForAllTys ) import Maybes ( maybeToBool ) -import Outputable ( PprStyle(..), Outputable(..){-instance * (,) -} ) import PprCore import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} ) -import Pretty ( Doc, vcat, ptext, nest, punctuate, comma, hcat, text ) import TyVar ( GenTyVar{-instance Eq-} ) import Unique ( Unique{-instance Eq-}, u2i ) -import UniqFM ( keysUFM ) -import Util ( assoc, zipEqual, zipWithEqual, Ord3(..) - , pprTrace, panic -#ifdef DEBUG - , assertPanic -#endif - ) +import UniqFM ( keysUFM ) +import Util ( assoc, zipEqual, zipWithEqual ) +import Outputable +import List ( partition ) isSpecPragmaId_maybe x = Nothing -- ToDo:!trace "OccurAnal.isSpecPragmaId_maybe" \end{code} @@ -232,11 +224,11 @@ occurAnalyseBinds binds simplifier_sw_chkr -- for interface files too. Sigh ppr_bind bind@(NonRec binder expr) - = ppr PprDebug bind + = ppr bind ppr_bind bind@(Rec binds) = vcat [ptext SLIT("Rec {"), - nest 2 (ppr PprDebug bind), + nest 2 (ppr bind), ptext SLIT("end Rec }")] \end{code} @@ -340,7 +332,7 @@ occAnalBind env (Rec pairs) body_usage where pp_scc (CyclicSCC cycle) = hcat [text "Cyclic ", hcat (punctuate comma (map pp_item cycle))] pp_scc (AcyclicSCC item) = hcat [text "Acyclic ", pp_item item] - pp_item (_, bndr, _) = ppr PprDebug bndr + pp_item (_, bndr, _) = ppr bndr binders = map fst pairs new_env = env `addNewCands` binders @@ -510,9 +502,9 @@ reOrderRec env (CyclicSCC binds) -- On the other hand we *could* simplify those case expressions if -- we didn't stupidly choose d as the loop breaker. - not_fun_ty ty = not (maybeToBool (getFunTy_maybe rho_ty)) + not_fun_ty ty = not (maybeToBool (splitFunTy_maybe rho_ty)) where - (_, rho_ty) = splitForAllTy ty + (_, rho_ty) = splitForAllTys ty -- A variable RHS var_rhs (Var v) = True @@ -629,8 +621,6 @@ occAnal env (Lam (TyBinder tyvar) body) -- where -- (body_usage, body') = occAnal env body -occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder" - occAnal env (Case scrut alts) = case occAnalAlts env alts of { (alts_usage, alts') -> case occAnal env scrut of { (scrut_usage, scrut') -> diff --git a/ghc/compiler/simplCore/SAT.lhs b/ghc/compiler/simplCore/SAT.lhs index 7ef97dbf21..d4fb6e6fb1 100644 --- a/ghc/compiler/simplCore/SAT.lhs +++ b/ghc/compiler/simplCore/SAT.lhs @@ -38,11 +38,10 @@ Experimental Evidence: Heap: +/- 7% Instrs: Always improves for 2 or more Static Args. \begin{code} -#include "HsVersions.h" - module SAT ( doStaticArgs ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" + import Util ( panic ) doStaticArgs = panic "SAT.doStaticArgs (ToDo)" diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs index 36295dfcd8..ac39df4a5a 100644 --- a/ghc/compiler/simplCore/SATMonad.lhs +++ b/ghc/compiler/simplCore/SATMonad.lhs @@ -10,11 +10,10 @@ 96/03: We aren't using the static-argument transformation right now. \begin{code} -#include "HsVersions.h" - module SATMonad where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" + import Util ( panic ) junk_from_SATMonad = panic "SATMonad.junk" @@ -31,9 +30,9 @@ module SATMonad ( ) where import Type ( mkTyVarTy, mkSigmaTy, TyVarTemplate, - splitSigmaTy, splitFunTy, - glueTyArgs, instantiateTy, SYN_IE(TauType), - Class, SYN_IE(ThetaType), SYN_IE(SigmaType), + splitSigmaTy, splitFunTys, + glueTyArgs, instantiateTy, TauType, + Class, ThetaType, SigmaType, InstTyEnv(..) ) import Id ( mkSysLocal, idType ) @@ -145,7 +144,7 @@ newSATName id ty us env getArgLists :: CoreExpr -> ([Arg Type],[Arg Id]) getArgLists expr = let - (uvs, tvs, lambda_bounds, body) = collectBinders expr + (tvs, lambda_bounds, body) = collectBinders expr in ([ Static (mkTyVarTy tv) | tv <- tvs ], [ Static v | v <- lambda_bounds ]) @@ -239,7 +238,7 @@ saTransform binder rhs where -- get type info for the local function: (tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder - (reg_arg_tys, res_type) = splitFunTy tau_ty + (reg_arg_tys, res_type) = splitFunTys tau_ty -- now, we drop the ones that are -- static, that is, the ones we will not pass to the local function @@ -249,8 +248,8 @@ saTransform binder rhs reg_arg_tys' = dropStatics (drop l args) reg_arg_tys tau_ty' = glueTyArgs reg_arg_tys' res_type - mk_inst_tyenv [] _ = [] - mk_inst_tyenv (Static s:args) (t:ts) = (t,s) : mk_inst_tyenv args ts + mk_inst_tyenv [] _ = emptyTyVarEnv + mk_inst_tyenv (Static s:args) (t:ts) = addToTyVarEnv (mk_inst_tyenv args ts) t s mk_inst_tyenv (_:args) (_:ts) = mk_inst_tyenv args ts dropStatics [] t = t diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 23edaed052..1c068f07dd 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -10,18 +10,15 @@ We also let-ify many applications (notably case scrutinees), so they will have a fighting chance of being floated sensible. \begin{code} -#include "HsVersions.h" - module SetLevels ( setLevels, Level(..), tOP_LEVEL, incMinorLvl, ltMajLvl, ltLvl, isTopLvl --- not exported: , incMajorLvl, isTopMajLvl, unTopify ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import AnnCoreSyn import CoreSyn @@ -32,27 +29,24 @@ import FreeVars -- all of it import Id ( idType, mkSysLocal, nullIdEnv, addOneToIdEnv, growIdEnvList, unionManyIdSets, minusIdSet, mkIdSet, - idSetToList, SYN_IE(Id), - lookupIdEnv, SYN_IE(IdEnv) + idSetToList, Id, + lookupIdEnv, IdEnv ) -import Pretty ( ptext, hcat, char, int ) import SrcLoc ( noSrcLoc ) -import Type ( isPrimType, mkTyVarTys, mkForAllTys, tyVarsOfTypes, SYN_IE(Type) ) -import TyVar ( nullTyVarEnv, addOneToTyVarEnv, +import Type ( isUnpointedType, mkTyVarTys, mkForAllTys, tyVarsOfTypes, Type ) +import TyVar ( emptyTyVarEnv, addToTyVarEnv, growTyVarEnvList, lookupTyVarEnv, tyVarSetToList, - SYN_IE(TyVarEnv), SYN_IE(TyVar), + TyVarEnv, TyVar, unionManyTyVarSets, unionTyVarSets ) import UniqSupply ( thenUs, returnUs, mapUs, mapAndUnzipUs, - mapAndUnzip3Us, getUnique, SYN_IE(UniqSM), + mapAndUnzip3Us, getUnique, UniqSM, UniqSupply ) -import Usage ( SYN_IE(UVar) ) +import BasicTypes ( Unused ) import Util ( mapAccumL, zipWithEqual, zipEqual, panic, assertPanic ) -#if __GLASGOW_HASKELL__ >= 202 -import Outputable ( Outputable(..) ) -#endif +import Outputable isLeakFreeType x y = False -- safe option; ToDo \end{code} @@ -96,9 +90,9 @@ sub-expression so that it will indeed float. This context level starts at @Level 0 0@; it is never @Top@. \begin{code} -type LevelledExpr = GenCoreExpr (Id, Level) Id TyVar UVar -type LevelledArg = GenCoreArg Id TyVar UVar -type LevelledBind = GenCoreBinding (Id, Level) Id TyVar UVar +type LevelledExpr = GenCoreExpr (Id, Level) Id Unused +type LevelledArg = GenCoreArg Id Unused +type LevelledBind = GenCoreBinding (Id, Level) Id Unused type LevelEnvs = (IdEnv Level, -- bind Ids to levels TyVarEnv Level) -- bind type variables to levels @@ -146,8 +140,8 @@ unTopify Top = Level 0 0 unTopify lvl = lvl instance Outputable Level where - ppr sty Top = ptext SLIT("<Top>") - ppr sty (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ] + ppr Top = ptext SLIT("<Top>") + ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ] \end{code} %************************************************************************ @@ -175,7 +169,7 @@ setLevels binds us do_them bs `thenLvl` \ lvld_binds -> returnLvl (lvld_bind ++ lvld_binds) -initial_envs = (nullIdEnv, nullTyVarEnv) +initial_envs = (nullIdEnv, emptyTyVarEnv) lvlTopBind (NonRec binder rhs) = lvlBind (Level 0 0) initial_envs (AnnNonRec binder (freeVars rhs)) @@ -194,7 +188,7 @@ lvlTopBind (Rec pairs) The binding stuff works for top level too. \begin{code} -type CoreBindingWithFVs = AnnCoreBinding Id Id TyVar UVar FVInfo +type CoreBindingWithFVs = AnnCoreBinding Id Id Unused FVInfo lvlBind :: Level -> LevelEnvs @@ -296,10 +290,7 @@ lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) body) returnLvl (Lam (TyBinder tyvar) body') where incd_lvl = incMinorLvl ctxt_lvl - new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl - -lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (UsageBinder u) e) - = panic "SetLevels.lvlExpr:AnnLam UsageBinder" + new_tenv = addToTyVarEnv tenv tyvar incd_lvl lvlExpr ctxt_lvl envs (_, AnnLet bind body) = lvlBind ctxt_lvl envs bind `thenLvl` \ (binds', new_envs) -> @@ -356,7 +347,7 @@ lvlMFE :: Level -- Level of innermost enclosing lambda/tylam -> LvlM LevelledExpr -- Result expression lvlMFE ctxt_lvl envs@(venv,_) ann_expr - | isPrimType ty -- Can't let-bind it + | isUnpointedType ty -- Can't let-bind it = lvlExpr ctxt_lvl envs ann_expr | otherwise -- Not primitive type so could be let-bound diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs index 918b4a7d5c..ea06d8d3ac 100644 --- a/ghc/compiler/simplCore/SimplCase.lhs +++ b/ghc/compiler/simplCore/SimplCase.lhs @@ -6,17 +6,11 @@ Support code for @Simplify@. \begin{code} -#include "HsVersions.h" - module SimplCase ( simplCase, bindLargeRhs ) where -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(SmplLoop) ( simplBind, simplExpr, MagicUnfoldingFun ) -#else +#include "HsVersions.h" + import {-# SOURCE #-} Simplify ( simplBind, simplExpr ) ---import {-# SOURCE #-} MagicUFs ( MagicUnfoldingFun ) -#endif import BinderInfo -- too boring to try to select things... import CmdLineOpts ( SimplifierSwitch(..) ) @@ -26,8 +20,8 @@ import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp, unTagBindersAlts, unTagBinders, coreExprType ) import Id ( idType, isDataCon, getIdDemandInfo, dataConArgTys, - SYN_IE(DataCon), GenId{-instance Eq-}, - SYN_IE(Id) + DataCon, GenId{-instance Eq-}, + Id ) import IdInfo ( willBeDemanded, DemandInfo ) import Literal ( isNoRepLit, Literal{-instance Eq-} ) @@ -36,12 +30,11 @@ import PrelVals ( voidId ) import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} ) import SimplEnv import SimplMonad -import Type ( isPrimType, maybeAppDataTyConExpandingDicts, getAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy ) +import Type ( isUnpointedType, splitAlgTyConApp_maybe, splitAlgTyConApp, mkFunTy, mkFunTys ) import TyCon ( isDataTyCon ) import TysPrim ( voidTy ) import Unique ( Unique{-instance Eq-} ) -import Usage ( GenUsage{-instance Eq-} ) -import Util ( SYN_IE(Eager), runEager, appEager, +import Util ( Eager, runEager, appEager, isIn, isSingleton, zipEqual, panic, assertPanic ) \end{code} @@ -441,7 +434,7 @@ bindLargeRhs :: SimplEnv InExpr) -- Modified rhs bindLargeRhs env args rhs_ty rhs_c - | null used_args && isPrimType rhs_ty + | null used_args && isUnpointedType rhs_ty -- If we try to lift a primitive-typed something out -- for let-binding-purposes, we will *caseify* it (!), -- with potentially-disastrous strictness results. So @@ -521,12 +514,12 @@ simplAlts env scrut (AlgAlts [] (BindDefault bndr@(id,occ_info) rhs)) rhs_c newIds inst_con_arg_tys `thenSmpl` \ new_bindees -> let new_args = [ (b, bad_occ_info) | b <- new_bindees ] - con_app = mkCon con [] ty_args (map VarArg new_bindees) + con_app = mkCon con ty_args (map VarArg new_bindees) new_rhs = Let (NonRec bndr con_app) rhs in simplAlts env scrut (AlgAlts [(con,new_args,new_rhs)] NoDefault) rhs_c where - maybe_data_ty = maybeAppDataTyConExpandingDicts (idType id) + maybe_data_ty = splitAlgTyConApp_maybe (idType id) Just (tycon, ty_args, cons) = maybe_data_ty (con:other_cons) = cons inst_con_arg_tys = dataConArgTys con ty_args @@ -545,7 +538,7 @@ simplAlts env scrut (AlgAlts alts deflt) rhs_c new_env = case scrut of Var v -> extendEnvGivenNewRhs env1 v (Con con args) where - (_, ty_args, _) = getAppDataTyConExpandingDicts (idType v) + (_, ty_args, _) = splitAlgTyConApp (idType v) args = map TyArg ty_args ++ map VarArg con_args' other -> env1 @@ -809,7 +802,7 @@ mkCoCase env scrut (AlgAlts outer_alts v | scrut_is_var = Var scrut_var | otherwise = Con con (map TyArg arg_tys ++ map VarArg args) - arg_tys = case (getAppDataTyConExpandingDicts (idType deflt_var)) of + arg_tys = case (splitAlgTyConApp (idType deflt_var)) of (_, arg_tys, _) -> arg_tys mkCoCase env scrut (PrimAlts @@ -957,7 +950,6 @@ eq_args _ _ = False eq_arg (LitArg l1) (LitArg l2) = l1 == l2 eq_arg (VarArg v1) (VarArg v2) = v1 == v2 -eq_arg (TyArg t1) (TyArg t2) = t1 `eqTy` t2 -eq_arg (UsageArg u1) (UsageArg u2) = u1 == u2 +eq_arg (TyArg t1) (TyArg t2) = t1 == t2 eq_arg _ _ = False \end{code} diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index d4617c9679..09f3e679fd 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -4,12 +4,9 @@ \section[SimplCore]{Driver for simplifying @Core@ programs} \begin{code} -#include "HsVersions.h" - module SimplCore ( core2core ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(IO(hPutStr,stderr)) +#include "HsVersions.h" import AnalFBWW ( analFBWW ) import Bag ( isEmptyBag, foldBag ) @@ -32,7 +29,7 @@ import SimplUtils ( etaCoreExpr, typeOkForCase ) import CoreUnfold import Literal ( Literal(..), literalType, mkMachInt ) import ErrUtils ( ghcExit, dumpIfSet, doIfSet ) -import FiniteMap ( FiniteMap ) +import FiniteMap ( FiniteMap, emptyFM ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FoldrBuildWW ( mkFoldrBuildWW ) @@ -40,14 +37,14 @@ import Id ( mkSysLocal, setIdVisibility, replaceIdInfo, replacePragmaInfo, getIdDemandInfo, idType, getIdInfo, getPragmaInfo, mkIdWithNewUniq, nullIdEnv, addOneToIdEnv, delOneFromIdEnv, - lookupIdEnv, SYN_IE(IdEnv), omitIfaceSigForId, + lookupIdEnv, IdEnv, omitIfaceSigForId, apply_to_Id, - GenId{-instance Outputable-}, SYN_IE(Id) + GenId{-instance Outputable-}, Id ) import IdInfo ( willBeDemanded, DemandInfo ) import Name ( isExported, isLocallyDefined, isLocalName, uniqToOccName, - SYN_IE(Module), NamedThing(..), OccName(..) + Module, NamedThing(..), OccName(..) ) import TyCon ( TyCon ) import PrimOp ( PrimOp(..) ) @@ -55,27 +52,21 @@ import PrelVals ( unpackCStringId, unpackCString2Id, integerZeroId, integerPlusOneId, integerPlusTwoId, integerMinusOneId ) -import Type ( maybeAppDataTyCon, isPrimType, SYN_IE(Type) ) +import Type ( splitAlgTyConApp_maybe, isUnpointedType, Type ) import TysWiredIn ( stringTy, isIntegerTy ) import LiberateCase ( liberateCase ) import MagicUFs ( MagicUnfoldingFun ) -import Outputable ( pprDumpStyle, printErrs, - PprStyle(..), Outputable(..){-instance * (,) -} - ) import PprCore import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-}, nmbrType ) -import Pretty ( Doc, vcat, ($$), hsep ) import SAT ( doStaticArgs ) import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount ) import SimplPgm ( simplifyPgm ) import Specialise import SpecUtils ( pprSpecErrs ) import StrictAnal ( saWwTopBinds ) -import TyVar ( SYN_IE(TyVar), nullTyVarEnv, GenTyVar{-instance Eq-}, - nameTyVar - ) +import TyVar ( TyVar, nameTyVar ) import Unique ( Unique{-instance Eq-}, Uniquable(..), integerTyConKey, ratioTyConKey, mkUnique, incrUnique, @@ -85,13 +76,13 @@ import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, getUnique ) import UniqFM ( UniqFM, lookupUFM, addToUFM ) -import Usage ( SYN_IE(UVar), cloneUVar ) -import Util ( mapAccumL, assertPanic, panic{-ToDo:rm-}, pprTrace, pprPanic ) +import Util ( mapAccumL ) import SrcLoc ( noSrcLoc ) import Constants ( tARGET_MIN_INT, tARGET_MAX_INT ) import Bag import Maybes - +import IO ( hPutStr, stderr ) +import Outputable \end{code} \begin{code} @@ -99,13 +90,12 @@ core2core :: [CoreToDo] -- spec of what core-to-core passes to do -> FAST_STRING -- module name (profiling only) -> UniqSupply -- a name supply -> [TyCon] -- local data tycons and tycon specialisations - -> FiniteMap TyCon [(Bool, [Maybe Type])] -> [CoreBinding] -- input... -> IO ([CoreBinding], -- results: program, plus... SpecialiseData) -- specialisation data -core2core core_todos module_name us local_tycons tycon_specs binds +core2core core_todos module_name us local_tycons binds = -- Do the main business foldl_mn do_core_pass (binds, us, init_specdata, zeroSimplCount) @@ -122,7 +112,7 @@ core2core core_todos module_name us local_tycons tycon_specs binds -- Dump output dumpIfSet (opt_D_dump_simpl || opt_D_verbose_core2core) "Core transformations" - (pprCoreBindings pprDumpStyle final_binds) >> + (pprCoreBindings final_binds) >> -- Report statistics doIfSet opt_D_simplifier_stats @@ -133,7 +123,7 @@ core2core core_todos module_name us local_tycons tycon_specs binds -- Return results return (final_binds, spec_data) where - init_specdata = initSpecData local_tycons tycon_specs + init_specdata = initSpecData local_tycons emptyFM {- tycon_specs -} -------------- do_core_pass info@(binds, us, spec_data, simpl_stats) to_do = @@ -218,7 +208,7 @@ core2core core_todos module_name us local_tycons tycon_specs binds CoreDoPrintCore -- print result of last pass -> dumpIfSet (not opt_D_verbose_core2core) "Print Core" - (pprCoreBindings pprDumpStyle binds) >> + (pprCoreBindings binds) >> return (binds, us1, spec_data, simpl_stats) ------------------------------------------------- @@ -233,9 +223,13 @@ core2core core_todos module_name us local_tycons tycon_specs binds simpl_stats2 what = -- Report verbosely, if required dumpIfSet opt_D_verbose_core2core what - (pprCoreBindings pprDumpStyle binds2) >> + (pprCoreBindings binds2) >> - lintCoreBindings what spec_done binds2 >> + lintCoreBindings what True {- spec_done -} binds2 >> + -- The spec_done flag tells the linter to + -- complain about unboxed let-bindings + -- But we're not specialising unboxed types any more, + -- so its irrelevant. return (binds2, -- processed binds, possibly run thru CoreLint @@ -481,18 +475,13 @@ tidyCoreExpr (Lam (TyBinder tv) body) tidyCoreExpr body `thenTM` \ body' -> returnTM (Lam (TyBinder tv') body') -tidyCoreExpr (Lam (UsageBinder uv) body) - = newUVar uv $ \ uv' -> - tidyCoreExpr body `thenTM` \ body' -> - returnTM (Lam (UsageBinder uv') body') - -- Try for let-to-case (see notes in Simplify.lhs for why -- some let-to-case stuff is deferred to now). tidyCoreExpr (Let (NonRec bndr rhs) body) | willBeDemanded (getIdDemandInfo bndr) && not rhs_is_whnf && -- Don't do it if RHS is already in WHNF typeOkForCase (idType bndr) - = ASSERT( not (isPrimType (idType bndr)) ) + = ASSERT( not (isUnpointedType (idType bndr)) ) tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body))) where rhs_is_whnf = case mkFormSummary rhs of @@ -534,7 +523,7 @@ tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs))) -- Eliminate polymorphic case, for which we can't generate code just yet tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs))) | not (typeOkForCase (idType deflt_bndr)) - = pprTrace "Warning: discarding polymorphic case:" (ppr PprDebug scrut) $ + = pprTrace "Warning: discarding polymorphic case:" (ppr scrut) $ case scrut of Var v -> lookupId v `thenTM` \ v' -> extendEnvTM deflt_bndr v' (tidyCoreExpr rhs) @@ -603,7 +592,6 @@ tidyCoreArg (LitArg lit) tidyCoreArg (TyArg ty) = tidyTy ty `thenTM` \ ty' -> returnTM (TyArg ty') -tidyCoreArg (UsageArg u) = returnTM (UsageArg u) \end{code} \begin{code} @@ -673,7 +661,7 @@ litToRep (NoRepRational r rational_ty) returnTM (rational_ty, Con ratio_data_con [TyArg integer_ty, num_arg, denom_arg]) where (ratio_data_con, integer_ty) - = case (maybeAppDataTyCon rational_ty) of + = case (splitAlgTyConApp_maybe rational_ty) of Just (tycon, [i_ty], [con]) -> ASSERT(isIntegerTy i_ty && uniqueOf tycon == ratioTyConKey) (con, i_ty) @@ -806,14 +794,6 @@ newTyVar tyvar thing_inside mod env (gus, local_uniq, floats) env' = addToUFM env tyvar (TyBinder tyvar') in thing_inside tyvar' mod env' (gus, local_uniq', floats) - -newUVar uvar thing_inside mod env (gus, local_uniq, floats) - = let - local_uniq' = incrUnique local_uniq - uvar' = cloneUVar uvar local_uniq - env' = addToUFM env uvar (UsageBinder uvar') - in - thing_inside uvar' mod env' (gus, local_uniq', floats) \end{code} Re-numbering types @@ -826,17 +806,12 @@ tidyTy ty mod env usf@(_, local_uniq, _) -- This little impedance-matcher calls nmbrType with the right arguments nmbr_ty env uniq ty - = nmbrType tv_env u_env uniq ty + = nmbrType tv_env uniq ty where tv_env :: TyVar -> TyVar tv_env tyvar = case lookupUFM env tyvar of Just (TyBinder tyvar') -> tyvar' other -> tyvar - - u_env :: UVar -> UVar - u_env uvar = case lookupUFM env uvar of - Just (UsageBinder uvar') -> uvar' - other -> uvar \end{code} diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index b18468267a..fb5d225dcd 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -4,13 +4,11 @@ \section[SimplEnv]{Environment stuff for the simplifier} \begin{code} -#include "HsVersions.h" - module SimplEnv ( nullSimplEnv, combineSimplEnv, pprSimplEnv, -- debugging only - extendTyEnv, extendTyEnvList, + extendTyEnv, extendTyEnvList, extendTyEnvEnv, simplTy, simplTyInId, extendIdEnvWithAtom, extendIdEnvWithAtoms, @@ -31,24 +29,20 @@ module SimplEnv ( setEnclosingCC, getEnclosingCC, -- Types - SYN_IE(SwitchChecker), + SwitchChecker, SimplEnv, - SYN_IE(InIdEnv), SYN_IE(InTypeEnv), + InIdEnv, InTypeEnv, UnfoldConApp, RhsInfo(..), - SYN_IE(InId), SYN_IE(InBinder), SYN_IE(InBinding), SYN_IE(InType), - SYN_IE(OutId), SYN_IE(OutBinder), SYN_IE(OutBinding), SYN_IE(OutType), + InId, InBinder, InBinding, InType, + OutId, OutBinder, OutBinding, OutType, - SYN_IE(InExpr), SYN_IE(InAlts), SYN_IE(InDefault), SYN_IE(InArg), - SYN_IE(OutExpr), SYN_IE(OutAlts), SYN_IE(OutDefault), SYN_IE(OutArg) + InExpr, InAlts, InDefault, InArg, + OutExpr, OutAlts, OutDefault, OutArg ) where -IMP_Ubiq(){-uitous-} - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop -#endif +#include "HsVersions.h" import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc, okToInline, @@ -70,26 +64,23 @@ import Id ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd, applyTypeEnvToId, getInlinePragma, nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv, addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly, - SYN_IE(IdEnv), SYN_IE(IdSet), GenId, SYN_IE(Id) ) + IdEnv, IdSet, GenId, Id ) import Literal ( isNoRepLit, Literal{-instances-} ) import Maybes ( maybeToBool, expectJust ) import Name ( isLocallyDefined ) import OccurAnal ( occurAnalyseExpr ) -import Outputable ( PprStyle(..), Outputable(..){-instances-} ) import PprCore -- various instances import PprType ( GenType, GenTyVar ) -import Pretty -import Type ( eqTy, applyTypeEnvToTy, SYN_IE(Type) ) -import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList, - SYN_IE(TyVarEnv), GenTyVar{-instance Eq-} , - SYN_IE(TyVar) +import Type ( instantiateTy, Type ) +import TyVar ( emptyTyVarEnv, plusTyVarEnv, addToTyVarEnv, growTyVarEnvList, + TyVarEnv, GenTyVar{-instance Eq-} , + TyVar ) import Unique ( Unique{-instance Outputable-}, Uniquable(..) ) import UniqFM ( addToUFM, addToUFM_C, ufmToList ) -import Usage ( SYN_IE(UVar), GenUsage{-instances-} ) -import Util ( SYN_IE(Eager), appEager, returnEager, runEager, - zipEqual, thenCmp, cmpList, panic, panic#, assertPanic, Ord3(..) ) - +import Util ( Eager, appEager, returnEager, runEager, + zipEqual, thenCmp, cmpList ) +import Outputable \end{code} %************************************************************************ @@ -155,7 +146,7 @@ data SimplEnv nullSimplEnv :: SwitchChecker -> SimplEnv nullSimplEnv sw_chkr - = SimplEnv sw_chkr subsumedCosts nullTyVarEnv nullIdEnv nullIdEnv nullConApps + = SimplEnv sw_chkr subsumedCosts emptyTyVarEnv nullIdEnv nullIdEnv nullConApps combineSimplEnv :: SimplEnv -> SimplEnv -> SimplEnv combineSimplEnv env@(SimplEnv chkr _ _ _ out_id_env con_apps) @@ -261,7 +252,7 @@ extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv extendTyEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) tyvar ty = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps where - new_ty_env = addOneToTyVarEnv ty_env tyvar ty + new_ty_env = addToTyVarEnv ty_env tyvar ty extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv extendTyEnvList (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) pairs @@ -269,7 +260,13 @@ extendTyEnvList (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) pai where new_ty_env = growTyVarEnvList ty_env pairs -simplTy (SimplEnv _ _ ty_env _ _ _) ty = returnEager (applyTypeEnvToTy ty_env ty) +extendTyEnvEnv :: SimplEnv -> TypeEnv -> SimplEnv +extendTyEnvEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) new_ty_env + = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps + where + new_ty_env = ty_env `plusTyVarEnv` new_ty_env + +simplTy (SimplEnv _ _ ty_env _ _ _) ty = returnEager (instantiateTy ty_env ty) simplTyInId (SimplEnv _ _ ty_env _ _ _) id = returnEager (applyTypeEnvToId ty_env id) \end{code} @@ -486,7 +483,7 @@ lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args Nothing -> Nothing Just assocs -> case [id | (tys, id) <- assocs, - and (zipWith eqTy tys ty_args)] + and (zipWith (==) tys ty_args)] of [] -> Nothing (id:_) -> Just id @@ -520,36 +517,31 @@ it, so we can use it for a @FiniteMap@ key. \begin{code} instance Eq UnfoldConApp where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } instance Ord UnfoldConApp where - a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } - -instance Ord3 UnfoldConApp where - cmp = cmp_app + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmp_app a b cmp_app (UCA c1 as1) (UCA c2 as2) - = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2 + = compare c1 c2 `thenCmp` cmpList cmp_arg as1 as2 where - -- ToDo: make an "instance Ord3 CoreArg"??? + -- ToDo: make an "instance Ord CoreArg"??? - cmp_arg (VarArg x) (VarArg y) = x `cmp` y - cmp_arg (LitArg x) (LitArg y) = x `cmp` y - cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs" - cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs" + cmp_arg (VarArg x) (VarArg y) = x `compare` y + cmp_arg (LitArg x) (LitArg y) = x `compare` y + cmp_arg (TyArg x) (TyArg y) = panic "SimplEnv.cmp_app:TyArgs" cmp_arg x y - | tag x _LT_ tag y = LT_ - | otherwise = GT_ + | tag x _LT_ tag y = LT + | otherwise = GT where tag (VarArg _) = ILIT(1) tag (LitArg _) = ILIT(2) tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg" - tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg" \end{code} diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index d0b4358373..f0645c9b0b 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -4,10 +4,8 @@ \section[SimplMonad]{The simplifier Monad} \begin{code} -#include "HsVersions.h" - module SimplMonad ( - SYN_IE(SmplM), + SmplM, initSmpl, returnSmpl, thenSmpl, thenSmpl_, mapSmpl, mapAndUnzipSmpl, @@ -20,28 +18,23 @@ module SimplMonad ( cloneId, cloneIds, cloneTyVarSmpl, newIds, newId ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(Ix) +#include "HsVersions.h" -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(SmplLoop) -- well, cheating sort of -#else -import {-# SOURCE #-} Simplify -import {-# SOURCE #-} MagicUFs -#endif +-- import {-# SOURCE #-} Simplify +-- import {-# SOURCE #-} MagicUFs -import Id ( GenId, mkSysLocal, mkIdWithNewUniq, SYN_IE(Id) ) +import Id ( GenId, mkSysLocal, mkIdWithNewUniq, Id ) import CoreUnfold ( SimpleUnfolding ) import SimplEnv import SrcLoc ( noSrcLoc ) -import TyVar ( cloneTyVar, SYN_IE(TyVar) ) -import Type ( SYN_IE(Type) ) +import TyVar ( cloneTyVar, TyVar ) +import Type ( Type ) import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply ) -import Util ( zipWithEqual, panic, SYN_IE(Eager), appEager, pprTrace ) -import Pretty -import Outputable ( PprStyle(..), Outputable(..) ) +import Util ( zipWithEqual, Eager, appEager ) +import Outputable +import Ix infixr 9 `thenSmpl`, `thenSmpl_` \end{code} @@ -204,7 +197,7 @@ instance Text TickType where showSimplCount :: SimplCount -> String showSimplCount (SimplCount _ stuff (_, unf1, unf2)) - = shw stuff ++ "\nMost recent unfoldings: " ++ show (ppr PprDebug (reverse unf2 ++ reverse unf1)) + = shw stuff ++ "\nMost recent unfoldings: " ++ showSDoc (ppr (reverse unf2 ++ reverse unf1)) where shw [] = "" shw ((t,n):tns) | n /= 0 = show t ++ ('\t' : show n) ++ ('\n' : shw tns) @@ -273,7 +266,7 @@ maxUnfoldHistory = 20 tickUnfold :: Id -> SmplM () tickUnfold id us (SimplCount n stuff (n_unf, unf1, unf2)) - = -- pprTrace "Unfolding: " (ppr PprDebug id) $ + = -- pprTrace "Unfolding: " (ppr id) $ new_stuff `seqL` new_unf `seqTriple` ((), SimplCount (n _ADD_ ILIT(1)) new_stuff new_unf) diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs index cbd9de7d50..197ed80407 100644 --- a/ghc/compiler/simplCore/SimplPgm.lhs +++ b/ghc/compiler/simplCore/SimplPgm.lhs @@ -4,35 +4,33 @@ \section[SimplPgm]{Interface to the simplifier} \begin{code} -#include "HsVersions.h" - module SimplPgm ( simplifyPgm ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_simpl_iterations, - switchIsOn, SimplifierSwitch(..), SYN_IE(SwitchResult) + switchIsOn, SimplifierSwitch(..), SwitchResult ) import CoreSyn import CoreUnfold ( SimpleUnfolding ) import CoreUtils ( substCoreExpr ) -import Id ( mkIdEnv, lookupIdEnv, SYN_IE(IdEnv), - GenId{-instance Ord3-} +import Id ( mkIdEnv, lookupIdEnv, IdEnv ) import Maybes ( catMaybes ) import OccurAnal ( occurAnalyseBinds ) -import Pretty ( Doc, vcat, hcat, int, char, text, ptext, empty ) -import Outputable ( PprStyle(..) ) -- added SOF import PprCore ( pprCoreBinding ) -- added SOF import SimplEnv import SimplMonad import Simplify ( simplTopBinds ) -import TyVar ( nullTyVarEnv, SYN_IE(TyVarEnv) ) +import TyVar ( TyVarEnv ) import UniqSupply ( thenUs, returnUs, mapUs, - splitUniqSupply, SYN_IE(UniqSM), + splitUniqSupply, UniqSM, UniqSupply ) -import Util ( isIn, isn'tIn, removeDups, pprTrace ) +import Util ( isIn, isn'tIn, removeDups ) +import Outputable + +import GlaExts ( trace ) \end{code} \begin{code} @@ -78,7 +76,7 @@ simplifyPgm binds s_sw_chkr simpl_stats us int max_simpl_iterations], text (showSimplCount dr), if opt_D_dump_simpl_iterations then - vcat (map (pprCoreBinding PprDebug) new_pgm) + vcat (map (pprCoreBinding) new_pgm) else empty ]) diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 7997378d89..718dfeeb87 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -4,8 +4,6 @@ \section[SimplUtils]{The simplifier utilities} \begin{code} -#include "HsVersions.h" - module SimplUtils ( floatExposesHNF, @@ -19,17 +17,14 @@ module SimplUtils ( singleConstructorType, typeOkForCase ) where -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(SmplLoop) -- paranoia checking -#endif +#include "HsVersions.h" import BinderInfo import CmdLineOpts ( opt_DoEtaReduction, SimplifierSwitch(..) ) import CoreSyn import CoreUnfold ( SimpleUnfolding, mkFormSummary, exprIsTrivial, FormSummary(..) ) import Id ( idType, isBottomingId, addInlinePragma, addIdDemandInfo, - idWantsToBeINLINEd, dataConArgTys, SYN_IE(Id), + idWantsToBeINLINEd, dataConArgTys, Id, getIdArity, GenId{-instance Eq-} ) import IdInfo ( ArityInfo(..), DemandInfo ) @@ -38,8 +33,8 @@ import PrelVals ( augmentId, buildId ) import PrimOp ( primOpIsCheap ) import SimplEnv import SimplMonad -import Type ( tyVarsOfType, mkForAllTys, mkTyVarTys, isPrimType, getTyVar_maybe, - maybeAppDataTyConExpandingDicts, SYN_IE(Type) +import Type ( tyVarsOfType, mkForAllTys, mkTyVarTys, getTyVar_maybe, + splitAlgTyConApp_maybe, Type ) import TyCon ( isDataTyCon ) import TyVar ( elementOfTyVarSet, @@ -60,7 +55,7 @@ floatExposesHNF :: Bool -- Float let(rec)s out of rhs -> Bool -- Float cheap primops out of rhs -> Bool -- OK to duplicate code - -> GenCoreExpr bdr Id tyvar uvar + -> GenCoreExpr bdr Id flexi -> Bool floatExposesHNF float_lets float_primops ok_to_dup rhs @@ -320,7 +315,7 @@ arguments as you care to give it. For this special case we return 100, to represent "infinity", which is a bit of a hack. \begin{code} -etaExpandCount :: GenCoreExpr bdr Id tyvar uvar +etaExpandCount :: GenCoreExpr bdr Id flexi -> Int -- Number of extra args you can safely abstract etaExpandCount (Lam (ValBinder _) body) @@ -349,7 +344,7 @@ etaExpandCount other = 0 -- Give up -- Case with non-whnf scrutinee ----------------------------- -eta_fun :: GenCoreExpr bdr Id tv uv -- The function +eta_fun :: GenCoreExpr bdr Id flexi -- The function -> Int -- How many args it can safely be applied to eta_fun (App fun arg) | notValArg arg = eta_fun fun @@ -384,7 +379,7 @@ which aren't WHNF but are ``cheap'' are: where op is a cheap primitive operator \begin{code} -manifestlyCheap :: GenCoreExpr bndr Id tv uv -> Bool +manifestlyCheap :: GenCoreExpr bndr Id flexi -> Bool manifestlyCheap (Var _) = True manifestlyCheap (Lit _) = True @@ -401,7 +396,7 @@ manifestlyCheap (Case scrut alts) = manifestlyCheap scrut && all manifestlyCheap (rhssOfAlts alts) manifestlyCheap other_expr -- look for manifest partial application - = case (collectArgs other_expr) of { (fun, _, _, vargs) -> + = case (collectArgs other_expr) of { (fun, _, vargs) -> case fun of Var f | isBottomingId f -> True -- Application of a function which @@ -458,13 +453,13 @@ idMinArity id = case getIdArity id of singleConstructorType :: Type -> Bool singleConstructorType ty - = case (maybeAppDataTyConExpandingDicts ty) of + = case (splitAlgTyConApp_maybe ty) of Just (tycon, ty_args, [con]) | isDataTyCon tycon -> True other -> False typeOkForCase :: Type -> Bool typeOkForCase ty - = case (maybeAppDataTyConExpandingDicts ty) of + = case (splitAlgTyConApp_maybe ty) of Just (tycon, ty_args, []) -> False Just (tycon, ty_args, non_null_data_cons) | isDataTyCon tycon -> True other -> False diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index 98a89578a9..88d91d06d4 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -4,18 +4,13 @@ \section[SimplVar]{Simplifier stuff related to variables} \begin{code} -#include "HsVersions.h" - module SimplVar ( completeVar ) where -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(SmplLoop) ( simplExpr ) -#else +#include "HsVersions.h" + import {-# SOURCE #-} Simplify ( simplExpr ) -#endif import Constants ( uNFOLDING_USE_THRESHOLD, uNFOLDING_CON_DISCOUNT_WEIGHT @@ -32,17 +27,15 @@ import CostCentre ( CostCentre, isCurrentCostCentre ) import Id ( idType, getIdInfo, getIdUnfolding, getIdSpecialisation, idMustBeINLINEd, GenId{-instance Outputable-} ) -import SpecEnv ( SpecEnv, lookupSpecEnv ) +import SpecEnv ( matchSpecEnv ) import Literal ( isNoRepLit ) import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun ) -import Outputable ( Outputable(..), PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) import SimplEnv import SimplMonad import TyCon ( tyConFamilySize ) -import Util ( pprTrace, assertPanic, panic ) import Maybes ( maybeToBool ) -import Pretty +import Outputable \end{code} %************************************************************************ @@ -84,9 +77,9 @@ completeVar env var args result_ty | maybeToBool maybe_specialisation = tick SpecialisationDone `thenSmpl_` - simplExpr (extendTyEnvList env spec_bindings) + simplExpr (extendTyEnvEnv env spec_bindings) spec_template - (map TyArg leftover_ty_args ++ remaining_args) + remaining_args result_ty | otherwise @@ -124,8 +117,8 @@ completeVar env var args result_ty ---------- Specialisation stuff (ty_args, remaining_args) = initialTyArgs args - maybe_specialisation = lookupSpecEnv (getIdSpecialisation var) ty_args - (Just (spec_template, (spec_bindings, leftover_ty_args))) = maybe_specialisation + maybe_specialisation = matchSpecEnv (getIdSpecialisation var) ty_args + Just (spec_bindings, spec_template) = maybe_specialisation ---------- Switches @@ -146,7 +139,7 @@ unfold var unf_env unf_template args result_ty {- simplCount `thenSmpl` \ n -> (if n > 1000 then - pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr PprDebug var]) + pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr var]) else id ) diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 758d7a3260..97b698fb1b 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -4,16 +4,9 @@ \section[Simplify]{The main module of the simplifier} \begin{code} -#include "HsVersions.h" - module Simplify ( simplTopBinds, simplExpr, simplBind ) where -IMPORT_1_3(List(partition)) - -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(SmplLoop) -- paranoia checking -#endif +#include "HsVersions.h" import BinderInfo import CmdLineOpts ( SimplifierSwitch(..) ) @@ -38,11 +31,6 @@ import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..), import Literal ( isNoRepLit ) import Maybes ( maybeToBool ) import PprType ( GenType{-instance Outputable-}, GenTyVar{- instance Outputable -} ) -#if __GLASGOW_HASKELL__ <= 30 -import PprCore ( GenCoreArg, GenCoreExpr ) -#endif -import TyVar ( GenTyVar {- instance Eq -} ) -import Pretty --( ($$) ) import PrimOp ( primOpOkForSpeculation, PrimOp(..) ) import SimplCase ( simplCase, bindLargeRhs ) import SimplEnv @@ -50,13 +38,14 @@ import SimplMonad import SimplVar ( completeVar ) import Unique ( Unique ) import SimplUtils -import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys, maybeAppDataTyCon, - splitFunTy, splitFunTyExpandingDicts, getFunTy_maybe, eqTy +import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys, splitAlgTyConApp_maybe, + splitFunTys, splitFunTy_maybe, isUnpointedType ) import TysPrim ( realWorldStatePrimTy ) -import Outputable ( PprStyle(..), Outputable(..) ) -import Util ( SYN_IE(Eager), appEager, returnEager, runEager, mapEager, - isSingleton, zipEqual, zipWithEqual, mapAndUnzip, panic, pprPanic, assertPanic, pprTrace ) +import Util ( Eager, appEager, returnEager, runEager, mapEager, + isSingleton, zipEqual, zipWithEqual, mapAndUnzip + ) +import Outputable \end{code} The controlling flags, and what they do @@ -339,8 +328,7 @@ First the case when it's applied to an argument. \begin{code} simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty - = -- ASSERT(not (isPrimType ty)) - tick TyBetaReduction `thenSmpl_` + = tick TyBetaReduction `thenSmpl_` simplExpr (extendTyEnv env tyvar ty) body args result_ty \end{code} @@ -434,7 +422,7 @@ We must be careful to maintain the scc counts ... \begin{code} simplExpr env (SCC cc1 (SCC cc2 expr)) args result_ty - | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False } + | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ -> True; _ -> False } -- eliminate inner scc if no call counts and same cc as outer = simplExpr env (SCC cc1 expr) args result_ty @@ -508,7 +496,7 @@ simplRhsExpr \begin{code} simplRhsExpr env binder@(id,occ_info) rhs new_id - | maybeToBool (maybeAppDataTyCon rhs_ty) + | maybeToBool (splitAlgTyConApp_maybe rhs_ty) -- Deal with the data type case, in which case the elaborate -- eta-expansion nonsense is really quite a waste of time. = simplExpr rhs_env rhs [] rhs_ty `thenSmpl` \ rhs' -> @@ -516,8 +504,6 @@ simplRhsExpr env binder@(id,occ_info) rhs new_id | otherwise -- OK, use the big hammer = -- Deal with the big lambda part - ASSERT( null uvars ) -- For now - mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' -> let new_tys = mkTyVarTys tyvars' @@ -551,7 +537,7 @@ simplRhsExpr env binder@(id,occ_info) rhs new_id env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre | otherwise = env - (uvars, tyvars, body) = collectUsageAndTyBinders rhs + (tyvars, body) = collectTyBinders rhs \end{code} @@ -658,11 +644,11 @@ simplValLam env expr min_no_of_args expr_ty | otherwise -- Eta expansion possible = -- A SSERT( no_of_extra_binders <= length potential_extra_binder_tys ) (if not ( no_of_extra_binders <= length potential_extra_binder_tys ) then - pprTrace "simplValLam" (vcat [ppr PprDebug expr, - ppr PprDebug expr_ty, - ppr PprDebug binders, + pprTrace "simplValLam" (vcat [ppr expr, + ppr expr_ty, + ppr binders, int no_of_extra_binders, - ppr PprDebug potential_extra_binder_tys]) + ppr potential_extra_binder_tys]) else \x -> x) $ tick EtaExpansion `thenSmpl_` @@ -680,11 +666,11 @@ simplValLam env expr min_no_of_args expr_ty where (binders,body) = collectValBinders expr no_of_binders = length binders - (arg_tys, res_ty) = splitFunTyExpandingDicts expr_ty + (arg_tys, res_ty) = splitFunTys expr_ty potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then - pprTrace "simplValLam" (vcat [ppr PprDebug expr, - ppr PprDebug expr_ty, - ppr PprDebug binders]) + pprTrace "simplValLam" (vcat [ppr expr, + ppr expr_ty, + ppr binders]) else \x->x) $ drop no_of_binders arg_tys body_ty = mkFunTys potential_extra_binder_tys res_ty @@ -720,8 +706,8 @@ simplValLam env expr min_no_of_args expr_ty -- but usually doesn't `max` case potential_extra_binder_tys of - [ty] | ty `eqTy` realWorldStatePrimTy -> 1 - other -> 0 + [ty] | ty == realWorldStatePrimTy -> 1 + other -> 0 \end{code} @@ -923,22 +909,29 @@ simplNonRec env binder@(id,occ_info) rhs body_c body_ty | idWantsToBeINLINEd id = complete_bind env rhs -- Don't mess about with floating or let-to-case on -- INLINE things - | otherwise - = simpl_bind env rhs - where - -- Try let-to-case; see notes below about let-to-case - simpl_bind env rhs | try_let_to_case && - will_be_demanded && - (rhs_is_bot || - not rhs_is_whnf && -- Don't do it if RHS is a constr applicn - singleConstructorType rhs_ty - -- Only do let-to-case for single constructor types. - -- For other types we defer doing it until the tidy-up phase at - -- the end of simplification. - ) - = tick Let2Case `thenSmpl_` - simplCase env rhs (AlgAlts [] (BindDefault binder (Var id))) - (\env rhs -> complete_bind env rhs) body_ty + + -- Do let-to-case right away for unpointed types + -- These shouldn't occur much, but do occur right after desugaring, + -- because we havn't done dependency analysis at that point, so + -- we can't trivially do let-to-case (because there may be some unboxed + -- things bound in letrecs that aren't really recursive). + | isUnpointedType rhs_ty && not rhs_is_whnf + = simplCase env rhs (PrimAlts [] (BindDefault binder (Var id))) + (\env rhs -> complete_bind env rhs) body_ty + + -- Try let-to-case; see notes below about let-to-case + | try_let_to_case && + will_be_demanded && + ( rhs_is_bot + || (not rhs_is_whnf && singleConstructorType rhs_ty) + -- Don't do let-to-case if the RHS is a constructor application. + -- Even then only do it for single constructor types. + -- For other types we defer doing it until the tidy-up phase at + -- the end of simplification. + ) + = tick Let2Case `thenSmpl_` + simplCase env rhs (AlgAlts [] (BindDefault binder (Var id))) + (\env rhs -> complete_bind env rhs) body_ty -- OLD COMMENT: [now the new RHS is only "x" so there's less worry] -- NB: it's tidier to call complete_bind not simpl_bind, else -- we nearly end up in a loop. Consider: @@ -948,6 +941,9 @@ simplNonRec env binder@(id,occ_info) rhs body_c body_ty -- 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! + | otherwise + = simpl_bind env rhs + where -- Try let-from-let simpl_bind env (Let bind rhs) | let_floating_ok = tick LetFloatFromLet `thenSmpl_` @@ -1382,14 +1378,14 @@ computeResultType env expr_ty orig_args let go ty [] = ty go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args - go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of + go ty (a:args) | isValArg a = case (splitFunTy_maybe ty) of Just (_, res_ty) -> go res_ty args Nothing -> pprPanic "computeResultType" (vcat [ - ppr PprDebug (a:args), - ppr PprDebug orig_args, - ppr PprDebug expr_ty', - ppr PprDebug ty]) + ppr (a:args), + ppr orig_args, + ppr expr_ty', + ppr ty]) in go expr_ty' orig_args diff --git a/ghc/compiler/simplCore/SmplLoop.lhi b/ghc/compiler/simplCore/SmplLoop.lhi deleted file mode 100644 index dd01da4de7..0000000000 --- a/ghc/compiler/simplCore/SmplLoop.lhi +++ /dev/null @@ -1,38 +0,0 @@ -Breaks the loop between SimplEnv and MagicUFs, by telling SimplEnv all -it needs to know about MagicUFs (not much). - -Also break the loop between SimplVar/SimplCase (which use -Simplify.simplExpr) and SimplExpr (which uses whatever -SimplVar/SimplCase cough up). - -Tell SimplEnv about SimplUtils.simplIdWantsToBeINLINEd. - -\begin{code} -interface SmplLoop where - -import MagicUFs ( MagicUnfoldingFun ) -import SimplEnv ( SimplEnv, InBinding(..), InExpr(..), - OutArg(..), OutExpr(..), OutType(..) - ) -import Simplify ( simplExpr, simplBind ) -import SimplUtils ( simplIdWantsToBeINLINEd ) - -import BinderInfo(BinderInfo) -import CoreSyn(GenCoreArg, GenCoreBinding, GenCoreExpr) -import Id(GenId) -import SimplMonad(SimplCount) -import TyVar(GenTyVar) -import Type(GenType) -import UniqSupply(UniqSupply) -import Unique(Unique) -import Usage(GenUsage) - -data MagicUnfoldingFun -data SimplCount -data SimplEnv - -simplIdWantsToBeINLINEd :: GenId (GenType (GenTyVar (GenUsage Unique)) Unique) -> SimplEnv -> Bool - -simplBind :: SimplEnv -> GenCoreBinding (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> (SimplEnv -> UniqSupply -> SimplCount -> (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique, SimplCount)) -> GenType (GenTyVar (GenUsage Unique)) Unique -> UniqSupply -> SimplCount -> (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique, SimplCount) -simplExpr :: SimplEnv -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> [GenCoreArg (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique] -> GenType (GenTyVar (GenUsage Unique)) Unique -> UniqSupply -> SimplCount -> (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique, SimplCount) -\end{code} diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs index 38967fe781..1f54bad3cd 100644 --- a/ghc/compiler/simplStg/LambdaLift.lhs +++ b/ghc/compiler/simplStg/LambdaLift.lhs @@ -4,25 +4,23 @@ \section[LambdaLift]{A STG-code lambda lifter} \begin{code} -#include "HsVersions.h" - module LambdaLift ( liftProgram ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import StgSyn import Bag ( Bag, emptyBag, unionBags, unitBag, snocBag, bagToList ) import Id ( idType, mkSysLocal, addIdArity, mkIdSet, unitIdSet, minusIdSet, setIdVisibility, - unionManyIdSets, idSetToList, SYN_IE(IdSet), - nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv), - SYN_IE(Id) + unionManyIdSets, idSetToList, IdSet, + nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv, + Id ) import IdInfo ( ArityInfo, exactArity ) -import Name ( SYN_IE(Module) ) +import Name ( Module ) import SrcLoc ( noSrcLoc ) -import Type ( splitForAllTy, mkForAllTys, mkFunTys, SYN_IE(Type) ) +import Type ( splitForAllTys, mkForAllTys, mkFunTys, Type ) import UniqSupply ( getUnique, splitUniqSupply, UniqSupply ) import Util ( zipEqual, panic, assertPanic ) \end{code} @@ -382,7 +380,7 @@ mkScPieces extra_arg_set (id, StgRhsClosure cc bi _ upd args body) -- Construct the supercombinator type type_of_original_id = idType id extra_arg_tys = map idType extra_args - (tyvars, rest) = splitForAllTy type_of_original_id + (tyvars, rest) = splitForAllTys type_of_original_id sc_ty = mkForAllTys tyvars (mkFunTys extra_arg_tys rest) sc_rhs = StgRhsClosure cc bi [] upd (extra_args ++ args) body diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index a14a279521..2b37c43110 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -4,12 +4,9 @@ \section[SimplStg]{Driver for simplifying @STG@ programs} \begin{code} -#include "HsVersions.h" - module SimplStg ( stg2stg ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(IO(hPutStr,stderr)) +#include "HsVersions.h" import StgSyn @@ -29,16 +26,17 @@ import CmdLineOpts ( opt_SccGroup, --Not used:opt_EnsureSplittableC, StgToDo(..) ) import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv, - growIdEnvList, isNullIdEnv, SYN_IE(IdEnv), - GenId{-instance Eq/Outputable -}, SYN_IE(Id) + growIdEnvList, isNullIdEnv, IdEnv, + GenId{-instance Eq/Outputable -}, Id ) import Maybes ( maybeToBool ) import PprType ( GenType{-instance Outputable-} ) import ErrUtils ( doIfSet ) -import Outputable ( PprStyle, Outputable(..), printErrs, pprDumpStyle ) -import Pretty ( Doc, ($$), vcat, text, ptext ) import UniqSupply ( splitUniqSupply, UniqSupply ) import Util ( mapAccumL, panic, assertPanic ) +import IO ( hPutStr, stderr ) +import Outputable +import GlaExts ( trace ) \end{code} \begin{code} @@ -57,7 +55,7 @@ stg2stg stg_todos module_name us binds doIfSet do_verbose_stg2stg (printErrs (text "VERBOSE STG-TO-STG:" $$ text "*** Core2Stg:" $$ - vcat (map (ppr pprDumpStyle) (setStgVarInfo False binds)))) >> + vcat (map ppr (setStgVarInfo False binds)))) >> -- Do the main business! foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos @@ -107,7 +105,7 @@ stg2stg stg_todos module_name us binds ------------- stg_linter = if False --LATER: opt_DoStgLinting (ToDo) - then lintStgBindings pprDumpStyle + then lintStgBindings else ( \ whodunnit binds -> binds ) ------------------------------------------- @@ -149,9 +147,8 @@ stg2stg stg_todos module_name us binds end_pass us2 what ccs binds2 = -- report verbosely, if required (if do_verbose_stg2stg then - hPutStr stderr (show - (($$) (text ("*** "++what++":")) - (vcat (map (ppr pprDumpStyle) binds2)) + hPutStr stderr (showSDoc + (text ("*** "++what++":") $$ vcat (map ppr binds2) )) else return ()) >> let diff --git a/ghc/compiler/simplStg/StgStats.lhs b/ghc/compiler/simplStg/StgStats.lhs index 7be7b106c2..a55c4186d7 100644 --- a/ghc/compiler/simplStg/StgStats.lhs +++ b/ghc/compiler/simplStg/StgStats.lhs @@ -21,16 +21,14 @@ The program gather statistics about \end{enumerate} \begin{code} -#include "HsVersions.h" - module StgStats ( showStgStats ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import StgSyn import FiniteMap ( emptyFM, plusFM_C, unitFM, fmToList, FiniteMap ) -import Id (SYN_IE(Id)) +import Id (Id) \end{code} \begin{code} diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs index 46c66ded07..aef731c1b4 100644 --- a/ghc/compiler/simplStg/StgVarInfo.lhs +++ b/ghc/compiler/simplStg/StgVarInfo.lhs @@ -7,11 +7,9 @@ And, as we have the info in hand, we may convert some lets to let-no-escapes. \begin{code} -#include "HsVersions.h" - module StgVarInfo ( setStgVarInfo ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import StgSyn @@ -19,20 +17,18 @@ import Id ( emptyIdSet, mkIdSet, minusIdSet, unionIdSets, unionManyIdSets, isEmptyIdSet, unitIdSet, intersectIdSets, addIdArity, getIdArity, - addOneToIdSet, SYN_IE(IdSet), + addOneToIdSet, IdSet, nullIdEnv, growIdEnvList, lookupIdEnv, unitIdEnv, combineIdEnvs, delManyFromIdEnv, - rngIdEnv, SYN_IE(IdEnv), - GenId{-instance Eq-}, SYN_IE(Id) + rngIdEnv, IdEnv, + GenId{-instance Eq-}, Id ) import IdInfo ( ArityInfo(..) ) import Maybes ( maybeToBool ) import Name ( isLocallyDefined ) -import BasicTypes ( SYN_IE(Arity) ) -import Outputable ( PprStyle(..), Outputable(..) ) +import BasicTypes ( Arity ) import PprType ( GenType{-instance Outputable-} ) -import Util ( panic, pprPanic, assertPanic ) -import Pretty ( Doc ) +import Outputable infixr 9 `thenLne`, `thenLne_` \end{code} @@ -724,7 +720,7 @@ lookupLiveVarsForSet fvs sw env lvs_cont case (lookupIdEnv env v) of Just (_, LetrecBound _ lvs) -> addOneToIdSet lvs v Just _ -> unitIdSet v - Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr PprShowAll v) + Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v) else emptyIdSet \end{code} diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs index 59768a2d9f..2e20a1a4e1 100644 --- a/ghc/compiler/simplStg/UpdAnal.lhs +++ b/ghc/compiler/simplStg/UpdAnal.lhs @@ -6,47 +6,50 @@ %----------------------------------------------------------------------------- \subsection{Module Interface} + \begin{code} +module UpdAnal ( updateAnalyse ) where + #include "HsVersions.h" + +import Prelude hiding ( lookup ) + +import StgSyn +import Id ( IdEnv, growIdEnv, addOneToIdEnv, combineIdEnvs, nullIdEnv, + unitIdEnv, mkIdEnv, rngIdEnv, lookupIdEnv, + IdSet, + getIdUpdateInfo, addIdUpdateInfo, mkSysLocal, idType, isImportedId, + externallyVisibleId, + Id, GenId + ) +import IdInfo ( UpdateInfo, UpdateSpec, mkUpdateInfo, updateInfoMaybe ) +import Type ( splitFunTys, splitSigmaTy ) +import UniqSet +import Unique ( getBuiltinUniques ) +import SrcLoc ( noSrcLoc ) +import Util ( panic ) \end{code} -> module UpdAnal ( updateAnalyse ) where -> -> IMP_Ubiq(){-uitous-} -> -> import Prelude hiding ( lookup ) -> -> import StgSyn -> import Id ( SYN_IE(IdEnv), growIdEnv, addOneToIdEnv, combineIdEnvs, nullIdEnv, -> unitIdEnv, mkIdEnv, rngIdEnv, lookupIdEnv, -> SYN_IE(IdSet), -> getIdUpdateInfo, addIdUpdateInfo, mkSysLocal, idType, isImportedId, -> externallyVisibleId, -> SYN_IE(Id), GenId -> ) -> import IdInfo ( UpdateInfo, SYN_IE(UpdateSpec), mkUpdateInfo, updateInfoMaybe ) -> import Type ( splitFunTy, splitSigmaTy ) -> import UniqSet -> import Unique ( getBuiltinUniques ) -> import SrcLoc ( noSrcLoc ) -> import Util ( panic ) -> %----------------------------------------------------------------------------- \subsection{Reverse application} This is used instead of lazy pattern bindings to avoid space leaks. -> infixr 3 =: -> a =: k = k a +\begin{code} +infixr 3 =: +a =: k = k a +\end{code} %----------------------------------------------------------------------------- \subsection{Types} List of closure references -> type Refs = IdSet -> x `notInRefs` y = not (x `elementOfUniqSet` y) +\begin{code} +type Refs = IdSet +x `notInRefs` y = not (x `elementOfUniqSet` y) +\end{code} A closure value: environment of closures that are evaluated on entry, a list of closures that are referenced from the result, and an @@ -57,57 +60,59 @@ combined often. A generic environment is used for the main environment mapping closure names to values; as a common operation is extension of this environment, this representation should be efficient. -> -- partain: funny synonyms to cope w/ the fact -> -- that IdEnvs know longer know what their keys are -> -- (94/05) ToDo: improve -> type IdEnvInt = IdEnv (Id, Int) -> type IdEnvClosure = IdEnv (Id, Closure) - -> -- backward-compat functions -> null_IdEnv :: IdEnv (Id, a) -> null_IdEnv = nullIdEnv -> -> unit_IdEnv :: Id -> a -> IdEnv (Id, a) -> unit_IdEnv k v = unitIdEnv k (k, v) -> -> mk_IdEnv :: [(Id, a)] -> IdEnv (Id, a) -> mk_IdEnv pairs = mkIdEnv [ (k, (k,v)) | (k,v) <- pairs ] -> -> grow_IdEnv :: IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a) -> grow_IdEnv env1 env2 = growIdEnv env1 env2 -> -> addOneTo_IdEnv :: IdEnv (Id, a) -> Id -> a -> IdEnv (Id, a) -> addOneTo_IdEnv env k v = addOneToIdEnv env k (k, v) -> -> combine_IdEnvs :: (a->a->a) -> IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a) -> combine_IdEnvs combiner env1 env2 = combineIdEnvs new_combiner env1 env2 -> where -> new_combiner (id, x) (_, y) = (id, combiner x y) -> -> dom_IdEnv :: IdEnv (Id, a) -> Refs -> dom_IdEnv env = mkUniqSet [ i | (i,_) <- rngIdEnv env ] -> -> lookup_IdEnv :: IdEnv (Id, a) -> Id -> Maybe a -> lookup_IdEnv env key = case lookupIdEnv env key of -> Nothing -> Nothing -> Just (_,a) -> Just a -> -- end backward compat stuff - -> type Closure = (IdEnvInt, Refs, AbFun) - -> type AbVal = IdEnvClosure -> Closure -> data AbFun = Fun (Closure -> Closure) - -> -- partain: speeding-up stuff -> -> type CaseBoundVars = IdSet -> noCaseBound = emptyUniqSet -> isCaseBound = elementOfUniqSet -> x `notCaseBound` y = not (isCaseBound x y) -> moreCaseBound :: CaseBoundVars -> [Id] -> CaseBoundVars -> moreCaseBound old new = old `unionUniqSets` mkUniqSet new -> -> -- end speeding-up +\begin{code} +-- partain: funny synonyms to cope w/ the fact +-- that IdEnvs know longer know what their keys are +-- (94/05) ToDo: improve +type IdEnvInt = IdEnv (Id, Int) +type IdEnvClosure = IdEnv (Id, Closure) + +-- backward-compat functions +null_IdEnv :: IdEnv (Id, a) +null_IdEnv = nullIdEnv + +unit_IdEnv :: Id -> a -> IdEnv (Id, a) +unit_IdEnv k v = unitIdEnv k (k, v) + +mk_IdEnv :: [(Id, a)] -> IdEnv (Id, a) +mk_IdEnv pairs = mkIdEnv [ (k, (k,v)) | (k,v) <- pairs ] + +grow_IdEnv :: IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a) +grow_IdEnv env1 env2 = growIdEnv env1 env2 + +addOneTo_IdEnv :: IdEnv (Id, a) -> Id -> a -> IdEnv (Id, a) +addOneTo_IdEnv env k v = addOneToIdEnv env k (k, v) + +combine_IdEnvs :: (a->a->a) -> IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a) +combine_IdEnvs combiner env1 env2 = combineIdEnvs new_combiner env1 env2 + where + new_combiner (id, x) (_, y) = (id, combiner x y) + +dom_IdEnv :: IdEnv (Id, a) -> Refs +dom_IdEnv env = mkUniqSet [ i | (i,_) <- rngIdEnv env ] + +lookup_IdEnv :: IdEnv (Id, a) -> Id -> Maybe a +lookup_IdEnv env key = case lookupIdEnv env key of + Nothing -> Nothing + Just (_,a) -> Just a +-- end backward compat stuff + +type Closure = (IdEnvInt, Refs, AbFun) + +type AbVal = IdEnvClosure -> Closure +data AbFun = Fun (Closure -> Closure) + +-- partain: speeding-up stuff + +type CaseBoundVars = IdSet +noCaseBound = emptyUniqSet +isCaseBound = elementOfUniqSet +x `notCaseBound` y = not (isCaseBound x y) +moreCaseBound :: CaseBoundVars -> [Id] -> CaseBoundVars +moreCaseBound old new = old `unionUniqSets` mkUniqSet new + +-- end speeding-up +\end{code} %---------------------------------------------------------------------------- \subsection{Environment lookup} @@ -116,32 +121,36 @@ If the requested value is not in the environment, we return an unknown value. Lookup is designed to be partially applied to a variable, and repeatedly applied to different environments after that. -> lookup v -> | isImportedId v -> = const (case updateInfoMaybe (getIdUpdateInfo v) of -> Nothing -> unknownClosure -> Just spec -> convertUpdateSpec spec) -> | otherwise -> = \p -> case lookup_IdEnv p v of -> Just b -> b -> Nothing -> unknownClosure +\begin{code} +lookup v + | isImportedId v + = const (case updateInfoMaybe (getIdUpdateInfo v) of + Nothing -> unknownClosure + Just spec -> convertUpdateSpec spec) + | otherwise + = \p -> case lookup_IdEnv p v of + Just b -> b + Nothing -> unknownClosure +\end{code} %----------------------------------------------------------------------------- Represent a list of references as an ordered list. -> mkRefs :: [Id] -> Refs -> mkRefs = mkUniqSet +\begin{code} +mkRefs :: [Id] -> Refs +mkRefs = mkUniqSet -> noRefs :: Refs -> noRefs = emptyUniqSet +noRefs :: Refs +noRefs = emptyUniqSet -> elemRefs = elementOfUniqSet +elemRefs = elementOfUniqSet -> merge :: [Refs] -> Refs -> merge xs = foldr merge2 emptyUniqSet xs +merge :: [Refs] -> Refs +merge xs = foldr merge2 emptyUniqSet xs -> merge2 :: Refs -> Refs -> Refs -> merge2 = unionUniqSets +merge2 :: Refs -> Refs -> Refs +merge2 = unionUniqSets +\end{code} %----------------------------------------------------------------------------- \subsection{Some non-interesting values} @@ -149,8 +158,10 @@ Represent a list of references as an ordered list. bottom will be used for abstract values that are not functions. Hopefully its value will never be required! -> bottom :: AbFun -> bottom = panic "Internal: (Update Analyser) bottom" +\begin{code} +bottom :: AbFun +bottom = panic "Internal: (Update Analyser) bottom" +\end{code} noClosure is a value that is definitely not a function (i.e. primitive values and constructor applications). unknownClosure is a value about @@ -158,59 +169,71 @@ which we have no information at all. This should occur rarely, but could happen when an id is imported and the exporting module was not compiled with the update analyser. -> noClosure, unknownClosure :: Closure -> noClosure = (null_IdEnv, noRefs, bottom) -> unknownClosure = (null_IdEnv, noRefs, dont_know noRefs) +\begin{code} +noClosure, unknownClosure :: Closure +noClosure = (null_IdEnv, noRefs, bottom) +unknownClosure = (null_IdEnv, noRefs, dont_know noRefs) +\end{code} dont_know is a black hole: it is something we know nothing about. Applying dont_know to anything will generate a new dont_know that simply contains more buried references. -> dont_know :: Refs -> AbFun -> dont_know b' -> = Fun (\(c,b,f) -> let b'' = dom_IdEnv c `merge2` b `merge2` b' -> in (null_IdEnv, b'', dont_know b'')) +\begin{code} +dont_know :: Refs -> AbFun +dont_know b' + = Fun (\(c,b,f) -> let b'' = dom_IdEnv c `merge2` b `merge2` b' + in (null_IdEnv, b'', dont_know b'')) +\end{code} -%----------------------------------------------------------------------------- +----------------------------------------------------------------------------- -> getrefs :: IdEnvClosure -> [AbVal] -> Refs -> Refs -> getrefs p vs rest = foldr merge2 rest (getrefs' (map ($ p) vs)) -> where -> getrefs' [] = [] -> getrefs' ((c,b,_):rs) = dom_IdEnv c : b : getrefs' rs +\begin{code} +getrefs :: IdEnvClosure -> [AbVal] -> Refs -> Refs +getrefs p vs rest = foldr merge2 rest (getrefs' (map ($ p) vs)) + where + getrefs' [] = [] + getrefs' ((c,b,_):rs) = dom_IdEnv c : b : getrefs' rs +\end{code} -%----------------------------------------------------------------------------- +----------------------------------------------------------------------------- udData is used when we are putting a list of closure references into a data structure, or something else that we know nothing about. -> udData :: [StgArg] -> CaseBoundVars -> AbVal -> udData vs cvs -> = \p -> (null_IdEnv, getrefs p local_ids noRefs, bottom) -> where local_ids = [ lookup v | (StgVarArg v) <- vs, v `notCaseBound` cvs ] +\begin{code} +udData :: [StgArg] -> CaseBoundVars -> AbVal +udData vs cvs + = \p -> (null_IdEnv, getrefs p local_ids noRefs, bottom) + where local_ids = [ lookup v | (StgVarArg v) <- vs, v `notCaseBound` cvs ] +\end{code} %----------------------------------------------------------------------------- \subsection{Analysing an atom} -> udAtom :: CaseBoundVars -> StgArg -> AbVal -> udAtom cvs (StgVarArg v) -> | v `isCaseBound` cvs = const unknownClosure -> | otherwise = lookup v -> -> udAtom cvs _ = const noClosure +\begin{code} +udAtom :: CaseBoundVars -> StgArg -> AbVal +udAtom cvs (StgVarArg v) + | v `isCaseBound` cvs = const unknownClosure + | otherwise = lookup v + +udAtom cvs _ = const noClosure +\end{code} %----------------------------------------------------------------------------- \subsection{Analysing an STG expression} -> ud :: StgExpr -- Expression to be analysed -> -> CaseBoundVars -- List of case-bound vars -> -> IdEnvClosure -- Current environment -> -> (StgExpr, AbVal) -- (New expression, abstract value) -> -> ud e@(StgPrim _ vs _) cvs p = (e, udData vs cvs) -> ud e@(StgCon _ vs _) cvs p = (e, udData vs cvs) -> ud e@(StgSCC ty lab a) cvs p = ud a cvs p =: \(a', abval_a) -> -> (StgSCC ty lab a', abval_a) +\begin{code} +ud :: StgExpr -- Expression to be analysed + -> CaseBoundVars -- List of case-bound vars + -> IdEnvClosure -- Current environment + -> (StgExpr, AbVal) -- (New expression, abstract value) + +ud e@(StgPrim _ vs _) cvs p = (e, udData vs cvs) +ud e@(StgCon _ vs _) cvs p = (e, udData vs cvs) +ud e@(StgSCC ty lab a) cvs p = ud a cvs p =: \(a', abval_a) -> + (StgSCC ty lab a', abval_a) +\end{code} Here is application. The first thing to do is analyse the head, and get an abstract function. Multiple applications are performed by using @@ -219,97 +242,101 @@ abstract function iff the atom is a local variable. I've left the type signature for doApp in to make things a bit clearer. -> ud e@(StgApp a atoms lvs) cvs p -> = (e, abval_app) -> where -> abval_atoms = map (udAtom cvs) atoms -> abval_a = udAtom cvs a -> abval_app = \p -> -> let doApp :: Closure -> AbVal -> Closure -> doApp (c, b, Fun f) abval_atom = -> abval_atom p =: \e@(_,_,_) -> -> f e =: \(c', b', f') -> -> (combine_IdEnvs (+) c' c, b', f') -> in foldl doApp (abval_a p) abval_atoms - -> ud (StgCase expr lve lva uniq alts) cvs p -> = ud expr cvs p =: \(expr', abval_selector) -> -> udAlt alts p =: \(alts', abval_alts) -> -> let -> abval_case = \p -> -> abval_selector p =: \(c, b, abfun_selector) -> -> abval_alts p =: \(cs, bs, abfun_alts) -> -> let bs' = b `merge2` bs in -> (combine_IdEnvs (+) c cs, bs', dont_know bs') -> in -> (StgCase expr' lve lva uniq alts', abval_case) -> where -> -> udAlt :: StgCaseAlts -> -> IdEnvClosure -> -> (StgCaseAlts, AbVal) -> -> udAlt (StgAlgAlts ty [alt] StgNoDefault) p -> = udAlgAlt p alt =: \(alt', abval) -> -> (StgAlgAlts ty [alt'] StgNoDefault, abval) -> udAlt (StgAlgAlts ty [] def) p -> = udDef def p =: \(def', abval) -> -> (StgAlgAlts ty [] def', abval) -> udAlt (StgAlgAlts ty alts def) p -> = udManyAlts alts def udAlgAlt (StgAlgAlts ty) p -> udAlt (StgPrimAlts ty [alt] StgNoDefault) p -> = udPrimAlt p alt =: \(alt', abval) -> -> (StgPrimAlts ty [alt'] StgNoDefault, abval) -> udAlt (StgPrimAlts ty [] def) p -> = udDef def p =: \(def', abval) -> -> (StgPrimAlts ty [] def', abval) -> udAlt (StgPrimAlts ty alts def) p -> = udManyAlts alts def udPrimAlt (StgPrimAlts ty) p -> -> udPrimAlt p (l, e) -> = ud e cvs p =: \(e', v) -> ((l, e'), v) -> -> udAlgAlt p (id, vs, use_mask, e) -> = ud e (moreCaseBound cvs vs) p =: \(e', v) -> ((id, vs, use_mask, e'), v) -> -> udDef :: StgCaseDefault -> -> IdEnvClosure -> -> (StgCaseDefault, AbVal) -> -> udDef StgNoDefault p -> = (StgNoDefault, \p -> (null_IdEnv, noRefs, dont_know noRefs)) -> udDef (StgBindDefault v is_used expr) p -> = ud expr (moreCaseBound cvs [v]) p =: \(expr', abval) -> -> (StgBindDefault v is_used expr', abval) -> -> udManyAlts alts def udalt stgalts p -> = udDef def p =: \(def', abval_def) -> -> unzip (map (udalt p) alts) =: \(alts', abvals_alts) -> -> let -> abval_alts = \p -> -> abval_def p =: \(cd, bd, _) -> -> unzip3 (map ($ p) abvals_alts) =: \(cs, bs, _) -> -> let bs' = merge (bd:bs) in -> (foldr (combine_IdEnvs max) cd cs, bs', dont_know bs') -> in (stgalts alts' def', abval_alts) +\begin{code} +ud e@(StgApp a atoms lvs) cvs p + = (e, abval_app) + where + abval_atoms = map (udAtom cvs) atoms + abval_a = udAtom cvs a + abval_app = \p -> + let doApp :: Closure -> AbVal -> Closure + doApp (c, b, Fun f) abval_atom = + abval_atom p =: \e@(_,_,_) -> + f e =: \(c', b', f') -> + (combine_IdEnvs (+) c' c, b', f') + in foldl doApp (abval_a p) abval_atoms + +ud (StgCase expr lve lva uniq alts) cvs p + = ud expr cvs p =: \(expr', abval_selector) -> + udAlt alts p =: \(alts', abval_alts) -> + let + abval_case = \p -> + abval_selector p =: \(c, b, abfun_selector) -> + abval_alts p =: \(cs, bs, abfun_alts) -> + let bs' = b `merge2` bs in + (combine_IdEnvs (+) c cs, bs', dont_know bs') + in + (StgCase expr' lve lva uniq alts', abval_case) + where + + udAlt :: StgCaseAlts + -> IdEnvClosure + -> (StgCaseAlts, AbVal) + + udAlt (StgAlgAlts ty [alt] StgNoDefault) p + = udAlgAlt p alt =: \(alt', abval) -> + (StgAlgAlts ty [alt'] StgNoDefault, abval) + udAlt (StgAlgAlts ty [] def) p + = udDef def p =: \(def', abval) -> + (StgAlgAlts ty [] def', abval) + udAlt (StgAlgAlts ty alts def) p + = udManyAlts alts def udAlgAlt (StgAlgAlts ty) p + udAlt (StgPrimAlts ty [alt] StgNoDefault) p + = udPrimAlt p alt =: \(alt', abval) -> + (StgPrimAlts ty [alt'] StgNoDefault, abval) + udAlt (StgPrimAlts ty [] def) p + = udDef def p =: \(def', abval) -> + (StgPrimAlts ty [] def', abval) + udAlt (StgPrimAlts ty alts def) p + = udManyAlts alts def udPrimAlt (StgPrimAlts ty) p + + udPrimAlt p (l, e) + = ud e cvs p =: \(e', v) -> ((l, e'), v) + + udAlgAlt p (id, vs, use_mask, e) + = ud e (moreCaseBound cvs vs) p =: \(e', v) -> ((id, vs, use_mask, e'), v) + + udDef :: StgCaseDefault + -> IdEnvClosure + -> (StgCaseDefault, AbVal) + + udDef StgNoDefault p + = (StgNoDefault, \p -> (null_IdEnv, noRefs, dont_know noRefs)) + udDef (StgBindDefault v is_used expr) p + = ud expr (moreCaseBound cvs [v]) p =: \(expr', abval) -> + (StgBindDefault v is_used expr', abval) + + udManyAlts alts def udalt stgalts p + = udDef def p =: \(def', abval_def) -> + unzip (map (udalt p) alts) =: \(alts', abvals_alts) -> + let + abval_alts = \p -> + abval_def p =: \(cd, bd, _) -> + unzip3 (map ($ p) abvals_alts) =: \(cs, bs, _) -> + let bs' = merge (bd:bs) in + (foldr (combine_IdEnvs max) cd cs, bs', dont_know bs') + in (stgalts alts' def', abval_alts) +\end{code} The heart of the analysis: here we decide whether to make a specific closure updatable or not, based on the results of analysing the body. -> ud (StgLet binds body) cvs p -> = udBinding binds cvs p =: \(binds', vs, abval1, abval2) -> -> abval1 p =: \(cs, p') -> -> grow_IdEnv p p' =: \p -> -> ud body cvs p =: \(body', abval_body) -> -> abval_body p =: \(c, b, abfun) -> -> tag b (combine_IdEnvs (+) cs c) binds' =: \tagged_binds -> -> let -> abval p -> = abval2 p =: \(c1, p') -> -> abval_body (grow_IdEnv p p') =: \(c2, b, abfun) -> -> (combine_IdEnvs (+) c1 c2, b, abfun) -> in -> (StgLet tagged_binds body', abval) +\begin{code} +ud (StgLet binds body) cvs p + = udBinding binds cvs p =: \(binds', vs, abval1, abval2) -> + abval1 p =: \(cs, p') -> + grow_IdEnv p p' =: \p -> + ud body cvs p =: \(body', abval_body) -> + abval_body p =: \(c, b, abfun) -> + tag b (combine_IdEnvs (+) cs c) binds' =: \tagged_binds -> + let + abval p + = abval2 p =: \(c1, p') -> + abval_body (grow_IdEnv p p') =: \(c2, b, abfun) -> + (combine_IdEnvs (+) c1 c2, b, abfun) + in + (StgLet tagged_binds body', abval) +\end{code} %----------------------------------------------------------------------------- \subsection{Analysing bindings} @@ -326,84 +353,90 @@ respective bindings have already been analysed. We don't need to find anything out about closures with arguments, constructor closures etc. -> udBinding :: StgBinding -> -> CaseBoundVars -> -> IdEnvClosure -> -> (StgBinding, -> [Id], -> IdEnvClosure -> (IdEnvInt, IdEnvClosure), -> IdEnvClosure -> (IdEnvInt, IdEnvClosure)) -> -> udBinding (StgNonRec v rhs) cvs p -> = udRhs rhs cvs p =: \(rhs', abval) -> -> abval p =: \(c, b, abfun) -> -> let -> abval_rhs a = \p -> -> abval p =: \(c, b, abfun) -> -> (c, unit_IdEnv v (a, b, abfun)) -> a = case rhs of -> StgRhsClosure _ _ _ Updatable [] _ -> unit_IdEnv v 1 -> _ -> null_IdEnv -> in (StgNonRec v rhs', [v], abval_rhs a, abval_rhs null_IdEnv) -> -> udBinding (StgRec ve) cvs p -> = (StgRec ve', [], abval_rhs, abval_rhs) -> where -> (vs, ve', abvals) = unzip3 (map udBind ve) -> fv = (map lookup . filter (`notCaseBound` cvs) . concat . map collectfv) ve -> vs' = mkRefs vs -> abval_rhs = \p -> -> let -> p' = grow_IdEnv (mk_IdEnv (vs `zip` (repeat closure))) p -> closure = (null_IdEnv, fv', dont_know fv') -> fv' = getrefs p fv vs' -> (cs, ps) = unzip (doRec vs abvals) -> -> doRec [] _ = [] -> doRec (v:vs) (abval:as) -> = abval p' =: \(c,b,abfun) -> -> (c, (v,(null_IdEnv, b, abfun))) : doRec vs as -> -> in -> (foldr (combine_IdEnvs (+)) null_IdEnv cs, mk_IdEnv ps) -> -> udBind (v,rhs) -> = udRhs rhs cvs p =: \(rhs', abval) -> -> (v,(v,rhs'), abval) -> -> collectfv (_, StgRhsClosure _ _ fv _ _ _) = fv -> collectfv (_, StgRhsCon _ con args) = [ v | (StgVarArg v) <- args ] +\begin{code} +udBinding :: StgBinding + -> CaseBoundVars + -> IdEnvClosure + -> (StgBinding, + [Id], + IdEnvClosure -> (IdEnvInt, IdEnvClosure), + IdEnvClosure -> (IdEnvInt, IdEnvClosure)) + +udBinding (StgNonRec v rhs) cvs p + = udRhs rhs cvs p =: \(rhs', abval) -> + abval p =: \(c, b, abfun) -> + let + abval_rhs a = \p -> + abval p =: \(c, b, abfun) -> + (c, unit_IdEnv v (a, b, abfun)) + a = case rhs of + StgRhsClosure _ _ _ Updatable [] _ -> unit_IdEnv v 1 + _ -> null_IdEnv + in (StgNonRec v rhs', [v], abval_rhs a, abval_rhs null_IdEnv) + +udBinding (StgRec ve) cvs p + = (StgRec ve', [], abval_rhs, abval_rhs) + where + (vs, ve', abvals) = unzip3 (map udBind ve) + fv = (map lookup . filter (`notCaseBound` cvs) . concat . map collectfv) ve + vs' = mkRefs vs + abval_rhs = \p -> + let + p' = grow_IdEnv (mk_IdEnv (vs `zip` (repeat closure))) p + closure = (null_IdEnv, fv', dont_know fv') + fv' = getrefs p fv vs' + (cs, ps) = unzip (doRec vs abvals) + + doRec [] _ = [] + doRec (v:vs) (abval:as) + = abval p' =: \(c,b,abfun) -> + (c, (v,(null_IdEnv, b, abfun))) : doRec vs as + + in + (foldr (combine_IdEnvs (+)) null_IdEnv cs, mk_IdEnv ps) + + udBind (v,rhs) + = udRhs rhs cvs p =: \(rhs', abval) -> + (v,(v,rhs'), abval) + + collectfv (_, StgRhsClosure _ _ fv _ _ _) = fv + collectfv (_, StgRhsCon _ con args) = [ v | (StgVarArg v) <- args ] +\end{code} %----------------------------------------------------------------------------- \subsection{Analysing Right-Hand Sides} -> udRhs e@(StgRhsCon _ _ vs) cvs p = (e, udData vs cvs) -> -> udRhs (StgRhsClosure cc bi fv u [] body) cvs p -> = ud body cvs p =: \(body', abval_body) -> -> (StgRhsClosure cc bi fv u [] body', abval_body) +\begin{code} +udRhs e@(StgRhsCon _ _ vs) cvs p = (e, udData vs cvs) + +udRhs (StgRhsClosure cc bi fv u [] body) cvs p + = ud body cvs p =: \(body', abval_body) -> + (StgRhsClosure cc bi fv u [] body', abval_body) +\end{code} Here is the code for closures with arguments. A closure has a number of arguments, which correspond to a set of nested lambda expressions. We build up the analysis using foldr with the function doLam to analyse each lambda expression. -> udRhs (StgRhsClosure cc bi fv u args body) cvs p -> = ud body cvs p =: \(body', abval_body) -> -> let -> fv' = map lookup (filter (`notCaseBound` cvs) fv) -> abval_rhs = \p -> -> foldr doLam (\b -> abval_body) args (getrefs p fv' noRefs) p -> in -> (StgRhsClosure cc bi fv u args body', abval_rhs) -> where -> -> doLam :: Id -> (Refs -> AbVal) -> Refs -> AbVal -> doLam i f b p -> = (null_IdEnv, b, -> Fun (\x@(c',b',_) -> -> let b'' = dom_IdEnv c' `merge2` b' `merge2` b in -> f b'' (addOneTo_IdEnv p i x))) +\begin{code} +udRhs (StgRhsClosure cc bi fv u args body) cvs p + = ud body cvs p =: \(body', abval_body) -> + let + fv' = map lookup (filter (`notCaseBound` cvs) fv) + abval_rhs = \p -> + foldr doLam (\b -> abval_body) args (getrefs p fv' noRefs) p + in + (StgRhsClosure cc bi fv u args body', abval_rhs) + where + + doLam :: Id -> (Refs -> AbVal) -> Refs -> AbVal + doLam i f b p + = (null_IdEnv, b, + Fun (\x@(c',b',_) -> + let b'' = dom_IdEnv c' `merge2` b' `merge2` b in + f b'' (addOneTo_IdEnv p i x))) +\end{code} %----------------------------------------------------------------------------- \subsection{Adjusting Update flags} @@ -412,19 +445,21 @@ The closure is tagged single entry iff it is used at most once, it is not referenced from inside a data structure or function, and it has no arguments (closures with arguments are re-entrant). -> tag :: Refs -> IdEnvInt -> StgBinding -> StgBinding -> -> tag b c r@(StgNonRec v (StgRhsClosure cc bi fv Updatable [] body)) -> = if (v `notInRefs` b) && (lookupc c v <= 1) -> then -- trace "One!" ( -> StgNonRec v (StgRhsClosure cc bi fv SingleEntry [] body) -> -- ) -> else r -> tag b c other = other -> -> lookupc c v = case lookup_IdEnv c v of -> Just n -> n -> Nothing -> 0 +\begin{code} +tag :: Refs -> IdEnvInt -> StgBinding -> StgBinding + +tag b c r@(StgNonRec v (StgRhsClosure cc bi fv Updatable [] body)) + = if (v `notInRefs` b) && (lookupc c v <= 1) + then -- trace "One!" ( + StgNonRec v (StgRhsClosure cc bi fv SingleEntry [] body) + -- ) + else r +tag b c other = other + +lookupc c v = case lookup_IdEnv c v of + Just n -> n + Nothing -> 0 +\end{code} %----------------------------------------------------------------------------- \subsection{Top Level analysis} @@ -433,18 +468,20 @@ Should we tag top level closures? This could have good implications for CAFs (i.e. they could be made non-updateable if only used once, thus preventing a space leak). -> updateAnalyse :: [StgBinding] -> [StgBinding] {- Exported -} -> updateAnalyse bs -> = udProgram bs null_IdEnv - -> udProgram :: [StgBinding] -> IdEnvClosure -> [StgBinding] -> udProgram [] p = [] -> udProgram (d:ds) p -> = udBinding d noCaseBound p =: \(d', vs, _, abval_bind) -> -> abval_bind p =: \(_, p') -> -> grow_IdEnv p p' =: \p'' -> -> attachUpdateInfoToBinds d' p'' =: \d'' -> -> d'' : udProgram ds p'' +\begin{code} +updateAnalyse :: [StgBinding] -> [StgBinding] {- Exported -} +updateAnalyse bs + = udProgram bs null_IdEnv + +udProgram :: [StgBinding] -> IdEnvClosure -> [StgBinding] +udProgram [] p = [] +udProgram (d:ds) p + = udBinding d noCaseBound p =: \(d', vs, _, abval_bind) -> + abval_bind p =: \(_, p') -> + grow_IdEnv p p' =: \p'' -> + attachUpdateInfoToBinds d' p'' =: \d'' -> + d'' : udProgram ds p'' +\end{code} %----------------------------------------------------------------------------- \subsection{Exporting Update Information} @@ -452,43 +489,47 @@ thus preventing a space leak). Convert the exported representation of a function's update function into a real Closure value. -> convertUpdateSpec :: UpdateSpec -> Closure -> convertUpdateSpec = mkClosure null_IdEnv noRefs noRefs - -> mkClosure :: IdEnvInt -> Refs -> Refs -> UpdateSpec -> Closure -> -> mkClosure c b b' [] = (c, b', dont_know b') -> mkClosure c b b' (0 : ns) = (null_IdEnv, b, Fun (\ _ -> mkClosure c b b' ns)) -> mkClosure c b b' (1 : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) -> -> mkClosure -> (combine_IdEnvs (+) c c') -> (dom_IdEnv c' `merge2` b'' `merge2` b) -> (b'' `merge2` b') -> ns )) -> mkClosure c b b' (n : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) -> -> mkClosure c -> (dom_IdEnv c' `merge2` b'' `merge2` b) -> (dom_IdEnv c' `merge2` b'' `merge2` b') -> ns )) +\begin{code} +convertUpdateSpec :: UpdateSpec -> Closure +convertUpdateSpec = mkClosure null_IdEnv noRefs noRefs + +mkClosure :: IdEnvInt -> Refs -> Refs -> UpdateSpec -> Closure + +mkClosure c b b' [] = (c, b', dont_know b') +mkClosure c b b' (0 : ns) = (null_IdEnv, b, Fun (\ _ -> mkClosure c b b' ns)) +mkClosure c b b' (1 : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) -> + mkClosure + (combine_IdEnvs (+) c c') + (dom_IdEnv c' `merge2` b'' `merge2` b) + (b'' `merge2` b') + ns )) +mkClosure c b b' (n : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) -> + mkClosure c + (dom_IdEnv c' `merge2` b'' `merge2` b) + (dom_IdEnv c' `merge2` b'' `merge2` b') + ns )) +\end{code} Convert a Closure into a representation that can be placed in a .hi file. -> mkUpdateSpec :: Id -> Closure -> UpdateSpec -> mkUpdateSpec v f = {- removeSuperfluous2s -} (map countUses ids) -> where -> (c,b,_) = foldl doApp f ids -> ids = map mkid (getBuiltinUniques arity) -> mkid u = mkSysLocal SLIT("upd") u noType noSrcLoc -> countUses u = if u `elemRefs` b then 2 else min (lookupc c u) 2 -> noType = panic "UpdAnal: no type!" -> -> doApp (c,b,Fun f) i -> = f (unit_IdEnv i 1, noRefs, dont_know noRefs) =: \(c',b',f') -> -> (combine_IdEnvs (+) c' c, b', f') -> -> (_,dict_tys,tau_ty) = (splitSigmaTy . idType) v -> (reg_arg_tys, _) = splitFunTy tau_ty -> arity = length dict_tys + length reg_arg_tys +\begin{code} +mkUpdateSpec :: Id -> Closure -> UpdateSpec +mkUpdateSpec v f = {- removeSuperfluous2s -} (map countUses ids) + where + (c,b,_) = foldl doApp f ids + ids = map mkid (getBuiltinUniques arity) + mkid u = mkSysLocal SLIT("upd") u noType noSrcLoc + countUses u = if u `elemRefs` b then 2 else min (lookupc c u) 2 + noType = panic "UpdAnal: no type!" + + doApp (c,b,Fun f) i + = f (unit_IdEnv i 1, noRefs, dont_know noRefs) =: \(c',b',f') -> + (combine_IdEnvs (+) c' c, b', f') + + (_,dict_tys,tau_ty) = (splitSigmaTy . idType) v + (reg_arg_tys, _) = splitFunTys tau_ty + arity = length dict_tys + length reg_arg_tys +\end{code} removeSuperfluous2s = reverse . dropWhile (> 1) . reverse @@ -499,16 +540,18 @@ This is so that the information can later be retrieved for printing out in the .hi file. This is not an ideal solution, however it will suffice for now. -> attachUpdateInfoToBinds b p -> = case b of -> StgNonRec v rhs -> StgNonRec (attachOne v) rhs -> StgRec bs -> StgRec [ (attachOne v, rhs) | (v, rhs) <- bs ] -> -> where attachOne v -> | externallyVisibleId v -> = let c = lookup v p in -> addIdUpdateInfo v -> (mkUpdateInfo (mkUpdateSpec v c)) -> | otherwise = v +\begin{code} +attachUpdateInfoToBinds b p + = case b of + StgNonRec v rhs -> StgNonRec (attachOne v) rhs + StgRec bs -> StgRec [ (attachOne v, rhs) | (v, rhs) <- bs ] + + where attachOne v + | externallyVisibleId v + = let c = lookup v p in + addIdUpdateInfo v + (mkUpdateInfo (mkUpdateSpec v c)) + | otherwise = v +\end{code} %----------------------------------------------------------------------------- diff --git a/ghc/compiler/specialise/SpecEnv.hi-boot b/ghc/compiler/specialise/SpecEnv.hi-boot index 466e8c4013..077a6efc69 100644 --- a/ghc/compiler/specialise/SpecEnv.hi-boot +++ b/ghc/compiler/specialise/SpecEnv.hi-boot @@ -1,7 +1,5 @@ _interface_ SpecEnv 1 _exports_ -SpecEnv SpecEnv nullSpecEnv isNullSpecEnv; +SpecEnv SpecEnv ; _declarations_ -1 data SpecEnv; -1 isNullSpecEnv _:_ SpecEnv.SpecEnv -> PrelBase.Bool ;; -1 nullSpecEnv _:_ SpecEnv.SpecEnv ;; +1 data SpecEnv a ; diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs index 44f6fd2ecb..168e467953 100644 --- a/ghc/compiler/specialise/SpecEnv.lhs +++ b/ghc/compiler/specialise/SpecEnv.lhs @@ -4,81 +4,118 @@ \section[SpecEnv]{Specialisation info about an @Id@} \begin{code} -#include "HsVersions.h" - module SpecEnv ( - SYN_IE(SpecEnv), MatchEnv, - nullSpecEnv, isNullSpecEnv, - addOneToSpecEnv, lookupSpecEnv + SpecEnv, + emptySpecEnv, isEmptySpecEnv, + addToSpecEnv, matchSpecEnv, unifySpecEnv ) where -IMP_Ubiq() +#include "HsVersions.h" -import MatchEnv -import Type --( matchTys, isTyVarTy ) -import Usage ( SYN_IE(UVar) ) -import OccurAnal ( occurAnalyseGlobalExpr ) -import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(SimplifiableCoreExpr) ) -import Maybes ( MaybeErr(..) ) -import TyVar --ToDo:rm +import Type ( Type, GenType, matchTys, tyVarsOfTypes ) +import TyVar ( TyVar, TyVarEnv, lookupTyVarEnv, tyVarSetToList ) +import Unify ( Subst, unifyTyListsX ) +import Maybes +import Util ( assertPanic ) \end{code} -A @SpecEnv@ holds details of an @Id@'s specialisations. It should be -a newtype (ToDo), but for 1.2 compatibility we make it a data type. -It can't be a synonym because there's an IdInfo instance of it -that doesn't work if it's (MatchEnv a b). -Furthermore, making it a data type makes it easier to break the IdInfo loop. + +%************************************************************************ +%* * +\section{SpecEnv} +%* * +%************************************************************************ \begin{code} -data SpecEnv = SpecEnv (MatchEnv [Type] SimplifiableCoreExpr) +data SpecEnv value + = EmptySE + | SpecEnv [([Type], value)] -- No pair of templates unify with each others \end{code} -For example, if \tr{f}'s @SpecEnv@ contains the mapping: -\begin{verbatim} - [List a, b] ===> (\d -> f' a b) -\end{verbatim} -then when we find an application of f to matching types, we simply replace -it by the matching RHS: -\begin{verbatim} - f (List Int) Bool ===> (\d -> f' Int Bool) -\end{verbatim} -All the stuff about how many dictionaries to discard, and what types -to apply the specialised function to, are handled by the fact that the -SpecEnv contains a template for the result of the specialisation. - -There is one more exciting case, which is dealt with in exactly the same -way. If the specialised value is unboxed then it is lifted at its -definition site and unlifted at its uses. For example: - - pi :: forall a. Num a => a +For now we just use association lists. -might have a specialisation - - [Int#] ===> (case pi' of Lift pi# -> pi#) +\begin{code} +emptySpecEnv :: SpecEnv a +emptySpecEnv = EmptySE -where pi' :: Lift Int# is the specialised version of pi. +isEmptySpecEnv EmptySE = True +isEmptySpecEnv _ = False +\end{code} +@lookupSpecEnv@ looks up in a @SpecEnv@. Since no pair of templates +unify, the first match must be the only one. \begin{code} -nullSpecEnv :: SpecEnv -nullSpecEnv = SpecEnv nullMEnv - -isNullSpecEnv :: SpecEnv -> Bool -isNullSpecEnv (SpecEnv env) = null (mEnvToList env) - -addOneToSpecEnv :: SpecEnv -> [Type] -> CoreExpr -> MaybeErr SpecEnv ([Type], SimplifiableCoreExpr) -addOneToSpecEnv (SpecEnv env) tys rhs - = --pprTrace "addOneToSpecEnv" (($$) (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 = --pprTrace "lookupSpecEnv" (ppr PprDebug tys) $ - lookupMEnv matchTys env tys +data SpecEnvResult val + = Match Subst val -- Match, instantiating only + -- type variables in the template + + | CouldMatch -- A match could happen if the + -- some of the type variables in the key + -- were further instantiated. + + | NoMatch -- No match possible, regardless of how + -- the key is further instantiated + +-- If the key *unifies* with one of the templates, then the +-- result is Match or CouldMatch, depending on whether any of the +-- type variables in the key had to be instantiated + +unifySpecEnv :: SpecEnv value -- The envt + -> [Type] -- Key + -> SpecEnvResult value + + +unifySpecEnv EmptySE key = NoMatch +unifySpecEnv (SpecEnv alist) key + = find alist + where + find [] = NoMatch + find ((tpl, val) : rest) + = case unifyTyListsX tpl key of + Nothing -> find rest + Just subst | all uninstantiated (tyVarSetToList (tyVarsOfTypes key)) + -> Match subst val + | otherwise + -> CouldMatch + where + uninstantiated tv = case lookupTyVarEnv subst tv of + Just xx -> False + Nothing -> True + +-- matchSpecEnv does a one-way match only, but in return +-- it is more polymorphic than unifySpecEnv + +matchSpecEnv :: SpecEnv value -- The envt + -> [GenType flexi] -- Key + -> Maybe (TyVarEnv (GenType flexi), value) + +matchSpecEnv EmptySE key = Nothing +matchSpecEnv (SpecEnv alist) key + = find alist + where + find [] = Nothing + find ((tpl, val) : rest) + = case matchTys tpl key of + Nothing -> find rest + Just (subst, leftovers) -> ASSERT( null leftovers ) + Just (subst, val) \end{code} +@addToSpecEnv@ extends a @SpecEnv@, checking for overlaps. +\begin{code} +addToSpecEnv :: SpecEnv value -- Envt + -> [Type] -> value -- New item + -> MaybeErr (SpecEnv value) -- Success... + ([Type], value) -- Failure: Offending overlap + +addToSpecEnv EmptySE key value = returnMaB (SpecEnv [(key, value)]) +addToSpecEnv (SpecEnv alist) key value + = case filter matches_key alist of + [] -> returnMaB (SpecEnv ((key,value) : alist)) -- No match + (bad : _) -> failMaB bad -- At least one match + where + matches_key (tpl, val) = maybeToBool (unifyTyListsX tpl key) +\end{code} diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index 49335982f5..6a5f4a88cb 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -4,11 +4,9 @@ \section[Specialise]{Stamping out overloading, and (optionally) polymorphism} \begin{code} -#include "HsVersions.h" - module SpecUtils ( specialiseCallTys, - SYN_IE(ConstraintVector), + ConstraintVector, getIdOverloading, isUnboxedSpecialisation, @@ -20,42 +18,64 @@ module SpecUtils ( pprSpecErrs ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CmdLineOpts ( opt_SpecialiseOverloaded, opt_SpecialiseUnboxed, opt_SpecialiseAll, opt_PprUserLength ) import Bag ( isEmptyBag, bagToList, Bag ) -import Class ( GenClass{-instance NamedThing-}, SYN_IE(Class) ) +import Class ( Class ) import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM, lookupWithDefaultFM ) import Id ( idType, isDictFunId, - isDefaultMethodId_maybe, mkSameSpecCon, - GenId {-instance NamedThing -}, SYN_IE(Id) + isDefaultMethodId_maybe, + Id ) import Maybes ( maybeToBool, catMaybes, firstJust ) import Name ( OccName, pprOccName, modAndOcc, NamedThing(..) ) -import Outputable ( PprStyle(..), Outputable(..) ) +import Outputable import PprType ( pprGenType, pprParendGenType, pprMaybeTy, - TyCon{-ditto-}, GenType{-ditto-}, GenTyVar + TyCon ) -import Pretty -- plenty of it -import TyCon ( tyConTyVars, TyCon{-instance NamedThing-} ) -import Type ( splitSigmaTy, mkTyVarTy, mkForAllTys, - getTyVar_maybe, isUnboxedType, SYN_IE(Type) +import TyCon ( tyConTyVars ) +import Type ( mkSigmaTy, instantiateTauTy, instantiateThetaTy, + splitSigmaTy, mkTyVarTy, mkForAllTys, + getTyVar_maybe, isUnboxedType, Type ) -import TyVar ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) ) -import Unique ( Unique{-instance Eq-} ) -import Util ( equivClasses, zipWithEqual, cmpPString, +import TyVar ( TyVar, mkTyVarEnv ) +import Util ( equivClasses, zipWithEqual, assertPanic, panic{-ToDo:rm-} ) cmpType = panic "SpecUtils.cmpType (ToDo: get rid of)" getInstIdModule = panic "SpecUtils.getInstIdModule (ToDo)" +mkSameSpecCon = panic "SpecUtils.mkSameSpecCon (ToDo)" \end{code} + +\begin{code} +specialiseTy :: Type -- The type of the Id of which the SpecId + -- is a specialised version + -> [Maybe Type] -- The types at which it is specialised + -> Int -- Number of leading dictionary args to ignore + -> Type + +specialiseTy main_ty maybe_tys dicts_to_ignore + = mkSigmaTy remaining_tyvars + (instantiateThetaTy inst_env remaining_theta) + (instantiateTauTy inst_env tau) + where + (tyvars, theta, tau) = splitSigmaTy main_ty -- A prefix of, but usually all, + -- the theta is discarded! + remaining_theta = drop dicts_to_ignore theta + tyvars_and_maybe_tys = tyvars `zip` maybe_tys + remaining_tyvars = [tyvar | (tyvar, Nothing) <- tyvars_and_maybe_tys] + inst_env = mkTyVarEnv [(tyvar,ty) | (tyvar, Just ty) <- tyvars_and_maybe_tys] +\end{code} + + @specialiseCallTys@ works out which type args don't need to be specialised on, based on flags, the overloading constraint vector, and the types. @@ -102,6 +122,11 @@ gained by specialising wrt them. \begin{code} getIdOverloading :: Id -> ([TyVar], [(Class,TyVar)]) +getIdOverloading = panic "getIdOverloading" + +-- Looks suspicious to me; and I'm not sure what corresponds to +-- (Class,TyVar) pairs in the multi-param type class world. +{- getIdOverloading id = (tyvars, tyvar_part_of theta) where @@ -111,6 +136,7 @@ getIdOverloading id tyvar_part_of ((c,ty):theta) = case (getTyVar_maybe ty) of Nothing -> [] Just tv -> (c, tv) : tyvar_part_of theta +-} \end{code} \begin{code} @@ -157,20 +183,20 @@ with a list of specialising types. An error message is returned if not. \begin{code} argTysMatchSpecTys_error :: [Maybe Type] -> [Type] - -> Maybe Doc + -> Maybe SDoc argTysMatchSpecTys_error spec_tys arg_tys = if match spec_tys arg_tys then Nothing else Just (sep [ptext SLIT("Spec and Arg Types Inconsistent:"), - ptext SLIT("spectys="), sep [pprMaybeTy PprDebug ty | ty <- spec_tys], - ptext SLIT("argtys="), sep [pprParendGenType PprDebug ty | ty <- arg_tys]]) + ptext SLIT("spectys="), sep [pprMaybeTy ty | ty <- spec_tys], + ptext SLIT("argtys="), sep [pprParendGenType ty | ty <- arg_tys]]) where match (Nothing:spec_tys) (arg:arg_tys) = not (isUnboxedType arg) && match spec_tys arg_tys match (Just spec:spec_tys) (arg:arg_tys) = case (cmpType True{-properly-} spec arg) of - EQ_ -> match spec_tys arg_tys + EQ -> match spec_tys arg_tys other -> False match [] [] = True match _ _ = False @@ -184,7 +210,7 @@ pprSpecErrs :: FAST_STRING -- module name -> (Bag (Id,[Maybe Type])) -- errors -> (Bag (Id,[Maybe Type])) -- warnings -> (Bag (TyCon,[Maybe Type])) -- errors - -> Doc + -> SDoc pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs | not any_errs && not any_warn @@ -237,26 +263,26 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs (mod_name, ty_name) = modAndOcc ty module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm] - mods = map head (equivClasses _CMP_STRING_ module_names) + mods = map head (equivClasses compare module_names) (unks, known) = if null mods then ([], []) - else case _CMP_STRING_ (head mods) _NIL_ of - EQ_ -> ([_NIL_], tail mods) + else case head mods `compare` _NIL_ of + EQ -> ([_NIL_], tail mods) other -> ([], mods) use_modules = unks ++ known - pp_module_specs :: FAST_STRING -> Doc + pp_module_specs :: FAST_STRING -> SDoc pp_module_specs mod | mod == _NIL_ = ASSERT (null mod_tyspecs) - vcat (map (pp_idspec ty_sty (ptext SLIT("UNKNOWN:"))) mod_idspecs) + vcat (map (pp_idspec (ptext SLIT("UNKNOWN:"))) mod_idspecs) | have_specs = vcat [ - vcat (map (pp_tyspec ty_sty (pp_module mod)) mod_tyspecs), - vcat (map (pp_idspec ty_sty (pp_module mod)) mod_idspecs) + vcat (map (pp_tyspec (pp_module mod)) mod_tyspecs), + vcat (map (pp_idspec (pp_module mod)) mod_idspecs) ] | otherwise @@ -266,17 +292,16 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs mod_tyspecs = lookupWithDefaultFM tyspecs_fm [] mod mod_idspecs = lookupWithDefaultFM idspecs_fm [] mod have_specs = not (null mod_tyspecs && null mod_idspecs) - ty_sty = PprInterface pp_module mod = hcat [ptext mod, char ':'] -pp_tyspec :: PprStyle -> Doc -> (OccName, TyCon, [Maybe Type]) -> Doc +pp_tyspec :: SDoc -> (OccName, TyCon, [Maybe Type]) -> SDoc -pp_tyspec sty pp_mod (_, tycon, tys) +pp_tyspec pp_mod (_, tycon, tys) = hsep [pp_mod, text "{-# SPECIALIZE data", - ppr (PprForUser opt_PprUserLength) tycon, hsep (map (pprParendGenType sty) spec_tys), + ppr tycon, hsep (map pprParendGenType spec_tys), text "-} {- Essential -}" ] where @@ -287,16 +312,16 @@ pp_tyspec sty pp_mod (_, tycon, tys) choose_ty (tv, Nothing) = (mkTyVarTy tv, Just tv) choose_ty (tv, Just ty) = (ty, Nothing) -pp_idspec :: PprStyle -> Doc -> (OccName, Id, [Maybe Type], Bool) -> Doc +pp_idspec :: SDoc -> (OccName, Id, [Maybe Type], Bool) -> SDoc pp_idspec = error "pp_idspec" {- LATER -pp_idspec sty pp_mod (_, id, tys, is_err) +pp_idspec pp_mod (_, id, tys, is_err) | isDictFunId id = hsep [pp_mod, text "{-# SPECIALIZE instance", - pprGenType sty spec_ty, + pprGenType spec_ty, text "#-}", pp_essential ] | is_const_method_id @@ -305,10 +330,10 @@ pp_idspec sty pp_mod (_, id, tys, is_err) in hsep [pp_mod, text "{-# SPECIALIZE", - ppr sty clsop, text "::", - pprGenType sty spec_ty, + ppr clsop, text "::", + pprGenType spec_ty, text "#-} {- IN instance", - pprOccName sty (getOccName cls), pprParendGenType sty clsty, + pprOccName (getOccName cls), pprParendGenType clsty, text "-}", pp_essential ] | is_default_method_id @@ -317,17 +342,17 @@ pp_idspec sty pp_mod (_, id, tys, is_err) in hsep [pp_mod, text "{- instance", - pprOccName sty (getOccName cls), + pprOccName (getOccName cls), ptext SLIT("EXPLICIT METHOD REQUIRED"), - ppr sty clsop, text "::", - pprGenType sty spec_ty, + ppr clsop, text "::", + pprGenType spec_ty, text "-}", pp_essential ] | otherwise = hsep [pp_mod, text "{-# SPECIALIZE", - ppr (PprForUser opt_PprUserLength) id, ptext SLIT("::"), - pprGenType sty spec_ty, + ppr id, ptext SLIT("::"), + pprGenType spec_ty, text "#-}", pp_essential ] where spec_ty = specialiseTy (idType id) tys 100 -- HACK to drop all dicts!!! diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 504ea360c8..6bed59f2e3 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -4,8 +4,6 @@ \section[Specialise]{Stamping out overloading, and (optionally) polymorphism} \begin{code} -#include "HsVersions.h" - module Specialise ( specProgram, initSpecData, @@ -13,13 +11,12 @@ module Specialise ( SpecialiseData(..) ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(List(partition)) +#include "HsVersions.h" import Bag ( emptyBag, unitBag, isEmptyBag, unionBags, partitionBag, listToBag, bagToList, Bag ) -import Class ( GenClass{-instance Eq-}, SYN_IE(Class) ) +import Class ( Class ) import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats, opt_SpecialiseTrace ) @@ -34,33 +31,29 @@ import Id ( idType, isDefaultMethodId_maybe, toplevelishId, isImportedId, mkIdWithNewUniq, dataConTyCon, applyTypeEnvToId, nullIdEnv, addOneToIdEnv, growIdEnvList, - lookupIdEnv, SYN_IE(IdEnv), + lookupIdEnv, IdEnv, emptyIdSet, mkIdSet, unitIdSet, elementOfIdSet, minusIdSet, - unionIdSets, unionManyIdSets, SYN_IE(IdSet), - GenId{-instance Eq-}, SYN_IE(Id) + unionIdSets, unionManyIdSets, IdSet, + GenId{-instance Eq-}, Id ) import Literal ( Literal{-instance Outputable-} ) import Maybes ( catMaybes, firstJust, maybeToBool ) import Name ( isLocallyDefined ) -import Outputable ( PprStyle(..), interppSP, Outputable(..){-instance * []-} ) import PprType ( pprGenType, pprParendGenType, pprMaybeTy, GenType{-instance Outputable-}, GenTyVar{-ditto-}, TyCon{-ditto-} ) -import Pretty ( hang, hsep, text, vcat, hcat, ptext, char, - int, space, empty, Doc - ) import PrimOp ( PrimOp(..) ) import SpecUtils -import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyConExpandingDicts, - tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType, isDictTy, - SYN_IE(Type) +import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, splitAlgTyConApp, + tyVarsOfTypes, instantiateTy, isUnboxedType, isDictTy, + Type ) import TyCon ( TyCon{-instance Eq-} ) import TyVar ( cloneTyVar, mkSysTyVar, - elementOfTyVarSet, SYN_IE(TyVarSet), - nullTyVarEnv, growTyVarEnvList, SYN_IE(TyVarEnv), + elementOfTyVarSet, TyVarSet, + emptyTyVarEnv, growTyVarEnvList, TyVarEnv, GenTyVar{-instance Eq-} ) import TysWiredIn ( liftDataCon ) @@ -68,8 +61,10 @@ import Unique ( Unique{-instance Eq-} ) import UniqSet ( mkUniqSet, unionUniqSets, uniqSetToList ) import UniqSupply ( splitUniqSupply, getUniques, getUnique ) import Util ( equivClasses, mapAccumL, assoc, zipEqual, zipWithEqual, - thenCmp, panic, pprTrace, pprPanic, assertPanic + thenCmp ) +import List ( partition ) +import Outputable infixr 9 `thenSM` @@ -717,18 +712,18 @@ data CallInstance \begin{code} pprCI :: CallInstance -> Doc pprCI (CallInstance id spec_tys dicts _ maybe_specinfo) - = hang (hsep [ptext SLIT("Call inst for"), ppr PprDebug id]) - 4 (vcat [hsep (text "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]), + = hang (hsep [ptext SLIT("Call inst for"), ppr id]) + 4 (vcat [hsep (text "types" : [pprMaybeTy ty | ty <- spec_tys]), case maybe_specinfo of - Nothing -> hsep (text "dicts" : [ppr_arg PprDebug dict | dict <- dicts]) + Nothing -> hsep (text "dicts" : [ppr_arg dict | dict <- dicts]) Just (SpecInfo _ _ spec_id) - -> hsep [ptext SLIT("Explicit SpecId"), ppr PprDebug spec_id] + -> hsep [ptext SLIT("Explicit SpecId"), ppr spec_id] ]) -- ToDo: instance Outputable CoreArg? -ppr_arg sty (TyArg t) = ppr sty t -ppr_arg sty (LitArg i) = ppr sty i -ppr_arg sty (VarArg v) = ppr sty v +ppr_arg (TyArg t) = ppr sty t +ppr_arg (LitArg i) = ppr sty i +ppr_arg (VarArg v) = ppr sty v isUnboxedCI :: CallInstance -> Bool isUnboxedCI (CallInstance _ spec_tys _ _ _) @@ -745,17 +740,17 @@ Comparisons are based on the {\em types}, ignoring the dictionary args: \begin{code} -cmpCI :: CallInstance -> CallInstance -> TAG_ +cmpCI :: CallInstance -> CallInstance -> Ordering cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _) - = cmp id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2 + = compare id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2 -cmpCI_tys :: CallInstance -> CallInstance -> TAG_ +cmpCI_tys :: CallInstance -> CallInstance -> Ordering cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _) = cmpUniTypeMaybeList tys1 tys2 eqCI_tys :: CallInstance -> CallInstance -> Bool eqCI_tys c1 c2 - = case cmpCI_tys c1 c2 of { EQ_ -> True; other -> False } + = case cmpCI_tys c1 c2 of { EQ -> True; other -> False } isCIofTheseIds :: [Id] -> CallInstance -> Bool isCIofTheseIds ids (CallInstance ci_id _ _ _ _) @@ -795,7 +790,7 @@ getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i) in -- pprTrace "getCIs:" -- (hang (hcat [char '{', - -- interppSP PprDebug ids, + -- interppSP ids, -- char '}']) -- 4 (vcat (map pprCI cis_here_list))) (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i) @@ -824,7 +819,7 @@ dumpCIs cis top_lev floating inst_cis bound_ids full_ids pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++ " (may be a non-HM recursive call)\n") (hang (hcat [char '{', - interppSP PprDebug bound_ids, + interppSP bound_ids, char '}']) 4 (vcat [ptext SLIT("Dumping CIs:"), vcat (map pprCI (bagToList cis_of_bound_id)), @@ -837,7 +832,7 @@ dumpCIs cis top_lev floating inst_cis bound_ids full_ids (if not (isEmptyBag cis_dump_unboxed) then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n" (hang (hcat [char '{', - interppSP PprDebug full_ids, + interppSP full_ids, char '}']) 4 (vcat (map pprCI (bagToList cis_dump)))) else id) @@ -890,11 +885,11 @@ data TyConInstance = TyConInstance TyCon -- Type Constructor [Maybe Type] -- Applied to these specialising types -cmpTyConI :: TyConInstance -> TyConInstance -> TAG_ +cmpTyConI :: TyConInstance -> TyConInstance -> Ordering cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2) - = cmp tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2 + = compare tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2 -cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_ +cmpTyConI_tys :: TyConInstance -> TyConInstance -> Ordering cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2) = cmpUniTypeMaybeList tys1 tys2 @@ -1237,7 +1232,7 @@ specTyConsAndScope scopeM (if opt_SpecialiseTrace && not (null tycon_specs_list) then pprTrace "Specialising TyCons:\n" (vcat [ if not (null specs) then - hang (hsep [(ppr PprDebug tycon), ptext SLIT("at types")]) + hang (hsep [(ppr tycon), ptext SLIT("at types")]) 4 (vcat (map pp_specs specs)) else empty | (tycon, specs) <- tycon_specs_list]) @@ -1254,7 +1249,7 @@ specTyConsAndScope scopeM uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis) tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis] - pp_specs (False, spec_tys) = hsep [pprMaybeTy PprDebug spec_ty | spec_ty <- spec_tys] + pp_specs (False, spec_tys) = hsep [pprMaybeTy spec_ty | spec_ty <- spec_tys] \end{code} @@ -1535,7 +1530,7 @@ specAlts (AlgAlts alts deflt) scrutinee_ty args -- alternatives: (_, ty_args, _) = --trace "Specialise.specAlts:getAppData..." $ - getAppDataTyConExpandingDicts scrutinee_ty + splitAlgTyConApp scrutinee_ty specAlgAlt ty_args (con,binders,rhs) = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) -> @@ -1841,9 +1836,9 @@ instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis then pprTrace "dumpCIs: not same overloading ... top level \n" else (\ x y -> y) ) (hang (hcat [ptext SLIT("{"), - interppSP PprDebug new_ids, + interppSP new_ids, ptext SLIT("}")]) - 4 (vcat [vcat (map (pprGenType PprDebug . idType) new_ids), + 4 (vcat [vcat (map (pprGenType . idType) new_ids), vcat (map pprCI (concat equiv_ciss))])) (returnSM ([], emptyUDs, [])) @@ -2022,7 +2017,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)), tickSpecInsts final_uds, spec_info) where - lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys + lookup_orig_spec = matchSpecEnv (getIdSpecialisation orig_id) arg_tys explicit_cis_for_this_id = filter (isCIofTheseIds [new_id]) explicit_cis [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id @@ -2031,19 +2026,19 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis trace_nospec :: String -> Id -> a -> a trace_nospec str spec_id = pprTrace str - (hsep [ppr PprDebug new_id, hsep (map pp_ty arg_tys), - ptext SLIT("==>"), ppr PprDebug spec_id]) + (hsep [ppr new_id, hsep (map pp_ty arg_tys), + ptext SLIT("==>"), ppr spec_id]) in (if opt_SpecialiseTrace then pprTrace "Specialising:" (hang (hcat [char '{', - interppSP PprDebug new_ids, + interppSP new_ids, char '}']) 4 (vcat [ hcat [ptext SLIT("types: "), hsep (map pp_ty arg_tys)], if isExplicitCI do_cis then empty else hcat [ptext SLIT("dicts: "), hsep (map pp_dict dict_args)], - hcat [ptext SLIT("specs: "), ppr PprDebug spec_ids]])) + hcat [ptext SLIT("specs: "), ppr spec_ids]])) else id) ( do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) -> @@ -2051,8 +2046,8 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis returnSM (maybe_inst_bind, inst_uds, spec_infos) ) where - pp_dict d = ppr_arg PprDebug d - pp_ty t = pprParendGenType PprDebug t + pp_dict d = ppr_arg d + pp_ty t = pprParendGenType t do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar) do_the_wotsit tyvars (Just ty) = (tyvars, ty) @@ -2139,16 +2134,16 @@ mkTyConInstance con tys case record_inst of Nothing -- No TyCon instance -> -- pprTrace "NoTyConInst:" - -- (hsep [ppr PprDebug tycon, ptext SLIT("at"), - -- ppr PprDebug con, hsep (map (ppr PprDebug) tys)]) + -- (hsep [ppr tycon, ptext SLIT("at"), + -- ppr con, hsep (map (ppr) tys)]) (returnSM (singleConUDs con)) Just spec_tys -- Record TyCon instance -> -- pprTrace "TyConInst:" - -- (hsep [ppr PprDebug tycon, ptext SLIT("at"), - -- ppr PprDebug con, hsep (map (ppr PprDebug) tys), + -- (hsep [ppr tycon, ptext SLIT("at"), + -- ppr con, hsep (map (ppr) tys), -- hcat [char '(', - -- hsep [pprMaybeTy PprDebug ty | ty <- spec_tys], + -- hsep [pprMaybeTy ty | ty <- spec_tys], -- char ')']]) (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con)) where @@ -2172,7 +2167,7 @@ recordTyConInst con tys in -- pprTrace "ConSpecExists?: " -- (vcat [ptext (if spec_exists then SLIT("True") else SLIT("False")), - -- ppr PprShowAll con, hsep (map (ppr PprDebug) tys)]) + -- ppr PprShowAll con, hsep (map ppr tys)]) (if (not spec_exists && do_tycon_spec) then returnSM (Just spec_tys) else returnSM Nothing) @@ -2203,7 +2198,7 @@ type SpecM result -> UniqSupply -> result -initSM m uniqs = m nullTyVarEnv nullIdEnv uniqs +initSM m uniqs = m emptyTyVarEnv nullIdEnv uniqs returnSM :: a -> SpecM a thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b @@ -2348,8 +2343,7 @@ bindSpecIds olds clones spec_infos specm tvenv idenv us mk_old_to_clone rest_olds rest_clones spec_infos_rest where add_spec_info (NoLift (VarArg new)) - = NoLift (VarArg (new `addIdSpecialisation` - (mkSpecEnv spec_infos_this_id))) + = NoLift (VarArg (new `addIdSpecialisation` (mkSpecEnv spec_infos_this_id))) add_spec_info lifted = lifted -- no specialised instances for unboxed lifted values @@ -2376,7 +2370,7 @@ lookupId id tvenv idenv us specTy :: Type -> SpecM Type -- Apply the current type envt to the type specTy ty tvenv idenv us - = applyTypeEnvToTy tvenv ty + = instantiateTy tvenv ty \end{code} \begin{code} @@ -2488,10 +2482,10 @@ mkCall new_id arg_infos = returnSM ( (Var unlift_spec_id)) else pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n" - (hsep [ppr PprDebug new_id, - hsep (map (pprParendGenType PprDebug) ty_args), + (hsep [ppr new_id, + hsep (map (pprParendGenType) ty_args), ptext SLIT("==>"), - ppr PprDebug spec_id]) + ppr spec_id]) else let (vals_left, _, unlifts_left) = unzip3 args_left @@ -2526,18 +2520,18 @@ checkUnspecOK :: Id -> [Type] -> a -> a checkUnspecOK check_id tys = if isLocallyDefined check_id && any isUnboxedType tys then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n" - (hsep [ppr PprDebug check_id, - hsep (map (pprParendGenType PprDebug) tys)]) + (hsep [ppr check_id, + hsep (map (pprParendGenType) tys)]) else id checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a checkSpecOK check_id tys spec_id tys_left = if any isUnboxedType tys_left then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n" - (vcat [hsep [ppr PprDebug check_id, - hsep (map (pprParendGenType PprDebug) tys)], - hsep [ppr PprDebug spec_id, - hsep (map (pprParendGenType PprDebug) tys_left)]]) + (vcat [hsep [ppr check_id, + hsep (map (pprParendGenType) tys)], + hsep [ppr spec_id, + hsep (map (pprParendGenType) tys_left)]]) else id -} \end{code} diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 16ab5e5fea..d38db7ca30 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -10,12 +10,9 @@ Convert a @CoreSyntax@ program to a @StgSyntax@ program. \begin{code} -#include "HsVersions.h" - module CoreToStg ( topCoreBindsToStg ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(Ratio(numerator,denominator)) +#include "HsVersions.h" import CoreSyn -- input import StgSyn -- output @@ -27,7 +24,7 @@ import Id ( mkSysLocal, idType, isBottomingId, externallyVisibleId, nullIdEnv, addOneToIdEnv, lookupIdEnv, growIdEnvList, - SYN_IE(IdEnv), GenId{-instance NamedThing-}, SYN_IE(Id) + IdEnv, GenId{-instance NamedThing-}, Id ) import Literal ( mkMachInt, Literal(..) ) import PrelVals ( unpackCStringId, unpackCString2Id, @@ -35,16 +32,15 @@ import PrelVals ( unpackCStringId, unpackCString2Id, integerPlusTwoId, integerMinusOneId ) import PrimOp ( PrimOp(..) ) -import SpecUtils ( mkSpecialisedCon ) import SrcLoc ( noSrcLoc ) import TyCon ( TyCon{-instance Uniquable-} ) -import Type ( getAppDataTyConExpandingDicts, SYN_IE(Type) ) +import Type ( splitAlgTyConApp, Type ) import TysWiredIn ( stringTy ) import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} ) import UniqSupply -- all of it, really -import Util ( zipLazy, panic, assertPanic, pprTrace {-TEMP-} ) -import Pretty +import Util ( zipLazy ) import Outputable +import Ratio ( numerator, denominator ) isLeakFreeType x y = False -- safe option; ToDo \end{code} @@ -208,7 +204,6 @@ coreArgsToStg env [] = ([], []) coreArgsToStg env (a:as) = case a of TyArg t -> (t:trest, vrest) - UsageArg u -> (trest, vrest) VarArg v -> (trest, stgLookup env v : vrest) LitArg l -> (trest, StgLitArg l : vrest) where @@ -234,9 +229,8 @@ coreExprToStg env (Var var) coreExprToStg env (Con con args) = let (types, stg_atoms) = coreArgsToStg env args - spec_con = mkSpecialisedCon con types in - returnUs (StgCon spec_con stg_atoms bOGUS_LVs) + returnUs (StgCon con stg_atoms bOGUS_LVs) coreExprToStg env (Prim op args) = let @@ -254,7 +248,7 @@ coreExprToStg env (Prim op args) \begin{code} coreExprToStg env expr@(Lam _ _) = let - (_,_, binders, body) = collectBinders expr + (_, binders, body) = collectBinders expr in coreExprToStg env body `thenUs` \ stg_body -> @@ -310,7 +304,6 @@ coreExprToStg env expr@(App _ _) where -- Collect arguments, discarding type/usage applications collect_args (App e (TyArg _)) args = collect_args e args - collect_args (App e (UsageArg _)) args = collect_args e args collect_args (App fun arg) args = collect_args fun (arg:args) collect_args (Coerce _ _ expr) args = collect_args expr args collect_args fun args = (fun, args) @@ -336,7 +329,7 @@ coreExprToStg env (Case discrim alts) ) where discrim_ty = coreExprType discrim - (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty + (_, discrim_ty_args, _) = splitAlgTyConApp discrim_ty alts_to_stg discrim (AlgAlts alts deflt) = default_to_stg discrim deflt `thenUs` \ stg_deflt -> @@ -345,9 +338,7 @@ coreExprToStg env (Case discrim alts) where boxed_alt_to_stg (con, bs, rhs) = coreExprToStg env rhs `thenUs` \ stg_rhs -> - returnUs (spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs) - where - spec_con = mkSpecialisedCon con discrim_ty_args + returnUs (con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs) alts_to_stg discrim (PrimAlts alts deflt) = default_to_stg discrim deflt `thenUs` \ stg_deflt -> diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 70bbf41a58..a2d37a6dfe 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -4,11 +4,9 @@ \section[StgLint]{A ``lint'' pass to check for Stg correctness} \begin{code} -#include "HsVersions.h" - module StgLint ( lintStgBindings ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import StgSyn @@ -16,22 +14,23 @@ import Bag ( Bag, emptyBag, isEmptyBag, snocBag, foldBag ) import Id ( idType, isAlgCon, dataConArgTys, emptyIdSet, isEmptyIdSet, elementOfIdSet, mkIdSet, intersectIdSets, - unionIdSets, idSetToList, SYN_IE(IdSet), - GenId{-instanced NamedThing-}, SYN_IE(Id) + unionIdSets, idSetToList, IdSet, + GenId{-instanced NamedThing-}, Id ) import Literal ( literalType, Literal{-instance Outputable-} ) import Maybes ( catMaybes ) import Name ( isLocallyDefined, getSrcLoc ) -import Outputable ( PprStyle, Outputable(..){-instance * []-} ) +import ErrUtils ( ErrMsg ) import PprType ( GenType{-instance Outputable-}, TyCon ) -import Pretty -- quite a bit of it import PrimOp ( primOpType ) import SrcLoc ( SrcLoc{-instance Outputable-} ) -import Type ( mkFunTys, splitFunTy, maybeAppDataTyConExpandingDicts, - isTyVarTy, eqTy, splitFunTyExpandingDicts, SYN_IE(Type) +import Type ( mkFunTys, splitFunTys, splitAlgTyConApp_maybe, + isTyVarTy, Type ) import TyCon ( isDataTyCon ) -import Util ( zipEqual, pprPanic, panic, panic# ) +import Util ( zipEqual ) +import GlaExts ( trace ) +import Outputable infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_` @@ -51,17 +50,17 @@ Checks for @lintStgBindings@ is the top-level interface function. \begin{code} -lintStgBindings :: PprStyle -> String -> [StgBinding] -> [StgBinding] +lintStgBindings :: String -> [StgBinding] -> [StgBinding] -lintStgBindings sty whodunnit binds +lintStgBindings whodunnit binds = _scc_ "StgLint" case (initL (lint_binds binds)) of Nothing -> binds Just msg -> pprPanic "" (vcat [ - ptext SLIT("*** Stg Lint Errors: in "),text whodunnit, ptext SLIT(" ***"), - msg sty, + ptext SLIT("*** Stg Lint ErrMsgs: in "),text whodunnit, ptext SLIT(" ***"), + msg, ptext SLIT("*** Offending Program ***"), - pprStgBindings sty binds, + pprStgBindings binds, ptext SLIT("*** End of Offense ***")]) where lint_binds :: [StgBinding] -> LintM () @@ -181,7 +180,7 @@ lintStgExpr e@(StgCase scrut _ _ _ alts) = lintStgExpr scrut `thenMaybeL` \ _ -> -- Check that it is a data type - case (maybeAppDataTyConExpandingDicts scrut_ty) of + case (splitAlgTyConApp_maybe scrut_ty) of Just (tycon, _, _) | isDataTyCon tycon -> lintStgAlts alts scrut_ty tycon other -> addErrL (mkCaseDataConMsg e) `thenL_` @@ -221,7 +220,7 @@ lintStgAlts alts scrut_ty case_tycon check ty = checkTys first_ty ty (mkCaseAltMsg alts) lintAlgAlt scrut_ty (con, args, _, rhs) - = (case maybeAppDataTyConExpandingDicts scrut_ty of + = (case splitAlgTyConApp_maybe scrut_ty of Nothing -> addErrL (mkAlgAltMsg1 scrut_ty) Just (tycon, tys_applied, cons) -> @@ -271,31 +270,29 @@ type LintM a = [LintLocInfo] -- Locations -> Bag ErrMsg -- Error messages so far -> (a, Bag ErrMsg) -- Result and error messages (if any) -type ErrMsg = PprStyle -> Doc - data LintLocInfo = RhsOf Id -- The variable bound | LambdaBodyOf [Id] -- The lambda-binder | BodyOfLetRec [Id] -- One of the binders instance Outputable LintLocInfo where - ppr sty (RhsOf v) - = hcat [ppr sty (getSrcLoc v), ptext SLIT(": [RHS of "), pp_binders sty [v], char ']'] + ppr (RhsOf v) + = hcat [ppr (getSrcLoc v), ptext SLIT(": [RHS of "), pp_binders [v], char ']'] - ppr sty (LambdaBodyOf bs) - = hcat [ppr sty (getSrcLoc (head bs)), - ptext SLIT(": [in body of lambda with binders "), pp_binders sty bs, char ']'] + ppr (LambdaBodyOf bs) + = hcat [ppr (getSrcLoc (head bs)), + ptext SLIT(": [in body of lambda with binders "), pp_binders bs, char ']'] - ppr sty (BodyOfLetRec bs) - = hcat [ppr sty (getSrcLoc (head bs)), - ptext SLIT(": [in body of letrec with binders "), pp_binders sty bs, char ']'] + ppr (BodyOfLetRec bs) + = hcat [ppr (getSrcLoc (head bs)), + ptext SLIT(": [in body of letrec with binders "), pp_binders bs, char ']'] -pp_binders :: PprStyle -> [Id] -> Doc -pp_binders sty bs +pp_binders :: [Id] -> SDoc +pp_binders bs = sep (punctuate comma (map pp_binder bs)) where pp_binder b - = hsep [ppr sty b, ptext SLIT("::"), ppr sty (idType b)] + = hsep [ppr b, ptext SLIT("::"), ppr (idType b)] \end{code} \begin{code} @@ -305,9 +302,7 @@ initL m if isEmptyBag errs then Nothing else - Just ( \ sty -> - foldBag ($$) ( \ msg -> msg sty ) empty errs - ) + Just (foldBag ($$) (\ msg -> msg) empty errs) } returnL :: a -> LintM a @@ -362,9 +357,7 @@ addErrL msg loc scope errs = ((), addErr errs msg loc) addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg addErr errs_so_far msg locs - = errs_so_far `snocBag` ( \ sty -> - hang (ppr sty (head locs)) 4 (msg sty) - ) + = errs_so_far `snocBag` (hang (ppr (head locs)) 4 msg) addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m loc scope errs @@ -385,7 +378,7 @@ addInScopeVars ids m loc scope errs -- names after all. WDP 94/07 -- (if isEmptyIdSet shadowed -- then id --- else pprTrace "Shadowed vars:" (ppr PprDebug (idSetToList shadowed))) $ +-- else pprTrace "Shadowed vars:" (ppr (idSetToList shadowed))) $ m loc (scope `unionIdSets` new_set) errs \end{code} @@ -398,7 +391,7 @@ checkFunApp :: Type -- The function type checkFunApp fun_ty arg_tys msg loc scope errs = cfa res_ty expected_arg_tys arg_tys where - (expected_arg_tys, res_ty) = splitFunTyExpandingDicts fun_ty + (expected_arg_tys, res_ty) = splitFunTys fun_ty cfa res_ty expected [] -- Args have run out; that's fine = (Just (mkFunTys expected res_ty), errs) @@ -410,7 +403,7 @@ checkFunApp fun_ty arg_tys msg loc scope errs | isTyVarTy res_ty = (Just res_ty, errs) | otherwise - = case splitFunTy (unDictifyTy res_ty) of + = case splitFunTys (unDictifyTy res_ty) of ([], _) -> (Nothing, addErr errs msg loc) -- Too many args (new_expected, new_res) -> cfa new_res new_expected arg_tys @@ -424,7 +417,7 @@ checkFunApp fun_ty arg_tys msg loc scope errs checkInScope :: Id -> LintM () checkInScope id loc scope errs = if isLocallyDefined id && not (isAlgCon id) && not (id `elementOfIdSet` scope) then - ((), addErr errs (\ sty -> hsep [ppr sty id, ptext SLIT("is out of scope")]) loc) + ((), addErr errs (hsep [ppr id, ptext SLIT("is out of scope")]) loc) else ((), errs) @@ -437,99 +430,99 @@ checkTys ty1 ty2 msg loc scope errs \begin{code} mkCaseAltMsg :: StgCaseAlts -> ErrMsg -mkCaseAltMsg alts sty +mkCaseAltMsg alts = ($$) (text "In some case alternatives, type of alternatives not all same:") - -- LATER: (ppr sty alts) + -- LATER: (ppr alts) (panic "mkCaseAltMsg") mkCaseDataConMsg :: StgExpr -> ErrMsg -mkCaseDataConMsg expr sty +mkCaseDataConMsg expr = ($$) (ptext SLIT("A case scrutinee not a type-constructor type:")) - (pp_expr sty expr) + (pp_expr expr) mkCaseAbstractMsg :: TyCon -> ErrMsg -mkCaseAbstractMsg tycon sty +mkCaseAbstractMsg tycon = ($$) (ptext SLIT("An algebraic case on an abstract type:")) - (ppr sty tycon) + (ppr tycon) mkDefltMsg :: StgCaseDefault -> ErrMsg -mkDefltMsg deflt sty +mkDefltMsg deflt = ($$) (ptext SLIT("Binder in default case of a case expression doesn't match type of scrutinee:")) - --LATER: (ppr sty deflt) + --LATER: (ppr deflt) (panic "mkDefltMsg") mkFunAppMsg :: Type -> [Type] -> StgExpr -> ErrMsg -mkFunAppMsg fun_ty arg_tys expr sty +mkFunAppMsg fun_ty arg_tys expr = vcat [text "In a function application, function type doesn't match arg types:", - hang (ptext SLIT("Function type:")) 4 (ppr sty fun_ty), - hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr sty) arg_tys)), - hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)] + hang (ptext SLIT("Function type:")) 4 (ppr fun_ty), + hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys)), + hang (ptext SLIT("Expression:")) 4 (pp_expr expr)] mkRhsConMsg :: Type -> [Type] -> ErrMsg -mkRhsConMsg fun_ty arg_tys sty +mkRhsConMsg fun_ty arg_tys = vcat [text "In a RHS constructor application, con type doesn't match arg types:", - hang (ptext SLIT("Constructor type:")) 4 (ppr sty fun_ty), - hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr sty) arg_tys))] + hang (ptext SLIT("Constructor type:")) 4 (ppr fun_ty), + hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys))] mkUnappTyMsg :: Id -> Type -> ErrMsg -mkUnappTyMsg var ty sty +mkUnappTyMsg var ty = vcat [text "Variable has a for-all type, but isn't applied to any types.", - (<>) (ptext SLIT("Var: ")) (ppr sty var), - (<>) (ptext SLIT("Its type: ")) (ppr sty ty)] + (<>) (ptext SLIT("Var: ")) (ppr var), + (<>) (ptext SLIT("Its type: ")) (ppr ty)] mkAlgAltMsg1 :: Type -> ErrMsg -mkAlgAltMsg1 ty sty +mkAlgAltMsg1 ty = ($$) (text "In some case statement, type of scrutinee is not a data type:") - (ppr sty ty) + (ppr ty) mkAlgAltMsg2 :: Type -> Id -> ErrMsg -mkAlgAltMsg2 ty con sty +mkAlgAltMsg2 ty con = vcat [ text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", - ppr sty ty, - ppr sty con + ppr ty, + ppr con ] mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg -mkAlgAltMsg3 con alts sty +mkAlgAltMsg3 con alts = vcat [ text "In some algebraic case alternative, number of arguments doesn't match constructor:", - ppr sty con, - ppr sty alts + ppr con, + ppr alts ] mkAlgAltMsg4 :: Type -> Id -> ErrMsg -mkAlgAltMsg4 ty arg sty +mkAlgAltMsg4 ty arg = vcat [ text "In some algebraic case alternative, type of argument doesn't match data constructor:", - ppr sty ty, - ppr sty arg + ppr ty, + ppr arg ] mkPrimAltMsg :: (Literal, StgExpr) -> ErrMsg -mkPrimAltMsg alt sty +mkPrimAltMsg alt = ($$) (text "In a primitive case alternative, type of literal doesn't match type of scrutinee:") - (ppr sty alt) + (ppr alt) mkRhsMsg :: Id -> Type -> ErrMsg -mkRhsMsg binder ty sty +mkRhsMsg binder ty = vcat [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"), - ppr sty binder], - hsep [ptext SLIT("Binder's type:"), ppr sty (idType binder)], - hsep [ptext SLIT("Rhs type:"), ppr sty ty] + ppr binder], + hsep [ptext SLIT("Binder's type:"), ppr (idType binder)], + hsep [ptext SLIT("Rhs type:"), ppr ty] ] -pp_expr :: PprStyle -> StgExpr -> Doc -pp_expr sty expr = ppr sty expr +pp_expr :: StgExpr -> SDoc +pp_expr expr = ppr expr sleazy_eq_ty ty1 ty2 -- NB: probably severe overkill (WDP 95/04) = trace "StgLint.sleazy_eq_ty:use eqSimplTy?" $ - case (splitFunTyExpandingDicts ty1) of { (tyargs1,tyres1) -> - case (splitFunTyExpandingDicts ty2) of { (tyargs2,tyres2) -> + case (splitFunTys ty1) of { (tyargs1,tyres1) -> + case (splitFunTys ty2) of { (tyargs2,tyres2) -> let ty11 = mkFunTys tyargs1 tyres1 ty22 = mkFunTys tyargs2 tyres2 in - ty11 `eqTy` ty22 }} + ty11 == ty22 }} \end{code} diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 7a7a65fbce..704be4b1de 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -9,11 +9,9 @@ form of @CoreSyntax@, the style being one that happens to be ideally suited to spineless tagless code generation. \begin{code} -#include "HsVersions.h" - module StgSyn ( GenStgArg(..), - SYN_IE(GenStgLiveVars), + GenStgLiveVars, GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), GenStgCaseAlts(..), GenStgCaseDefault(..), @@ -26,9 +24,9 @@ module StgSyn ( combineStgBinderInfo, -- a set of synonyms for the most common (only :-) parameterisation - SYN_IE(StgArg), SYN_IE(StgLiveVars), - SYN_IE(StgBinding), SYN_IE(StgExpr), SYN_IE(StgRhs), - SYN_IE(StgCaseAlts), SYN_IE(StgCaseDefault), + StgArg, StgLiveVars, + StgBinding, StgExpr, StgRhs, + StgCaseAlts, StgCaseDefault, pprStgBinding, pprStgBindings, getArgPrimRep, @@ -37,22 +35,17 @@ module StgSyn ( collectFinalStgBinders ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CostCentre ( showCostCentre, CostCentre ) -import Id ( idPrimRep, SYN_IE(DataCon), - GenId{-instance NamedThing-}, SYN_IE(Id) ) +import Id ( idPrimRep, DataCon, + GenId{-instance NamedThing-}, Id ) import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} ) -import Outputable ( PprStyle(..), userStyle, - ifPprDebug, interppSP, interpp'SP, - Outputable(..){-instance * Bool-} - ) -import PprType ( GenType{-instance Outputable-} ) -import Pretty -- all of it +import Outputable import PrimOp ( PrimOp{-instance Outputable-} ) -import Type ( SYN_IE(Type) ) +import Type ( Type ) import Unique ( pprUnique, Unique ) -import UniqSet ( isEmptyUniqSet, uniqSetToList, SYN_IE(UniqSet) ) +import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet ) import Util ( panic ) \end{code} @@ -463,7 +456,7 @@ This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module. data UpdateFlag = ReEntrant | Updatable | SingleEntry instance Outputable UpdateFlag where - ppr sty u + ppr u = char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' }) \end{code} @@ -498,30 +491,30 @@ Robin Popplestone asked for semi-colon separators on STG binds; here's hoping he likes terminators instead... Ditto for case alternatives. \begin{code} -pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) => - PprStyle -> GenStgBinding bndr bdee -> Doc +pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) + => GenStgBinding bndr bdee -> SDoc -pprGenStgBinding sty (StgNonRec bndr rhs) - = hang (hsep [ppr sty bndr, equals]) - 4 ((<>) (ppr sty rhs) semi) +pprGenStgBinding (StgNonRec bndr rhs) + = hang (hsep [ppr bndr, equals]) + 4 ((<>) (ppr rhs) semi) -pprGenStgBinding sty (StgCoerceBinding bndr occ) - = hang (hsep [ppr sty bndr, equals, ptext SLIT("{-Coerce-}")]) - 4 ((<>) (ppr sty occ) semi) +pprGenStgBinding (StgCoerceBinding bndr occ) + = hang (hsep [ppr bndr, equals, ptext SLIT("{-Coerce-}")]) + 4 ((<>) (ppr occ) semi) -pprGenStgBinding sty (StgRec pairs) - = vcat ((ifPprDebug sty (ptext SLIT("{- StgRec (begin) -}"))) : - (map (ppr_bind sty) pairs) ++ [(ifPprDebug sty (ptext SLIT("{- StgRec (end) -}")))]) +pprGenStgBinding (StgRec pairs) + = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) : + (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))]) where - ppr_bind sty (bndr, expr) - = hang (hsep [ppr sty bndr, equals]) - 4 ((<>) (ppr sty expr) semi) + ppr_bind (bndr, expr) + = hang (hsep [ppr bndr, equals]) + 4 ((<>) (ppr expr) semi) -pprStgBinding :: PprStyle -> StgBinding -> Doc -pprStgBinding sty bind = pprGenStgBinding sty bind +pprStgBinding :: StgBinding -> SDoc +pprStgBinding bind = pprGenStgBinding bind -pprStgBindings :: PprStyle -> [StgBinding] -> Doc -pprStgBindings sty binds = vcat (map (pprGenStgBinding sty) binds) +pprStgBindings :: [StgBinding] -> SDoc +pprStgBindings binds = vcat (map (pprGenStgBinding) binds) \end{code} \begin{code} @@ -538,38 +531,38 @@ instance (Outputable bndr, Outputable bdee, Ord bdee) instance (Outputable bndr, Outputable bdee, Ord bdee) => Outputable (GenStgRhs bndr bdee) where - ppr sty rhs = pprStgRhs sty rhs + ppr rhs = pprStgRhs rhs \end{code} \begin{code} -pprStgArg :: (Outputable bdee) => PprStyle -> GenStgArg bdee -> Doc +pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc -pprStgArg sty (StgVarArg var) = ppr sty var -pprStgArg sty (StgConArg con) = ppr sty con -pprStgArg sty (StgLitArg lit) = ppr sty lit +pprStgArg (StgVarArg var) = ppr var +pprStgArg (StgConArg con) = ppr con +pprStgArg (StgLitArg lit) = ppr lit \end{code} \begin{code} -pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) => - PprStyle -> GenStgExpr bndr bdee -> Doc +pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) + => GenStgExpr bndr bdee -> SDoc -- special case -pprStgExpr sty (StgApp func [] lvs) - = (<>) (ppr sty func) (pprStgLVs sty lvs) +pprStgExpr (StgApp func [] lvs) + = (<>) (ppr func) (pprStgLVs lvs) -- general case -pprStgExpr sty (StgApp func args lvs) - = hang ((<>) (ppr sty func) (pprStgLVs sty lvs)) - 4 (sep (map (ppr sty) args)) +pprStgExpr (StgApp func args lvs) + = hang ((<>) (ppr func) (pprStgLVs lvs)) + 4 (sep (map (ppr) args)) \end{code} \begin{code} -pprStgExpr sty (StgCon con args lvs) - = hcat [ (<>) (ppr sty con) (pprStgLVs sty lvs), - ptext SLIT("! ["), interppSP sty args, char ']' ] +pprStgExpr (StgCon con args lvs) + = hcat [ (<>) (ppr con) (pprStgLVs lvs), + ptext SLIT("! ["), interppSP args, char ']' ] -pprStgExpr sty (StgPrim op args lvs) - = hcat [ ppr sty op, char '#', pprStgLVs sty lvs, - ptext SLIT(" ["), interppSP sty args, char ']' ] +pprStgExpr (StgPrim op args lvs) + = hcat [ ppr op, char '#', pprStgLVs lvs, + ptext SLIT(" ["), interppSP args, char ']' ] \end{code} \begin{code} @@ -581,135 +574,135 @@ pprStgExpr sty (StgPrim op args lvs) -- -- Very special! Suspicious! (SLPJ) -pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs)) +pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs)) expr@(StgLet _ _)) = ($$) - (hang (hcat [ptext SLIT("let { "), ppr sty bndr, ptext SLIT(" = "), - text (showCostCentre sty True{-as string-} cc), - pp_binder_info sty bi, - ptext SLIT(" ["), ifPprDebug sty (interppSP sty free_vars), ptext SLIT("] \\"), - ppr sty upd_flag, ptext SLIT(" ["), - interppSP sty args, char ']']) - 8 (sep [hsep [ppr sty rhs, ptext SLIT("} in")]])) - (ppr sty expr) + (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "), + text (showCostCentre True{-as string-} cc), + pp_binder_info bi, + ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"), + ppr upd_flag, ptext SLIT(" ["), + interppSP args, char ']']) + 8 (sep [hsep [ppr rhs, ptext SLIT("} in")]])) + (ppr expr) -- special case: let ... in let ... -pprStgExpr sty (StgLet bind expr@(StgLet _ _)) +pprStgExpr (StgLet bind expr@(StgLet _ _)) = ($$) - (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding sty bind, ptext SLIT("} in")])]) - (ppr sty expr) + (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])]) + (ppr expr) -- general case -pprStgExpr sty (StgLet bind expr) - = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding sty bind), - hang (ptext SLIT("} in ")) 2 (ppr sty expr)] +pprStgExpr (StgLet bind expr) + = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind), + hang (ptext SLIT("} in ")) 2 (ppr expr)] -pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr) +pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr) = sep [hang (ptext SLIT("let-no-escape {")) - 2 (pprGenStgBinding sty bind), + 2 (pprGenStgBinding bind), hang ((<>) (ptext SLIT("} in ")) - (ifPprDebug sty ( + (ifPprDebug ( nest 4 ( - hcat [ptext SLIT("-- lvs: ["), interppSP sty (uniqSetToList lvs_whole), - ptext SLIT("]; rhs lvs: ["), interppSP sty (uniqSetToList lvs_rhss), + hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole), + ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss), char ']'])))) - 2 (ppr sty expr)] + 2 (ppr expr)] \end{code} \begin{code} -pprStgExpr sty (StgSCC ty cc expr) - = sep [ hsep [ptext SLIT("_scc_"), text (showCostCentre sty True{-as string-} cc)], - pprStgExpr sty expr ] +pprStgExpr (StgSCC ty cc expr) + = sep [ hsep [ptext SLIT("_scc_"), text (showCostCentre True{-as string-} cc)], + pprStgExpr expr ] \end{code} \begin{code} -pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts) +pprStgExpr (StgCase expr lvs_whole lvs_rhss uniq alts) = sep [sep [ptext SLIT("case"), - nest 4 (hsep [pprStgExpr sty expr, - ifPprDebug sty ((<>) (ptext SLIT("::")) (pp_ty alts))]), + nest 4 (hsep [pprStgExpr expr, + ifPprDebug (ptext SLIT("::") <> pp_ty alts)]), ptext SLIT("of {")], - ifPprDebug sty ( + ifPprDebug ( nest 4 ( - hcat [ptext SLIT("-- lvs: ["), interppSP sty (uniqSetToList lvs_whole), - ptext SLIT("]; rhs lvs: ["), interppSP sty (uniqSetToList lvs_rhss), + hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole), + ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss), ptext SLIT("]; uniq: "), pprUnique uniq])), - nest 2 (ppr_alts sty alts), + nest 2 (ppr_alts alts), char '}'] where - ppr_default sty StgNoDefault = empty - ppr_default sty (StgBindDefault bndr used expr) - = hang (hsep [pp_binder, ptext SLIT("->")]) 4 (ppr sty expr) + ppr_default StgNoDefault = empty + ppr_default (StgBindDefault bndr used expr) + = hang (hsep [pp_binder, ptext SLIT("->")]) 4 (ppr expr) where - pp_binder = if used then ppr sty bndr else char '_' + pp_binder = if used then ppr bndr else char '_' - pp_ty (StgAlgAlts ty _ _) = ppr sty ty - pp_ty (StgPrimAlts ty _ _) = ppr sty ty + pp_ty (StgAlgAlts ty _ _) = ppr ty + pp_ty (StgPrimAlts ty _ _) = ppr ty - ppr_alts sty (StgAlgAlts ty alts deflt) - = vcat [ vcat (map (ppr_bxd_alt sty) alts), - ppr_default sty deflt ] + ppr_alts (StgAlgAlts ty alts deflt) + = vcat [ vcat (map (ppr_bxd_alt) alts), + ppr_default deflt ] where - ppr_bxd_alt sty (con, params, use_mask, expr) - = hang (hsep [ppr sty con, interppSP sty params, ptext SLIT("->")]) - 4 ((<>) (ppr sty expr) semi) + ppr_bxd_alt (con, params, use_mask, expr) + = hang (hsep [ppr con, interppSP params, ptext SLIT("->")]) + 4 ((<>) (ppr expr) semi) - ppr_alts sty (StgPrimAlts ty alts deflt) - = vcat [ vcat (map (ppr_ubxd_alt sty) alts), - ppr_default sty deflt ] + ppr_alts (StgPrimAlts ty alts deflt) + = vcat [ vcat (map (ppr_ubxd_alt) alts), + ppr_default deflt ] where - ppr_ubxd_alt sty (lit, expr) - = hang (hsep [ppr sty lit, ptext SLIT("->")]) - 4 ((<>) (ppr sty expr) semi) + ppr_ubxd_alt (lit, expr) + = hang (hsep [ppr lit, ptext SLIT("->")]) + 4 ((<>) (ppr expr) semi) \end{code} \begin{code} --- pprStgLVs :: PprStyle -> GenStgLiveVars occ -> Doc - -pprStgLVs sty lvs | userStyle sty = empty - -pprStgLVs sty lvs - = if isEmptyUniqSet lvs then +pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc +pprStgLVs lvs + = getPprStyle $ \ sty -> + if userStyle sty || isEmptyUniqSet lvs then empty else - hcat [text "{-lvs:", interpp'SP sty (uniqSetToList lvs), text "-}"] + hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"] \end{code} \begin{code} -pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) => - PprStyle -> GenStgRhs bndr bdee -> Doc +pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) + => GenStgRhs bndr bdee -> SDoc -- special case -pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs)) - = hcat [ text (showCostCentre sty True{-as String-} cc), - pp_binder_info sty bi, - ptext SLIT(" ["), ifPprDebug sty (ppr sty free_var), - ptext SLIT("] \\"), ppr sty upd_flag, ptext SLIT(" [] "), ppr sty func ] +pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs)) + = hcat [ text (showCostCentre True{-as String-} cc), + pp_binder_info bi, + brackets (ifPprDebug (ppr free_var)), + ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ] + -- general case -pprStgRhs sty (StgRhsClosure cc bi free_vars upd_flag args body) - = hang (hcat [ text (showCostCentre sty True{-as String-} cc), - pp_binder_info sty bi, - ptext SLIT(" ["), ifPprDebug sty (interppSP sty free_vars), - ptext SLIT("] \\"), ppr sty upd_flag, ptext SLIT(" ["), interppSP sty args, char ']']) - 4 (ppr sty body) +pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body) + = hang (hcat [text (showCostCentre True{-as String-} cc), + pp_binder_info bi, + brackets (ifPprDebug (interppSP free_vars)), + ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)]) + 4 (ppr body) -pprStgRhs sty (StgRhsCon cc con args) - = hcat [ text (showCostCentre sty True{-as String-} cc), - space, ppr sty con, ptext SLIT("! ["), interppSP sty args, char ']' ] +pprStgRhs (StgRhsCon cc con args) + = hcat [ text (showCostCentre True{-as String-} cc), + space, ppr con, ptext SLIT("! "), brackets (interppSP args)] -------------- -pp_binder_info sty _ | userStyle sty = empty -pp_binder_info sty NoStgBinderInfo = empty +pp_binder_info NoStgBinderInfo = empty -- cases so boring that we print nothing -pp_binder_info sty (StgBinderInfo True b c d e) = empty +pp_binder_info (StgBinderInfo True b c d e) = empty -- general case -pp_binder_info sty (StgBinderInfo a b c d e) - = parens (hsep (punctuate comma (map pp_bool [a,b,c,d,e]))) - where - pp_bool x = ppr (panic "pp_bool") x +pp_binder_info (StgBinderInfo a b c d e) + = getPprStyle $ \ sty -> + if userStyle sty then + empty + else + parens (hsep (punctuate comma (map ppr [a,b,c,d,e]))) \end{code} Collect @IdInfo@ stuff that is most easily just snaffled straight diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index f5e5aab80f..84d51195bd 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -4,8 +4,6 @@ \section[SaAbsInt]{Abstract interpreter for strictness analysis} \begin{code} -#include "HsVersions.h" - module SaAbsInt ( findStrictness, findDemand, @@ -15,35 +13,33 @@ module SaAbsInt ( isBot ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict ) import CoreSyn import CoreUnfold ( Unfolding(..), UfExpr, RdrName, SimpleUnfolding(..), FormSummary ) import CoreUtils ( unTagBinders ) import Id ( idType, getIdStrictness, getIdUnfolding, - dataConTyCon, dataConArgTys, SYN_IE(Id) + dataConTyCon, dataConArgTys, Id ) import IdInfo ( StrictnessInfo(..) ) import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, wwUnpackNew ) import MagicUFs ( MagicUnfoldingFun ) import Maybes ( maybeToBool ) -import Outputable -import Pretty --TEMP:( Doc, ptext ) import PrimOp ( PrimOp(..) ) import SaLib -import TyCon ( maybeTyConSingleCon, isEnumerationTyCon, isNewTyCon, +import TyCon ( isProductTyCon, isEnumerationTyCon, isNewTyCon, TyCon{-instance Eq-} ) import BasicTypes ( NewOrData(..) ) -import Type ( maybeAppDataTyConExpandingDicts, - isPrimType, SYN_IE(Type) ) +import Type ( splitAlgTyConApp_maybe, + isUnpointedType, Type ) import TysWiredIn ( intTyCon, integerTyCon, doubleTyCon, floatTyCon, wordTyCon, addrTyCon ) -import Util ( isIn, isn'tIn, nOfThem, zipWithEqual, - pprTrace, panic, pprPanic, assertPanic - ) +import Util ( isIn, isn'tIn, nOfThem, zipWithEqual ) +import GlaExts ( trace ) +import Outputable returnsRealWorld x = False -- ToDo: panic "SaAbsInt.returnsRealWorld (ToDo)" \end{code} @@ -165,7 +161,7 @@ combineCaseValues AbsAnal other_scrutinee branches tracer = if at_least_one_AbsFun && at_least_one_AbsTop && no_AbsBots then - pprTrace "combineCase:" (ppr PprDebug branches) + pprTrace "combineCase:" (ppr branches) else id in @@ -359,7 +355,7 @@ evalStrictness WwPrim val other -> -- A primitive value should be defined, never bottom; -- hence this paranoia check - pprPanic "evalStrictness: WwPrim:" (ppr PprDebug other) + pprPanic "evalStrictness: WwPrim:" (ppr other) \end{code} For absence analysis, we're interested in whether "poison" in the @@ -438,7 +434,7 @@ absId anal var env -- Try the strictness info absValFromStrictness anal strictness_info in - -- pprTrace "absId:" (hcat [ppr PprDebug var, ptext SLIT("=:"), pp_anal anal, text SLIT(":="),ppr PprDebug result]) $ + -- pprTrace "absId:" (hcat [ppr var, ptext SLIT("=:"), pp_anal anal, text SLIT(":="),ppr result]) $ result where pp_anal StrAnal = ptext SLIT("STR") @@ -507,8 +503,8 @@ absEval AbsAnal (Prim op as) env -- For absence analysis, we want to see if the poison shows up... absEval anal (Con con as) env - | has_single_con - = --pprTrace "absEval.Con" (cat[ text "con: ", (ppr PprDebug con), text "args: ", interppSP PprDebug as]) $ + | isProductTyCon (dataConTyCon con) + = --pprTrace "absEval.Con" (cat[ text "con: ", (ppr con), text "args: ", interppSP as]) $ AbsProd [absEvalAtom anal a env | a <- as, isValArg a] | otherwise -- Not single-constructor @@ -521,8 +517,6 @@ absEval anal (Con con as) env if any anyBot [absEvalAtom AbsAnal a env | a <- as, isValArg a] then AbsBot else AbsTop - where - has_single_con = maybeToBool (maybeTyConSingleCon (dataConTyCon con)) \end{code} \begin{code} @@ -565,7 +559,7 @@ absEval anal (Case expr (AlgAlts alts deflt)) env {- (case anal of StrAnal -> id - _ -> pprTrace "absCase:ABS:" (($$) (hsep [ppr PprDebug expr, ppr PprDebug result, ppr PprDebug expr_val, ppr PprDebug abs_deflt, ppr PprDebug abs_alts]) (ppr PprDebug (keysFM env `zip` eltsFM env))) + _ -> pprTrace "absCase:ABS:" (($$) (hsep [ppr expr, ppr result, ppr expr_val, ppr abs_deflt, ppr abs_alts]) (ppr (keysFM env `zip` eltsFM env))) ) -} result @@ -701,7 +695,7 @@ absApply AbsAnal (AbsApproxFun demand val) arg else val #ifdef DEBUG -absApply anal f@(AbsProd _) arg = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr PprDebug f) <+> (ppr PprDebug arg)) +absApply anal f@(AbsProd _) arg = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg)) #endif \end{code} @@ -739,7 +733,7 @@ findStrictness [] str_val abs_val = [] findStrictness (ty:tys) str_val abs_val = let - demand = findRecDemand [] str_fn abs_fn ty + demand = findRecDemand str_fn abs_fn ty str_fn val = absApply StrAnal str_val val abs_fn val = absApply AbsAnal abs_val val @@ -753,14 +747,14 @@ findStrictness (ty:tys) str_val abs_val \begin{code} findDemandStrOnly str_env expr binder -- Only strictness environment available - = findRecDemand [] str_fn abs_fn (idType binder) + = findRecDemand str_fn abs_fn (idType binder) where str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val) abs_fn val = AbsBot -- Always says poison; so it looks as if -- nothing is absent; safe findDemandAbsOnly abs_env expr binder -- Only absence environment available - = findRecDemand [] str_fn abs_fn (idType binder) + = findRecDemand str_fn abs_fn (idType binder) where str_fn val = AbsBot -- Always says non-termination; -- that'll make findRecDemand peer into the @@ -769,7 +763,7 @@ findDemandAbsOnly abs_env expr binder -- Only absence environment available findDemand str_env abs_env expr binder - = findRecDemand [] str_fn abs_fn (idType binder) + = findRecDemand str_fn abs_fn (idType binder) where str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val) abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val) @@ -808,15 +802,13 @@ then we'd let-to-case it: Ho hum. \begin{code} -findRecDemand :: [TyCon] -- TyCons already seen; used to avoid - -- zooming into recursive types - -> (AbsVal -> AbsVal) -- The strictness function +findRecDemand :: (AbsVal -> AbsVal) -- The strictness function -> (AbsVal -> AbsVal) -- The absence function -> Type -- The type of the argument -> Demand -findRecDemand seen str_fn abs_fn ty - = if isPrimType ty then -- It's a primitive type! +findRecDemand str_fn abs_fn ty + = if isUnpointedType ty then -- It's a primitive type! wwPrim else if not (anyBot (abs_fn AbsBot)) then -- It's absent @@ -830,13 +822,12 @@ findRecDemand seen str_fn abs_fn ty else -- It's strict (or we're pretending it is)! - case (maybeAppDataTyConExpandingDicts ty) of + case (splitAlgTyConApp_maybe ty) of Nothing -> wwStrict - Just (tycon,tycon_arg_tys,[data_con]) | tycon `not_elem` seen -> - -- Single constructor case, tycon not already seen higher up - + Just (tycon,tycon_arg_tys,[data_con]) | isProductTyCon tycon -> + -- Non-recursive, single constructor case let cmpnt_tys = dataConArgTys data_con tycon_arg_tys prod_len = length cmpnt_tys @@ -845,7 +836,7 @@ findRecDemand seen str_fn abs_fn ty if isNewTyCon tycon then -- A newtype! ASSERT( null (tail cmpnt_tys) ) let - demand = findRecDemand (tycon:seen) str_fn abs_fn (head cmpnt_tys) + demand = findRecDemand str_fn abs_fn (head cmpnt_tys) in case demand of -- No point in unpacking unless there is more to see inside WwUnpack _ _ _ -> wwUnpackNew demand @@ -854,7 +845,7 @@ findRecDemand seen str_fn abs_fn ty else -- A data type! let compt_strict_infos - = [ findRecDemand (tycon:seen) + = [ findRecDemand (\ cmpnt_val -> str_fn (mkMainlyTopProd prod_len i cmpnt_val) ) @@ -868,8 +859,6 @@ findRecDemand seen str_fn abs_fn ty if isEnumerationTyCon tycon then wwEnum else wwStrict else wwUnpackData compt_strict_infos - where - not_elem = isn'tIn "findRecDemand" Just (tycon,_,_) -> -- Multi-constr data types, *or* an abstract data @@ -882,7 +871,7 @@ findRecDemand seen str_fn abs_fn ty wwStrict where is_numeric_type ty - = case (maybeAppDataTyConExpandingDicts ty) of -- NB: duplicates stuff done above + = case (splitAlgTyConApp_maybe ty) of -- NB: duplicates stuff done above Nothing -> False Just (tycon, _, _) | tycon `is_elem` diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs index 485b597f10..0a4269a1c1 100644 --- a/ghc/compiler/stranal/SaLib.lhs +++ b/ghc/compiler/stranal/SaLib.lhs @@ -6,29 +6,26 @@ See also: the ``library'' for the ``back end'' (@SaBackLib@). \begin{code} -#include "HsVersions.h" - module SaLib ( AbsVal(..), AnalysisKind(..), - AbsValEnv{-abstract-}, SYN_IE(StrictEnv), SYN_IE(AbsenceEnv), + AbsValEnv{-abstract-}, StrictEnv, AbsenceEnv, nullAbsValEnv, addOneToAbsValEnv, growAbsValEnvList, lookupAbsValEnv, absValFromStrictness ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import CoreSyn ( SYN_IE(CoreExpr) ) +import CoreSyn ( CoreExpr ) import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList, - lookupIdEnv, SYN_IE(IdEnv), - GenId{-instance Outputable-}, SYN_IE(Id) + lookupIdEnv, IdEnv, + GenId{-instance Outputable-}, Id ) import IdInfo ( StrictnessInfo(..) ) import Demand ( Demand{-instance Outputable-} ) -import Outputable ( Outputable(..){-instance * []-} ) +import Outputable import PprType ( GenType{-instance Outputable-} ) -import Pretty ( ptext, hsep, char ) \end{code} %************************************************************************ @@ -73,15 +70,15 @@ data AbsVal -- argument if the Demand so indicates. instance Outputable AbsVal where - ppr sty AbsTop = ptext SLIT("AbsTop") - ppr sty AbsBot = ptext SLIT("AbsBot") - ppr sty (AbsProd prod) = hsep [ptext SLIT("AbsProd"), ppr sty prod] - ppr sty (AbsFun arg body env) - = hsep [ptext SLIT("AbsFun{"), ppr sty arg, - ptext SLIT("???"), -- text "}{env:", ppr sty (keysFM env `zip` eltsFM env), + ppr AbsTop = ptext SLIT("AbsTop") + ppr AbsBot = ptext SLIT("AbsBot") + ppr (AbsProd prod) = hsep [ptext SLIT("AbsProd"), ppr prod] + ppr (AbsFun arg body env) + = hsep [ptext SLIT("AbsFun{"), ppr arg, + ptext SLIT("???"), -- text "}{env:", ppr (keysFM env `zip` eltsFM env), char '}' ] - ppr sty (AbsApproxFun demand val) - = hsep [ptext SLIT("AbsApprox "), ppr sty demand, ppr sty val ] + ppr (AbsApproxFun demand val) + = hsep [ptext SLIT("AbsApprox "), ppr demand, ppr val] \end{code} %----------- diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index d0ea862b10..70204b1ff9 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -7,33 +7,30 @@ The original version(s) of all strictness-analyser code (except the Semantique analyser) was written by Andy Gill. \begin{code} -#include "HsVersions.h" - module StrictAnal ( saWwTopBinds ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CmdLineOpts ( opt_D_dump_stranal, opt_D_simplifier_stats ) import CoreSyn import Id ( idType, addIdStrictness, isWrapperId, getIdDemandInfo, addIdDemandInfo, - GenId{-instance Outputable-}, SYN_IE(Id) + GenId{-instance Outputable-}, Id ) import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo, mkDemandInfo, willBeDemanded, DemandInfo ) -import PprCore ( pprCoreBinding, pprBigCoreBinder ) -import Outputable ( PprStyle(..) ) +import PprCore ( pprCoreBinding ) import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} ) -import Pretty ( Doc, hcat, ptext, int, char, vcat ) import SaAbsInt import SaLib import TyVar ( GenTyVar{-instance Eq-} ) import WorkWrap -- "back-end" of strictness analyser import Unique ( Unique{-instance Eq -} ) import UniqSupply ( UniqSupply ) -import Util ( zipWith4Equal, pprTrace, panic ) +import Util ( zipWith4Equal ) +import Outputable \end{code} %************************************************************************ @@ -102,7 +99,7 @@ saWwTopBinds us binds -- possibly show what we decided about strictness... (if opt_D_dump_stranal then pprTrace "Strictness:\n" (vcat ( - map (pprCoreBinding PprDebug) binds_w_strictness)) + map (pprCoreBinding) binds_w_strictness)) else id ) -- possibly show how many things we marked as demanded... @@ -392,8 +389,8 @@ addStrictnessInfoToId str_val abs_val binder body | otherwise = case (collectBinders body) of - (_, _, [], rhs) -> binder - (_, _, lambda_bounds, rhs) -> binder `addIdStrictness` + (_, [], rhs) -> binder + (_, lambda_bounds, rhs) -> binder `addIdStrictness` mkStrictnessInfo strictness False where tys = map idType lambda_bounds diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 4a749243e2..fbac09bc6c 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -4,11 +4,9 @@ \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} \begin{code} -#include "HsVersions.h" - module WorkWrap ( workersAndWrappers, getWorkerIdAndCons ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CoreSyn import CoreUnfold ( Unfolding, certainlySmallEnoughToInline, calcUnfoldingGuidance ) @@ -17,18 +15,16 @@ import CmdLineOpts ( opt_UnfoldingCreationThreshold ) import CoreUtils ( coreExprType ) import Id ( getInlinePragma, getIdStrictness, mkWorkerId, addIdStrictness, addInlinePragma, - SYN_IE(IdSet), emptyIdSet, addOneToIdSet, - GenId, SYN_IE(Id) + IdSet, emptyIdSet, addOneToIdSet, + GenId, Id ) import IdInfo ( noIdInfo, addUnfoldInfo, mkStrictnessInfo, addStrictnessInfo, StrictnessInfo(..) ) import SaLib -import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) ) +import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM ) import WwLib -import Pretty ( Doc ) -import Outputable ( ppr, PprStyle(..) ) -import Util ( pprPanic ) +import Outputable \end{code} We take Core bindings whose binders have their strictness attached (by @@ -204,7 +200,7 @@ tryWW fn_id rhs | otherwise -- Do w/w split = let - (uvars, tyvars, wrap_args, body) = collectBinders rhs + (tyvars, wrap_args, body) = collectBinders rhs in mkWwBodies tyvars wrap_args (coreExprType body) @@ -235,7 +231,7 @@ tryWW fn_id rhs StrictnessInfo args_info _ -> args_info revised_wrap_args_info = setUnpackStrategy wrap_args_info --- This rather crude function looks at a wrapper function, and +-- This rather (nay! extremely!) crude function looks at a wrapper function, and -- snaffles out (a) the worker Id and (b) constructors needed to -- make the wrapper. -- These are needed when we write an interface file. @@ -252,5 +248,5 @@ getWorkerIdAndCons wrap_id wrapper_fn get_work_id (App fn _) = get_work_id fn get_work_id (Var work_id) = work_id - get_work_id other = pprPanic "getWorkerIdAndCons" (ppr PprDebug wrap_id) + get_work_id other = pprPanic "getWorkerIdAndCons" (ppr wrap_id) \end{code} diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index bb06e5092f..bd2ebe513c 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -4,8 +4,6 @@ \section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser} \begin{code} -#include "HsVersions.h" - module WwLib ( WwBinding(..), @@ -13,30 +11,29 @@ module WwLib ( mkWwBodies, mkWrapper ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(List(nub)) +#include "HsVersions.h" import CoreSyn -import Id ( GenId, idType, mkSysLocal, dataConArgTys, isDataCon, isNewCon, SYN_IE(Id) ) +import Id ( GenId, idType, mkSysLocal, dataConArgTys, isDataCon, isNewCon, Id ) import IdInfo ( mkStrictnessInfo, {-??nonAbsentArgs,-} Demand(..) ) import PrelVals ( aBSENT_ERROR_ID, voidId ) import TysPrim ( voidTy ) import SrcLoc ( noSrcLoc ) -import Type ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys, - splitForAllTyExpandingDicts, splitForAllTy, splitFunTyExpandingDicts, - maybeAppDataTyConExpandingDicts, - SYN_IE(Type) +import Type ( isUnpointedType, mkTyVarTys, mkForAllTys, mkFunTys, + splitForAllTys, splitFunTys, + splitAlgTyConApp_maybe, + Type ) import TyCon ( isNewTyCon, isDataTyCon ) import BasicTypes ( NewOrData(..) ) -import TyVar ( SYN_IE(TyVar) ) +import TyVar ( TyVar ) import PprType ( GenType, GenTyVar ) import UniqSupply ( returnUs, thenUs, thenMaybeUs, - getUniques, getUnique, SYN_IE(UniqSM) + getUniques, getUnique, UniqSM ) -import Util ( zipWithEqual, zipEqual, assertPanic, panic, pprPanic ) -import Pretty +import Util ( zipWithEqual, zipEqual ) import Outputable +import List ( nub ) \end{code} %************************************************************************ @@ -239,8 +236,8 @@ mkWrapper fun_ty demands in getUniques n_wrap_args `thenUs` \ wrap_uniqs -> let - (tyvars, tau_ty) = splitForAllTyExpandingDicts fun_ty - (arg_tys, body_ty) = splitFunTyExpandingDicts tau_ty + (tyvars, tau_ty) = splitForAllTys fun_ty + (arg_tys, body_ty) = splitFunTys tau_ty -- The "expanding dicts" part here is important, even for the splitForAll -- The imported thing might be a dictionary, such as Functor Foo -- But Functor Foo = forall a b. (a->b) -> Foo a -> Foo b @@ -266,7 +263,7 @@ mkWwBodies :: [TyVar] -> [Id] -> Type -- Original fn args and body type mkWwBodies tyvars args body_ty demands | allAbsent demands && - isPrimType body_ty + isUnpointedType body_ty = -- Horrid special case. If the worker would have no arguments, and the -- function returns a primitive type value, that would make the worker into -- an unboxed value. We box it by passing a dummy void argument, thus: @@ -334,13 +331,13 @@ mkWW ((arg,WwUnpack new_or_data True cs) : ds) where inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys (arg_tycon, tycon_arg_tys, data_con) - = case (maybeAppDataTyConExpandingDicts (idType arg)) of + = case (splitAlgTyConApp_maybe (idType arg)) of Just (arg_tycon, tycon_arg_tys, [data_con]) -> -- The main event: a single-constructor data type (arg_tycon, tycon_arg_tys, data_con) - Just (_, _, data_cons) -> pprPanic "mk_ww_arg_processing: not one constr (interface files not consistent/up to date ?)" ((ppr PprDebug arg) <+> (ppr PprDebug (idType arg))) + Just (_, _, data_cons) -> pprPanic "mk_ww_arg_processing: not one constr (interface files not consistent/up to date ?)" ((ppr arg) <+> (ppr (idType arg))) Nothing -> panic "mk_ww_arg_processing: not datatype" @@ -362,7 +359,7 @@ mkWW ((arg,other_demand) : ds) \begin{code} mk_absent_let arg body - | not (isPrimType arg_ty) + | not (isUnpointedType arg_ty) = Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body | otherwise = panic "WwLib: haven't done mk_absent_let for primitives yet" diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index ffd9ec0e00..64f831aca7 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -4,80 +4,72 @@ \section[Inst]{The @Inst@ type: dictionaries or method instances} \begin{code} -#include "HsVersions.h" - module Inst ( - Inst(..), -- Visible only to TcSimplify + LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs, mkLIE, + pprInsts, pprInstsInFull, - InstOrigin(..), OverloadedLit(..), - SYN_IE(LIE), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs, - pprLIE, pprLIEInFull, + Inst, OverloadedLit(..), pprInst, - SYN_IE(InstanceMapper), + InstanceMapper, - newDicts, newDictsAtLoc, newMethod, newMethodWithGivenTy, newOverloadedLit, + newDictFromOld, newDicts, newDictsAtLoc, + newMethod, newMethodWithGivenTy, newOverloadedLit, - tyVarsOfInst, lookupInst, lookupSimpleInst, + tyVarsOfInst, instLoc, getDictClassTys, - isDict, isTyVarDict, + lookupInst, lookupSimpleInst, LookupInstResult(..), + + isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, + instBindingRequired, instCanBeGeneralised, zonkInst, instToId, - matchesInst, - instBindingRequired, instCanBeGeneralised, - - pprInst + InstOrigin(..), pprOrigin ) where -IMP_Ubiq() -IMPORT_1_3(Ratio(Rational)) - -import HsSyn ( HsLit(..), HsExpr(..), HsBinds, Fixity, MonoBinds(..), - InPat, OutPat, Stmt, DoOrListComp, Match, GRHSsAndBinds, - ArithSeqInfo, HsType, Fake ) -import RnHsSyn ( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr) ) -import TcHsSyn ( SYN_IE(TcExpr), - SYN_IE(TcDictBinds), SYN_IE(TcMonoBinds), - mkHsTyApp, mkHsDictApp, tcIdTyVars ) +#include "HsVersions.h" +import HsSyn ( HsLit(..), HsExpr(..), MonoBinds(..) ) +import RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr ) +import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr, + TcDictBinds, TcMonoBinds, + mkHsTyApp, mkHsDictApp, tcIdTyVars, zonkTcId + ) import TcMonad import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey ) -import TcType ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcThetaType), SYN_IE(TcTauType), - SYN_IE(TcType), SYN_IE(TcRhoType), TcMaybe, SYN_IE(TcTyVarSet), - tcInstType, zonkTcType, zonkTcTheta, - tcSplitForAllTy, tcSplitRhoTy +import TcType ( TcThetaType, + TcType, TcRhoType, TcTauType, TcMaybe, TcTyVarSet, + tcInstType, zonkTcType, zonkTcTypes, tcSplitForAllTy, tcSplitRhoTy, + zonkTcThetaType ) import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList, listToBag, consBag, Bag ) import Class ( classInstEnv, - SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv) + Class, ClassInstEnv ) -import ErrUtils ( addErrLoc, SYN_IE(Error) ) -import Id ( GenId, idType, mkUserLocal, mkSysLocal, SYN_IE(Id) ) -import PrelInfo ( isCcallishClass, isNoDictClass ) -import MatchEnv ( lookupMEnv, insertMEnv ) +import Id ( idType, mkUserLocal, mkSysLocal, Id, + GenIdSet, elementOfIdSet + ) +import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) import Name ( OccName(..), Name, mkLocalName, mkSysLocalName, occNameString, getOccName ) -import Outputable -import PprType ( GenClass, TyCon, GenType, GenTyVar, pprParendGenType ) -import Pretty -import SpecEnv ( SpecEnv ) -import SrcLoc ( SrcLoc, noSrcLoc ) -import Type ( GenType, eqSimpleTy, instantiateTy, - isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy, +import PprType ( TyCon, pprConstraint ) +import SpecEnv ( SpecEnv, matchSpecEnv, addToSpecEnv ) +import SrcLoc ( SrcLoc ) +import Type ( Type, ThetaType, instantiateTy, instantiateThetaTy, matchTys, + isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy, splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes, - mkSynTy, SYN_IE(Type) + mkSynTy ) -import TyVar ( unionTyVarSets, GenTyVar ) +import TyVar ( zipTyVarEnv, lookupTyVarEnv, unionTyVarSets ) import TysPrim ( intPrimTy ) import TysWiredIn ( intDataCon, integerTy, isIntTy, isIntegerTy, inIntRange ) import Unique ( fromRationalClassOpKey, rationalTyConKey, fromIntClassOpKey, fromIntegerClassOpKey, Unique ) -import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic, pprTrace{-ToDo:rm-} ) -#if __GLASGOW_HASKELL__ >= 202 -import Maybes -#endif +import Maybes ( MaybeErr, expectJust ) +import Util ( thenCmp, zipEqual, zipWithEqual, isIn ) +import Outputable \end{code} %************************************************************************ @@ -91,6 +83,7 @@ type LIE s = Bag (Inst s) emptyLIE = emptyBag unitLIE inst = unitBag inst +mkLIE insts = listToBag insts plusLIE lie1 lie2 = lie1 `unionBags` lie2 consLIE inst lie = inst `consBag` lie plusLIEs lies = unionManyBags lies @@ -98,15 +91,14 @@ plusLIEs lies = unionManyBags lies zonkLIE :: LIE s -> NF_TcM s (LIE s) zonkLIE lie = mapBagNF_Tc zonkInst lie -pprLIE :: PprStyle -> LIE s -> Doc -pprLIE sty lie = pprQuote sty $ \ sty -> - braces (hsep (punctuate comma (map (pprInst sty) (bagToList lie)))) +pprInsts :: [Inst s] -> SDoc +pprInsts insts = parens (hsep (punctuate comma (map pprInst insts))) -pprLIEInFull sty insts - = vcat (map go (bagToList insts)) +pprInstsInFull insts + = vcat (map go insts) where - go inst = ppr sty inst <+> pprOrigin sty inst + go inst = quotes (ppr inst) <+> pprOrigin inst \end{code} %************************************************************************ @@ -127,8 +119,8 @@ type Int, represented by data Inst s = Dict Unique - Class -- The type of the dict is (c t), where - (TcType s) -- c is the class and t the type; + Class -- The type of the dict is (c ts), where + [TcType s] -- c is the class and ts the types; (InstOrigin s) SrcLoc @@ -167,46 +159,138 @@ data Inst s data OverloadedLit = OverloadedIntegral Integer -- The number | OverloadedFractional Rational -- The number +\end{code} + +Ordering +~~~~~~~~ +@Insts@ are ordered by their class/type info, rather than by their +unique. This allows the context-reduction mechanism to use standard finite +maps to do their stuff. + +\begin{code} +instance Ord (Inst s) where + compare = cmpInst + +instance Eq (Inst s) where + (==) i1 i2 = case i1 `cmpInst` i2 of + EQ -> True + other -> False + +cmpInst (Dict _ clas1 tys1 _ _) (Dict _ clas2 tys2 _ _) + = (clas1 `compare` clas2) `thenCmp` (tys1 `compare` tys2) +cmpInst (Dict _ _ _ _ _) other + = LT + + +cmpInst (Method _ _ _ _ _ _ _) (Dict _ _ _ _ _) + = GT +cmpInst (Method _ id1 tys1 _ _ _ _) (Method _ id2 tys2 _ _ _ _) + = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2) +cmpInst (Method _ _ _ _ _ _ _) other + = LT + +cmpInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _) + = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2) +cmpInst (LitInst _ _ _ _ _) other + = GT + +cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2 +cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2 +cmpOverLit (OverloadedIntegral _) (OverloadedFractional _) = LT +cmpOverLit (OverloadedFractional _) (OverloadedIntegral _) = GT +\end{code} + + +Selection +~~~~~~~~~ +\begin{code} +instOrigin (Dict u clas tys origin loc) = origin +instOrigin (Method u clas ty _ _ origin loc) = origin +instOrigin (LitInst u lit ty origin loc) = origin + +instLoc (Dict u clas tys origin loc) = loc +instLoc (Method u clas ty _ _ origin loc) = loc +instLoc (LitInst u lit ty origin loc) = loc + +getDictClassTys (Dict u clas tys _ _) = (clas, tys) + +tyVarsOfInst :: Inst s -> TcTyVarSet s +tyVarsOfInst (Dict _ _ tys _ _) = tyVarsOfTypes tys +tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id + -- The id might not be a RealId; in the case of + -- locally-overloaded class methods, for example +tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty +\end{code} + +Predicates +~~~~~~~~~~ +\begin{code} +isDict :: Inst s -> Bool +isDict (Dict _ _ _ _ _) = True +isDict other = False + +isMethodFor :: GenIdSet (TcType s) -> Inst s -> Bool +isMethodFor ids (Method uniq (TcId id) tys _ _ orig loc) + = id `elementOfIdSet` ids +isMethodFor ids inst + = False + +isTyVarDict :: Inst s -> Bool +isTyVarDict (Dict _ _ tys _ _) = all isTyVarTy tys +isTyVarDict other = False + +isStdClassTyVarDict (Dict _ clas [ty] _ _) = isStandardClass clas && isTyVarTy ty +isStdClassTyVarDict other = False +\end{code} + +Two predicates which deal with the case where class constraints don't +necessarily result in bindings. The first tells whether an @Inst@ +must be witnessed by an actual binding; the second tells whether an +@Inst@ can be generalised over. + +\begin{code} +instBindingRequired :: Inst s -> Bool +instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas) +instBindingRequired other = True -getInstOrigin (Dict u clas ty origin loc) = origin -getInstOrigin (Method u fn tys theta tau origin loc) = origin -getInstOrigin (LitInst u lit ty origin loc) = origin +instCanBeGeneralised :: Inst s -> Bool +instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas) +instCanBeGeneralised other = True \end{code} + Construction ~~~~~~~~~~~~ \begin{code} newDicts :: InstOrigin s - -> [(Class, TcType s)] + -> TcThetaType s -> NF_TcM s (LIE s, [TcIdOcc s]) newDicts orig theta = tcGetSrcLoc `thenNF_Tc` \ loc -> newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, ids) -> returnNF_Tc (listToBag dicts, ids) -{- - tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> - let - mk_dict u (clas, ty) = Dict u clas ty orig loc - dicts = zipWithEqual "newDicts" mk_dict new_uniqs theta - in - returnNF_Tc (listToBag dicts, map instToId dicts) --} -- Local function, similar to newDicts, -- but with slightly different interface newDictsAtLoc :: InstOrigin s -> SrcLoc - -> [(Class, TcType s)] + -> TcThetaType s -> NF_TcM s ([Inst s], [TcIdOcc s]) newDictsAtLoc orig loc theta = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> let - mk_dict u (clas, ty) = Dict u clas ty orig loc + mk_dict u (clas, tys) = Dict u clas tys orig loc dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta in returnNF_Tc (dicts, map instToId dicts) +newDictFromOld :: Inst s -> Class -> [TcType s] -> NF_TcM s (Inst s) +newDictFromOld (Dict _ _ _ orig loc) clas tys + = tcGetUnique `thenNF_Tc` \ uniq -> + returnNF_Tc (Dict uniq clas tys orig loc) + + newMethod :: InstOrigin s -> TcIdOcc s -> [TcType s] @@ -214,12 +298,13 @@ newMethod :: InstOrigin s newMethod orig id tys = -- Get the Id type and instantiate it at the specified types (case id of - RealId id -> let (tyvars, rho) = splitForAllTy (idType id) + RealId id -> let (tyvars, rho) = splitForAllTys (idType id) in - tcInstType (zipEqual "newMethod" tyvars tys) rho + ASSERT( length tyvars == length tys) + tcInstType (zipTyVarEnv tyvars tys) rho TcId id -> tcSplitForAllTy (idType id) `thenNF_Tc` \ (tyvars, rho) -> - returnNF_Tc (instantiateTy (zipEqual "newMethod(2)" tyvars tys) rho) + returnNF_Tc (instantiateTy (zipTyVarEnv tyvars tys) rho) ) `thenNF_Tc` \ rho_ty -> let (theta, tau) = splitRhoTy rho_ty @@ -243,10 +328,10 @@ newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but -- slightly different interface = -- Get the Id type and instantiate it at the specified types let - (tyvars,rho) = splitForAllTy (idType real_id) + (tyvars,rho) = splitForAllTys (idType real_id) in - tcInstType (zipEqual "newMethodAtLoc" tyvars tys) rho `thenNF_Tc` \ rho_ty -> - tcGetUnique `thenNF_Tc` \ new_uniq -> + tcInstType (zipTyVarEnv tyvars tys) rho `thenNF_Tc` \ rho_ty -> + tcGetUnique `thenNF_Tc` \ new_uniq -> let (theta, tau) = splitRhoTy rho_ty meth_inst = Method new_uniq (RealId real_id) tys theta tau orig loc @@ -302,15 +387,17 @@ need, and it's a lot of extra work. \begin{code} zonkInst :: Inst s -> NF_TcM s (Inst s) -zonkInst (Dict u clas ty orig loc) - = zonkTcType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (Dict u clas new_ty orig loc) - -zonkInst (Method u id tys theta tau orig loc) -- Doesn't zonk the id! - = mapNF_Tc zonkTcType tys `thenNF_Tc` \ new_tys -> - zonkTcTheta theta `thenNF_Tc` \ new_theta -> - zonkTcType tau `thenNF_Tc` \ new_tau -> - returnNF_Tc (Method u id new_tys new_theta new_tau orig loc) +zonkInst (Dict u clas tys orig loc) + = zonkTcTypes tys `thenNF_Tc` \ new_tys -> + returnNF_Tc (Dict u clas new_tys orig loc) + +zonkInst (Method u id tys theta tau orig loc) + = zonkTcId id `thenNF_Tc` \ new_id -> + -- Essential to zonk the id in case it's a local variable + zonkTcTypes tys `thenNF_Tc` \ new_tys -> + zonkTcThetaType theta `thenNF_Tc` \ new_theta -> + zonkTcType tau `thenNF_Tc` \ new_tau -> + returnNF_Tc (Method u new_id new_tys new_theta new_tau orig loc) zonkInst (LitInst u lit ty orig loc) = zonkTcType ty `thenNF_Tc` \ new_ty -> @@ -318,68 +405,6 @@ zonkInst (LitInst u lit ty orig loc) \end{code} -\begin{code} -tyVarsOfInst :: Inst s -> TcTyVarSet s -tyVarsOfInst (Dict _ _ ty _ _) = tyVarsOfType ty -tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id - -- The id might not be a RealId; in the case of - -- locally-overloaded class methods, for example -tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty -\end{code} - -@matchesInst@ checks when two @Inst@s are instances of the same -thing at the same type, even if their uniques differ. - -\begin{code} -matchesInst :: Inst s -> Inst s -> Bool - -matchesInst (Dict _ clas1 ty1 _ _) (Dict _ clas2 ty2 _ _) - = clas1 == clas2 && ty1 `eqSimpleTy` ty2 - -matchesInst (Method _ id1 tys1 _ _ _ _) (Method _ id2 tys2 _ _ _ _) - = id1 == id2 - && and (zipWith eqSimpleTy tys1 tys2) - && length tys1 == length tys2 - -matchesInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _) - = lit1 `eq` lit2 && ty1 `eqSimpleTy` ty2 - where - (OverloadedIntegral i1) `eq` (OverloadedIntegral i2) = i1 == i2 - (OverloadedFractional f1) `eq` (OverloadedFractional f2) = f1 == f2 - _ `eq` _ = False - -matchesInst other1 other2 = False -\end{code} - - -Predicates -~~~~~~~~~~ -\begin{code} -isDict :: Inst s -> Bool -isDict (Dict _ _ _ _ _) = True -isDict other = False - -isTyVarDict :: Inst s -> Bool -isTyVarDict (Dict _ _ ty _ _) = isTyVarTy ty -isTyVarDict other = False -\end{code} - -Two predicates which deal with the case where class constraints don't -necessarily result in bindings. The first tells whether an @Inst@ -must be witnessed by an actual binding; the second tells whether an -@Inst@ can be generalised over. - -\begin{code} -instBindingRequired :: Inst s -> Bool -instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas) -instBindingRequired other = True - -instCanBeGeneralised :: Inst s -> Bool -instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas) -instCanBeGeneralised other = True -\end{code} - - Printing ~~~~~~~~ ToDo: improve these pretty-printing things. The ``origin'' is really only @@ -387,37 +412,26 @@ relevant in error messages. \begin{code} instance Outputable (Inst s) where - ppr sty inst = pprQuote sty (\ sty -> pprInst sty inst) + ppr inst = pprInst inst -pprInst sty (LitInst u lit ty orig loc) +pprInst (LitInst u lit ty orig loc) = hsep [case lit of OverloadedIntegral i -> integer i OverloadedFractional f -> rational f, ptext SLIT("at"), - ppr sty ty, - show_uniq sty u] + ppr ty, + show_uniq u] -pprInst sty (Dict u clas ty orig loc) - = hsep [ppr sty clas, pprParendGenType sty ty, show_uniq sty u] +pprInst (Dict u clas tys orig loc) = pprConstraint clas tys <+> show_uniq u -pprInst sty (Method u id tys _ _ orig loc) - = hsep [ppr sty id, ptext SLIT("at"), - interppSP sty tys, - show_uniq sty u] +pprInst (Method u id tys _ _ orig loc) + = hsep [ppr id, ptext SLIT("at"), + interppSP tys, + show_uniq u] -show_uniq PprDebug u = ppr PprDebug u -show_uniq sty u = empty +show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}") \end{code} -Printing in error messages. These two must look the same. - -\begin{code} -noInstanceErr inst sty = ptext SLIT("No instance for:") <+> ppr sty inst - -noSimpleInst clas ty sty - = ptext SLIT("No instance for:") <+> - (pprQuote sty (\ sty -> ppr sty clas <+> pprParendGenType sty ty)) -\end{code} %************************************************************************ %* * @@ -445,65 +459,70 @@ The "a" in the pattern must be one of the forall'd variables in the dfun type. \begin{code} +data LookupInstResult s + = NoInstance + | SimpleInst (TcExpr s) -- Just a variable, type application, or literal + | GenInst [Inst s] (TcExpr s) -- The expression and its needed insts lookupInst :: Inst s - -> TcM s ([Inst s], - TcDictBinds s) -- The new binding + -> NF_TcM s (LookupInstResult s) -- Dictionaries -lookupInst dict@(Dict _ clas ty orig loc) - = case lookupMEnv matchTy (get_inst_env clas orig) ty of - Nothing -> tcAddSrcLoc loc $ - tcAddErrCtxt (\sty -> pprOrigin sty dict) $ - failTc (noInstanceErr dict) +lookupInst dict@(Dict _ clas tys orig loc) + = case matchSpecEnv (classInstEnv clas) tys of - Just (dfun_id, tenv) + Just (tenv, dfun_id) -> let - (tyvars, rho) = splitForAllTy (idType dfun_id) - ty_args = map (assoc "lookupInst" tenv) tyvars - -- tenv should bind all the tyvars + (tyvars, rho) = splitForAllTys (idType dfun_id) + ty_args = map (expectJust "Inst" . lookupTyVarEnv tenv) tyvars + -- tenv should bind all the tyvars in tcInstType tenv rho `thenNF_Tc` \ dfun_rho -> let (theta, tau) = splitRhoTy dfun_rho + ty_app = mkHsTyApp (HsVar (RealId dfun_id)) ty_args in + if null theta then + returnNF_Tc (SimpleInst ty_app) + else newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) -> let - rhs = mkHsDictApp (mkHsTyApp (HsVar (RealId dfun_id)) ty_args) dict_ids + rhs = mkHsDictApp ty_app dict_ids in - returnTc (dicts, VarMonoBind (instToId dict) rhs) + returnNF_Tc (GenInst dicts rhs) + Nothing -> returnNF_Tc NoInstance -- Methods lookupInst inst@(Method _ id tys theta _ orig loc) = newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) -> - returnTc (dicts, VarMonoBind (instToId inst) (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids)) + returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids)) -- Literals lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc) | isIntTy ty && in_int_range -- Short cut for Int - = returnTc ([], VarMonoBind inst_id int_lit) + = returnNF_Tc (GenInst [] int_lit) + -- GenInst, not SimpleInst, because int_lit is actually a constructor application | isIntegerTy ty -- Short cut for Integer - = returnTc ([], VarMonoBind inst_id integer_lit) + = returnNF_Tc (GenInst [] integer_lit) | in_int_range -- It's overloaded but small enough to fit into an Int = tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int -> newMethodAtLoc orig loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) -> - returnTc ([method_inst], VarMonoBind inst_id (HsApp (HsVar method_id) int_lit)) + returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit)) | otherwise -- Alas, it is overloaded and a big literal! = tcLookupGlobalValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer -> newMethodAtLoc orig loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) -> - returnTc ([method_inst], VarMonoBind inst_id (HsApp (HsVar method_id) integer_lit)) + returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit)) where in_int_range = inIntRange i intprim_lit = HsLitOut (HsIntPrim i) intPrimTy integer_lit = HsLitOut (HsInt i) integerTy int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit - inst_id = instToId inst lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc) = tcLookupGlobalValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational -> @@ -515,7 +534,7 @@ lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc) rational_lit = HsLitOut (HsFrac f) rational_ty in newMethodAtLoc orig loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) -> - returnTc ([method_inst], VarMonoBind (instToId inst) (HsApp (HsVar method_id) rational_lit)) + returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit)) \end{code} There is a second, simpler interface, when you want an instance of a @@ -526,55 +545,31 @@ ambiguous dictionaries. \begin{code} lookupSimpleInst :: ClassInstEnv -> Class - -> Type -- Look up (c,t) - -> TcM s [(Class,Type)] -- Here are the needed (c,t)s - -lookupSimpleInst class_inst_env clas ty - = case (lookupMEnv matchTy class_inst_env ty) of - Nothing -> failTc (noSimpleInst clas ty) - Just (dfun,tenv) -> returnTc [(c,instantiateTy tenv t) | (c,t) <- theta] - where - (_, theta, _) = splitSigmaTy (idType dfun) -\end{code} + -> [Type] -- Look up (c,t) + -> NF_TcM s (Maybe ThetaType) -- Here are the needed (c,t)s +lookupSimpleInst class_inst_env clas tys + = case matchSpecEnv class_inst_env tys of + Nothing -> returnNF_Tc Nothing -@mkInstSpecEnv@ is used to construct the @SpecEnv@ for a dfun. -It does it by filtering the class's @InstEnv@. All pretty shady stuff. - -\begin{code} -mkInstSpecEnv clas inst_ty inst_tvs inst_theta = panic "mkInstSpecEnv" + Just (tenv, dfun) + -> returnNF_Tc (Just (instantiateThetaTy tenv theta)) + where + (_, theta, _) = splitSigmaTy (idType dfun) \end{code} -\begin{pseudocode} -mkInstSpecEnv :: Class -- class - -> Type -- instance type - -> [TyVarTemplate] -- instance tyvars - -> ThetaType -- superclasses dicts - -> SpecEnv -- specenv for dfun of instance - -mkInstSpecEnv clas inst_ty inst_tvs inst_theta - = mkSpecEnv (catMaybes (map maybe_spec_info matches)) - where - matches = matchMEnv matchTy (classInstEnv clas) inst_ty - - maybe_spec_info (_, match_info, MkInstTemplate dfun _ []) - = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun) - maybe_spec_info (_, match_info, _) - = Nothing -\end{pseudocode} - \begin{code} addClassInst :: ClassInstEnv -- Incoming envt - -> Type -- The instance type: inst_ty + -> [Type] -- The instance types: inst_tys -> Id -- Dict fun id to apply. Free tyvars of inst_ty must -- be the same as the forall'd tyvars of the dfun id. -> MaybeErr ClassInstEnv -- Success - (Type, Id) -- Offending overlap + ([Type], Id) -- Offending overlap -addClassInst inst_env inst_ty dfun_id = insertMEnv matchTy inst_env inst_ty dfun_id +addClassInst inst_env inst_tys dfun_id = addToSpecEnv inst_env inst_tys dfun_id \end{code} @@ -612,18 +607,7 @@ data InstOrigin s | ClassDeclOrigin -- Manufactured during a class decl --- NO MORE! --- | DerivingOrigin InstanceMapper --- Class --- TyCon - - -- During "deriving" operations we have an ever changing - -- mapping of classes to instances, so we record it inside the - -- origin information. This is a bit of a hack, but it works - -- fine. (Simon is to blame [WDP].) - - | InstanceSpecOrigin InstanceMapper - Class -- in a SPECIALIZE instance pragma + | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma Type -- When specialising instances the instance info attached to @@ -631,8 +615,6 @@ data InstOrigin s -- origin information. This is a bit of a hack, but it works -- fine. (Patrick is to blame [WDP].) --- | DefaultDeclOrigin -- Related to a `default' declaration - | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value -- Argument or result of a ccall @@ -650,22 +632,9 @@ data InstOrigin s \end{code} \begin{code} --- During deriving and instance specialisation operations --- we can't get the instances of the class from inside the --- class, because the latter ain't ready yet. Instead we --- find a mapping from classes to envts inside the dict origin. - -get_inst_env :: Class -> InstOrigin s -> ClassInstEnv --- get_inst_env clas (DerivingOrigin inst_mapper _ _) --- = fst (inst_mapper clas) -get_inst_env clas (InstanceSpecOrigin inst_mapper _ _) - = inst_mapper clas -get_inst_env clas other_orig = classInstEnv clas - - -pprOrigin :: PprStyle -> Inst s -> Doc -pprOrigin sty inst - = hsep [text "arising from", pp_orig orig, text "at", ppr sty locn] +pprOrigin :: Inst s -> SDoc +pprOrigin inst + = hsep [text "arising from", pp_orig orig <> comma, text "at", ppr locn] where (orig, locn) = case inst of Dict _ _ _ orig loc -> (orig,loc) @@ -673,15 +642,15 @@ pprOrigin sty inst LitInst _ _ _ orig loc -> (orig,loc) pp_orig (OccurrenceOf id) - = hsep [ptext SLIT("use of"), ppr sty id] + = hsep [ptext SLIT("use of"), quotes (ppr id)] pp_orig (OccurrenceOfCon id) - = hsep [ptext SLIT("use of"), ppr sty id] + = hsep [ptext SLIT("use of"), quotes (ppr id)] pp_orig (LiteralOrigin lit) - = hsep [ptext SLIT("the literal"), ppr sty lit] + = hsep [ptext SLIT("the literal"), quotes (ppr lit)] pp_orig (InstanceDeclOrigin) = ptext SLIT("an instance declaration") pp_orig (ArithSeqOrigin seq) - = hsep [ptext SLIT("the arithmetic sequence:"), ppr sty seq] + = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)] pp_orig (SignatureOrigin) = ptext SLIT("a type signature") pp_orig (Rank2Origin) @@ -690,17 +659,18 @@ pprOrigin sty inst = ptext SLIT("a do statement") pp_orig (ClassDeclOrigin) = ptext SLIT("a class declaration") - pp_orig (InstanceSpecOrigin _ clas ty) + pp_orig (InstanceSpecOrigin clas ty) = hsep [text "a SPECIALIZE instance pragma; class", - ppr sty clas, text "type:", ppr sty ty] + ppr clas, text "type:", ppr ty] pp_orig (ValSpecOrigin name) - = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), ppr sty name] + = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), ppr name] pp_orig (CCallOrigin clabel Nothing{-ccall result-}) = hsep [ptext SLIT("the result of the _ccall_ to"), text clabel] pp_orig (CCallOrigin clabel (Just arg_expr)) - = hsep [ptext SLIT("an argument in the _ccall_ to"), text clabel <> comma, text "namely", ppr sty arg_expr] + = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma, + text "namely", quotes (ppr arg_expr)] pp_orig (LitLitOrigin s) - = hsep [ptext SLIT("the ``literal-literal''"), text s] + = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)] pp_orig (UnknownOrigin) = ptext SLIT("...oops -- I don't know where the overloading came from!") \end{code} diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 30500ba58e..43612e725d 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -4,48 +4,42 @@ \section[TcBinds]{TcBinds} \begin{code} -#include "HsVersions.h" +module TcBinds ( tcBindsAndThen, tcTopBindsAndThen, + tcPragmaSigs, checkSigTyVars, tcBindWithSigs, + sigCtxt, sigThetaCtxt, TcSigInfo(..) ) where -module TcBinds ( tcBindsAndThen, tcPragmaSigs, checkSigTyVars, tcBindWithSigs, TcSigInfo(..) ) where +#include "HsVersions.h" -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds ) -#else import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds ) -#endif - -import HsSyn ( HsBinds(..), Sig(..), MonoBinds(..), - Match, HsType, InPat(..), OutPat(..), HsExpr(..), - SYN_IE(RecFlag), nonRecursive, - GRHSsAndBinds, ArithSeqInfo, HsLit, Fake, Stmt, DoOrListComp, Fixity, - collectMonoBinders ) -import RnHsSyn ( SYN_IE(RenamedHsBinds), RenamedSig(..), - SYN_IE(RenamedMonoBinds) + +import HsSyn ( HsBinds(..), MonoBinds(..), Sig(..), InPat(..), + collectMonoBinders ) -import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), - SYN_IE(TcExpr), +import RnHsSyn ( RenamedHsBinds, RenamedSig(..), + RenamedMonoBinds + ) +import TcHsSyn ( TcHsBinds, TcMonoBinds, + TcExpr, TcIdOcc(..), TcIdBndr, tcIdType ) import TcMonad -import Inst ( Inst, SYN_IE(LIE), emptyLIE, plusLIE, plusLIEs, InstOrigin(..), - newDicts, tyVarsOfInst, instToId, newMethodWithGivenTy +import Inst ( Inst, LIE, emptyLIE, plusLIE, plusLIEs, InstOrigin(..), + newDicts, tyVarsOfInst, instToId, newMethodWithGivenTy, + zonkInst, pprInsts ) import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newLocalId, tcGetGlobalTyVars, tcExtendGlobalTyVars ) -import SpecEnv ( SpecEnv ) import TcMatches ( tcMatchesFun ) import TcSimplify ( tcSimplify, tcSimplifyAndCheck ) import TcMonoType ( tcHsType ) import TcPat ( tcPat ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcType ( TcIdOcc(..), SYN_IE(TcIdBndr), - SYN_IE(TcType), SYN_IE(TcThetaType), SYN_IE(TcTauType), - SYN_IE(TcTyVarSet), SYN_IE(TcTyVar), - newTyVarTy, zonkTcType, zonkTcTheta, zonkSigTyVar, - newTcTyVar, tcInstSigType, newTyVarTys +import TcType ( TcType, TcThetaType, TcTauType, + TcTyVarSet, TcTyVar, + newTyVarTy, newTcTyVar, tcInstSigType, newTyVarTys, + zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcTyVar ) import Unify ( unifyTauTy, unifyTauTyLists ) @@ -55,22 +49,17 @@ import IdInfo ( noIdInfo ) import Maybes ( maybeToBool, assocMaybe, catMaybes ) import Name ( getOccName, getSrcLoc, Name ) import PragmaInfo ( PragmaInfo(..) ) -import Pretty -import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, tyVarsOfTypes, eqSimpleTheta, +import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, tyVarsOfTypes, mkSigmaTy, splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, mkDictTy, - splitRhoTy, mkForAllTy, splitForAllTy ) -import TyVar ( GenTyVar, SYN_IE(TyVar), tyVarKind, mkTyVarSet, minusTyVarSet, emptyTyVarSet, + splitRhoTy, mkForAllTy, splitForAllTys ) +import TyVar ( GenTyVar, TyVar, tyVarKind, mkTyVarSet, minusTyVarSet, emptyTyVarSet, elementOfTyVarSet, unionTyVarSets, tyVarSetToList ) import Bag ( bagToList, foldrBag, isEmptyBag ) -import Util ( isIn, zipEqual, zipWithEqual, zipWith3Equal, hasNoDups, assoc, - assertPanic, panic, pprTrace ) -import PprType ( GenClass, GenType, GenTyVar ) +import Util ( isIn, zipEqual, zipWithEqual, zipWith3Equal, hasNoDups, assoc ) import Unique ( Unique ) +import BasicTypes ( TopLevelFlag(..), RecFlag(..) ) import SrcLoc ( SrcLoc ) - -import Outputable --( interppSP, interpp'SP ) - - +import Outputable \end{code} @@ -106,54 +95,81 @@ At the top-level the LIE is sure to contain nothing but constant dictionaries, which we resolve at the module level. \begin{code} -tcBindsAndThen - :: (RecFlag -> TcMonoBinds s -> thing -> thing) -- Combinator +tcTopBindsAndThen, tcBindsAndThen + :: (RecFlag -> TcMonoBinds s -> this -> that) -- Combinator -> RenamedHsBinds - -> TcM s (thing, LIE s) - -> TcM s (thing, LIE s) - -tcBindsAndThen combiner EmptyBinds do_next - = do_next `thenTc` \ (thing, lie) -> - returnTc (combiner nonRecursive EmptyMonoBinds thing, lie) - -tcBindsAndThen combiner (ThenBinds binds1 binds2) do_next - = tcBindsAndThen combiner binds1 (tcBindsAndThen combiner binds2 do_next) - -tcBindsAndThen combiner (MonoBind bind sigs is_rec) do_next - = fixTc (\ ~(prag_info_fn, _) -> - -- This is the usual prag_info fix; the PragmaInfo field of an Id - -- is not inspected till ages later in the compiler, so there - -- should be no black-hole problems here. - - -- TYPECHECK THE SIGNATURES - mapTc (tcTySig prag_info_fn) ty_sigs `thenTc` \ tc_ty_sigs -> - - tcBindWithSigs binder_names bind - tc_ty_sigs is_rec prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) -> + -> TcM s (this, LIE s) + -> TcM s (that, LIE s) - -- Extend the environment to bind the new polymorphic Ids - tcExtendLocalValEnv binder_names poly_ids $ +tcTopBindsAndThen = tc_binds_and_then TopLevel +tcBindsAndThen = tc_binds_and_then NotTopLevel - -- Build bindings and IdInfos corresponding to user pragmas - tcPragmaSigs sigs `thenTc` \ (prag_info_fn, prag_binds, prag_lie) -> +tc_binds_and_then top_lvl combiner binds do_next + = tcBinds top_lvl binds `thenTc` \ (mbinds1, binds_lie, env, ids) -> + tcSetEnv env $ -- Now do whatever happens next, in the augmented envt - do_next `thenTc` \ (thing, thing_lie) -> + do_next `thenTc` \ (thing, thing_lie) -> -- Create specialisations of functions bound here - bindInstsOfLocalFuns (prag_lie `plusLIE` thing_lie) - poly_ids `thenTc` \ (lie2, inst_mbinds) -> + -- Nota Bene: we glom the bindings all together in a single + -- recursive group ("recursive" passed to combiner, below) + -- so that we can do thsi bindInsts thing once for all the bindings + -- and the thing inside. This saves a quadratic-cost algorithm + -- when there's a long sequence of bindings. + bindInstsOfLocalFuns (binds_lie `plusLIE` thing_lie) ids `thenTc` \ (final_lie, mbinds2) -> -- All done let - final_lie = lie2 `plusLIE` poly_lie - final_thing = combiner is_rec poly_binds $ - combiner nonRecursive inst_mbinds $ - combiner nonRecursive prag_binds - thing + final_mbinds = mbinds1 `AndMonoBinds` mbinds2 in - returnTc (prag_info_fn, (final_thing, final_lie)) - ) `thenTc` \ (_, result) -> + returnTc (combiner Recursive final_mbinds thing, final_lie) + +tcBinds :: TopLevelFlag + -> RenamedHsBinds + -> TcM s (TcMonoBinds s, LIE s, TcEnv s, [TcIdBndr s]) + -- The envt is the envt with binders in scope + -- The binders are those bound by this group of bindings + +tcBinds top_lvl EmptyBinds + = tcGetEnv `thenNF_Tc` \ env -> + returnTc (EmptyMonoBinds, emptyLIE, env, []) + + -- Short-cut for the rather common case of an empty bunch of bindings +tcBinds top_lvl (MonoBind EmptyMonoBinds sigs is_rec) + = tcGetEnv `thenNF_Tc` \ env -> + returnTc (EmptyMonoBinds, emptyLIE, env, []) + +tcBinds top_lvl (ThenBinds binds1 binds2) + = tcBinds top_lvl binds1 `thenTc` \ (mbinds1, lie1, env1, ids1) -> + tcSetEnv env1 $ + tcBinds top_lvl binds2 `thenTc` \ (mbinds2, lie2, env2, ids2) -> + returnTc (mbinds1 `AndMonoBinds` mbinds2, lie1 `plusLIE` lie2, env2, ids1++ids2) + +tcBinds top_lvl (MonoBind bind sigs is_rec) + = fixTc (\ ~(prag_info_fn, _) -> + -- This is the usual prag_info fix; the PragmaInfo field of an Id + -- is not inspected till ages later in the compiler, so there + -- should be no black-hole problems here. + + -- TYPECHECK THE SIGNATURES + mapTc (tcTySig prag_info_fn) ty_sigs `thenTc` \ tc_ty_sigs -> + + tcBindWithSigs top_lvl binder_names bind + tc_ty_sigs is_rec prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) -> + + -- Extend the environment to bind the new polymorphic Ids + tcExtendLocalValEnv binder_names poly_ids $ + + -- Build bindings and IdInfos corresponding to user pragmas + tcPragmaSigs sigs `thenTc` \ (prag_info_fn, prag_binds, prag_lie) -> + + -- Catch the environment and return + tcGetEnv `thenNF_Tc` \ env -> + returnTc (prag_info_fn, (poly_binds `AndMonoBinds` prag_binds, + poly_lie `plusLIE` prag_lie, + env, poly_ids) + ) ) `thenTc` \ (_, result) -> returnTc result where binder_names = map fst (bagToList (collectMonoBinders bind)) @@ -205,14 +221,15 @@ so all the clever stuff is in here. \begin{code} tcBindWithSigs - :: [Name] + :: TopLevelFlag + -> [Name] -> RenamedMonoBinds -> [TcSigInfo s] -> RecFlag -> (Name -> PragmaInfo) -> TcM s (TcMonoBinds s, LIE s, [TcIdBndr s]) -tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn +tcBindWithSigs top_lvl binder_names mbind tc_ty_sigs is_rec prag_info_fn = recoverTc ( -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise subsequent @@ -252,8 +269,8 @@ tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn getTyVarsToGen is_unrestricted mono_id_tys lie `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen) -> -- DEAL WITH TYPE VARIABLE KINDS - mapTc defaultUncommittedTyVar - (tyVarSetToList tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list -> + -- **** This step can do unification => keep other zonking after this **** + mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list -> let real_tyvars_to_gen = mkTyVarSet real_tyvars_to_gen_list -- It's important that the final list @@ -264,20 +281,20 @@ tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn -- Also NB that tcSimplify takes zonked tyvars as its arg, hence we pass -- real_tyvars_to_gen -- - -- **** This step can do unification => keep other zonking after this **** in -- SIMPLIFY THE LIE - tcExtendGlobalTyVars tyvars_not_to_gen ( + tcExtendGlobalTyVars (tyVarSetToList tyvars_not_to_gen) ( if null tc_ty_sigs then -- No signatures, so just simplify the lie -- NB: no signatures => no polymorphic recursion, so no -- need to use mono_lies (which will be empty anyway) - tcSimplify real_tyvars_to_gen lie `thenTc` \ (lie_free, dict_binds, lie_bound) -> + tcSimplify (text "tcBinds1" <+> ppr binder_names) + top_lvl real_tyvars_to_gen lie `thenTc` \ (lie_free, dict_binds, lie_bound) -> returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound)) else - zonkTcTheta sig_theta `thenNF_Tc` \ sig_theta' -> + zonkTcThetaType sig_theta `thenNF_Tc` \ sig_theta' -> newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (dicts_sig, dict_ids) -> -- It's important that sig_theta is zonked, because -- dict_id is later used to form the type of the polymorphic thing, @@ -293,8 +310,12 @@ tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn -- Check that the needed dicts can be expressed in -- terms of the signature ones - tcAddErrCtxt (sigsCtxt tysig_names) $ - tcSimplifyAndCheck real_tyvars_to_gen givens lie `thenTc` \ (lie_free, dict_binds) -> + tcAddErrCtxt (bindSigsCtxt tysig_names) $ + tcAddErrCtxtM (sigThetaCtxt dicts_sig) $ + tcSimplifyAndCheck + (text "tcBinds2" <+> ppr binder_names) + real_tyvars_to_gen givens lie `thenTc` \ (lie_free, dict_binds) -> + returnTc (lie_free, dict_binds, dict_ids) ) `thenTc` \ (lie_free, dict_binds, dicts_bound) -> @@ -307,7 +328,7 @@ tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn -- That's why we just use an ASSERT here. -- BUILD THE POLYMORPHIC RESULT IDs - mapNF_Tc zonkTcType mono_id_tys `thenNF_Tc` \ zonked_mono_id_types -> + zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_types -> let exports = zipWith3 mk_export binder_names mono_ids zonked_mono_id_types dict_tys = map tcIdType dicts_bound @@ -366,8 +387,9 @@ tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn tysig_names = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs] is_unrestricted = isUnRestrictedGroup tysig_names mbind - kind | is_rec = mkBoxedTypeKind -- Recursive, so no unboxed types - | otherwise = mkTypeKind -- Non-recursive, so we permit unboxed types + kind = case is_rec of + Recursive -> mkBoxedTypeKind -- Recursive, so no unboxed types + NonRecursive -> mkTypeKind -- Non-recursive, so we permit unboxed types \end{code} Polymorphic recursion @@ -456,8 +478,8 @@ find which tyvars are constrained. \begin{code} getTyVarsToGen is_unrestricted mono_id_tys lie - = tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars -> - mapNF_Tc zonkTcType mono_id_tys `thenNF_Tc` \ zonked_mono_id_tys -> + = tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars -> + zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_tys -> let tyvars_to_gen = tyVarsOfTypes zonked_mono_id_tys `minusTyVarSet` free_tyvars in @@ -465,7 +487,7 @@ getTyVarsToGen is_unrestricted mono_id_tys lie then returnTc (emptyTyVarSet, tyvars_to_gen) else - tcSimplify tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) -> + tcSimplify (text "getTVG") NotTopLevel tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) -> let -- ASSERT: dicts_sig is already zonked! constrained_tyvars = foldrBag (unionTyVarSets . tyVarsOfInst) emptyTyVarSet constrained_dicts @@ -659,7 +681,7 @@ checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _) : all_sigs_but_fi tcAddErrCtxt (sigCtxt id) $ checkSigTyVars sig_tyvars sig_tau - mk_dict_tys theta = [mkDictTy c t | (c,t) <- theta] + mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta] \end{code} @@ -674,8 +696,6 @@ are eg matching signature [(a,b)] against inferred type [(p,p)] [then a and b will be unified together] -BUT ACTUALLY THESE FIRST TWO ARE FORCED BY USING DontBind TYVARS - (c) not mentioned in the environment eg the signature for f in this: @@ -687,24 +707,43 @@ BUT ACTUALLY THESE FIRST TWO ARE FORCED BY USING DontBind TYVARS Before doing this, the substitution is applied to the signature type variable. +We used to have the notion of a "DontBind" type variable, which would +only be bound to itself or nothing. Then points (a) and (b) were +self-checking. But it gave rise to bogus consequential error messages. +For example: + + f = (*) -- Monomorphic + + g :: Num a => a -> a + g x = f x x + +Here, we get a complaint when checking the type signature for g, +that g isn't polymorphic enough; but then we get another one when +dealing with the (Num x) context arising from f's definition; +we try to unify x with Int (to default it), but find that x has already +been unified with the DontBind variable "a" from g's signature. +This is really a problem with side-effecting unification; we'd like to +undo g's effects when its type signature fails, but unification is done +by side effect, so we can't (easily). + +So we revert to ordinary type variables for signatures, and try to +give a helpful message in checkSigTyVars. + \begin{code} checkSigTyVars :: [TcTyVar s] -- The original signature type variables -> TcType s -- signature type (for err msg) - -> TcM s () + -> TcM s [TcTyVar s] -- Zonked signature type variables checkSigTyVars sig_tyvars sig_tau - = -- Several type signatures in the same bindings group can - -- cause the signature type variable from the different - -- signatures to be unified. So we need to zonk them. - mapNF_Tc zonkSigTyVar sig_tyvars `thenNF_Tc` \ sig_tyvars' -> - - -- Point (a) is forced by the fact that they are signature type - -- variables, so the unifer won't bind them to a type. + = mapNF_Tc zonkTcTyVar sig_tyvars `thenNF_Tc` \ sig_tys -> + let + sig_tyvars' = map (getTyVar "checkSigTyVars") sig_tys + in - -- Check point (b) - checkTcM (hasNoDups sig_tyvars') + -- Check points (a) and (b) + checkTcM (all isTyVarTy sig_tys && hasNoDups sig_tyvars') (zonkTcType sig_tau `thenNF_Tc` \ sig_tau' -> - failTc (badMatchErr sig_tau sig_tau') + failWithTc (badMatchErr sig_tau sig_tau') ) `thenTc_` -- Check point (c) @@ -713,15 +752,15 @@ checkSigTyVars sig_tyvars sig_tau -- 1-1 with sig_tyvars, so we can just map back. tcGetGlobalTyVars `thenNF_Tc` \ globals -> let --- mono_tyvars = [sig_tv | (sig_tv, sig_tv') <- sig_tyvars `zip` sig_tyvars', --- sig_tv' `elementOfTyVarSet` globals --- ] mono_tyvars' = [sig_tv' | sig_tv' <- sig_tyvars', sig_tv' `elementOfTyVarSet` globals] + + mono_tyvars = map (assoc "checkSigTyVars" (sig_tyvars' `zip` sig_tyvars)) mono_tyvars' in checkTcM (null mono_tyvars') - (zonkTcType sig_tau `thenNF_Tc` \ sig_tau' -> - failTc (notAsPolyAsSigErr sig_tau' mono_tyvars')) + (failWithTc (notAsPolyAsSigErr sig_tau mono_tyvars)) `thenTc_` + + returnTc sig_tyvars' \end{code} @@ -843,7 +882,7 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id -> tcInstSigType [] (idType main_id) `thenNF_Tc` \ main_ty -> let - (main_tyvars, main_rho) = splitForAllTy main_ty + (main_tyvars, main_rho) = splitForAllTys main_ty (main_theta,main_tau) = splitRhoTy main_rho main_arg_tys = mkTyVarTys main_tyvars in @@ -857,7 +896,7 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) -- either left polymorphic, or instantiate to ground type. -- Also check that the overloaded type variables are instantiated to -- ground type; or equivalently that all dictionaries have ground type - mapTc zonkTcType main_arg_tys `thenNF_Tc` \ main_arg_tys' -> + zonkTcTypes main_arg_tys `thenNF_Tc` \ main_arg_tys' -> zonkTcThetaType main_theta `thenNF_Tc` \ main_theta' -> tcAddErrCtxt (specGroundnessCtxt main_arg_tys') (checkTc (all isGroundOrTyVarTy main_arg_tys')) `thenTc_` @@ -916,43 +955,46 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) \begin{code} -patMonoBindsCtxt bind sty - = hang (ptext SLIT("In a pattern binding:")) 4 (ppr sty bind) +patMonoBindsCtxt bind + = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind) ----------------------------------------------- -valSpecSigCtxt v ty sty - = hang (ptext SLIT("In a SPECIALIZE pragma for a value:")) - 4 (sep [(<>) (ppr sty v) (ptext SLIT(" ::")), - ppr sty ty]) - - +valSpecSigCtxt v ty + = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"), + nest 4 (ppr v <+> ptext SLIT(" ::") <+> ppr ty)] ----------------------------------------------- -notAsPolyAsSigErr sig_tau mono_tyvars sty +notAsPolyAsSigErr sig_tau mono_tyvars = hang (ptext SLIT("A type signature is more polymorphic than the inferred type")) - 4 (vcat [text "Can't for-all the type variable(s)" <+> interpp'SP sty mono_tyvars, - text "in the inferred type" <+> ppr sty sig_tau + 4 (vcat [text "Can't for-all the type variable(s)" <+> + pprQuotedList mono_tyvars, + text "in the type" <+> quotes (ppr sig_tau) ]) ----------------------------------------------- -badMatchErr sig_ty inferred_ty sty +badMatchErr sig_ty inferred_ty = hang (ptext SLIT("Type signature doesn't match inferred type")) - 4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sty sig_ty), - hang (ptext SLIT("Inferred :")) 4 (ppr sty inferred_ty) + 4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sig_ty), + hang (ptext SLIT("Inferred :")) 4 (ppr inferred_ty) ]) ----------------------------------------------- -sigCtxt id sty - = sep [ptext SLIT("When checking signature for"), ppr sty id] -sigsCtxt ids sty - = sep [ptext SLIT("When checking signature(s) for:"), interpp'SP sty ids] +sigCtxt id + = sep [ptext SLIT("When checking the type signature for"), quotes (ppr id)] + +sigThetaCtxt dicts_sig + = mapNF_Tc zonkInst (bagToList dicts_sig) `thenNF_Tc` \ dicts' -> + returnNF_Tc (ptext SLIT("Available context:") <+> pprInsts dicts') + +bindSigsCtxt ids + = ptext SLIT("When checking the type signature(s) for") <+> pprQuotedList ids ----------------------------------------------- -sigContextsErr sty +sigContextsErr = ptext SLIT("Mismatched contexts") -sigContextsCtxt s1 s2 sty +sigContextsCtxt s1 s2 = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"), - ppr sty s1, ptext SLIT("and"), ppr sty s2]) + quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)]) 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)")) ----------------------------------------------- @@ -960,16 +1002,16 @@ specGroundnessCtxt = panic "specGroundnessCtxt" -------------------------------------------- -specContextGroundnessCtxt -- err_ctxt dicts sty +specContextGroundnessCtxt -- err_ctxt dicts = panic "specContextGroundnessCtxt" {- = hang ( - sep [hsep [ptext SLIT("In the SPECIALIZE pragma for"), ppr sty name], - hcat [ptext SLIT(" specialised to the type"), ppr sty spec_ty], - pp_spec_id sty, + sep [hsep [ptext SLIT("In the SPECIALIZE pragma for"), ppr name], + hcat [ptext SLIT(" specialised to the type"), ppr spec_ty], + pp_spec_id, ptext SLIT("... not all overloaded type variables were instantiated"), ptext SLIT("to ground types:")]) - 4 (vcat [hsep [ppr sty c, ppr sty t] + 4 (vcat [hsep [ppr c, ppr t] | (c,t) <- map getDictClassAndType dicts]) where (name, spec_ty, locn, pp_spec_id) @@ -977,10 +1019,6 @@ specContextGroundnessCtxt -- err_ctxt dicts sty ValSpecSigCtxt n ty loc -> (n, ty, loc, \ x -> empty) ValSpecSpecIdCtxt n ty spec loc -> (n, ty, loc, - \ sty -> hsep [ptext SLIT("... type of explicit id"), ppr sty spec]) + hsep [ptext SLIT("... type of explicit id"), ppr spec]) -} \end{code} - - - - diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 284f1ce0d1..407f3d62c2 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -4,50 +4,45 @@ \section[TcClassDcl]{Typechecking class declarations} \begin{code} -#include "HsVersions.h" - -module TcClassDcl ( tcClassDecl1, tcClassDecls2, - badMethodErr, tcMethodBind - ) where +module TcClassDcl ( tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) where -IMP_Ubiq() +#include "HsVersions.h" -import HsSyn ( HsDecl(..), ClassDecl(..), HsBinds(..), MonoBinds(..), - Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), - DefaultDecl, TyDecl, InstDecl, IfaceSig, Fixity, - HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar, InPat(..), - SYN_IE(RecFlag), nonRecursive, andMonoBinds, collectMonoBinders, - Stmt, DoOrListComp, ArithSeqInfo, Fake ) -import HsTypes ( getTyVarName ) +import HsSyn ( HsDecl(..), ClassDecl(..), Sig(..), MonoBinds(..), + InPat(..), + andMonoBinds, collectMonoBinders, + getTyVarName + ) import HsPragmas ( ClassPragmas(..) ) +import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..) ) import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..), - RenamedClassOpSig(..), SYN_IE(RenamedMonoBinds), - RenamedGenPragmas(..), RenamedContext(..), SYN_IE(RenamedHsDecl) + RenamedClassOpSig(..), RenamedMonoBinds, + RenamedGenPragmas(..), RenamedContext(..), RenamedHsDecl ) -import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr), +import TcHsSyn ( TcHsBinds, TcMonoBinds, TcExpr, mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType ) -import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod ) -import TcEnv ( tcLookupClass, tcLookupTyVar, newLocalIds, tcAddImportedIdInfo, +import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod ) +import TcEnv ( TcIdOcc(..), newLocalIds, tcAddImportedIdInfo, + tcLookupClass, tcLookupTyVar, tcExtendGlobalTyVars ) -import TcBinds ( tcBindWithSigs, TcSigInfo(..) ) -import TcKind ( unifyKind, TcKind ) +import TcBinds ( tcBindWithSigs, checkSigTyVars, sigCtxt, sigThetaCtxt, TcSigInfo(..) ) +import TcKind ( unifyKinds, TcKind ) import TcMonad import TcMonoType ( tcHsType, tcContext ) import TcSimplify ( tcSimplifyAndCheck ) -import TcType ( TcIdOcc(..), SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, - tcInstSigType, tcInstSigTcType ) +import TcType ( TcType, TcTyVar, TcTyVarSet, tcInstSigTyVars, + zonkSigTyVar, tcInstSigTcType + ) import PragmaInfo ( PragmaInfo(..) ) import Bag ( bagToList, unionManyBags ) -import Class ( GenClass, mkClass, classBigSig, - classDefaultMethodId, - SYN_IE(Class) - ) -import CmdLineOpts ( opt_PprUserLength ) -import Id ( GenId, mkSuperDictSelId, mkMethodSelId, - mkDefaultMethodId, getIdUnfolding, - idType, SYN_IE(Id) +import Class ( mkClass, classBigSig, Class ) +import CmdLineOpts ( opt_PprUserLength, opt_GlasgowExts ) +import Id ( Id, StrictnessMark(..), + mkSuperDictSelId, mkMethodSelId, + mkDefaultMethodId, getIdUnfolding, mkDataCon, + idType ) import CoreUnfold ( getUnfoldingTemplate ) import IdInfo @@ -55,15 +50,14 @@ import Name ( Name, isLocallyDefined, moduleString, getSrcLoc, OccName, nameOccName, nameString, NamedThing(..) ) import Outputable -import Pretty -import PprType ( GenClass, GenType, GenTyVar ) -import SpecEnv ( SpecEnv ) import SrcLoc ( mkGeneratedSrcLoc ) import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, splitRhoTy, - mkForAllTy, mkSigmaTy, splitSigmaTy, SYN_IE(Type) + mkForAllTy, mkSigmaTy, splitSigmaTy, mkForAllTys, Type, ThetaType ) import TysWiredIn ( stringTy ) -import TyVar ( unitTyVarSet, GenTyVar, SYN_IE(TyVar) ) +import TyVar ( unitTyVarSet, tyVarSetToList, mkTyVarSet, tyVarKind, TyVar ) +import TyCon ( mkDataTyCon ) +import Kind ( mkBoxedTypeKind, mkArrowKind ) import Unique ( Unique, Uniquable(..) ) import Util import Maybes ( assocMaybe, maybeToBool ) @@ -113,107 +107,112 @@ Death to "ExpandingDicts". \begin{code} tcClassDecl1 rec_env rec_inst_mapper (ClassDecl context class_name - tyvar_name class_sigs def_methods pragmas src_loc) + tyvar_names class_sigs def_methods pragmas + tycon_name datacon_name src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (classDeclCtxt class_name) $ + -- CHECK ARITY 1 FOR HASKELL 1.4 + checkTc (opt_GlasgowExts || length tyvar_names == 1) + (classArityErr class_name) `thenTc_` + -- LOOK THINGS UP IN THE ENVIRONMENT - tcLookupClass class_name `thenTc` \ (class_kind, rec_class) -> - tcLookupTyVar (getTyVarName tyvar_name) `thenNF_Tc` \ (tyvar_kind, rec_tyvar) -> - let - rec_class_inst_env = rec_inst_mapper rec_class - in + tcLookupClass class_name `thenTc` \ (class_kinds, rec_class) -> + mapAndUnzipNF_Tc (tcLookupTyVar . getTyVarName) tyvar_names + `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) -> -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND - unifyKind class_kind tyvar_kind `thenTc_` + unifyKinds class_kinds tyvar_kinds `thenTc_` -- CHECK THE CONTEXT - tcClassContext rec_class rec_tyvar context pragmas - `thenTc` \ (scs, sc_sel_ids) -> + tcClassContext rec_class rec_tyvars context pragmas + `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) -> -- CHECK THE CLASS SIGNATURES, - mapTc (tcClassSig rec_env rec_class rec_tyvar) class_sigs - `thenTc` \ sig_stuff -> + mapTc (tcClassSig rec_env rec_class rec_tyvars) class_sigs + `thenTc` \ sig_stuff -> -- MAKE THE CLASS OBJECT ITSELF let - (op_sel_ids, defm_ids) = unzip sig_stuff - clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar - scs sc_sel_ids op_sel_ids defm_ids + (op_tys, op_sel_ids, defm_ids) = unzip3 sig_stuff + rec_class_inst_env = rec_inst_mapper rec_class + clas = mkClass (getName class_name) rec_tyvars + sc_theta sc_sel_ids op_sel_ids defm_ids + tycon rec_class_inst_env - in - returnTc clas -\end{code} - - let - clas_ty = mkTyVarTy clas_tyvar - dict_component_tys = classDictArgTys clas_ty + dict_component_tys = sc_tys ++ op_tys new_or_data = case dict_component_tys of [_] -> NewType other -> DataType - dict_con_id = mkDataCon class_name - [NotMarkedStrict] + dict_con_id = mkDataCon datacon_name + [NotMarkedStrict | _ <- dict_component_tys] [{- No labelled fields -}] - [clas_tyvar] + rec_tyvars [{-No context-}] + [{-No existential tyvars-}] [{-Or context-}] dict_component_tys tycon - tycon = mkDataTyCon class_name - (tyVarKind rec_tyvar `mkArrowKind` mkBoxedTypeKind) - [rec_tyvar] - [{- Empty context -}] - [dict_con_id] - [{- No derived classes -}] + tycon = mkDataTyCon tycon_name + (foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars) + rec_tyvars + [] -- No context + [dict_con_id] -- Constructors + [] -- No derivings + (Just clas) -- Yes! It's a dictionary new_or_data + NonRecursive in + returnTc clas +\end{code} \begin{code} -tcClassContext :: Class -> TyVar +tcClassContext :: Class -> [TyVar] -> RenamedContext -- class context -> RenamedClassPragmas -- pragmas for superclasses - -> TcM s ([Class], -- the superclasses - [Id]) -- superclass selector Ids + -> TcM s (ThetaType, -- the superclass context + [Type], -- types of the superclass dictionaries + [Id]) -- superclass selector Ids -tcClassContext rec_class rec_tyvar context pragmas +tcClassContext rec_class rec_tyvars context pragmas = -- Check the context. -- The renamer has already checked that the context mentions -- only the type variable of the class decl. - tcContext context `thenTc` \ theta -> + tcContext context `thenTc` \ sc_theta -> let - super_classes = [ supers | (supers, _) <- theta ] + sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta] in -- Make super-class selector ids - mapTc (mk_super_id rec_class) super_classes `thenTc` \ sc_sel_ids -> + mapTc mk_super_id sc_theta `thenTc` \ sc_sel_ids -> -- Done - returnTc (super_classes, sc_sel_ids) + returnTc (sc_theta, sc_tys, sc_sel_ids) where - rec_tyvar_ty = mkTyVarTy rec_tyvar + rec_tyvar_tys = mkTyVarTys rec_tyvars - mk_super_id rec_class super_class + mk_super_id (super_class, tys) = tcGetUnique `thenNF_Tc` \ uniq -> let - ty = mkForAllTy rec_tyvar $ - mkFunTy (mkDictTy rec_class rec_tyvar_ty) - (mkDictTy super_class rec_tyvar_ty) + ty = mkForAllTys rec_tyvars $ + mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys) in returnTc (mkSuperDictSelId uniq rec_class super_class ty) tcClassSig :: TcEnv s -- Knot tying only! -> Class -- ...ditto... - -> TyVar -- The class type variable, used for error check only + -> [TyVar] -- The class type variable, used for error check only -> RenamedClassOpSig - -> TcM s (Id, -- selector id + -> TcM s (Type, -- Type of the method + Id, -- selector id Maybe Id) -- default-method ids -tcClassSig rec_env rec_clas rec_clas_tyvar +tcClassSig rec_env rec_clas rec_clas_tyvars (ClassOpSig op_name maybe_dm_name op_ty src_loc) @@ -226,8 +225,8 @@ tcClassSig rec_env rec_clas rec_clas_tyvar -- and that it is not constrained by theta tcHsType op_ty `thenTc` \ local_ty -> let - global_ty = mkSigmaTy [rec_clas_tyvar] - [(rec_clas, mkTyVarTy rec_clas_tyvar)] + global_ty = mkSigmaTy rec_clas_tyvars + [(rec_clas, mkTyVarTys rec_clas_tyvars)] local_ty in @@ -241,7 +240,7 @@ tcClassSig rec_env rec_clas rec_clas_tyvar in Just (tcAddImportedIdInfo rec_env dm_id) in - returnTc (sel_id, maybe_dm_id) + returnTc (local_ty, sel_id, maybe_dm_id) \end{code} @@ -289,7 +288,7 @@ tcClassDecl2 :: RenamedClassDecl -- The class declaration -> NF_TcM s (LIE s, TcMonoBinds s) tcClassDecl2 (ClassDecl context class_name - tyvar_name class_sigs default_binds pragmas src_loc) + tyvar_names class_sigs default_binds pragmas _ _ src_loc) | not (isLocallyDefined class_name) = returnNF_Tc (emptyLIE, EmptyMonoBinds) @@ -301,7 +300,7 @@ tcClassDecl2 (ClassDecl context class_name -- Get the relevant class tcLookupClass class_name `thenTc` \ (_, clas) -> let - (tyvar, scs, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas + (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas -- The selector binds are already in the selector Id's unfoldings sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id)) @@ -399,22 +398,20 @@ tcDefaultMethodBinds tcDefaultMethodBinds clas default_binds = -- Construct suitable signatures - tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], [inst_ty], inst_env) -> + tcInstSigTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) -> -- Typecheck the default bindings let - clas_tyvar_set = unitTyVarSet clas_tyvar - tc_dm meth_bind | not (maybeToBool maybe_stuff) = -- Binding for something that isn't in the class signature - failTc (badMethodErr bndr_name clas) + failWithTc (badMethodErr bndr_name clas) | otherwise = -- Normal case - tcMethodBind clas origin inst_ty sel_id meth_bind + tcMethodBind clas origin inst_tys clas_tyvars sel_id meth_bind `thenTc` \ (bind, insts, (_, local_dm_id)) -> - returnTc (bind, insts, ([clas_tyvar], RealId dm_id, local_dm_id)) + returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id)) where bndr_name = case meth_bind of FunMonoBind name _ _ _ -> name @@ -428,23 +425,25 @@ tcDefaultMethodBinds clas default_binds -- We're looking at a default-method binding, so the dm_id -- is sure to be there! Hence the inner "Just". in - tcExtendGlobalTyVars clas_tyvar_set ( - mapAndUnzip3Tc tc_dm (flatten default_binds []) - ) `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) -> + mapAndUnzip3Tc tc_dm + (flatten default_binds []) `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) -> -- Check the context - newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> + newDicts origin [(clas,inst_tys)] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> let - avail_insts = this_dict + avail_insts = this_dict in - tcSimplifyAndCheck - clas_tyvar_set + tcAddErrCtxt (classDeclCtxt clas) $ + tcAddErrCtxtM (sigThetaCtxt avail_insts) $ + mapNF_Tc zonkSigTyVar clas_tyvars `thenNF_Tc` \ clas_tyvars' -> + tcSimplifyAndCheck (text "classDecl") + (mkTyVarSet clas_tyvars') avail_insts (unionManyBags insts_needed) `thenTc` \ (const_lie, dict_binds) -> let full_binds = AbsBinds - [clas_tyvar] + clas_tyvars' [this_dict_id] abs_bind_stuff (dict_binds `AndMonoBinds` andMonoBinds defm_binds) @@ -452,7 +451,7 @@ tcDefaultMethodBinds clas default_binds returnTc (const_lie, full_binds) where - (tyvar, scs, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas + (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas origin = ClassDeclOrigin flatten EmptyMonoBinds rest = rest @@ -469,24 +468,38 @@ tyvar sets. tcMethodBind :: Class -> InstOrigin s - -> TcType s -- Instance type + -> [TcType s] -- Instance types + -> [TcTyVar s] -- Free variables of those instance types + -- they'll be signature tyvars, and we + -- want to check that they don't bound -> Id -- The method selector -> RenamedMonoBinds -- Method binding (just one) -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s)) -tcMethodBind clas origin inst_ty sel_id meth_bind +tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind = tcAddSrcLoc src_loc $ - newMethod origin (RealId sel_id) [inst_ty] `thenNF_Tc` \ meth@(_, TcId local_meth_id) -> + newMethod origin (RealId sel_id) inst_tys `thenNF_Tc` \ meth@(_, TcId local_meth_id) -> tcInstSigTcType (idType local_meth_id) `thenNF_Tc` \ (tyvars', rho_ty') -> let (theta', tau') = splitRhoTy rho_ty' sig_info = TySigInfo bndr_name local_meth_id tyvars' theta' tau' src_loc in - tcBindWithSigs [bndr_name] meth_bind [sig_info] - nonRecursive (\_ -> NoPragmaInfo) `thenTc` \ (binds, insts, _) -> + tcExtendGlobalTyVars inst_tyvars ( + tcAddErrCtxt (methodCtxt sel_id) $ + tcBindWithSigs NotTopLevel [bndr_name] meth_bind [sig_info] + NonRecursive (\_ -> NoPragmaInfo) + ) `thenTc` \ (binds, insts, _) -> + + -- Now check that the instance type variables + -- (or, in the case of a class decl, the class tyvars) + -- have not been unified with anything in the environment + tcAddErrCtxt (monoCtxt sel_id) ( + tcAddErrCtxt (sigCtxt sel_id) $ + checkSigTyVars inst_tyvars (idType local_meth_id) + ) `thenTc_` returnTc (binds, insts, meth) - where + where (bndr_name, src_loc) = case meth_bind of FunMonoBind name _ _ loc -> (name, loc) PatMonoBind (VarPatIn name) _ loc -> (name, loc) @@ -495,9 +508,21 @@ tcMethodBind clas origin inst_ty sel_id meth_bind Contexts and errors ~~~~~~~~~~~~~~~~~~~ \begin{code} -badMethodErr bndr clas sty - = hsep [ptext SLIT("Class"), ppr sty clas, ptext SLIT("does not have a method"), ppr sty bndr] +classArityErr class_name + = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name) + +classDeclCtxt class_name + = ptext SLIT("In the class declaration for") <+> quotes (ppr class_name) + +methodCtxt sel_id + = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id) + +monoCtxt sel_id + = sep [ptext SLIT("Probable cause: the right hand side of") <+> quotes (ppr sel_id), + nest 4 (ptext SLIT("mentions a top-level variable subject to the dreaded monomorphism restriction")) + ] -classDeclCtxt class_name sty - = hsep [ptext SLIT("In the class declaration for"), ppr sty class_name] +badMethodErr bndr clas + = hsep [ptext SLIT("Class"), quotes (ppr clas), + ptext SLIT("does not have a method"), quotes (ppr bndr)] \end{code} diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index 49f9421afa..714f278ca2 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -4,30 +4,24 @@ \section[TcDefaults]{Typechecking \tr{default} declarations} \begin{code} -#include "HsVersions.h" - module TcDefaults ( tcDefaults ) where -IMP_Ubiq() +#include "HsVersions.h" -import HsSyn ( HsDecl(..), TyDecl, ClassDecl, InstDecl, HsBinds, - DefaultDecl(..), HsType, IfaceSig, - HsExpr, HsLit, ArithSeqInfo, Fake, InPat) +import HsSyn ( HsDecl(..), DefaultDecl(..) ) import RnHsSyn ( RenamedHsDecl(..), RenamedDefaultDecl(..) ) import TcMonad import Inst ( InstOrigin(..) ) -import TcEnv ( tcLookupClassByKey ) -import SpecEnv ( SpecEnv ) +import TcEnv ( TcIdOcc, tcLookupClassByKey ) import TcMonoType ( tcHsType ) import TcSimplify ( tcSimplifyCheckThetas ) -import TcType ( TcIdOcc ) import TysWiredIn ( intTy, doubleTy, unitTy ) -import Type ( SYN_IE(Type) ) +import Type ( Type ) import Unique ( numClassKey ) -import Pretty ( ptext, vcat ) import ErrUtils ( addShortErrLocLine ) +import Outputable import Util \end{code} @@ -53,25 +47,28 @@ tc_defaults [DefaultDecl mono_tys locn] -- Check that all the types are instances of Num -- We only care about whether it worked or not - tcLookupClassByKey numClassKey `thenNF_Tc` \ num -> + tcAddErrCtxt defaultDeclCtxt $ + tcLookupClassByKey numClassKey `thenNF_Tc` \ num -> tcSimplifyCheckThetas - [ (num, ty) | ty <- tau_tys ] `thenTc_` + [{- Nothing given -}] + [ (num, [ty]) | ty <- tau_tys ] `thenTc_` returnTc tau_tys tc_defaults decls - = failTc (dupDefaultDeclErr decls) + = failWithTc (dupDefaultDeclErr decls) -dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty +defaultDeclCtxt = ptext SLIT("when checking that each type in a default declaration") + $$ ptext SLIT("is an instance of class Num") + + +dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) = vcat (item1 : map dup_item dup_things) where item1 - = addShortErrLocLine locn1 (\ sty -> - ptext SLIT("multiple default declarations")) sty + = addShortErrLocLine locn1 (ptext SLIT("multiple default declarations")) dup_item (DefaultDecl _ locn) - = addShortErrLocLine locn (\ sty -> - ptext SLIT("here was another default declaration")) sty - + = addShortErrLocLine locn (ptext SLIT("here was another default declaration")) \end{code} diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index dd422ae1ff..4e392531ee 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -6,69 +6,55 @@ Handles @deriving@ clauses on @data@ declarations. \begin{code} -#include "HsVersions.h" - module TcDeriv ( tcDeriving ) where -IMP_Ubiq() +#include "HsVersions.h" -import HsSyn ( HsDecl, FixityDecl, Fixity, InstDecl, - Sig, HsBinds(..), MonoBinds(..), - GRHSsAndBinds, Match, HsExpr, HsLit, InPat, - ArithSeqInfo, Fake, HsType, - collectMonoBinders - ) +import HsSyn ( HsBinds(..), MonoBinds(..), collectMonoBinders ) import HsPragmas ( InstancePragmas(..) ) -import RdrHsSyn ( RdrName, SYN_IE(RdrNameMonoBinds) ) -import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds), SYN_IE(RenamedFixityDecl) ) +import RdrHsSyn ( RdrName, RdrNameMonoBinds ) +import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds, RenamedFixityDecl ) import TcMonad -import Inst ( SYN_IE(InstanceMapper) ) -import TcEnv ( getEnv_TyCons, tcLookupClassByKey ) -import SpecEnv ( SpecEnv ) +import Inst ( InstanceMapper ) +import TcEnv ( TcIdOcc, getEnv_TyCons, tcLookupClassByKey ) import TcKind ( TcKind ) import TcGenDeriv -- Deriv stuff import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs ) import TcSimplify ( tcSimplifyThetas ) -import TcType ( TcIdOcc ) import RnBinds ( rnMethodBinds, rnTopMonoBinds ) import RnEnv ( newDfunName, bindLocatedLocalsRn ) -import RnMonad ( SYN_IE(RnM), RnDown, GDown, SDown, RnNameSupply(..), +import RnMonad ( RnM, RnDown, GDown, SDown, RnNameSupply(..), setNameSupplyRn, renameSourceCode, thenRn, mapRn, returnRn ) import Bag ( Bag, emptyBag, isEmptyBag, unionBags, listToBag ) -import Class ( classKey, GenClass, SYN_IE(Class) ) -import ErrUtils ( addErrLoc, SYN_IE(Error) ) +import Class ( classKey, Class ) +import ErrUtils ( ErrMsg ) import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId ) import PrelInfo ( needsDataDeclCtxtClassKeys ) import Maybes ( maybeToBool ) import Name ( isLocallyDefined, getSrcLoc, ExportFlag(..), Provenance, - Name{--O only-}, SYN_IE(Module), NamedThing(..) + Name{--O only-}, Module, NamedThing(..) ) -import Outputable ( PprStyle(..), Outputable(..){-instances e.g., (,)-} ) -import PprType ( GenType, GenTyVar, GenClass, TyCon ) -import Pretty ( ($$), vcat, hsep, hcat, parens, empty, (<+>), - ptext, char, hang, Doc ) import SrcLoc ( mkGeneratedSrcLoc, SrcLoc ) import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, tyConTheta, maybeTyConSingleCon, isDataTyCon, isEnumerationTyCon, isAlgTyCon, TyCon ) -import Type ( GenType(..), SYN_IE(TauType), mkTyVarTys, applyTyCon, - mkSigmaTy, mkDictTy, isPrimType, instantiateTy, - getAppDataTyCon, getAppTyCon +import Type ( GenType(..), TauType, mkTyVarTys, mkTyConApp, + mkSigmaTy, mkDictTy, isUnboxedType, + splitAlgTyConApp ) import TysPrim ( voidTy ) -import TyVar ( GenTyVar, SYN_IE(TyVar) ) +import TyVar ( GenTyVar, TyVar ) import UniqFM ( emptyUFM ) import Unique -- Keys stuff import Bag ( bagToList ) import Util ( zipWithEqual, zipEqual, sortLt, removeDups, assoc, - thenCmp, cmpList, panic, panic#, pprPanic, pprPanic#, - Ord3(..), assertPanic-- , pprTrace{-ToDo:rm-} - + thenCmp, cmpList ) +import Outputable \end{code} %************************************************************************ @@ -161,7 +147,7 @@ type DerivEqn = (Class, TyCon, [TyVar], DerivRhs) -- NEW: it's convenient to re-use InstInfo -- We'll "panic" out some fields... -type DerivRhs = [(Class, TauType)] -- Same as a ThetaType! +type DerivRhs = [(Class, [TauType])] -- Same as a ThetaType! type DerivSoln = DerivRhs \end{code} @@ -203,15 +189,18 @@ tcDeriving :: Module -- name of module under scrutiny -> Bag InstInfo -- What we already know about instances -> TcM s (Bag InstInfo, -- The generated "instance decls". RenamedHsBinds, -- Extra generated bindings - PprStyle -> Doc) -- Printable derived instance decls; + SDoc) -- Printable derived instance decls; -- for debugging via -ddump-derivings. tcDeriving modname rn_name_supply inst_decl_infos_in - = recoverTc (returnTc (emptyBag, EmptyBinds, \_ -> empty)) $ + = recoverTc (returnTc (emptyBag, EmptyBinds, empty)) $ -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". makeDerivEqns `thenTc` \ eqns -> + if null eqns then + returnTc (emptyBag, EmptyBinds, text "No derivings") + else -- Take the equation list and solve it, to deliver a list of -- solutions, a.k.a. the contexts for the instance decls @@ -238,7 +227,7 @@ tcDeriving modname rn_name_supply inst_decl_infos_in -- method bindings for the instances. (dfun_names_w_method_binds, rn_extra_binds) = renameSourceCode modname rn_name_supply ( - bindLocatedLocalsRn (\_ -> ptext (SLIT("deriving"))) mbinders $ \ _ -> + bindLocatedLocalsRn (ptext (SLIT("deriving"))) mbinders $ \ _ -> rnTopMonoBinds extra_mbinds [] `thenRn` \ rn_extra_binds -> mapRn rn_one method_binds_s `thenRn` \ dfun_names_w_method_binds -> returnRn (dfun_names_w_method_binds, rn_extra_binds) @@ -252,20 +241,20 @@ tcDeriving modname rn_name_supply inst_decl_infos_in ddump_deriv = ddump_deriving really_new_inst_infos rn_extra_binds in - --pprTrace "derived:\n" (ddump_deriv PprDebug) $ + --pprTrace "derived:\n" (ddump_deriv) $ returnTc (listToBag really_new_inst_infos, rn_extra_binds, ddump_deriv) where - ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Doc) + ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc - ddump_deriving inst_infos extra_binds sty - = vcat ((map pp_info inst_infos) ++ [ppr sty extra_binds]) + ddump_deriving inst_infos extra_binds + = vcat ((map pp_info inst_infos) ++ [ppr extra_binds]) where - pp_info (InstInfo clas tvs ty inst_decl_theta _ _ mbinds _ _) - = ($$) (ppr sty (mkSigmaTy tvs inst_decl_theta (mkDictTy clas ty))) - (ppr sty mbinds) + pp_info (InstInfo clas tvs [ty] inst_decl_theta _ _ mbinds _ _) + = ($$) (ppr (mkSigmaTy tvs inst_decl_theta (mkDictTy clas [ty]))) + (ppr mbinds) \end{code} @@ -361,9 +350,9 @@ makeDerivEqns (is_enumeration || is_single_con) ------------------------------------------------------------------ - cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_ + cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> Ordering cmp_deriv (c1, t1) (c2, t2) - = (c1 `cmp` c2) `thenCmp` (t1 `cmp` t2) + = (c1 `compare` c2) `thenCmp` (t1 `compare` t2) ------------------------------------------------------------------ mk_eqn :: (Class, TyCon) -> DerivEqn @@ -390,9 +379,9 @@ makeDerivEqns offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys mk_constraints data_con - = [ (clas, arg_ty) + = [ (clas, [arg_ty]) | arg_ty <- instd_arg_tys, - not (isPrimType arg_ty) -- No constraints for primitive types + not (isUnboxedType arg_ty) -- No constraints for unboxed types? ] where instd_arg_tys = dataConArgTys data_con tyvar_tys @@ -441,7 +430,7 @@ solveDerivEqns inst_decl_infos_in orig_eqns iterateDeriv :: [DerivSoln] ->TcM s [InstInfo] iterateDeriv current_solns = checkNoErrsTc (iterateOnce current_solns) `thenTc` \ (new_inst_infos, new_solns) -> - if (current_solns `eq_solns` new_solns) then + if (current_solns == new_solns) then returnTc new_inst_infos else iterateDeriv new_solns @@ -452,62 +441,46 @@ solveDerivEqns inst_decl_infos_in orig_eqns -- with the current set of solutions, giving a add_solns inst_decl_infos_in orig_eqns current_solns - `thenTc` \ (new_inst_infos, inst_mapper) -> + `thenNF_Tc` \ (new_inst_infos, inst_mapper) -> let class_to_inst_env cls = inst_mapper cls in -- Simplify each RHS listTc [ tcAddErrCtxt (derivCtxt tc) $ - tcSimplifyThetas class_to_inst_env [{-Nothing "given"-}] deriv_rhs + tcSimplifyThetas class_to_inst_env deriv_rhs | (_,tc,_,deriv_rhs) <- orig_eqns ] `thenTc` \ next_solns -> -- Canonicalise the solutions, so they compare nicely let canonicalised_next_solns - = [ sortLt lt_rhs next_soln | next_soln <- next_solns ] + = [ sortLt (<) next_soln | next_soln <- next_solns ] in returnTc (new_inst_infos, canonicalised_next_solns) - - ------------------------------------------------------------------ - lt_rhs r1 r2 = case cmp_rhs r1 r2 of { LT_ -> True; _ -> False } - eq_solns s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False } - cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2 - cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2) - = (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2) -#ifdef DEBUG - cmp_rhs other_1 other_2 - = panic# "tcDeriv:cmp_rhs:" --(hsep [ppr PprDebug other_1, ppr PprDebug other_2]) -#endif - \end{code} \begin{code} add_solns :: Bag InstInfo -- The global, non-derived ones -> [DerivEqn] -> [DerivSoln] - -> TcM s ([InstInfo], -- The new, derived ones - InstanceMapper) + -> NF_TcM s ([InstInfo], -- The new, derived ones + InstanceMapper) -- the eqns and solns move "in lockstep"; we have the eqns -- because we need the LHS info for addClassInstance. add_solns inst_infos_in eqns solns --- ------------------ --- OLD: checkErrsTc above now deals with this --- = discardErrsTc (buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper -> + = discardErrsTc (buildInstanceEnvs all_inst_infos) `thenNF_Tc` \ inst_mapper -> -- We do the discard-errs so that we don't get repeated error messages -- about duplicate instances. -- They'll appear later, when we do the top-level buildInstanceEnvs. --- ------------------ - = buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper -> - returnTc (new_inst_infos, inst_mapper) + returnNF_Tc (new_inst_infos, inst_mapper) where new_inst_infos = zipWithEqual "add_solns" mk_deriv_inst_info eqns solns all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos mk_deriv_inst_info (clas, tycon, tyvars, _) theta - = InstInfo clas tyvars (applyTyCon tycon (mkTyVarTys tyvars)) + = InstInfo clas tyvars [mkTyConApp tycon (mkTyVarTys tyvars)] theta (my_panic "dfun_theta") @@ -534,7 +507,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 = panic "add_soln" -- pprPanic ("add_soln:"++str) (hsep [char ':', ppr PprDebug clas, ppr PprDebug tycon]) + my_panic str = panic "add_soln" -- pprPanic ("add_soln:"++str) (hsep [char ':', ppr clas, ppr tycon]) \end{code} %************************************************************************ @@ -602,7 +575,7 @@ the renamer. What a great hack! \begin{code} -- Generate the method bindings for the required instance gen_bind :: InstInfo -> RdrNameMonoBinds -gen_bind (InstInfo clas _ ty _ _ _ _ _ _) +gen_bind (InstInfo clas _ [ty] _ _ _ _ _ _) | not from_here = EmptyMonoBinds | otherwise @@ -620,7 +593,7 @@ gen_bind (InstInfo clas _ ty _ _ _ _ _ _) tycon where from_here = isLocallyDefined tycon - (tycon,_,_) = getAppDataTyCon ty + (tycon,_,_) = splitAlgTyConApp ty gen_inst_info :: Module -- Module name @@ -628,21 +601,21 @@ gen_inst_info :: Module -- Module name -> InstInfo -- the gen'd (filled-in) "instance decl" gen_inst_info modname - (InstInfo clas tyvars ty inst_decl_theta _ _ _ locn _, (dfun_name, meth_binds)) + (InstInfo clas tyvars tys@(ty:_) inst_decl_theta _ _ _ locn _, (dfun_name, meth_binds)) = -- Generate the various instance-related Ids - InstInfo clas tyvars ty inst_decl_theta + InstInfo clas tyvars tys inst_decl_theta dfun_theta dfun_id meth_binds locn [] where (dfun_id, dfun_theta) = mkInstanceRelatedIds dfun_name - clas tyvars ty + clas tyvars tys inst_decl_theta from_here = isLocallyDefined tycon - (tycon,_,_) = getAppDataTyCon ty + (tycon,_,_) = splitAlgTyConApp ty \end{code} @@ -685,16 +658,16 @@ gen_taggery_Names :: [InstInfo] TagThingWanted)] gen_taggery_Names inst_infos - = --pprTrace "gen_taggery:\n" (vcat [hsep [ppr PprDebug c, ppr PprDebug t] | (c,t) <- all_CTs]) $ + = --pprTrace "gen_taggery:\n" (vcat [hsep [ppr c, ppr t] | (c,t) <- all_CTs]) $ foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far -> foldlTc do_tag2con names_so_far tycons_of_interest where - all_CTs = [ mk_CT c ty | (InstInfo c _ ty _ _ _ _ _ _) <- inst_infos ] + all_CTs = [ (c, get_tycon ty) | (InstInfo c _ [ty] _ _ _ _ _ _) <- inst_infos ] - mk_CT c ty = (c, fst (getAppTyCon ty)) + get_tycon ty = case splitAlgTyConApp ty of { (tc, _, _) -> tc } all_tycons = map snd all_CTs - (tycons_of_interest, _) = removeDups cmp all_tycons + (tycons_of_interest, _) = removeDups compare all_tycons do_con2tag acc_Names tycon | isDataTyCon tycon && @@ -731,13 +704,13 @@ gen_taggery_Names inst_infos \end{code} \begin{code} -derivingThingErr :: FAST_STRING -> FAST_STRING -> TyCon -> Error +derivingThingErr :: FAST_STRING -> FAST_STRING -> TyCon -> ErrMsg -derivingThingErr thing why tycon sty +derivingThingErr thing why tycon = hang (hsep [ptext SLIT("Can't make a derived instance of"), ptext thing]) - 0 (hang (hsep [ptext SLIT("for the type"), ppr sty tycon]) + 0 (hang (hsep [ptext SLIT("for the type"), quotes (ppr tycon)]) 0 (parens (ptext why))) -derivCtxt tycon sty - = ptext SLIT("When deriving classes for") <+> ppr sty tycon +derivCtxt tycon + = ptext SLIT("When deriving classes for") <+> quotes (ppr tycon) \end{code} diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index e406b2868c..a790a8b792 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -1,7 +1,7 @@ \begin{code} -#include "HsVersions.h" - module TcEnv( + TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId, + TcEnv, initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes, @@ -22,25 +22,20 @@ module TcEnv( tcGetGlobalTyVars, tcExtendGlobalTyVars ) where - -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(TcMLoop) -- for paranoia checking -#endif +#include "HsVersions.h" import HsTypes ( HsTyVar(..) ) -import Id ( SYN_IE(Id), GenId, idType, mkUserLocal, mkUserId, replaceIdInfo, getIdInfo ) +import Id ( Id, GenId, idType, mkUserLocal, mkUserId, replaceIdInfo, getIdInfo ) import PragmaInfo ( PragmaInfo(..) ) import TcKind ( TcKind, newKindVars, newKindVar, tcDefaultKind, kindToTcKind, Kind ) -import TcType ( SYN_IE(TcIdBndr), TcIdOcc(..), - SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), - newTyVarTys, tcInstTyVars, zonkTcTyVars +import TcType ( TcType, TcMaybe, TcTyVar, TcTyVarSet, TcThetaType, + newTyVarTys, tcInstTyVars, zonkTcTyVars, tcInstType ) -import TyVar ( unionTyVarSets, emptyTyVarSet, tyVarSetToList, SYN_IE(TyVar) ) +import TyVar ( mkTyVarSet, unionTyVarSets, emptyTyVarSet, tyVarSetToList, TyVar ) import PprType ( GenTyVar ) -import Type ( tyVarsOfTypes, splitForAllTy ) -import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon, SYN_IE(Arity) ) -import Class ( SYN_IE(Class), GenClass ) +import Type ( tyVarsOfType, tyVarsOfTypes, splitForAllTys, splitRhoTy ) +import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon, Arity ) +import Class ( Class ) import TcMonad @@ -49,16 +44,80 @@ import Name ( Name, OccName(..), getSrcLoc, occNameString, maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined, NamedThing(..) ) -import Pretty import Unique ( pprUnique10{-, pprUnique ToDo:rm-}, Unique, Uniquable(..) ) import UniqFM -import Util ( zipEqual, zipWithEqual, zipWith3Equal, zipLazy, - panic, pprPanic, pprTrace +import Util ( zipEqual, zipWithEqual, zipWith3Equal, zipLazy ) import Maybes ( maybeToBool ) import Outputable \end{code} +%************************************************************************ +%* * +\subsection{TcId, TcIdOcc} +%* * +%************************************************************************ + + +\begin{code} +type TcIdBndr s = GenId (TcType s) -- Binders are all TcTypes +data TcIdOcc s = TcId (TcIdBndr s) -- Bindees may be either + | RealId Id + +instance Eq (TcIdOcc s) where + (TcId id1) == (TcId id2) = id1 == id2 + (RealId id1) == (RealId id2) = id1 == id2 + _ == _ = False + +instance Ord (TcIdOcc s) where + (TcId id1) `compare` (TcId id2) = id1 `compare` id2 + (RealId id1) `compare` (RealId id2) = id1 `compare` id2 + (TcId _) `compare` (RealId _) = LT + (RealId _) `compare` (TcId _) = GT + +instance Outputable (TcIdOcc s) where + ppr (TcId id) = ppr id + ppr (RealId id) = ppr id + +instance NamedThing (TcIdOcc s) where + getName (TcId id) = getName id + getName (RealId id) = getName id + + +tcIdType :: TcIdOcc s -> TcType s +tcIdType (TcId id) = idType id +tcIdType (RealId id) = pprPanic "tcIdType:" (ppr id) + +tcIdTyVars (TcId id) = tyVarsOfType (idType id) +tcIdTyVars (RealId _) = emptyTyVarSet -- Top level Ids have no free type variables + + +-- A useful function that takes an occurrence of a global thing +-- and instantiates its type with fresh type variables +tcInstId :: Id + -> NF_TcM s ([TcTyVar s], -- It's instantiated type + TcThetaType s, -- + TcType s) -- + +tcInstId id + = let + (tyvars, rho) = splitForAllTys (idType id) + in + tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) -> + tcInstType tenv rho `thenNF_Tc` \ rho' -> + let + (theta', tau') = splitRhoTy rho' + in + returnNF_Tc (tyvars', theta', tau') +\end{code} + + +%************************************************************************ +%* * +\subsection{TcEnv} +%* * +%************************************************************************ + Data type declarations ~~~~~~~~~~~~~~~~~~~~~ @@ -69,15 +128,16 @@ data TcEnv s = TcEnv (ClassEnv s) (ValueEnv Id) -- Globals (ValueEnv (TcIdBndr s)) -- Locals - (MutableVar s (TcTyVarSet s)) -- Free type variables of locals + (TcRef s (TcTyVarSet s)) -- Free type variables of locals -- ...why mutable? see notes with tcGetGlobalTyVars type TyVarEnv s = UniqFM (TcKind s, TyVar) type TyConEnv s = UniqFM (TcKind s, Maybe Arity, TyCon) -- Arity present for Synonyms only -type ClassEnv s = UniqFM (TcKind s, Class) +type ClassEnv s = UniqFM ([TcKind s], Class) -- The kinds are the kinds of the args + -- to the class type ValueEnv id = UniqFM id -initEnv :: MutableVar s (TcTyVarSet s) -> TcEnv s +initEnv :: TcRef s (TcTyVarSet s) -> TcEnv s initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM emptyUFM emptyUFM mut getEnv_LocalIds (TcEnv _ _ _ _ ls _) = eltsUFM ls @@ -100,36 +160,26 @@ tcExtendTyVarEnv names kinds_w_types scope The Kind, TyVar, Class and TyCon envs ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Extending the environments. Notice the uses of @zipLazy@, which makes sure -that the knot-tied TyVars, TyCons and Classes aren't looked at too early. +Extending the environments. \begin{code} -tcExtendTyConEnv :: [(Name,Maybe Arity)] -> [TyCon] -> TcM s r -> TcM s r +tcExtendTyConEnv :: [(Name, (TcKind s, Maybe Arity, TyCon))] -> TcM s r -> TcM s r -tcExtendTyConEnv names_w_arities tycons scope - = newKindVars (length names_w_arities) `thenNF_Tc` \ kinds -> - tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> +tcExtendTyConEnv bindings scope + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let - tce' = addListToUFM tce [ (name, (kind, arity, tycon)) - | ((name,arity), (kind,tycon)) - <- zipEqual "tcExtendTyConEnv" names_w_arities (kinds `zipLazy` tycons) - ] + tce' = addListToUFM tce bindings in - tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope `thenTc` \ result -> - mapNF_Tc tcDefaultKind kinds `thenNF_Tc_` - returnTc result + tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope -tcExtendClassEnv :: [Name] -> [Class] -> TcM s r -> TcM s r -tcExtendClassEnv names classes scope - = newKindVars (length names) `thenNF_Tc` \ kinds -> - tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> +tcExtendClassEnv :: [(Name, ([TcKind s], Class))] -> TcM s r -> TcM s r +tcExtendClassEnv bindings scope + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let - ce' = addListToUFM ce (zipEqual "tcExtendClassEnv" names (kinds `zipLazy` classes)) + ce' = addListToUFM ce bindings in - tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope `thenTc` \ result -> - mapNF_Tc tcDefaultKind kinds `thenNF_Tc_` - returnTc result + tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope \end{code} @@ -138,7 +188,7 @@ Looking up in the environments. \begin{code} tcLookupTyVar name = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> - returnNF_Tc (lookupWithDefaultUFM tve (pprPanic "tcLookupTyVar:" (ppr PprShowAll name)) name) + returnNF_Tc (lookupWithDefaultUFM tve (pprPanic "tcLookupTyVar:" (ppr name)) name) tcLookupTyCon name @@ -161,8 +211,8 @@ tcLookupTyCon name -- Could be that he's using a class name as a type constructor case lookupUFM ce name of - Just _ -> failTc (classAsTyConErr name) - Nothing -> pprPanic "tcLookupTyCon:" (ppr PprDebug name) + Just _ -> failWithTc (classAsTyConErr name) + Nothing -> pprPanic "tcLookupTyCon:" (ppr name) } } tcLookupTyConByKey uniq @@ -183,10 +233,10 @@ tcLookupClass name Nothing -- Could be that he's using a type constructor as a class | maybeToBool (maybeWiredInTyConName name) || maybeToBool (lookupUFM tce name) - -> failTc (tyConAsClassErr name) + -> failWithTc (tyConAsClassErr name) | otherwise -- Wierd! Renamer shouldn't let this happen - -> pprPanic "tcLookupClass:" (ppr PprShowAll name) + -> pprPanic "tcLookupClass" (ppr name) tcLookupClassByKey uniq = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> @@ -246,7 +296,7 @@ tcExtendGlobalTyVars extra_global_tvs scope = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> let - new_global_tyvars = global_tvs `unionTyVarSets` extra_global_tvs + new_global_tyvars = global_tvs `unionTyVarSets` mkTyVarSet extra_global_tvs in tcNewMutVar new_global_tyvars `thenNF_Tc` \ gtvs' -> tcSetEnv (TcEnv tve tce ce gve lve gtvs') scope @@ -276,7 +326,7 @@ tcLookupGlobalValue name Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupWithDefaultUFM gve def name) where - def = pprPanic "tcLookupGlobalValue:" (ppr PprDebug name) + def = pprPanic "tcLookupGlobalValue:" (ppr name) tcLookupGlobalValueMaybe :: Name -> NF_TcM s (Maybe Id) tcLookupGlobalValueMaybe name @@ -320,7 +370,7 @@ tcAddImportedIdInfo unf_env id = id `replaceIdInfo` new_info -- The Id must be returned without a data dependency on maybe_id where - new_info = -- pprTrace "tcAdd" (ppr PprDebug id) $ + new_info = -- pprTrace "tcAdd" (ppr id) $ case tcExplicitLookupGlobal unf_env (getName id) of Nothing -> noIdInfo Just imported_id -> getIdInfo imported_id @@ -362,10 +412,11 @@ newLocalIds names tys returnNF_Tc new_ids \end{code} + \begin{code} -classAsTyConErr name sty - = hcat [ptext SLIT("Class used as a type constructor: "), ppr sty name] +classAsTyConErr name + = ptext SLIT("Class used as a type constructor:") <+> ppr name -tyConAsClassErr name sty - = hcat [ptext SLIT("Type constructor used as a class: "), ppr sty name] +tyConAsClassErr name + = ptext SLIT("Type constructor used as a class:") <+> ppr name \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index baaa137b7d..0ac4f084e4 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -4,62 +4,63 @@ \section[TcExpr]{Typecheck an expression} \begin{code} -#include "HsVersions.h" - module TcExpr ( tcExpr, tcStmt, tcId ) where -IMP_Ubiq() +#include "HsVersions.h" -import HsSyn ( HsExpr(..), Stmt(..), DoOrListComp(..), - HsBinds(..), MonoBinds(..), - SYN_IE(RecFlag), nonRecursive, - ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds, - Match, Fake, InPat, OutPat, HsType, Fixity, - pprParendExpr, failureFreePat, collectPatBinders ) -import RnHsSyn ( SYN_IE(RenamedHsExpr), - SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds) +import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), + HsBinds(..), Stmt(..), DoOrListComp(..), + pprParendExpr, failureFreePat, collectPatBinders ) -import TcHsSyn ( SYN_IE(TcExpr), SYN_IE(TcStmt), - SYN_IE(TcRecordBinds), +import RnHsSyn ( RenamedHsExpr, + RenamedStmt, RenamedRecordBinds + ) +import TcHsSyn ( TcExpr, TcStmt, + TcRecordBinds, mkHsTyApp ) import TcMonad +import BasicTypes ( RecFlag(..) ) + import Inst ( Inst, InstOrigin(..), OverloadedLit(..), - SYN_IE(LIE), emptyLIE, plusLIE, plusLIEs, newOverloadedLit, + LIE, emptyLIE, plusLIE, plusLIEs, newOverloadedLit, newMethod, newMethodWithGivenTy, newDicts ) -import TcBinds ( tcBindsAndThen, checkSigTyVars ) -import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey, +import TcBinds ( tcBindsAndThen, checkSigTyVars, sigThetaCtxt ) +import TcEnv ( TcIdOcc(..), tcInstId, + tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey, tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars, tcExtendGlobalTyVars, tcLookupGlobalValueMaybe, tcLookupTyCon ) -import SpecEnv ( SpecEnv ) import TcMatches ( tcMatchesCase, tcMatchExpected ) import TcMonoType ( tcHsType ) import TcPat ( tcPat ) -import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 ) -import TcType ( TcIdOcc(..), SYN_IE(TcType), TcMaybe(..), - tcInstId, tcInstType, tcInstSigTcType, tcInstTyVars, +import TcSimplify ( tcSimplifyAndCheck ) +import TcType ( TcType, TcMaybe(..), + tcInstType, tcInstSigTcType, tcInstTyVars, tcInstSigType, tcInstTcType, tcInstTheta, tcSplitRhoTy, newTyVarTy, newTyVarTys, zonkTcTyVars, zonkTcType ) import TcKind ( TcKind ) -import Class ( SYN_IE(Class) ) +import Class ( Class ) import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType ) import Id ( idType, dataConFieldLabels, dataConSig, recordSelectorFieldLabel, isRecordSelector, - SYN_IE(Id), GenId + Id, GenId ) import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind ) import Name ( Name{-instance Eq-} ) import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy, - getTyVar_maybe, getFunTy_maybe, instantiateTy, applyTyCon, - splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy, - isTauTy, mkFunTys, tyVarsOfType, tyVarsOfTypes, getForAllTy_maybe, - getAppDataTyCon, maybeAppDataTyCon + splitFunTy_maybe, splitFunTys, + mkTyConApp, + splitForAllTys, splitRhoTy, splitSigmaTy, + isTauTy, mkFunTys, tyVarsOfType, tyVarsOfTypes, + splitForAllTy_maybe, splitAlgTyConApp, splitAlgTyConApp_maybe + ) +import TyVar ( TyVarSet, emptyTyVarEnv, zipTyVarEnv, + unionTyVarSets, elementOfTyVarSet, mkTyVarSet, tyVarSetToList ) -import TyVar ( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, elementOfTyVarSet, mkTyVarSet ) import TyCon ( tyConDataCons ) import TysPrim ( intPrimTy, charPrimTy, doublePrimTy, floatPrimTy, addrPrimTy, realWorldTy @@ -76,10 +77,9 @@ import Unique ( Unique, cCallableClassKey, cReturnableClassKey, enumFromToClassOpKey, enumFromThenToClassOpKey, thenMClassOpKey, zeroClassOpKey, returnMClassOpKey ) -import Outputable ( speakNth, interpp'SP, Outputable(..) ) +import Outputable import PprType ( GenType, GenTyVar ) -- Instances import Maybes ( maybeToBool ) -import Pretty import ListSetOps ( minusList ) import Util \end{code} @@ -135,7 +135,7 @@ tcExpr (HsLit (HsFrac f)) res_ty tcExpr (HsLit lit@(HsLitLit s)) res_ty = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass -> newDicts (LitLitOrigin (_UNPK_ s)) - [(cCallableClass, res_ty)] `thenNF_Tc` \ (dicts, _) -> + [(cCallableClass, [res_ty])] `thenNF_Tc` \ (dicts, _) -> returnTc (HsLitOut lit res_ty, dicts) \end{code} @@ -188,7 +188,7 @@ tcExpr (HsPar expr) res_ty -- preserve parens so printing needn't guess where th tcExpr (NegApp expr neg) res_ty = tcExpr (HsApp neg expr) res_ty tcExpr (HsLam match) res_ty - = tcMatchExpected res_ty match `thenTc` \ (match',lie) -> + = tcMatchExpected [] res_ty match `thenTc` \ (match',lie) -> returnTc (HsLam match', lie) tcExpr (HsApp e1 e2) res_ty = accum e1 [e2] @@ -258,7 +258,7 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty let new_arg_dict (arg, arg_ty) = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg)) - [(cCallableClass, arg_ty)] `thenNF_Tc` \ (arg_dicts, _) -> + [(cCallableClass, [arg_ty])] `thenNF_Tc` \ (arg_dicts, _) -> returnNF_Tc arg_dicts -- Actually a singleton bag result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -} @@ -273,17 +273,15 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty -- type constructor. newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ result_ty -> let - io_result_ty = applyTyCon ioTyCon [result_ty] + io_result_ty = mkTyConApp ioTyCon [result_ty] in case tyConDataCons ioTyCon of { [ioDataCon] -> unifyTauTy io_result_ty res_ty `thenTc_` -- Construct the extra insts, which encode the -- constraints on the argument and result types. - mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args ty_vars) - `thenNF_Tc` \ ccarg_dicts_s -> - newDicts result_origin [(cReturnableClass, result_ty)] - `thenNF_Tc` \ (ccres_dict, _) -> + mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args ty_vars) `thenNF_Tc` \ ccarg_dicts_s -> + newDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) -> returnTc (HsApp (HsVar (RealId ioDataCon) `TyApp` [result_ty]) (CCall lbl args' may_gc is_asm io_result_ty), @@ -324,7 +322,6 @@ tcExpr (HsIf pred b1 b2 src_loc) res_ty tcAddErrCtxt (predCtxt pred) ( tcExpr pred boolTy ) `thenTc` \ (pred',lie1) -> - tcAddErrCtxt (branchCtxt b1 b2) $ tcExpr b1 res_ty `thenTc` \ (b1',lie2) -> tcExpr b2 res_ty `thenTc` \ (b2',lie3) -> returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3)) @@ -352,28 +349,28 @@ tcExpr (ExplicitTuple exprs) res_ty `thenTc` \ (exprs', lies) -> returnTc (ExplicitTuple exprs', plusLIEs lies) -tcExpr (RecordCon con rbinds) res_ty - = tcLookupGlobalValue con `thenNF_Tc` \ con_id -> - tcId con `thenNF_Tc` \ (con_expr, con_lie, con_tau) -> +tcExpr (RecordCon con_name _ rbinds) res_ty + = tcLookupGlobalValue con_name `thenNF_Tc` \ con_id -> + tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) -> let - (_, record_ty) = splitFunTy con_tau + (_, record_ty) = splitFunTys con_tau in -- Con is syntactically constrained to be a data constructor - ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) ) + ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) ) unifyTauTy record_ty res_ty `thenTc_` -- Check that the record bindings match the constructor let bad_fields = badFields rbinds con_id in - checkTc (null bad_fields) (badFieldsCon con bad_fields) `thenTc_` + checkTc (null bad_fields) (badFieldsCon con_id bad_fields) `thenTc_` -- Typecheck the record bindings -- (Do this after checkRecordFields in case there's a field that -- doesn't match the constructor.) tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) -> - returnTc (RecordConOut (RealId con_id) con_expr rbinds', con_lie `plusLIE` rbinds_lie) + returnTc (RecordCon (RealId con_id) con_expr rbinds', con_lie `plusLIE` rbinds_lie) -- The main complication with RecordUpd is that we need to explicitly @@ -414,15 +411,15 @@ tcExpr (RecordUpd record_expr rbinds) res_ty tcLookupGlobalValueMaybe first_field_name `thenNF_Tc` \ maybe_sel_id -> (case maybe_sel_id of Just sel_id | isRecordSelector sel_id -> returnTc sel_id - other -> failTc (notSelector first_field_name) + other -> failWithTc (notSelector first_field_name) ) `thenTc` \ sel_id -> let - (_, tau) = splitForAllTy (idType sel_id) - Just (data_ty, _) = getFunTy_maybe tau -- Must succeed since sel_id is a selector - (tycon, _, data_cons) = getAppDataTyCon data_ty + (_, tau) = splitForAllTys (idType sel_id) + Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector + (tycon, _, data_cons) = splitAlgTyConApp data_ty (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons) in - tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, result_inst_env) -> + tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) -> -- STEP 2 -- Check for bad fields @@ -433,7 +430,7 @@ tcExpr (RecordUpd record_expr rbinds) res_ty -- (Do this after checking for bad fields in case there's a field that -- doesn't match the constructor.) let - result_record_ty = applyTyCon tycon result_inst_tys + result_record_ty = mkTyConApp tycon result_inst_tys in unifyTauTy result_record_ty res_ty `thenTc_` tcRecordBinds result_record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) -> @@ -465,7 +462,7 @@ tcExpr (RecordUpd record_expr rbinds) res_ty -- STEP 5 -- Typecheck the expression to be updated let - record_ty = applyTyCon tycon inst_tys + record_ty = mkTyConApp tycon inst_tys in tcExpr record_expr record_ty `thenTc` \ (record_expr', record_lie) -> @@ -480,7 +477,7 @@ tcExpr (RecordUpd record_expr rbinds) res_ty -- union the ones that could participate in the update. let (tyvars, theta, _, _, _, _) = dataConSig (head data_cons) - inst_env = zipEqual "tcExpr:RecordUpd" tyvars result_inst_tys + inst_env = zipTyVarEnv tyvars result_inst_tys in tcInstTheta inst_env theta `thenNF_Tc` \ theta' -> newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) -> @@ -559,17 +556,22 @@ tcExpr in_expr@(ExprWithTySig expr poly_ty) res_ty in -- Type check the expression, expecting the signature type - tcExpr expr sig_tau' `thenTc` \ (texpr, lie) -> + tcExtendGlobalTyVars sig_tyvars' ( + tcExpr expr sig_tau' + ) `thenTc` \ (texpr, lie) -> -- Check the type variables of the signature, -- *after* typechecking the expression - checkSigTyVars sig_tyvars' sig_tau' `thenTc_` + checkSigTyVars sig_tyvars' sig_tau' `thenTc` \ zonked_sig_tyvars -> -- Check overloading constraints newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) -> - tcSimplifyAndCheck - (mkTyVarSet sig_tyvars') - sig_dicts lie `thenTc_` + tcAddErrCtxtM (sigThetaCtxt sig_dicts) ( + tcSimplifyAndCheck + (text "expr ty sig") + (mkTyVarSet zonked_sig_tyvars) + sig_dicts lie + ) `thenTc_` -- Now match the signature type with res_ty. -- We must not do this earlier, because res_ty might well @@ -620,12 +622,15 @@ tcApp fun args res_ty = -- First type-check the function tcExpr_id fun `thenTc` \ (fun', lie_fun, fun_ty) -> - tcAddErrCtxt (tooManyArgsCtxt fun) ( + tcAddErrCtxt (wrongArgsCtxt "too many" fun args) ( split_fun_ty fun_ty (length args) ) `thenTc` \ (expected_arg_tys, actual_result_ty) -> -- Unify with expected result before type-checking the args - unifyTauTy res_ty actual_result_ty `thenTc_` + -- This is when we might detect a too-few args situation + tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) ( + unifyTauTy res_ty actual_result_ty + ) `thenTc_` -- Now typecheck the args mapAndUnzipTc (tcArg fun) @@ -639,6 +644,22 @@ tcApp fun args res_ty returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s) +-- If an error happens we try to figure out whether the +-- function has been given too many or too few arguments, +-- and say so +checkArgsCtxt fun args expected_res_ty actual_res_ty + = zonkTcType expected_res_ty `thenNF_Tc` \ exp_ty' -> + zonkTcType actual_res_ty `thenNF_Tc` \ act_ty' -> + let + (exp_args, _) = splitFunTys exp_ty' + (act_args, _) = splitFunTys act_ty' + message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args + | length exp_args > length act_args = wrongArgsCtxt "too many" fun args + | otherwise = appCtxt fun args + in + returnNF_Tc message + + split_fun_ty :: TcType s -- The type of the function -> Int -- Number of arguments -> TcM s ([TcType s], -- Function argument types @@ -658,6 +679,7 @@ split_fun_ty fun_ty n tcArg :: RenamedHsExpr -- The function (for error messages) -> (RenamedHsExpr, TcType s, Int) -- Actual argument and expected arg type -> TcM s (TcExpr s, LIE s) -- Resulting argument and LIE + tcArg the_fun (arg, expected_arg_ty, arg_no) = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $ tcPolyExpr arg expected_arg_ty @@ -666,7 +688,7 @@ tcArg the_fun (arg, expected_arg_ty, arg_no) -- tcPolyExpr is like tcExpr, except that the expected type -- can be a polymorphic one. tcPolyExpr arg expected_arg_ty - | not (maybeToBool (getForAllTy_maybe expected_arg_ty)) + | not (maybeToBool (splitForAllTy_maybe expected_arg_ty)) = -- The ordinary, non-rank-2 polymorphic case tcExpr arg expected_arg_ty @@ -686,7 +708,6 @@ tcPolyExpr arg expected_arg_ty let (sig_theta, sig_tau) = splitRhoTy sig_rho in - -- Type-check the arg and unify with expected type tcExpr arg sig_tau `thenTc` \ (arg', lie_arg) -> @@ -702,25 +723,26 @@ tcPolyExpr arg expected_arg_ty -- list of "free vars" for the signature check. tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $ - tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) $ + tcExtendGlobalTyVars (tyVarSetToList (tyVarsOfType expected_arg_ty)) $ - checkSigTyVars sig_tyvars sig_tau `thenTc_` + checkSigTyVars sig_tyvars sig_tau `thenTc` \ zonked_sig_tyvars -> newDicts Rank2Origin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) -> -- ToDo: better origin - tcSimplifyAndCheck - (mkTyVarSet sig_tyvars) -- No need to zonk the tyvars because - -- they won't be bound to anything - sig_dicts lie_arg `thenTc` \ (lie', inst_binds) -> + + tcAddErrCtxtM (sigThetaCtxt sig_dicts) $ + tcSimplifyAndCheck (text "rank2") + (mkTyVarSet zonked_sig_tyvars) + sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) -> -- This HsLet binds any Insts which came out of the simplification. -- It's a bit out of place here, but using AbsBind involves inventing -- a couple of new names which seems worse. - returnTc ( TyLam sig_tyvars $ - DictLam dict_ids $ - HsLet (mk_binds inst_binds) arg' - , lie') - where - mk_binds inst_binds = MonoBind inst_binds [] nonRecursive + returnTc ( TyLam zonked_sig_tyvars $ + DictLam dict_ids $ + HsLet (MonoBind inst_binds [] Recursive) + arg' + , free_insts + ) \end{code} %************************************************************************ @@ -739,10 +761,10 @@ tcId name case maybe_local of Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id) - Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id -> - tcInstType [] (idType id) `thenNF_Tc` \ inst_ty -> + Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id -> + tcInstType emptyTyVarEnv (idType id) `thenNF_Tc` \ inst_ty -> let - (tyvars, rho) = splitForAllTy inst_ty + (tyvars, rho) = splitForAllTys inst_ty in instantiate_it2 (RealId id) tyvars rho @@ -959,10 +981,10 @@ tcRecordBinds expected_record_ty rbinds -- Record selectors all have type -- forall a1..an. T a1 .. an -> tau - ASSERT( maybeToBool (getFunTy_maybe tau) ) + ASSERT( maybeToBool (splitFunTy_maybe tau) ) let -- Selector must have type RecordType -> FieldType - Just (record_ty, field_ty) = getFunTy_maybe tau + Just (record_ty, field_ty) = splitFunTy_maybe tau in unifyTauTy expected_record_ty record_ty `thenTc_` tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie) -> @@ -1000,77 +1022,81 @@ Errors and contexts Mini-utils: \begin{code} -pp_nest_hang :: String -> Doc -> Doc +pp_nest_hang :: String -> SDoc -> SDoc pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff) \end{code} Boring and alphabetical: \begin{code} -arithSeqCtxt expr sty - = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr sty expr) +arithSeqCtxt expr + = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr) -branchCtxt b1 b2 sty - = sep [ptext SLIT("In the branches of a conditional:"), - pp_nest_hang "`then' branch:" (ppr sty b1), - pp_nest_hang "`else' branch:" (ppr sty b2)] +caseCtxt expr + = hang (ptext SLIT("In the case expression:")) 4 (ppr expr) -caseCtxt expr sty - = hang (ptext SLIT("In the case expression")) 4 (ppr sty expr) - -exprSigCtxt expr sty +exprSigCtxt expr = hang (ptext SLIT("In an expression with a type signature:")) - 4 (ppr sty expr) + 4 (ppr expr) + +listCtxt expr + = hang (ptext SLIT("In the list element:")) 4 (ppr expr) -listCtxt expr sty - = hang (ptext SLIT("In the list element")) 4 (ppr sty expr) +predCtxt expr + = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr) -predCtxt expr sty - = hang (ptext SLIT("In the predicate expression")) 4 (ppr sty expr) +sectionRAppCtxt expr + = hang (ptext SLIT("In the right section:")) 4 (ppr expr) -sectionRAppCtxt expr sty - = hang (ptext SLIT("In the right section")) 4 (ppr sty expr) +sectionLAppCtxt expr + = hang (ptext SLIT("In the left section:")) 4 (ppr expr) -sectionLAppCtxt expr sty - = hang (ptext SLIT("In the left section")) 4 (ppr sty expr) +funAppCtxt fun arg arg_no + = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"), + quotes (ppr fun) <> text ", namely"]) + 4 (quotes (ppr arg)) -stmtCtxt do_or_lc stmt sty +stmtCtxt do_or_lc stmt = hang (ptext SLIT("In a") <+> whatever <> colon) - 4 (ppr sty stmt) + 4 (ppr stmt) where whatever = case do_or_lc of ListComp -> ptext SLIT("list-comprehension qualifier") DoStmt -> ptext SLIT("do statement") Guard -> ptext SLIT("guard") -tooManyArgsCtxt f sty - = hang (ptext SLIT("Too many arguments in an application of the function")) - 4 (ppr sty f) +wrongArgsCtxt too_many_or_few fun args + = hang (ptext SLIT("Probable cause:") <+> ppr fun + <+> ptext SLIT("is applied to") <+> text too_many_or_few + <+> ptext SLIT("arguments in the call")) + 4 (ppr the_app) + where + the_app = foldl HsApp fun args -- Used in error messages -funAppCtxt fun arg arg_no sty - = hang (hsep [ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"), - ppr sty fun <> text ", namely"]) - 4 (ppr sty arg) +appCtxt fun args + = ptext SLIT("In the application") <+> (ppr the_app) + where + the_app = foldl HsApp fun args -- Used in error messages -lurkingRank2Err fun fun_ty sty - = hang (hsep [ptext SLIT("Illegal use of"), ppr sty fun]) - 4 (vcat [text "It is applied to too few arguments,", - ptext SLIT("so that the result type has for-alls in it")]) +lurkingRank2Err fun fun_ty + = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)]) + 4 (vcat [ptext SLIT("It is applied to too few arguments"), + ptext SLIT("so that the result type has for-alls in it")]) -rank2ArgCtxt arg expected_arg_ty sty - = ptext SLIT("In a polymorphic function argument") <+> ppr sty arg +rank2ArgCtxt arg expected_arg_ty + = ptext SLIT("In a polymorphic function argument:") <+> ppr arg -badFieldsUpd rbinds sty +badFieldsUpd rbinds = hang (ptext SLIT("No constructor has all these fields:")) - 4 (interpp'SP sty fields) + 4 (pprQuotedList fields) where fields = [field | (field, _, _) <- rbinds] -recordUpdCtxt sty = ptext SLIT("In a record update construct") +recordUpdCtxt = ptext SLIT("In a record update construct") -badFieldsCon con fields sty - = hsep [ptext SLIT("Constructor"), ppr sty con, - ptext SLIT("does not have field(s)"), interpp'SP sty fields] +badFieldsCon con fields + = hsep [ptext SLIT("Constructor"), ppr con, + ptext SLIT("does not have field(s):"), pprQuotedList fields] -notSelector field sty - = hsep [ppr sty field, ptext SLIT("is not a record selector")] +notSelector field + = hsep [quotes (ppr field), ptext SLIT("is not a record selector")] \end{code} diff --git a/ghc/compiler/typecheck/TcGRHSs.lhs b/ghc/compiler/typecheck/TcGRHSs.lhs index 0a0b58e47b..77a0eab01d 100644 --- a/ghc/compiler/typecheck/TcGRHSs.lhs +++ b/ghc/compiler/typecheck/TcGRHSs.lhs @@ -4,26 +4,20 @@ \section[TcGRHSs]{Typecheck guarded right-hand-sides} \begin{code} -#include "HsVersions.h" - module TcGRHSs ( tcGRHSsAndBinds ) where -IMP_Ubiq(){-uitous-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(TcLoop) -- for paranoia checking -#endif +#include "HsVersions.h" -import HsSyn ( GRHSsAndBinds(..), GRHS(..), MonoBinds, Stmt, DoOrListComp(..), - HsExpr, HsBinds(..), InPat, OutPat, Sig, Fake ) -import RnHsSyn ( SYN_IE(RenamedGRHSsAndBinds), SYN_IE(RenamedGRHS) ) -import TcHsSyn ( SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS) ) +import HsSyn ( HsBinds(..), GRHSsAndBinds(..), GRHS(..), DoOrListComp(..) ) +import RnHsSyn ( RenamedGRHSsAndBinds, RenamedGRHS ) +import TcHsSyn ( TcGRHSsAndBinds, TcGRHS ) import TcMonad -import Inst ( Inst, SYN_IE(LIE), plusLIE ) -import Kind ( mkTypeKind ) +import Inst ( Inst, LIE, plusLIE ) import TcBinds ( tcBindsAndThen ) import TcExpr ( tcExpr, tcStmt ) -import TcType ( SYN_IE(TcType), TcIdOcc(..), newTyVarTy ) +import TcType ( TcType, newTyVarTy ) +import TcEnv ( TcIdOcc(..) ) import TysWiredIn ( boolTy ) \end{code} @@ -40,21 +34,15 @@ tcGRHSs expected_ty (grhs:grhss) tcGRHSs expected_ty grhss `thenTc` \ (grhss', lie2) -> returnTc (grhs' : grhss', lie1 `plusLIE` lie2) - -tcGRHS expected_ty (OtherwiseGRHS expr locn) - = tcAddSrcLoc locn $ - tcExpr expr expected_ty `thenTc` \ (expr, lie) -> - returnTc (OtherwiseGRHS expr locn, lie) - tcGRHS expected_ty (GRHS guard expr locn) = tcAddSrcLoc locn $ - tc_stmts guard `thenTc` \ ((guard', expr'), lie) -> + tcStmts guard `thenTc` \ ((guard', expr'), lie) -> returnTc (GRHS guard' expr' locn, lie) where - tc_stmts [] = tcExpr expr expected_ty `thenTc` \ (expr2, expr_lie) -> - returnTc (([], expr2), expr_lie) - tc_stmts (stmt:stmts) = tcStmt tcExpr Guard (\x->x) combine stmt $ - tc_stmts stmts + tcStmts [] = tcExpr expr expected_ty `thenTc` \ (expr2, expr_lie) -> + returnTc (([], expr2), expr_lie) + tcStmts (stmt:stmts) = tcStmt tcExpr Guard (\x->x) combine stmt $ + tcStmts stmts combine stmt _ (stmts, expr) = (stmt:stmts, expr) \end{code} @@ -68,13 +56,16 @@ tcGRHSsAndBinds :: TcType s -- Expected type of RHSs -> RenamedGRHSsAndBinds -> TcM s (TcGRHSsAndBinds s, LIE s) +-- Shortcut for common case +tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss EmptyBinds) + = tcGRHSs expected_ty grhss `thenTc` \ (grhss', lie) -> + returnTc (GRHSsAndBindsOut grhss' EmptyBinds expected_ty, lie) + tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss binds) = tcBindsAndThen combiner binds - (tcGRHSs expected_ty grhss `thenTc` \ (grhss', lie) -> - returnTc (GRHSsAndBindsOut grhss' EmptyBinds expected_ty, lie) - ) + (tcGRHSs expected_ty grhss) where - combiner is_rec binds1 (GRHSsAndBindsOut grhss binds2 ty) - = GRHSsAndBindsOut grhss ((MonoBind binds1 [] is_rec) `ThenBinds` binds2) ty + combiner is_rec binds grhss + = GRHSsAndBindsOut grhss (MonoBind binds [] is_rec) expected_ty \end{code} diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index c2e2cf501f..b17d29ced4 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -9,8 +9,6 @@ This module is nominally ``subordinate'' to @TcDeriv@, which is the This is where we do all the grimy bindings' generation. \begin{code} -#include "HsVersions.h" - module TcGenDeriv ( gen_Bounded_binds, gen_Enum_binds, @@ -27,22 +25,22 @@ module TcGenDeriv ( TagThingWanted(..) ) where -IMP_Ubiq() -IMPORT_1_3(List(partition,intersperse)) +#include "HsVersions.h" -import HsSyn ( HsBinds(..), MonoBinds(..), Match(..), GRHSsAndBinds(..), - GRHS(..), HsExpr(..), HsLit(..), InPat(..), Stmt(..), DoOrListComp(..), - SYN_IE(RecFlag), recursive, - ArithSeqInfo, Sig, HsType, FixityDecl, Fixity, Fake ) +import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), GRHS(..), + Match(..), GRHSsAndBinds(..), Stmt(..), HsLit(..), + HsBinds(..), DoOrListComp(..), + unguardedRHS + ) import RdrHsSyn ( RdrName(..), varQual, varUnqual, mkOpApp, - SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat) + RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) -import BasicTypes ( IfaceFlavour(..) ) +import BasicTypes ( IfaceFlavour(..), RecFlag(..) ) import FieldLabel ( fieldLabelName ) import Id ( GenId, isNullaryDataCon, dataConTag, dataConRawArgTys, fIRST_TAG, - isDataCon, SYN_IE(DataCon), SYN_IE(ConTag), - dataConFieldLabels, SYN_IE(Id) ) + isDataCon, DataCon, ConTag, + dataConFieldLabels, Id ) import Maybes ( maybeToBool ) import Name ( getOccString, getOccName, getSrcLoc, occNameString, modAndOcc, OccName, Name ) @@ -51,21 +49,14 @@ import PrimOp ( PrimOp(..) ) import PrelInfo -- Lots of RdrNames import SrcLoc ( mkGeneratedSrcLoc, SrcLoc ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon ) -import Type ( eqTy, isPrimType, SYN_IE(Type) ) +import Type ( isUnpointedType, isUnboxedType, Type ) import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy ) import Util ( mapAccumL, zipEqual, zipWithEqual, zipWith3Equal, nOfThem, panic, assertPanic ) - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 200 -intersperse :: a -> [a] -> [a] -intersperse s [] = [] -intersperse s [x] = [x] -intersperse s (x:xs) = x : s : intersperse s xs -#endif - +import List ( partition, intersperse ) \end{code} %************************************************************************ @@ -272,6 +263,7 @@ cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2) Again, we must be careful about unboxed comparisons. For example, if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to generate: + \begin{verbatim} cmp_eq lt eq gt (O2 a1) (O2 a2) = compareInt# a1 a2 @@ -580,7 +572,7 @@ gen_Ix_binds tycon untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(d_RDR, dh_RDR)] ( let - grhs = [OtherwiseGRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc] + grhs = unguardedRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc in HsCase (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR)) @@ -613,7 +605,7 @@ gen_Ix_binds tycon data_con = case maybeTyConSingleCon tycon of -- just checking... Nothing -> panic "get_Ix_binds" - Just dc -> if (any isPrimType (dataConRawArgTys dc)) then + Just dc -> if (any isUnpointedType (dataConRawArgTys dc)) then error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str) else dc @@ -965,7 +957,7 @@ mk_easy_Match loc pats binds expr = mk_match loc pats expr (mkbind binds) where mkbind [] = EmptyBinds - mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] recursive + mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] Recursive -- The renamer expects everything in its input to be a -- "recursive" MonoBinds, and it is its job to sort things out -- from there. @@ -982,7 +974,7 @@ mk_FunMonoBind loc fun pats_and_exprs mk_match loc pats expr binds = foldr PatMatch - (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr loc] binds)) + (GRHSMatch (GRHSsAndBindsIn (unguardedRHS expr loc) binds)) (map paren pats) where paren p@(VarPatIn _) = p @@ -1017,17 +1009,17 @@ cmp_eq_Expr = compare_gen_Case cmp_eq_RDR compare_gen_Case fun lt eq gt a b = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-} [PatMatch (ConPatIn ltTag_RDR []) - (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)), + (GRHSMatch (GRHSsAndBindsIn (unguardedRHS lt mkGeneratedSrcLoc) EmptyBinds)), PatMatch (ConPatIn eqTag_RDR []) - (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)), + (GRHSMatch (GRHSsAndBindsIn (unguardedRHS eq mkGeneratedSrcLoc) EmptyBinds)), PatMatch (ConPatIn gtTag_RDR []) - (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))] + (GRHSMatch (GRHSsAndBindsIn (unguardedRHS gt mkGeneratedSrcLoc) EmptyBinds))] mkGeneratedSrcLoc careful_compare_Case ty lt eq gt a b - = if not (isPrimType ty) then + = if not (isUnboxedType ty) then compare_gen_Case compare_RDR lt eq gt a b else -- we have to do something special for primitive things... @@ -1043,7 +1035,7 @@ assoc_ty_id tyids ty = if null res then panic "assoc_ty" else head res where - res = [id | (ty',id) <- tyids, eqTy ty ty'] + res = [id | (ty',id) <- tyids, ty == ty'] eq_op_tbl = [(charPrimTy, eqH_Char_RDR) @@ -1074,7 +1066,7 @@ append_Expr a b = genOpApp a append_RDR b eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr eq_Expr ty a b - = if not (isPrimType ty) then + = if not (isUnboxedType ty) then genOpApp a eq_RDR b else -- we have to do something special for primitive things... genOpApp a relevant_eq_op b @@ -1096,7 +1088,7 @@ untag_Expr tycon ((untag_this, put_tag_here) : more) expr (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))] mkGeneratedSrcLoc where - grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc] + grhs = unguardedRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc cmp_tags_Expr :: RdrName -- Comparison op -> RdrName -> RdrName -- Things to compare diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index fbe5fbecf7..30c6100838 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -7,65 +7,61 @@ This module is an extension of @HsSyn@ syntax, for use in the type checker. \begin{code} -#include "HsVersions.h" - module TcHsSyn ( - SYN_IE(TcMonoBinds), SYN_IE(TcHsBinds), SYN_IE(TcPat), - SYN_IE(TcExpr), SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), SYN_IE(TcMatch), - SYN_IE(TcStmt), SYN_IE(TcArithSeqInfo), SYN_IE(TcRecordBinds), - SYN_IE(TcHsModule), SYN_IE(TcCoreExpr), SYN_IE(TcDictBinds), + TcMonoBinds, TcHsBinds, TcPat, + TcExpr, TcGRHSsAndBinds, TcGRHS, TcMatch, + TcStmt, TcArithSeqInfo, TcRecordBinds, + TcHsModule, TcCoreExpr, TcDictBinds, - SYN_IE(TypecheckedHsBinds), - SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedPat), - SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedArithSeqInfo), - SYN_IE(TypecheckedStmt), - SYN_IE(TypecheckedMatch), SYN_IE(TypecheckedHsModule), - SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS), - SYN_IE(TypecheckedRecordBinds), SYN_IE(TypecheckedDictBinds), + TypecheckedHsBinds, + TypecheckedMonoBinds, TypecheckedPat, + TypecheckedHsExpr, TypecheckedArithSeqInfo, + TypecheckedStmt, + TypecheckedMatch, TypecheckedHsModule, + TypecheckedGRHSsAndBinds, TypecheckedGRHS, + TypecheckedRecordBinds, TypecheckedDictBinds, mkHsTyApp, mkHsDictApp, mkHsTyLam, mkHsDictLam, - tcIdType, tcIdTyVars, - zonkTopBinds, zonkBinds, zonkMonoBinds + -- re-exported from TcEnv + TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId, + + maybeBoxedPrimType, + + zonkTopBinds, zonkBinds, zonkMonoBinds, zonkTcId ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -- friends: import HsSyn -- oodles of it import Id ( GenId(..), IdDetails, -- Can meddle modestly with Ids - SYN_IE(DictVar), idType, - SYN_IE(Id) + DictVar, idType, dataConArgTys, + Id ) -- others: -import Name ( Name{--O only-}, NamedThing(..) ) -import BasicTypes ( IfaceFlavour ) -import TcEnv ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv ) +import Name ( NamedThing(..) ) +import BasicTypes ( IfaceFlavour, Unused ) +import TcEnv ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv, + TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId + ) + import TcMonad -import TcType ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), - zonkTcTypeToType, zonkTcTyVarToTyVar +import TcType ( TcType, TcMaybe, TcTyVar, TcBox, + zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType ) -import Usage ( SYN_IE(UVar) ) -import Util ( zipEqual, panic, - pprPanic, pprTrace -#ifdef DEBUG - , assertPanic -#endif - ) - -import PprType ( GenType, GenTyVar ) -- instances -import Type ( mkTyVarTy, tyVarsOfType, SYN_IE(Type) ) -import TyVar ( GenTyVar {- instances -}, SYN_IE(TyVar), - SYN_IE(TyVarEnv), nullTyVarEnv, growTyVarEnvList, emptyTyVarSet ) +import TyCon ( isDataTyCon ) +import Type ( mkTyVarTy, tyVarsOfType, splitAlgTyConApp_maybe, isUnpointedType, Type ) +import TyVar ( TyVar, TyVarEnv, emptyTyVarEnv, growTyVarEnvList, emptyTyVarSet ) import TysPrim ( voidTy ) import CoreSyn ( GenCoreExpr ) import Unique ( Unique ) -- instances import Bag import UniqFM +import Util ( zipEqual ) import Outputable -import Pretty \end{code} @@ -80,33 +76,33 @@ At the end of type checking we zonk everything to @Typechecked...@ datatypes, which have immutable type variables in them. \begin{code} -type TcHsBinds s = HsBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcMonoBinds s = MonoBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) +type TcHsBinds s = HsBinds (TcBox s) (TcIdOcc s) (TcPat s) +type TcMonoBinds s = MonoBinds (TcBox s) (TcIdOcc s) (TcPat s) type TcDictBinds s = TcMonoBinds s -type TcPat s = OutPat (TcTyVar s) UVar (TcIdOcc s) -type TcExpr s = HsExpr (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcGRHSsAndBinds s = GRHSsAndBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcGRHS s = GRHS (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcMatch s = Match (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcStmt s = Stmt (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcArithSeqInfo s = ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcRecordBinds s = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcHsModule s = HsModule (TcTyVar s) UVar (TcIdOcc s) (TcPat s) - -type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcTyVar s) UVar - -type TypecheckedPat = OutPat TyVar UVar Id -type TypecheckedMonoBinds = MonoBinds TyVar UVar Id TypecheckedPat +type TcPat s = OutPat (TcBox s) (TcIdOcc s) +type TcExpr s = HsExpr (TcBox s) (TcIdOcc s) (TcPat s) +type TcGRHSsAndBinds s = GRHSsAndBinds (TcBox s) (TcIdOcc s) (TcPat s) +type TcGRHS s = GRHS (TcBox s) (TcIdOcc s) (TcPat s) +type TcMatch s = Match (TcBox s) (TcIdOcc s) (TcPat s) +type TcStmt s = Stmt (TcBox s) (TcIdOcc s) (TcPat s) +type TcArithSeqInfo s = ArithSeqInfo (TcBox s) (TcIdOcc s) (TcPat s) +type TcRecordBinds s = HsRecordBinds (TcBox s) (TcIdOcc s) (TcPat s) +type TcHsModule s = HsModule (TcBox s) (TcIdOcc s) (TcPat s) + +type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcBox s) + +type TypecheckedPat = OutPat Unused Id +type TypecheckedMonoBinds = MonoBinds Unused Id TypecheckedPat type TypecheckedDictBinds = TypecheckedMonoBinds -type TypecheckedHsBinds = HsBinds TyVar UVar Id TypecheckedPat -type TypecheckedHsExpr = HsExpr TyVar UVar Id TypecheckedPat -type TypecheckedArithSeqInfo = ArithSeqInfo TyVar UVar Id TypecheckedPat -type TypecheckedStmt = Stmt TyVar UVar Id TypecheckedPat -type TypecheckedMatch = Match TyVar UVar Id TypecheckedPat -type TypecheckedGRHSsAndBinds = GRHSsAndBinds TyVar UVar Id TypecheckedPat -type TypecheckedGRHS = GRHS TyVar UVar Id TypecheckedPat -type TypecheckedRecordBinds = HsRecordBinds TyVar UVar Id TypecheckedPat -type TypecheckedHsModule = HsModule TyVar UVar Id TypecheckedPat +type TypecheckedHsBinds = HsBinds Unused Id TypecheckedPat +type TypecheckedHsExpr = HsExpr Unused Id TypecheckedPat +type TypecheckedArithSeqInfo = ArithSeqInfo Unused Id TypecheckedPat +type TypecheckedStmt = Stmt Unused Id TypecheckedPat +type TypecheckedMatch = Match Unused Id TypecheckedPat +type TypecheckedGRHSsAndBinds = GRHSsAndBinds Unused Id TypecheckedPat +type TypecheckedGRHS = GRHS Unused Id TypecheckedPat +type TypecheckedRecordBinds = HsRecordBinds Unused Id TypecheckedPat +type TypecheckedHsModule = HsModule Unused Id TypecheckedPat \end{code} \begin{code} @@ -121,13 +117,29 @@ mkHsTyLam tyvars expr = TyLam tyvars expr mkHsDictLam [] expr = expr mkHsDictLam dicts expr = DictLam dicts expr +\end{code} -tcIdType :: TcIdOcc s -> TcType s -tcIdType (TcId id) = idType id -tcIdType (RealId id) = pprPanic "tcIdType:" (ppr PprDebug id) +%************************************************************************ +%* * +\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} +%* * +%************************************************************************ + +Some gruesome hackery for desugaring ccalls. It's here because if we put it +in Type.lhs we get irritating loops, and it's only used by TcInstDcls.lhs and +DsCCall.lhs. -tcIdTyVars (TcId id) = tyVarsOfType (idType id) -tcIdTyVars (RealId _) = emptyTyVarSet -- Top level Ids have no free type variables +\begin{code} +maybeBoxedPrimType :: Type -> Maybe (Id, Type) +maybeBoxedPrimType ty + = case splitAlgTyConApp_maybe ty of -- Data type, + Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon -- with exactly one constructor + -> case (dataConArgTys data_con tys_applied) of + [data_con_arg_ty] -- Applied to exactly one type, + | isUnpointedType data_con_arg_ty -- which is primitive + -> Just (data_con, data_con_arg_ty) + other_cases -> Nothing + other_cases -> Nothing \end{code} %************************************************************************ @@ -136,6 +148,16 @@ tcIdTyVars (RealId _) = emptyTyVarSet -- Top level Ids have no free type variab %* * %************************************************************************ +@zonkTcId@ just works on TcIdOccs. It's used when zonking Method insts. + +\begin{code} +zonkTcId :: TcIdOcc s -> NF_TcM s (TcIdOcc s) +zonkTcId tc_id@(RealId id) = returnNF_Tc tc_id +zonkTcId (TcId (Id u n ty details prags info)) + = zonkTcType ty `thenNF_Tc` \ ty' -> + returnNF_Tc (TcId (Id u n ty' details prags info)) +\end{code} + This zonking pass runs over the bindings a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc @@ -155,16 +177,15 @@ were previously in the LVE of the Tc monad.) It's all pretty boring stuff, because HsSyn is such a large type, and the environment manipulation is tiresome. - \begin{code} extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars] zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id +zonkIdBndr te (RealId id) = returnNF_Tc id zonkIdBndr te (TcId (Id u n ty details prags info)) = zonkTcTypeToType te ty `thenNF_Tc` \ ty' -> returnNF_Tc (Id u n ty' details prags info) -zonkIdBndr te (RealId id) = returnNF_Tc id zonkIdOcc :: TcIdOcc s -> NF_TcM s Id zonkIdOcc (RealId id) = returnNF_Tc id @@ -173,7 +194,7 @@ zonkIdOcc (TcId id) let new_id = case maybe_id' of Just id' -> id' - Nothing -> pprTrace "zonkIdOcc: " (ppr PprDebug id) $ + Nothing -> pprTrace "zonkIdOcc: " (ppr id) $ Id u n voidTy details prags info where Id u n _ details prags info = id @@ -187,7 +208,7 @@ zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, TcEnv s) zonkTopBinds binds -- Top level is implicitly recursive = fixNF_Tc (\ ~(_, new_ids) -> tcExtendGlobalValEnv (bagToList new_ids) $ - zonkMonoBinds nullTyVarEnv binds `thenNF_Tc` \ (binds', new_ids) -> + zonkMonoBinds emptyTyVarEnv binds `thenNF_Tc` \ (binds', new_ids) -> tcGetEnv `thenNF_Tc` \ env -> returnNF_Tc ((binds', env), new_ids) ) `thenNF_Tc` \ (stuff, _) -> @@ -318,10 +339,6 @@ zonkGRHSsAndBinds te (GRHSsAndBindsOut grhss binds ty) tcSetEnv new_env $ zonkExpr te expr `thenNF_Tc` \ new_expr -> returnNF_Tc (GRHS new_guard new_expr locn) - - zonk_grhs (OtherwiseGRHS expr locn) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (OtherwiseGRHS new_expr locn) in mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss -> zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> @@ -415,11 +432,16 @@ zonkExpr te (ExplicitTuple exprs) = mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs -> returnNF_Tc (ExplicitTuple new_exprs) -zonkExpr te (RecordConOut con_id con_expr rbinds) +zonkExpr te (HsCon con_id tys exprs) + = mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys -> + mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs -> + returnNF_Tc (HsCon con_id new_tys new_exprs) + +zonkExpr te (RecordCon con_id con_expr rbinds) = zonkIdOcc con_id `thenNF_Tc` \ new_con_id -> - zonkExpr te con_expr `thenNF_Tc` \ new_con_expr -> + zonkExpr te con_expr `thenNF_Tc` \ new_con_expr -> zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds -> - returnNF_Tc (RecordConOut new_con_id new_con_expr new_rbinds) + returnNF_Tc (RecordCon new_con_id new_con_expr new_rbinds) zonkExpr te (RecordUpd _ _) = panic "zonkExpr te:RecordUpd" @@ -471,20 +493,6 @@ zonkExpr te (DictApp expr dicts) mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> returnNF_Tc (DictApp new_expr new_dicts) -zonkExpr te (ClassDictLam dicts methods expr) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> - mapNF_Tc zonkIdOcc methods `thenNF_Tc` \ new_methods -> - returnNF_Tc (ClassDictLam new_dicts new_methods new_expr) - -zonkExpr te (Dictionary dicts methods) - = mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> - mapNF_Tc zonkIdOcc methods `thenNF_Tc` \ new_methods -> - returnNF_Tc (Dictionary new_dicts new_methods) - -zonkExpr te (SingleDict name) - = zonkIdOcc name `thenNF_Tc` \ name' -> - returnNF_Tc (SingleDict name') ------------------------------------------------------------------------- diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 63282687cf..7d7ca677f0 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -4,12 +4,11 @@ \section[TcIfaceSig]{Type checking of type signatures in interface files} \begin{code} -#include "HsVersions.h" - module TcIfaceSig ( tcInterfaceSigs ) where -IMP_Ubiq() +#include "HsVersions.h" +import HsSyn ( HsDecl(..), IfaceSig(..) ) import TcMonad import TcMonoType ( tcHsType, tcHsTypeKind ) import TcEnv ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv, @@ -18,8 +17,6 @@ import TcEnv ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv, ) import TcKind ( TcKind, kindToTcKind ) -import HsSyn ( IfaceSig(..), HsDecl(..), TyDecl, ClassDecl, InstDecl, DefaultDecl, HsBinds, - Fake, InPat, HsType ) import RnHsSyn ( RenamedHsDecl(..) ) import HsCore import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) ) @@ -29,12 +26,11 @@ import CoreUtils ( coreExprType ) import CoreUnfold import MagicUFs ( MagicUnfoldingFun ) import WwLib ( mkWrapper ) -import SpecEnv ( SpecEnv ) import PrimOp ( PrimOp(..) ) import Id ( GenId, mkImported, mkUserId, addInlinePragma, - isPrimitiveId_maybe, dataConArgTys, SYN_IE(Id) ) -import Type ( mkSynTy, getAppDataTyConExpandingDicts ) + isPrimitiveId_maybe, dataConArgTys, Id ) +import Type ( mkSynTy, splitAlgTyConApp ) import TyVar ( mkSysTyVar ) import Name ( Name ) import Unique ( rationalTyConKey, uniqueOf ) @@ -42,9 +38,8 @@ import TysWiredIn ( integerTy ) import PragmaInfo ( PragmaInfo(..) ) import ErrUtils ( pprBagOfErrors ) import Maybes ( maybeToBool ) -import Pretty -import Outputable ( Outputable(..), PprStyle(..) ) -import Util ( zipWithEqual, panic, pprTrace, pprPanic ) +import Outputable +import Util ( zipWithEqual ) import IdInfo \end{code} @@ -129,7 +124,7 @@ tcWorker unf_env (Just (worker_name,_)) maybe_worker_id = tcExplicitLookupGlobal unf_env worker_name -- The trace is so we can see what's getting dropped - trace_maybe Nothing = pprTrace "tcWorker failed:" (ppr PprDebug worker_name) Nothing + trace_maybe Nothing = pprTrace "tcWorker failed:" (ppr worker_name) Nothing trace_maybe (Just x) = Just x \end{code} @@ -149,7 +144,7 @@ tcUnfolding unf_env name core_expr -- compiler hackers who want to improve it! no_unfolding = getErrsTc `thenNF_Tc` \ (warns,errs) -> returnNF_Tc (pprTrace "tcUnfolding failed with:" - (hang (ppr PprDebug name) 4 (pprBagOfErrors PprDebug errs)) + (hang (ppr name) 4 (pprBagOfErrors errs)) NoUnfolding) \end{code} @@ -165,10 +160,10 @@ tcVar name = tcLookupGlobalValueMaybe name `thenNF_Tc` \ maybe_id -> case maybe_id of { Just id -> returnTc id; - Nothing -> failTc (noDecl name) + Nothing -> failWithTc (noDecl name) } -noDecl name sty = hsep [ptext SLIT("Warning: no binding for"), ppr sty name] +noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name] \end{code} UfCore expressions. @@ -262,9 +257,6 @@ tcCoreLamBndr (UfTyBinder name kind) thing_inside tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $ thing_inside (TyBinder tyvar) -tcCoreLamBndr (UfUsageBinder name) thing_inside - = error "tcCoreLamBndr: usage" - tcCoreValBndr (UfValBinder name ty) thing_inside = tcHsType ty `thenTc` \ ty' -> let @@ -291,7 +283,6 @@ mk_id name ty = mkUserId name ty NoPragmaInfo tcCoreArg (UfVarArg v) = tcVar v `thenTc` \ v' -> returnTc (VarArg v') tcCoreArg (UfTyArg ty) = tcHsTypeKind ty `thenTc` \ (_,ty') -> returnTc (TyArg ty') tcCoreArg (UfLitArg lit) = returnTc (LitArg lit) -tcCoreArg (UfUsageArg u) = error "tcCoreArg: usage" tcCoreAlts scrut_ty (UfAlgAlts alts deflt) = mapTc tc_alt alts `thenTc` \ alts' -> @@ -302,7 +293,7 @@ tcCoreAlts scrut_ty (UfAlgAlts alts deflt) = tcVar con `thenTc` \ con' -> let arg_tys = dataConArgTys con' inst_tys - (tycon, inst_tys, cons) = getAppDataTyConExpandingDicts scrut_ty + (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty arg_ids = zipWithEqual "tcCoreAlts" mk_id names arg_tys in tcExtendGlobalValEnv arg_ids $ @@ -334,7 +325,7 @@ tcCorePrim (UfOtherOp op) = tcVar op `thenTc` \ op_id -> case isPrimitiveId_maybe op_id of Just prim_op -> returnTc prim_op - Nothing -> pprPanic "tcCorePrim" (ppr PprDebug op_id) + Nothing -> pprPanic "tcCorePrim" (ppr op_id) tcCorePrim (UfCCallOp str casm gc arg_tys res_ty) = mapTc tcHsType arg_tys `thenTc` \ arg_tys' -> @@ -343,7 +334,7 @@ tcCorePrim (UfCCallOp str casm gc arg_tys res_ty) \end{code} \begin{code} -ifaceSigCtxt sig_name sty - = hsep [ptext SLIT("In an interface-file signature for"), ppr sty sig_name] +ifaceSigCtxt sig_name + = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name] \end{code} diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 9879fd3923..97a8b157f0 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -4,102 +4,85 @@ \section[TcInstDecls]{Typechecking instance declarations} \begin{code} -#include "HsVersions.h" - module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where +#include "HsVersions.h" -IMP_Ubiq() - -import HsSyn ( HsDecl(..), InstDecl(..), TyDecl, ClassDecl, DefaultDecl, - FixityDecl, IfaceSig, Sig(..), - SpecInstSig(..), HsBinds(..), - MonoBinds(..), GRHSsAndBinds(..), GRHS(..), Match, - InPat(..), OutPat(..), HsExpr(..), HsLit(..), - Stmt, DoOrListComp, ArithSeqInfo, Fake, Fixity, - HsType(..), HsTyVar, - SYN_IE(RecFlag), recursive, nonRecursive, collectMonoBinders, - andMonoBinds +import HsSyn ( HsDecl(..), InstDecl(..), HsType(..), + HsBinds(..), MonoBinds(..), GRHSsAndBinds(..), GRHS(..), + HsExpr(..), InPat(..), HsLit(..), + unguardedRHS, + collectMonoBinders, andMonoBinds ) -import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds), - SYN_IE(RenamedInstDecl), SYN_IE(RenamedFixityDecl), SYN_IE(RenamedHsExpr), - SYN_IE(RenamedSig), SYN_IE(RenamedSpecInstSig), SYN_IE(RenamedHsDecl) +import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds, + RenamedInstDecl, RenamedFixityDecl, RenamedHsExpr, + RenamedSig, RenamedSpecInstSig, RenamedHsDecl ) -import TcHsSyn ( SYN_IE(TcHsBinds), - SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType, +import TcHsSyn ( TcHsBinds, + TcMonoBinds, TcExpr, TcIdOcc(..), TcIdBndr, + tcIdType, maybeBoxedPrimType, mkHsTyLam, mkHsTyApp, mkHsDictLam, mkHsDictApp ) -import TcBinds ( tcPragmaSigs ) +import TcBinds ( tcPragmaSigs, sigThetaCtxt ) import TcClassDcl ( tcMethodBind, badMethodErr ) import TcMonad -import RnMonad ( SYN_IE(RnNameSupply) ) -import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper), - instToId, newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE ) +import RnMonad ( RnNameSupply ) +import Inst ( Inst, InstOrigin(..), InstanceMapper, + instToId, newDicts, newMethod, LIE, emptyLIE, plusLIE ) import PragmaInfo ( PragmaInfo(..) ) import TcDeriv ( tcDeriving ) -import TcEnv ( tcLookupClass, newLocalId, tcExtendGlobalTyVars, tcGetGlobalTyVars, +import TcEnv ( tcLookupClass, newLocalId, tcGetGlobalTyVars, tcExtendGlobalValEnv, tcAddImportedIdInfo ) -import SpecEnv ( SpecEnv ) -import TcGRHSs ( tcGRHSsAndBinds ) -import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs ) +import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs, classDataCon ) import TcKind ( TcKind, unifyKind ) import TcMatches ( tcMatchesFun ) -import TcMonoType ( tcTyVarScope, tcContext, tcHsTypeKind ) +import TcMonoType ( tcTyVarScope, tcContext, tcHsTypeKind, tcHsType ) import TcSimplify ( tcSimplifyAndCheck ) -import TcType ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), +import TcType ( TcType, TcTyVar, TcTyVarSet, + zonkSigTyVar, tcInstSigTyVars, tcInstType, tcInstSigTcType, - tcInstTheta, tcInstTcType, tcInstSigType + tcInstTheta, tcInstTcType ) import Unify ( unifyTauTy, unifyTauTyLists ) import Bag ( emptyBag, unitBag, unionBags, unionManyBags, concatBag, foldBag, bagToList, listToBag, - Bag ) -import CmdLineOpts ( opt_GlasgowExts, - opt_PprUserLength, opt_SpecialiseOverloaded, - opt_WarnMissingMethods + Bag + ) +import CmdLineOpts ( opt_GlasgowExts, + opt_SpecialiseOverloaded, opt_WarnMissingMethods ) -import Class ( GenClass, - classBigSig, - classDefaultMethodId, SYN_IE(Class) - ) -import Id ( GenId, idType, replacePragmaInfo, - isNullaryDataCon, dataConArgTys, SYN_IE(Id) ) +import Class ( classBigSig, classTyCon, Class ) +import Id ( idType, replacePragmaInfo, + isNullaryDataCon, dataConArgTys, Id ) import ListSetOps ( minusList ) import Maybes ( maybeToBool, expectJust, seqMaybe, catMaybes ) import Name ( nameOccName, getSrcLoc, mkLocalName, - isLocallyDefined, OccName, Name{--O only-}, SYN_IE(Module), + isLocallyDefined, Module, NamedThing(..) ) import PrelVals ( nO_EXPLICIT_METHOD_ERROR_ID, nO_DEFAULT_METHOD_ERROR_ID ) -import PprType ( GenType, GenTyVar, GenClass, TyCon, - pprParendGenType - ) -import Outputable +import PprType ( pprParendGenType, pprConstraint ) import SrcLoc ( SrcLoc, noSrcLoc ) -import Pretty -import TyCon ( isSynTyCon, isDataTyCon, derivedClasses ) -import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, isPrimType, +import TyCon ( tyConDataCons, isSynTyCon, isDataTyCon, tyConDerivings ) +import Type ( Type, ThetaType, mkTyVarTys, isUnpointedType, splitSigmaTy, splitAppTys, isTyVarTy, matchTy, mkSigmaTy, - getTyCon_maybe, maybeAppTyCon, SYN_IE(Type), getTyVar, - maybeBoxedPrimType, maybeAppDataTyCon, splitRhoTy, eqTy + splitTyConApp_maybe, getTyVar, splitDictTy_maybe, + splitAlgTyConApp_maybe, splitRhoTy, isSynTy, + tyVarsOfTypes ) -import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), tyVarSetToList, - mkTyVarSet, unionTyVarSets, SYN_IE(TyVar) ) +import TyVar ( zipTyVarEnv, mkTyVarSet, tyVarSetToList, TyVar ) import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) import TysWiredIn ( stringTy ) import Unique ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) ) -import Util ( zipEqual, panic, pprPanic, pprTrace, removeDups, Ord3(..) -#if __GLASGOW_HASKELL__ < 202 - , trace -#endif - ) +import Util ( zipEqual, removeDups ) +import Outputable \end{code} Typechecking instance declarations is done in two passes. The first @@ -182,7 +165,7 @@ tcInstDecls1 :: TcEnv s -- Contains IdInfo for dfun ids -> RnNameSupply -- for renaming derivings -> TcM s (Bag InstInfo, RenamedHsBinds, - PprStyle -> Doc) + SDoc) tcInstDecls1 unf_env decls mod_name rn_name_supply = -- Do the ordinary instance declarations @@ -210,38 +193,28 @@ tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src recoverNF_Tc (returnNF_Tc emptyBag) $ tcAddSrcLoc src_loc $ - -- Look things up - tcLookupClass class_name `thenTc` \ (clas_kind, clas) -> - - -- Typecheck the context and instance type - tcTyVarScope tyvar_names (\ tyvars -> - tcContext context `thenTc` \ theta -> - tcHsTypeKind inst_ty `thenTc` \ (tau_kind, tau) -> - unifyKind clas_kind tau_kind `thenTc_` - returnTc (tyvars, theta, tau) - ) `thenTc` \ (inst_tyvars, inst_theta, inst_tau) -> + -- Type-check all the stuff before the "where" + tcHsType poly_ty `thenTc` \ poly_ty' -> + let + (tyvars, theta, dict_ty) = splitSigmaTy poly_ty' + (clas, inst_tys) = case splitDictTy_maybe dict_ty of + Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty) + Just pair -> pair + in -- Check for respectable instance type - scrutiniseInstanceType dfun_name clas inst_tau - `thenTc` \ (inst_tycon,arg_tys) -> + scrutiniseInstanceType clas inst_tys `thenTc_` -- Make the dfun id and constant-method ids let (dfun_id, dfun_theta) = mkInstanceRelatedIds dfun_name - clas inst_tyvars inst_tau inst_theta + clas tyvars inst_tys theta -- Add info from interface file final_dfun_id = tcAddImportedIdInfo unf_env dfun_id in - returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta - dfun_theta final_dfun_id + returnTc (unitBag (InstInfo clas tyvars inst_tys theta + dfun_theta final_dfun_id binds src_loc uprags)) - where - (tyvar_names, context, dict_ty) = case poly_ty of - HsForAllTy tvs cxt dict_ty -> (tvs, cxt, dict_ty) - other -> ([], [], poly_ty) - (class_name, inst_ty) = case dict_ty of - MonoDictTy cls ty -> (cls,ty) - other -> pprPanic "Malformed instance decl" (ppr PprDebug poly_ty) \end{code} @@ -334,7 +307,7 @@ First comes the easy case of a non-local instance decl. \begin{code} tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcMonoBinds s) -tcInstDecl2 (InstInfo clas inst_tyvars inst_ty +tcInstDecl2 (InstInfo clas inst_tyvars inst_tys inst_decl_theta dfun_theta dfun_id monobinds locn uprags) @@ -358,88 +331,120 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty tcAddSrcLoc locn $ -- Get the class signature - tcInstSigTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) -> let origin = InstanceDeclOrigin - (class_tyvar, - super_classes, sc_sel_ids, + (class_tyvars, + sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas in - tcInstType tenv inst_ty `thenNF_Tc` \ inst_ty' -> + + -- Instantiate the instance decl with tc-style type variables + tcInstSigTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) -> + mapNF_Tc (tcInstType tenv) inst_tys `thenNF_Tc` \ inst_tys' -> tcInstTheta tenv dfun_theta `thenNF_Tc` \ dfun_theta' -> tcInstTheta tenv inst_decl_theta `thenNF_Tc` \ inst_decl_theta' -> - let - sc_theta' = super_classes `zip` repeat inst_ty' - in + + -- Instantiate the super-class context with inst_tys + + tcInstTheta (zipTyVarEnv class_tyvars inst_tys') sc_theta `thenNF_Tc` \ sc_theta' -> + -- Create dictionary Ids from the specified instance contexts. newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) -> newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) -> newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) -> - newDicts origin [(clas,inst_ty')] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> + newDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> -- Now process any INLINE or SPECIALIZE pragmas for the methods -- ...[NB May 97; all ignored except INLINE] - tcPragmaSigs uprags `thenTc` \ (prag_fn, spec_binds, spec_lie) -> + tcPragmaSigs uprags `thenTc` \ (prag_fn, spec_binds, spec_lie) -> -- Check that all the method bindings come from this class let - inst_tyvars_set' = mkTyVarSet inst_tyvars' check_from_this_class (bndr, loc) - | nameOccName bndr `elem` sel_names = returnTc () - | otherwise = recoverTc (returnTc ()) $ - tcAddSrcLoc loc $ - failTc (badMethodErr bndr clas) + | nameOccName bndr `elem` sel_names = returnNF_Tc () + | otherwise = tcAddSrcLoc loc $ + addErrTc (badMethodErr bndr clas) sel_names = map getOccName op_sel_ids + bndrs = bagToList (collectMonoBinders monobinds) in - mapTc check_from_this_class (bagToList (collectMonoBinders monobinds)) `thenTc_` + mapNF_Tc check_from_this_class bndrs `thenNF_Tc_` - -- Type check the method bindings themselves - tcExtendGlobalTyVars inst_tyvars_set' ( - tcExtendGlobalValEnv (catMaybes defm_ids) $ - -- Default-method Ids may be mentioned in synthesised RHSs + tcExtendGlobalValEnv (catMaybes defm_ids) ( - mapAndUnzip3Tc (tcInstMethodBind clas inst_ty' monobinds) + -- Default-method Ids may be mentioned in synthesised RHSs + mapAndUnzip3Tc (tcInstMethodBind clas inst_tys' inst_tyvars' monobinds) (op_sel_ids `zip` defm_ids) ) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) -> -- Check the overloading constraints of the methods and superclasses + mapNF_Tc zonkSigTyVar inst_tyvars' `thenNF_Tc` \ zonked_inst_tyvars -> + let + inst_tyvars_set = mkTyVarSet zonked_inst_tyvars + (meth_lies, meth_ids) = unzip meth_lies_w_ids - avail_insts -- These insts are in scope; quite a few, eh? - = this_dict `plusLIE` dfun_arg_dicts `plusLIE` unionManyBags meth_lies + + -- These insts are in scope; quite a few, eh? + avail_insts = this_dict `plusLIE` + dfun_arg_dicts `plusLIE` + sc_dicts `plusLIE` + unionManyBags meth_lies in - tcAddErrCtxt bindSigCtxt ( - tcSimplifyAndCheck - inst_tyvars_set' -- Local tyvars + tcAddErrCtxt superClassCtxt $ + tcAddErrCtxtM (sigThetaCtxt sc_dicts) $ + + + -- Deal with the LIE arising from the method bindings + tcSimplifyAndCheck (text "inst decl1a") + inst_tyvars_set -- Local tyvars avail_insts - (sc_dicts `unionBags` - unionManyBags insts_needed_s) -- Need to get defns for all these - ) `thenTc` \ (const_lie, super_binds) -> + (unionManyBags insts_needed_s) -- Need to get defns for all these + `thenTc` \ (const_lie1, op_binds) -> + + -- Deal with the super-class bindings + -- Ignore errors because they come from the *next* tcSimplify + discardErrsTc ( + tcSimplifyAndCheck (text "inst decl1b") + inst_tyvars_set + dfun_arg_dicts -- NB! Don't include this_dict here, else the sc_dicts + -- get bound by just selecting from this_dict!! + sc_dicts + ) `thenTc` \ (const_lie2, sc_binds) -> + -- Check that we *could* construct the superclass dictionaries, -- even though we are *actually* going to pass the superclass dicts in; -- the check ensures that the caller will never have a problem building -- them. - tcAddErrCtxt superClassSigCtxt ( - tcSimplifyAndCheck - inst_tyvars_set' -- Local tyvars + tcSimplifyAndCheck (text "inst decl1c") + inst_tyvars_set -- Local tyvars inst_decl_dicts -- The instance dictionaries available sc_dicts -- The superclass dicationaries reqd - ) `thenTc_` + `thenTc_` -- Ignore the result; we're only doing -- this to make sure it can be done. -- Create the result bindings let - dict_bind = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids) + const_lie = const_lie1 `plusLIE` const_lie2 + lie_binds = op_binds `AndMonoBinds` sc_binds + + dict_constr = classDataCon clas + + con_app = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys') + (map HsVar (sc_dict_ids ++ meth_ids)) + -- We don't produce a binding for the dict_constr; instead we + -- rely on the simplifier to unfold this saturated application + + dict_bind = VarMonoBind this_dict_id con_app method_binds = andMonoBinds method_binds_s main_bind = AbsBinds - inst_tyvars' + zonked_inst_tyvars dfun_arg_dicts_ids [(inst_tyvars', RealId dfun_id, this_dict_id)] - (super_binds `AndMonoBinds` + (lie_binds `AndMonoBinds` method_binds `AndMonoBinds` dict_bind) in @@ -457,12 +462,13 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty \begin{code} tcInstMethodBind :: Class - -> TcType s -- Instance type + -> [TcType s] -- Instance types + -> [TcTyVar s] -- and their free (sig) tyvars -> RenamedMonoBinds -- Method binding -> (Id, Maybe Id) -- Selector id and default-method id -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s)) -tcInstMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id) +tcInstMethodBind clas inst_tys inst_tyvars meth_binds (sel_id, maybe_dm_id) = tcGetSrcLoc `thenNF_Tc` \ loc -> tcGetUnique `thenNF_Tc` \ uniq -> let @@ -471,7 +477,7 @@ tcInstMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id) maybe_meth_bind = find meth_occ meth_binds the_meth_bind = case maybe_meth_bind of Just stuff -> stuff - Nothing -> mk_default_bind default_meth_name + Nothing -> mk_default_bind default_meth_name loc in -- Warn if no method binding, only if -fwarn-missing-methods @@ -482,7 +488,7 @@ tcInstMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id) (omittedMethodWarn sel_id clas) `thenNF_Tc_` -- Typecheck the method binding - tcMethodBind clas origin inst_ty sel_id the_meth_bind + tcMethodBind clas origin inst_tys inst_tyvars sel_id the_meth_bind where origin = InstanceDeclOrigin -- Poor @@ -496,10 +502,10 @@ tcInstMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id) find occ other = panic "Urk! Bad instance method binding" - mk_default_bind local_meth_name + mk_default_bind local_meth_name loc = PatMonoBind (VarPatIn local_meth_name) - (GRHSsAndBindsIn [OtherwiseGRHS default_expr noSrcLoc] EmptyBinds) - noSrcLoc + (GRHSsAndBindsIn (unguardedRHS default_expr loc) EmptyBinds) + loc default_expr = case maybe_dm_id of Just dm_id -> HsVar (getName dm_id) -- There's a default method @@ -508,8 +514,8 @@ tcInstMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id) error_expr = HsApp (HsVar (getName nO_DEFAULT_METHOD_ERROR_ID)) (HsLit (HsString (_PK_ error_msg))) - error_msg = show (hcat [ppr (PprForUser opt_PprUserLength) (getSrcLoc sel_id), text "|", - ppr (PprForUser opt_PprUserLength) sel_id + error_msg = show (hcat [ppr (getSrcLoc sel_id), text "|", + ppr sel_id ]) \end{code} @@ -562,7 +568,7 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty) `thenTc` \ inst_ty -> let - maybe_tycon = case maybeAppDataTyCon inst_ty of + maybe_tycon = case splitAlgTyConApp_maybe inst_ty of Just (tc,_,_) -> Just tc Nothing -> Nothing @@ -599,22 +605,21 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc tv_tmpl_map = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv in - mkInstanceRelatedIds - clas inst_tmpls inst_ty simpl_theta uprag + mkInstanceRelatedIds clas inst_tmpls inst_ty simpl_theta uprag `thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) -> getSwitchCheckerTc `thenNF_Tc` \ sw_chkr -> (if sw_chkr SpecialiseTrace then pprTrace "Specialised Instance: " - (vcat [hsep [if null simpl_theta then empty else ppr PprDebug simpl_theta, + (vcat [hsep [if null simpl_theta then empty else ppr simpl_theta, if null simpl_theta then empty else ptext SLIT("=>"), - ppr PprDebug clas, - pprParendGenType PprDebug inst_ty], + ppr clas, + pprParendGenType inst_ty], hsep [ptext SLIT(" derived from:"), - if null unspec_theta then empty else ppr PprDebug unspec_theta, + if null unspec_theta then empty else ppr unspec_theta, if null unspec_theta then empty else ptext SLIT("=>"), - ppr PprDebug clas, - pprParendGenType PprDebug unspec_inst_ty]]) + ppr clas, + pprParendGenType unspec_inst_ty]]) else id) ( returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta @@ -636,7 +641,7 @@ lookup_unspec_inst clas maybe_tycon inst_infos Just tycon -> match_tycon tycon Nothing -> match_fun - match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of + match_tycon tycon inst_ty = case (splitAlgTyConApp_maybe inst_ty) of Just (inst_tc,_,_) -> tycon == inst_tc Nothing -> False @@ -644,7 +649,7 @@ lookup_unspec_inst clas maybe_tycon inst_infos is_plain_instance inst_ty - = case (maybeAppDataTyCon inst_ty) of + = case (splitAlgTyConApp_maybe inst_ty) of Just (_,tys,_) -> all isTyVarTemplateTy tys Nothing -> case maybeUnpackFunTy inst_ty of Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res @@ -665,31 +670,8 @@ compiled elsewhere). In these cases, we let them go through anyway. We can also have instances for functions: @instance Foo (a -> b) ...@. \begin{code} -scrutiniseInstanceType dfun_name clas inst_tau - -- TYCON CHECK - | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon - = failTc (instTypeErr inst_tau) - - -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1) - | not (isLocallyDefined dfun_name) - = returnTc (inst_tycon,arg_tys) - - -- TYVARS CHECK - | not (opt_GlasgowExts || - (all isTyVarTy arg_tys && null tyvar_dups) - ) - = failTc (instTypeErr inst_tau) - - -- DERIVING CHECK - -- It is obviously illegal to have an explicit instance - -- for something that we are also planning to `derive' - -- Though we can have an explicit instance which is more - -- specific than the derived instance - | clas `elem` (derivedClasses inst_tycon) - && all isTyVarTy arg_tys - = failTc (derivingWhenInstanceExistsErr clas inst_tycon) - - | -- CCALL CHECK +scrutiniseInstanceType clas inst_taus + | -- CCALL CHECK (a).... urgh! -- To verify that a user declaration of a CCallable/CReturnable -- instance is OK, we must be able to see the constructor(s) -- of the instance type (see next guard.) @@ -698,38 +680,62 @@ scrutiniseInstanceType dfun_name clas inst_tau -- (uniqueOf clas == cCallableClassKey && not constructors_visible) || (uniqueOf clas == cReturnableClassKey && not constructors_visible) - = failTc (invisibleDataConPrimCCallErr clas inst_tau) + = failWithTc (invisibleDataConPrimCCallErr clas first_inst_tau) - | -- CCALL CHECK + | -- CCALL CHECK (b) -- A user declaration of a CCallable/CReturnable instance -- must be for a "boxed primitive" type. - (uniqueOf clas == cCallableClassKey && not (ccallable_type inst_tau)) || - (uniqueOf clas == cReturnableClassKey && not (creturnable_type inst_tau)) - = failTc (nonBoxedPrimCCallErr clas inst_tau) + (uniqueOf clas == cCallableClassKey && not (ccallable_type first_inst_tau)) || + (uniqueOf clas == cReturnableClassKey && not (creturnable_type first_inst_tau)) + = failWithTc (nonBoxedPrimCCallErr clas first_inst_tau) + + -- DERIVING CHECK + -- It is obviously illegal to have an explicit instance + -- for something that we are also planning to `derive' + | clas `elem` (tyConDerivings inst_tycon) + = failWithTc (derivingWhenInstanceExistsErr clas first_inst_tau) + -- Kind check will have ensured inst_taus is of length 1 + + -- ALL TYPE VARIABLES => bad + | all isTyVarTy inst_taus + = failWithTc (instTypeErr clas inst_taus (text "all the instance types are type variables")) + + -- WITH HASKELL 1.4, MUST HAVE C (T a b c) + | not opt_GlasgowExts + && not (length inst_taus == 1 && + maybeToBool tyconapp_maybe && + not (isSynTyCon inst_tycon) && + all isTyVarTy arg_tys && + length (tyVarSetToList (tyVarsOfTypes arg_tys)) == length arg_tys + -- This last condition checks that all the type variables are distinct + ) + = failWithTc (instTypeErr clas inst_taus + (text "the instance type must be of form (T a b c)" $$ + text "where T is not a synonym, and a,b,c are distinct type variables") + ) | otherwise - = returnTc (inst_tycon,arg_tys) + = returnTc () where - (possible_tycon, arg_tys) = splitAppTys inst_tau - inst_tycon_maybe = getTyCon_maybe possible_tycon - inst_tycon = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe - (_, tyvar_dups) = removeDups cmp (map (getTyVar "tcInstDecls1:getTyVarTy") arg_tys) + tyconapp_maybe = splitTyConApp_maybe first_inst_tau + Just (inst_tycon, arg_tys) = tyconapp_maybe + (first_inst_tau : _) = inst_taus constructors_visible = - case maybeAppDataTyCon inst_tau of + case splitAlgTyConApp_maybe first_inst_tau of Just (_,_,[]) -> False everything_else -> True -- These conditions come directly from what the DsCCall is capable of. -- Totally grotesque. Green card should solve this. -ccallable_type ty = isPrimType ty || -- Allow CCallable Int# etc +ccallable_type ty = isUnpointedType ty || -- Allow CCallable Int# etc maybeToBool (maybeBoxedPrimType ty) || -- Ditto Int etc - ty `eqTy` stringTy || + ty == stringTy || byte_arr_thing where - byte_arr_thing = case maybeAppDataTyCon ty of + byte_arr_thing = case splitAlgTyConApp_maybe ty of Just (tycon, ty_args, [data_con]) | isDataTyCon tycon -> length data_con_arg_tys == 2 && maybeToBool maybe_arg2_tycon && @@ -738,14 +744,14 @@ ccallable_type ty = isPrimType ty || -- Allow CCallable Int# etc where data_con_arg_tys = dataConArgTys data_con ty_args (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys - maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2 + maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2 Just (arg2_tycon,_) = maybe_arg2_tycon other -> False creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) || -- Or, a data type with a single nullary constructor - case (maybeAppDataTyCon ty) of + case (splitAlgTyConApp_maybe ty) of Just (tycon, tys_applied, [data_con]) -> isNullaryDataCon data_con other -> False @@ -753,24 +759,28 @@ creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) || \begin{code} -instTypeErr ty sty - = case ty of - SynTy tc _ _ -> hsep [ptext SLIT("The type synonym"), ppr sty tc, rest_of_msg] - TyVarTy tv -> hsep [ptext SLIT("The type variable"), ppr sty tv, rest_of_msg] - other -> sep [ptext SLIT("The type"), nest 4 (ppr sty ty), rest_of_msg] - where - rest_of_msg = ptext SLIT("cannot be used as an instance type") +instTypeErr clas tys msg + = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys), + nest 4 (parens msg) + ] + +instBndrErr bndr clas + = hsep [ptext SLIT("Class"), quotes (ppr clas), ptext SLIT("does not have a method"), quotes (ppr bndr)] -derivingWhenInstanceExistsErr clas tycon sty +derivingWhenInstanceExistsErr clas tycon = hang (hsep [ptext SLIT("Deriving class"), - ppr sty clas, - ptext SLIT("type"), ppr sty tycon]) + quotes (ppr clas), + ptext SLIT("type"), quotes (ppr tycon)]) 4 (ptext SLIT("when an explicit instance exists")) -nonBoxedPrimCCallErr clas inst_ty sty +nonBoxedPrimCCallErr clas inst_ty = hang (ptext SLIT("Unacceptable instance type for ccall-ish class")) - 4 (hsep [ ptext SLIT("class"), ppr sty clas, ptext SLIT("type"), - ppr sty inst_ty]) + 4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"), + ppr inst_ty]) + +omittedMethodWarn sel_id clas + = sep [ptext SLIT("Warning: no explicit method nor default method for") <+> quotes (ppr sel_id), + ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)] {- Declaring CCallable & CReturnable instances in a module different @@ -778,33 +788,26 @@ nonBoxedPrimCCallErr clas inst_ty sty abstractly (either programmatically or by the renamer being over-eager in its pruning.) -} -invisibleDataConPrimCCallErr clas inst_ty sty - = hang (hsep [(ppr sty inst_ty <> ptext SLIT("s constructors not visible when checking")), - ppr sty clas, ptext SLIT("instance")]) - 4 (hsep [text "(Try either importing", ppr sty inst_ty, +invisibleDataConPrimCCallErr clas inst_ty + = hang (hsep [ptext SLIT("Constructors for"), quotes (ppr inst_ty), + ptext SLIT("not visible when checking"), + quotes (ppr clas), ptext SLIT("instance")]) + 4 (hsep [text "(Try either importing", ppr inst_ty, text "non-abstractly or compile using -fno-prune-tydecls ..)"]) -omittedMethodWarn sel_id clas sty - = sep [ptext SLIT("Warning: no explicit method nor default method for") <+> ppr sty sel_id, - ptext SLIT("in an instance declaration for") <+> ppr sty clas] - -instMethodNotInClassErr occ clas sty +instMethodNotInClassErr occ clas = hang (ptext SLIT("Instance mentions a method not in the class")) - 4 (hsep [ptext SLIT("class"), ppr sty clas, ptext SLIT("method"), - ppr sty occ]) + 4 (hsep [ptext SLIT("class") <+> quotes (ppr clas), + ptext SLIT("method") <+> quotes (ppr occ)]) -patMonoBindsCtxt pbind sty +patMonoBindsCtxt pbind = hang (ptext SLIT("In a pattern binding:")) - 4 (ppr sty pbind) + 4 (ppr pbind) -methodSigCtxt name ty sty +methodSigCtxt name ty = hang (hsep [ptext SLIT("When matching the definition of class method"), - ppr sty name, ptext SLIT("to its signature :") ]) - 4 (ppr sty ty) - -bindSigCtxt sty - = ptext SLIT("When checking methods of an instance declaration") + quotes (ppr name), ptext SLIT("to its signature :") ]) + 4 (ppr ty) -superClassSigCtxt sty - = ptext SLIT("When checking superclass constraints of an instance declaration") +superClassCtxt = ptext SLIT("From the superclasses of the instance declaration") \end{code} diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index e8235cf4c0..a12633ae8a 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -6,43 +6,37 @@ The bits common to TcInstDcls and TcDeriv. \begin{code} -#include "HsVersions.h" - module TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, - buildInstanceEnvs + buildInstanceEnvs, + classDataCon ) where -IMP_Ubiq() +#include "HsVersions.h" -import HsSyn ( MonoBinds, Fake, InPat, Sig ) -import RnHsSyn ( SYN_IE(RenamedMonoBinds), RenamedSig(..), +import RnHsSyn ( RenamedMonoBinds, RenamedSig(..), RenamedInstancePragmas(..) ) import TcMonad -import Inst ( SYN_IE(InstanceMapper) ) +import Inst ( InstanceMapper ) import Bag ( bagToList, Bag ) -import Class ( GenClass, SYN_IE(ClassInstEnv), - classBigSig, SYN_IE(Class) - ) -import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp ) -import Id ( GenId, mkDictFunId, mkSysLocal, SYN_IE(Id) ) -import MatchEnv ( nullMEnv, insertMEnv ) +import Class ( ClassInstEnv, Class, classBigSig ) +import Id ( mkDictFunId, Id ) +import SpecEnv ( emptySpecEnv, addToSpecEnv ) import Maybes ( MaybeErr(..), mkLookupFunDef ) -import Name ( getSrcLoc, Name{--O only-} ) -import PprType ( GenClass, GenType, GenTyVar, pprParendType ) -import Pretty -import SpecEnv ( SpecEnv, nullSpecEnv, addOneToSpecEnv ) +import Name ( getSrcLoc, Name ) import SrcLoc ( SrcLoc ) -import Type ( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTys, - instantiateTy, matchTy, SYN_IE(ThetaType), - SYN_IE(Type) ) -import TyVar ( GenTyVar, SYN_IE(TyVar) ) +import Type ( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTys, instantiateThetaTy, + ThetaType, Type + ) +import PprType ( pprConstraint ) +import Class ( classTyCon ) +import TyCon ( tyConDataCons ) +import TyVar ( TyVar, zipTyVarEnv ) import Unique ( Unique ) -import Util ( equivClasses, zipWithEqual, panic{-, pprTrace-}, Ord3(..) ) - +import Util ( equivClasses, zipWithEqual, panic{-, pprTrace-}, assertPanic ) import Outputable \end{code} @@ -53,7 +47,7 @@ data InstInfo = InstInfo Class -- Class, k [TyVar] -- Type variables, tvs - Type -- The type at which the class is being instantiated + [Type] -- The types at which the class is being instantiated ThetaType -- inst_decl_theta: the original context, c, from the -- instance declaration. It constrains (some of) -- the TyVars above @@ -66,6 +60,22 @@ data InstInfo [RenamedSig] -- User pragmas recorded for generating specialised instances \end{code} + +%************************************************************************ +%* * +\subsection{Creating instance related Ids} +%* * +%************************************************************************ + +A tiny function which doesn't belong anywhere else. +It makes a nasty mutual-recursion knot if you put it in Class. + +\begin{code} +classDataCon :: Class -> Id +classDataCon clas = case tyConDataCons (classTyCon clas) of + (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr +\end{code} + %************************************************************************ %* * \subsection{Creating instance related Ids} @@ -76,28 +86,28 @@ data InstInfo mkInstanceRelatedIds :: Name -- Name to use for the dict fun; -> Class -> [TyVar] - -> Type + -> [Type] -> ThetaType -> (Id, ThetaType) -mkInstanceRelatedIds dfun_name clas inst_tyvars inst_ty inst_decl_theta +mkInstanceRelatedIds dfun_name clas inst_tyvars inst_tys inst_decl_theta = (dfun_id, dfun_theta) where - (_, super_classes, _, _, _) = classBigSig clas - super_class_theta = super_classes `zip` repeat inst_ty + (class_tyvars, sc_theta, _, _, _) = classBigSig clas + sc_theta' = instantiateThetaTy (zipTyVarEnv class_tyvars inst_tys) sc_theta dfun_theta = case inst_decl_theta of [] -> [] -- If inst_decl_theta is empty, then we don't -- want to have any dict arguments, so that we can -- expose the constant methods. - other -> inst_decl_theta ++ super_class_theta + other -> inst_decl_theta ++ sc_theta' -- Otherwise we pass the superclass dictionaries to -- the dictionary function; the Mark Jones optimisation. - dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty) + dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) - dfun_id = mkDictFunId dfun_name dfun_ty clas inst_ty + dfun_id = mkDictFunId dfun_name dfun_ty clas inst_tys \end{code} @@ -109,32 +119,32 @@ mkInstanceRelatedIds dfun_name clas inst_tyvars inst_ty inst_decl_theta \begin{code} buildInstanceEnvs :: Bag InstInfo - -> TcM s InstanceMapper + -> NF_TcM s InstanceMapper buildInstanceEnvs info = let - icmp :: InstInfo -> InstInfo -> TAG_ + icmp :: InstInfo -> InstInfo -> Ordering (InstInfo c1 _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _) - = c1 `cmp` c2 + = c1 `compare` c2 info_by_class = equivClasses icmp (bagToList info) in - mapTc buildInstanceEnv info_by_class `thenTc` \ inst_env_entries -> + mapNF_Tc buildInstanceEnv info_by_class `thenNF_Tc` \ inst_env_entries -> let - class_lookup_fn = mkLookupFunDef (==) inst_env_entries nullMEnv + class_lookup_fn = mkLookupFunDef (==) inst_env_entries emptySpecEnv in - returnTc class_lookup_fn + returnNF_Tc class_lookup_fn \end{code} \begin{code} buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class - -> TcM s (Class, ClassInstEnv) + -> NF_TcM s (Class, ClassInstEnv) buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _) : _) - = foldlTc addClassInstance - nullMEnv - inst_infos `thenTc` \ class_inst_env -> - returnTc (clas, class_inst_env) + = foldrNF_Tc addClassInstance + emptySpecEnv + inst_infos `thenNF_Tc` \ class_inst_env -> + returnNF_Tc (clas, class_inst_env) \end{code} @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@ @@ -143,73 +153,29 @@ about any overlap with an existing instance. \begin{code} addClassInstance - :: ClassInstEnv - -> InstInfo - -> TcM s ClassInstEnv + :: InstInfo + -> ClassInstEnv + -> NF_TcM s ClassInstEnv -addClassInstance class_inst_env - (InstInfo clas inst_tyvars inst_ty _ _ +addClassInstance + (InstInfo clas inst_tyvars inst_tys _ _ dfun_id _ src_loc _) + class_inst_env = -- Add the instance to the class's instance environment - case insertMEnv matchTy class_inst_env inst_ty dfun_id of - Failed (ty', dfun_id') -> recoverTc (returnTc class_inst_env) $ - dupInstFailure clas (inst_ty, src_loc) - (ty', getSrcLoc dfun_id'); - Succeeded class_inst_env' -> returnTc class_inst_env' - -{- OLD STUFF FOR CONSTANT METHODS - - -- 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) = ... ; ... } - -- - -- 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) |--> (\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. - -- - -- NOTE THAT this correctly deals with the case where there are - -- constant methods even though there are type variables in the - -- instance declaration. - - tcGetUnique `thenNF_Tc` \ uniq -> - let - dict = mkSysLocal SLIT("dict_tpl") uniq (mkDictTy clas inst_ty) src_loc - -- Slightly disgusting, but it's only a placeholder for - -- a dictionary to be chucked away. - - op_spec_envs' | null const_meth_ids = op_spec_envs - | 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] rhs of - Failed (tys', rhs') -> panic "TcInstDecls:add_const_meth" - Succeeded spec_env' -> spec_env' ) - where - rhs = mkValLam [dict] (mkTyApp (Var meth_id) (mkTyVarTys inst_tyvars)) - in - returnTc (class_inst_env', op_spec_envs') - END OF OLD STUFF -} + case addToSpecEnv class_inst_env inst_tys dfun_id of + Failed (ty', dfun_id') -> addErrTc (dupInstErr clas (inst_tys, src_loc) + (ty', getSrcLoc dfun_id')) + `thenNF_Tc_` + returnNF_Tc class_inst_env + Succeeded class_inst_env' -> returnNF_Tc class_inst_env' \end{code} \begin{code} -dupInstFailure clas info1@(ty1, locn1) info2@(ty2, locn2) +dupInstErr clas info1@(tys1, locn1) info2@(tys2, locn2) -- Overlapping/duplicate instances for given class; msg could be more glamourous - = tcAddErrCtxt ctxt $ - failTc (\sty -> ptext SLIT("Duplicate or overlapping instance declarations")) - where - ctxt sty = sep [hsep [ptext SLIT("for"), - pprQuote sty $ \ sty -> ppr sty clas <+> pprParendType sty ty1], - nest 4 (sep [ptext SLIT("at") <+> ppr sty locn1, - ptext SLIT("and") <+> ppr sty locn2])] + = hang (ptext SLIT("Duplicate or overlapping instance declarations")) + 4 (sep [ptext SLIT("for") <+> quotes (pprConstraint clas tys1), + nest 4 (sep [ptext SLIT("at") <+> ppr locn1, + ptext SLIT("and") <+> ppr locn2])]) \end{code} diff --git a/ghc/compiler/typecheck/TcKind.lhs b/ghc/compiler/typecheck/TcKind.lhs index bafa1fb623..1429bbde02 100644 --- a/ghc/compiler/typecheck/TcKind.lhs +++ b/ghc/compiler/typecheck/TcKind.lhs @@ -1,47 +1,40 @@ \begin{code} -#include "HsVersions.h" - module TcKind ( Kind, mkTypeKind, mkBoxedTypeKind, mkUnboxedTypeKind, mkArrowKind, hasMoreBoxityInfo, -- Kind -> Kind -> Bool resultKind, -- Kind -> Kind - TcKind, mkTcTypeKind, mkTcArrowKind, mkTcVarKind, + TcKind, newKindVar, -- NF_TcM s (TcKind s) newKindVars, -- Int -> NF_TcM s [TcKind s] unifyKind, -- TcKind s -> TcKind s -> TcM s () + unifyKinds, -- [TcKind s] -> [TcKind s] -> TcM s () kindToTcKind, -- Kind -> TcKind s tcDefaultKind -- TcKind s -> NF_TcM s Kind ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import Kind import TcMonad import Unique ( Unique, pprUnique10 ) -import Pretty -import Util ( nOfThem ) +import Util ( nOfThem, panic ) import Outputable \end{code} \begin{code} -data TcKind s -- Used for kind inference - = TcTypeKind - | TcArrowKind (TcKind s) (TcKind s) - | TcVarKind Unique (MutableVar s (Maybe (TcKind s))) - -mkTcTypeKind = TcTypeKind -mkTcArrowKind = TcArrowKind -mkTcVarKind = TcVarKind +type TcKind s = GenKind (TcRef s (TcMaybe s)) +data TcMaybe s = Unbound + | BoundTo (TcKind s) -- Always ArrowKind or BoxedTypeKind newKindVar :: NF_TcM s (TcKind s) newKindVar = tcGetUnique `thenNF_Tc` \ uniq -> - tcNewMutVar Nothing `thenNF_Tc` \ box -> - returnNF_Tc (TcVarKind uniq box) + tcNewMutVar Unbound `thenNF_Tc` \ box -> + returnNF_Tc (VarKind uniq box) newKindVars :: Int -> NF_TcM s [TcKind s] newKindVars n = mapNF_Tc (\ _ -> newKindVar) (nOfThem n ()) @@ -51,7 +44,16 @@ newKindVars n = mapNF_Tc (\ _ -> newKindVar) (nOfThem n ()) Kind unification ~~~~~~~~~~~~~~~~ \begin{code} -unifyKind :: TcKind s -> TcKind s -> TcM s () +unifyKinds :: [TcKind s] -> [TcKind s] -> TcM s () +unifyKinds [] [] = returnTc () +unifyKinds (k1:ks1) (k2:ks2) = unifyKind k1 k2 `thenTc_` + unifyKinds ks1 ks2 +unifyKinds _ _ = panic "unifyKinds: length mis-match" + +unifyKind :: TcKind s -- Expected + -> TcKind s -- Actual + -> TcM s () + unifyKind kind1 kind2 = tcAddErrCtxtM ctxt (unify_kind kind1 kind2) where @@ -60,59 +62,81 @@ unifyKind kind1 kind2 returnNF_Tc (unifyKindCtxt kind1' kind2') -unify_kind TcTypeKind TcTypeKind = returnTc () +-- TypeKind expected => the actual can be boxed or unboxed +unify_kind TypeKind TypeKind = returnTc () +unify_kind TypeKind BoxedTypeKind = returnTc () +unify_kind TypeKind UnboxedTypeKind = returnTc () + +unify_kind BoxedTypeKind BoxedTypeKind = returnTc () +unify_kind UnboxedTypeKind UnboxedTypeKind = returnTc () -unify_kind (TcArrowKind fun1 arg1) - (TcArrowKind fun2 arg2) +unify_kind (ArrowKind fun1 arg1) + (ArrowKind fun2 arg2) = unify_kind fun1 fun2 `thenTc_` unify_kind arg1 arg2 -unify_kind (TcVarKind uniq box) kind = unify_var uniq box kind -unify_kind kind (TcVarKind uniq box) = unify_var uniq box kind +unify_kind kind1@(VarKind uniq box) kind2 = unify_var False kind1 uniq box kind2 +unify_kind kind1 kind2@(VarKind uniq box) = unify_var True kind2 uniq box kind1 unify_kind kind1 kind2 - = failTc (kindMisMatchErr kind1 kind2) + = failWithTc (kindMisMatchErr kind1 kind2) \end{code} We could probably do some "shorting out" in unifyVarKind, but I'm not convinced it would save time, and it's a little tricky to get right. \begin{code} -unify_var uniq1 box1 kind2 +unify_var swap_vars kind1 uniq1 box1 kind2 = tcReadMutVar box1 `thenNF_Tc` \ maybe_kind1 -> case maybe_kind1 of - Just kind1 -> unify_kind kind1 kind2 - Nothing -> unify_unbound_var uniq1 box1 kind2 + Unbound -> unify_unbound_var False kind1 uniq1 box1 kind2 + BoundTo TypeKind -> unify_unbound_var True kind1 uniq1 box1 kind2 + -- *** NB: BoundTo TypeKind is a kind of un-bound + -- It can get refined to BoundTo UnboxedTypeKind or BoxedTypeKind + + BoundTo kind1' | swap_vars -> unify_kind kind2 kind1' + | otherwise -> unify_kind kind1' kind2 + -- Keep them the right way round, so that + -- the asymettric boxed/unboxed stuff works + -unify_unbound_var uniq1 box1 kind2@(TcVarKind uniq2 box2) +unify_unbound_var type_kind kind1 uniq1 box1 kind2@(VarKind uniq2 box2) | uniq1 == uniq2 -- Binding to self is a no-op = returnTc () | otherwise -- Distinct variables = tcReadMutVar box2 `thenNF_Tc` \ maybe_kind2 -> case maybe_kind2 of - Just kind2' -> unify_unbound_var uniq1 box1 kind2' - Nothing -> tcWriteMutVar box1 (Just kind2) `thenNF_Tc_` + BoundTo kind2' -> unify_unbound_var type_kind kind1 uniq1 box1 kind2' + Unbound -> tcWriteMutVar box2 (BoundTo kind1) `thenNF_Tc_` -- No need for occurs check here - returnTc () + -- Kind1 is an unbound variable, or BoundToTypeKind + returnTc () -unify_unbound_var uniq1 box1 non_var_kind2 - = occur_check non_var_kind2 `thenTc_` - tcWriteMutVar box1 (Just non_var_kind2) `thenNF_Tc_` +-- If the variable was originally bound to TypeKind, we succeed +-- unless the thing its bound to is an arrow. +unify_unbound_var True kind1 uniq1 box1 kind2@(ArrowKind k1 k2) + = failWithTc (kindMisMatchErr kind1 kind2) + +unify_unbound_var type_kind kind1 uniq1 box1 non_var_or_arrow_kind2 + = occur_check non_var_or_arrow_kind2 `thenTc_` + tcWriteMutVar box1 (BoundTo non_var_or_arrow_kind2) `thenNF_Tc_` returnTc () where - occur_check TcTypeKind = returnTc () - occur_check (TcArrowKind fun arg) = occur_check fun `thenTc_` occur_check arg - occur_check kind1@(TcVarKind uniq' box) + occur_check TypeKind = returnTc () + occur_check UnboxedTypeKind = returnTc () + occur_check BoxedTypeKind = returnTc () + occur_check (ArrowKind fun arg) = occur_check fun `thenTc_` occur_check arg + occur_check kind@(VarKind uniq' box) | uniq1 == uniq' - = failTc (kindOccurCheck kind1 non_var_kind2) + = failWithTc (kindOccurCheck kind non_var_or_arrow_kind2) | otherwise -- Different variable = tcReadMutVar box `thenNF_Tc` \ maybe_kind -> case maybe_kind of - Nothing -> returnTc () - Just kind -> occur_check kind + Unbound -> returnTc () + BoundTo kind' -> occur_check kind' \end{code} The "occurs check" is necessary to catch situation like @@ -122,37 +146,43 @@ The "occurs check" is necessary to catch situation like Kind flattening ~~~~~~~~~~~~~~~ -Coercions between TcKind and Kind +Coercions between TcKind and Kind. \begin{code} +-- This strange function is forced on us by the type system kindToTcKind :: Kind -> TcKind s -kindToTcKind TypeKind = TcTypeKind -kindToTcKind BoxedTypeKind = TcTypeKind -kindToTcKind UnboxedTypeKind = TcTypeKind -kindToTcKind (ArrowKind k1 k2) = TcArrowKind (kindToTcKind k1) (kindToTcKind k2) +kindToTcKind TypeKind = TypeKind +kindToTcKind BoxedTypeKind = BoxedTypeKind +kindToTcKind UnboxedTypeKind = UnboxedTypeKind +kindToTcKind (ArrowKind k1 k2) = ArrowKind (kindToTcKind k1) (kindToTcKind k2) -- Default all unbound kinds to TcTypeKind, and return the -- corresponding Kind as well. tcDefaultKind :: TcKind s -> NF_TcM s Kind -tcDefaultKind TcTypeKind - = returnNF_Tc BoxedTypeKind +tcDefaultKind TypeKind = returnNF_Tc TypeKind +tcDefaultKind BoxedTypeKind = returnNF_Tc BoxedTypeKind +tcDefaultKind UnboxedTypeKind = returnNF_Tc UnboxedTypeKind -tcDefaultKind (TcArrowKind kind1 kind2) +tcDefaultKind (ArrowKind kind1 kind2) = tcDefaultKind kind1 `thenNF_Tc` \ k1 -> tcDefaultKind kind2 `thenNF_Tc` \ k2 -> returnNF_Tc (ArrowKind k1 k2) -- Here's where we "default" unbound kinds to BoxedTypeKind -tcDefaultKind (TcVarKind uniq box) +tcDefaultKind (VarKind uniq box) = tcReadMutVar box `thenNF_Tc` \ maybe_kind -> case maybe_kind of - Just kind -> tcDefaultKind kind + BoundTo TypeKind -> bind_to_boxed + Unbound -> bind_to_boxed + BoundTo kind -> tcDefaultKind kind + where + -- Default unbound variables to kind BoxedTypeKind + bind_to_boxed = tcWriteMutVar box (BoundTo BoxedTypeKind) `thenNF_Tc_` + returnNF_Tc BoxedTypeKind + - Nothing -> -- Default unbound variables to kind Type - tcWriteMutVar box (Just TcTypeKind) `thenNF_Tc_` - returnNF_Tc BoxedTypeKind zonkTcKind :: TcKind s -> NF_TcM s (TcKind s) -- Removes variables that have now been bound. @@ -160,53 +190,38 @@ zonkTcKind :: TcKind s -> NF_TcM s (TcKind s) -- so that we don't need to follow through bound variables -- during error message construction. -zonkTcKind TcTypeKind = returnNF_Tc TcTypeKind +zonkTcKind TypeKind = returnNF_Tc TypeKind +zonkTcKind BoxedTypeKind = returnNF_Tc BoxedTypeKind +zonkTcKind UnboxedTypeKind = returnNF_Tc UnboxedTypeKind -zonkTcKind (TcArrowKind kind1 kind2) +zonkTcKind (ArrowKind kind1 kind2) = zonkTcKind kind1 `thenNF_Tc` \ k1 -> zonkTcKind kind2 `thenNF_Tc` \ k2 -> - returnNF_Tc (TcArrowKind k1 k2) + returnNF_Tc (ArrowKind k1 k2) -zonkTcKind kind@(TcVarKind uniq box) +zonkTcKind kind@(VarKind uniq box) = tcReadMutVar box `thenNF_Tc` \ maybe_kind -> case maybe_kind of - Nothing -> returnNF_Tc kind - Just kind' -> zonkTcKind kind' + Unbound -> returnNF_Tc kind + BoundTo kind' -> zonkTcKind kind' \end{code} -\begin{code} -instance Outputable (TcKind s) where - ppr sty kind = pprQuote sty $ \ sty -> ppr_kind sty kind - -ppr_kind sty TcTypeKind - = char '*' -ppr_kind sty (TcArrowKind kind1 kind2) - = sep [ppr_parend sty kind1, ptext SLIT("->"), ppr_kind sty kind2] -ppr_kind sty (TcVarKind uniq box) - = hcat [char 'k', pprUnique10 uniq] - -ppr_parend sty kind@(TcArrowKind _ _) = hcat [char '(', ppr_kind sty kind, char ')'] -ppr_parend sty other_kind = ppr_kind sty other_kind -\end{code} - - - Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} -unifyKindCtxt kind1 kind2 sty - = hang (ptext SLIT("When unifying two kinds")) 4 - (sep [ppr sty kind1, ptext SLIT("and"), ppr sty kind2]) +unifyKindCtxt kind1 kind2 + = vcat [ptext SLIT("Expected:") <+> ppr kind1, + ptext SLIT("Found: ") <+> ppr kind2] -kindOccurCheck kind1 kind2 sty +kindOccurCheck kind1 kind2 = hang (ptext SLIT("Cannot construct the infinite kind:")) 4 - (sep [ppr sty kind1, equals, ppr sty kind1, ptext SLIT("(\"occurs check\")")]) + (sep [ppr kind1, equals, ppr kind1, ptext SLIT("(\"occurs check\")")]) -kindMisMatchErr kind1 kind2 sty +kindMisMatchErr kind1 kind2 = hang (ptext SLIT("Couldn't match the kind")) 4 - (sep [ppr sty kind1, + (sep [ppr kind1, ptext SLIT("against"), - ppr sty kind2] + ppr kind2] ) \end{code} diff --git a/ghc/compiler/typecheck/TcLoop.lhi b/ghc/compiler/typecheck/TcLoop.lhi deleted file mode 100644 index 91302df4ce..0000000000 --- a/ghc/compiler/typecheck/TcLoop.lhi +++ /dev/null @@ -1,37 +0,0 @@ -This module breaks the loops among the typechecker modules -TcExpr, TcBinds, TcMonoBnds, TcQuals, TcGRHSs, TcMatches. - -\begin{code} -interface TcLoop where - -import TcGRHSs( tcGRHSsAndBinds ) -import HsMatches(GRHSsAndBinds) -import HsPat(InPat, OutPat) -import HsSyn(Fake) -import TcType(TcIdOcc, TcMaybe) -import SST(FSST_R) -import Unique(Unique) -import Name(Name) -import TyVar(GenTyVar) -import TcEnv(TcEnv) -import TcMonad(TcDown) -import PreludeGlaST(_MutableArray) -import Bag(Bag) -import Type(GenType) -import Inst(Inst) - -tcGRHSsAndBinds :: GenType (GenTyVar (_MutableArray a Int (TcMaybe a))) Unique - -> GRHSsAndBinds Fake Fake Name (InPat Name) - -> TcDown a - -> TcEnv a - -> State# a - -> FSST_R a (GRHSsAndBinds (GenTyVar (_MutableArray a Int (TcMaybe a))) - Unique - (TcIdOcc a) - (OutPat (GenTyVar (_MutableArray a Int (TcMaybe a))) - Unique - (TcIdOcc a)), - Bag (Inst a) - ) - () -\end{code} diff --git a/ghc/compiler/typecheck/TcMLoop.lhi b/ghc/compiler/typecheck/TcMLoop.lhi deleted file mode 100644 index 14a6ede64d..0000000000 --- a/ghc/compiler/typecheck/TcMLoop.lhi +++ /dev/null @@ -1,13 +0,0 @@ -\begin{code} -interface TcMLoop where - -import PreludeGlaST(_MutableArray) -import TcEnv(TcEnv,initEnv) -import TcType(TcMaybe) -import TyVar(GenTyVar) -import UniqFM(UniqFM) - -data TcEnv a -data TcMaybe a -initEnv :: _MutableArray a Int (UniqFM (GenTyVar (_MutableArray a Int (TcMaybe a)))) -> TcEnv a -\end{code} diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 82dd55dcd4..69af3b29d0 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -4,43 +4,34 @@ \section[TcMatches]{Typecheck some @Matches@} \begin{code} -#include "HsVersions.h" - module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchExpected ) where -IMP_Ubiq() +#include "HsVersions.h" -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds ) -#else import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds ) -#endif -import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat, - HsExpr(..), HsBinds(..), MonoBinds(..), OutPat, Fake, Stmt, - Sig, HsLit, DoOrListComp, Fixity, HsType, ArithSeqInfo, - collectPatBinders, pprMatch ) -import RnHsSyn ( SYN_IE(RenamedMatch) ) -import TcHsSyn ( SYN_IE(TcMatch) ) +import HsSyn ( HsBinds(..), Match(..), GRHSsAndBinds(..), GRHS(..), + HsExpr(..), MonoBinds(..), + collectPatBinders, pprMatch, getMatchLoc + ) +import RnHsSyn ( RenamedMatch ) +import TcHsSyn ( TcIdBndr, TcMatch ) import TcMonad -import Inst ( Inst, SYN_IE(LIE), plusLIE ) -import TcEnv ( newMonoIds ) +import Inst ( Inst, LIE, plusLIE ) +import TcEnv ( TcIdOcc(..), newMonoIds ) import TcPat ( tcPat ) -import TcType ( TcIdOcc(..), SYN_IE(TcType), TcMaybe, zonkTcType ) +import TcType ( TcType, TcMaybe, zonkTcType ) import TcSimplify ( bindInstsOfLocalFuns ) import Unify ( unifyTauTy, unifyTauTyList, unifyFunTy ) import Name ( Name {- instance Outputable -} ) import Kind ( Kind, mkTypeKind ) -import Pretty -import Type ( isTyVarTy, isTauTy, mkFunTy, getFunTy_maybe ) +import BasicTypes ( RecFlag(..) ) +import Type ( isTyVarTy, isTauTy, mkFunTy, splitFunTy_maybe ) import Util import Outputable -#if __GLASGOW_HASKELL__ >= 202 import SrcLoc (SrcLoc) -#endif - \end{code} @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a @@ -61,7 +52,7 @@ tcMatchesFun fun_name expected_ty matches@(first_match:_) -- ann-grabbing, because we don't always have annotations in -- hand when we call tcMatchesFun... - tcAddSrcLoc (get_Match_loc first_match) ( + tcAddSrcLoc (getMatchLoc first_match) ( -- Check that they all have the same no of arguments checkTc (all_same (noOfArgs matches)) @@ -102,15 +93,15 @@ tcMatchesExpected :: TcType s -> TcM s ([TcMatch s], LIE s) tcMatchesExpected expected_ty fun_or_case [match] - = tcAddSrcLoc (get_Match_loc match) $ + = tcAddSrcLoc (getMatchLoc match) $ tcAddErrCtxt (matchCtxt fun_or_case match) $ - tcMatchExpected expected_ty match `thenTc` \ (match', lie) -> + tcMatchExpected [] expected_ty match `thenTc` \ (match', lie) -> returnTc ([match'], lie) tcMatchesExpected expected_ty fun_or_case (match1 : matches) - = tcAddSrcLoc (get_Match_loc match1) ( + = tcAddSrcLoc (getMatchLoc match1) ( tcAddErrCtxt (matchCtxt fun_or_case match1) $ - tcMatchExpected expected_ty match1 + tcMatchExpected [] expected_ty match1 ) `thenTc` \ (match1', lie1) -> tcMatchesExpected expected_ty fun_or_case matches `thenTc` \ (matches', lie2) -> returnTc (match1' : matches', plusLIE lie1 lie2) @@ -118,14 +109,15 @@ tcMatchesExpected expected_ty fun_or_case (match1 : matches) \begin{code} tcMatchExpected - :: TcType s -- This gives the expected + :: [TcIdBndr s] -- Ids bound by enclosing matches + -> TcType s -- This gives the expected -- result-type of the Match. Early unification -- with this guy gives better error messages -> RenamedMatch -> TcM s (TcMatch s,LIE s) -- NB No type returned, because it was passed -- in instead! -tcMatchExpected expected_ty the_match@(PatMatch pat match) +tcMatchExpected matched_ids expected_ty the_match@(PatMatch pat match) = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) -> let binders = collectPatBinders pat @@ -133,35 +125,32 @@ tcMatchExpected expected_ty the_match@(PatMatch pat match) newMonoIds binders mkTypeKind (\ mono_ids -> tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) -> unifyTauTy pat_ty arg_ty `thenTc_` - tcMatchExpected rest_ty match `thenTc` \ (match', lie_match) -> - -- In case there are any polymorpic, overloaded binders in the pattern - -- (which can happen in the case of rank-2 type signatures, or data constructors - -- with polymorphic arguments), we must do a bindInstsOfLocalFns here - -- - -- 99% of the time there are no bindings. In the unusual case we - -- march down the match to dump them in the right place (boring but easy). - bindInstsOfLocalFuns lie_match mono_ids `thenTc` \ (lie_match', inst_mbinds) -> - let - inst_binds = MonoBind inst_mbinds [] False - match'' = case inst_mbinds of - EmptyMonoBinds -> match' - other -> glue_on match' - glue_on (PatMatch p m) = PatMatch p (glue_on m) - glue_on (GRHSMatch (GRHSsAndBindsOut grhss binds ty)) - = (GRHSMatch (GRHSsAndBindsOut grhss - (inst_binds `ThenBinds` binds) - ty)) - glue_on (SimpleMatch expr) = SimpleMatch (HsLet inst_binds expr) - in - returnTc (PatMatch pat' match'', - plusLIE lie_pat lie_match') + + tcMatchExpected (mono_ids ++ matched_ids) + rest_ty match `thenTc` \ (match', lie_match) -> + + returnTc (PatMatch pat' match', + plusLIE lie_pat lie_match) ) -tcMatchExpected expected_ty (GRHSMatch grhss_and_binds) - = tcGRHSsAndBinds expected_ty grhss_and_binds `thenTc` \ (grhss_and_binds', lie) -> +tcMatchExpected matched_ids expected_ty (GRHSMatch grhss_and_binds) + = -- Check that the remaining "expected type" is not a rank-2 type + -- If it is it'll mess up the unifier when checking the RHS checkTc (isTauTy expected_ty) lurkingRank2SigErr `thenTc_` - returnTc (GRHSMatch grhss_and_binds', lie) + + tcGRHSsAndBinds expected_ty grhss_and_binds `thenTc` \ (GRHSsAndBindsOut grhss binds ty, lie) -> + + -- In case there are any polymorpic, overloaded binders in the pattern + -- (which can happen in the case of rank-2 type signatures, or data constructors + -- with polymorphic arguments), we must do a bindInstsOfLocalFns here + bindInstsOfLocalFuns lie matched_ids `thenTc` \ (lie', inst_mbinds) -> + let + binds' = case inst_mbinds of + EmptyMonoBinds -> binds -- The common case + other -> MonoBind inst_mbinds [] Recursive `ThenBinds` binds + in + returnTc (GRHSMatch (GRHSsAndBindsOut grhss binds' ty), lie') \end{code} @@ -180,38 +169,23 @@ noOfArgs ms = map args_in_match ms args_in_match (PatMatch _ match) = 1 + args_in_match match \end{code} -@get_Match_loc@ takes a @RenamedMatch@ and returns the -source-location gotten from the GRHS inside. -THis is something of a nuisance, but no more. - -\begin{code} -get_Match_loc :: RenamedMatch -> SrcLoc - -get_Match_loc (PatMatch _ m) = get_Match_loc m -get_Match_loc (GRHSMatch (GRHSsAndBindsIn (g:_) _)) - = get_GRHS_loc g - where - get_GRHS_loc (OtherwiseGRHS _ locn) = locn - get_GRHS_loc (GRHS _ _ locn) = locn -\end{code} - Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} -matchCtxt MCase match sty +matchCtxt MCase match = hang (ptext SLIT("In a \"case\" branch:")) - 4 (pprMatch sty True{-is_case-} match) + 4 (pprMatch True{-is_case-} match) -matchCtxt (MFun fun) match sty - = hang (hcat [ptext SLIT("In an equation for function "), ppr sty fun, char ':']) - 4 (pprQuote sty $ \sty -> hcat [ppr sty fun, space, pprMatch sty False{-not case-} match]) +matchCtxt (MFun fun) match + = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr fun), char ':']) + 4 (hcat [ppr fun, space, pprMatch False{-not case-} match]) \end{code} \begin{code} -varyingArgsErr name matches sty - = sep [ptext SLIT("Varying number of arguments for function"), ppr sty name] +varyingArgsErr name matches + = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)] -lurkingRank2SigErr sty +lurkingRank2SigErr = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type") \end{code} diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 8c57967449..1855672922 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -4,67 +4,56 @@ \section[TcModule]{Typechecking a whole module} \begin{code} -#include "HsVersions.h" - module TcModule ( typecheckModule, - SYN_IE(TcResults), - SYN_IE(TcSpecialiseRequests), - SYN_IE(TcDDumpDeriv) + TcResults, + TcDDumpDeriv ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CmdLineOpts ( opt_D_dump_tc, opt_D_dump_deriv ) -import HsSyn ( HsDecl(..), HsModule(..), HsBinds(..), HsExpr, MonoBinds(..), - TyDecl, SpecDataSig, ClassDecl, InstDecl, IfaceSig, - SpecInstSig, DefaultDecl, Sig, Fake, InPat, - SYN_IE(RecFlag), nonRecursive, GRHSsAndBinds, Match, - FixityDecl, IE, ImportDecl, OutPat - ) -import RnHsSyn ( SYN_IE(RenamedHsModule), RenamedFixityDecl(..) ) -import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr), - SYN_IE(TypecheckedDictBinds), SYN_IE(TcMonoBinds), - SYN_IE(TypecheckedMonoBinds), +import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) ) +import RnHsSyn ( RenamedHsModule, RenamedFixityDecl(..) ) +import TcHsSyn ( TypecheckedHsBinds, TypecheckedHsExpr, + TypecheckedDictBinds, TcMonoBinds, + TypecheckedMonoBinds, zonkTopBinds ) import TcMonad import Inst ( Inst, emptyLIE, plusLIE ) -import TcBinds ( tcBindsAndThen ) +import TcBinds ( tcTopBindsAndThen ) import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults ) -import TcEnv ( tcExtendGlobalValEnv, getEnv_LocalIds, +import TcEnv ( TcIdOcc(..), tcExtendGlobalValEnv, tcExtendTyConEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes, tcLookupLocalValue, tcLookupLocalValueByKey, tcLookupTyCon, tcLookupGlobalValueByKeyMaybe ) -import SpecEnv ( SpecEnv ) import TcExpr ( tcId ) import TcIfaceSig ( tcInterfaceSigs ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) -import TcInstUtil ( buildInstanceEnvs, InstInfo ) +import TcInstUtil ( buildInstanceEnvs, classDataCon, InstInfo ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls1 ) import TcTyDecls ( mkDataBinds ) -import TcType ( TcIdOcc(..), SYN_IE(TcType), tcInstType ) -import TcKind ( TcKind ) +import TcType ( TcType, tcInstType ) +import TcKind ( TcKind, kindToTcKind ) import RnMonad ( RnNameSupply(..) ) -import Bag ( listToBag ) -import ErrUtils ( SYN_IE(Warning), SYN_IE(Error), +import Bag ( isEmptyBag ) +import ErrUtils ( WarnMsg, ErrMsg, pprBagOfErrors, dumpIfSet, ghcExit ) -import Id ( idType, GenId, SYN_IE(IdEnv), nullIdEnv ) +import Id ( idType, GenId, IdEnv, nullIdEnv ) import Maybes ( catMaybes, MaybeErr(..) ) -import Name ( Name, isLocallyDefined, pprModule ) -import Pretty -import TyCon ( TyCon, isSynTyCon ) -import Class ( GenClass, SYN_IE(Class), classSelIds ) -import Type ( applyTyCon, mkSynTy, SYN_IE(Type) ) -import PprType ( GenType, GenTyVar ) +import Name ( Name, isLocallyDefined, pprModule, NamedThing(..) ) +import TyCon ( TyCon, isSynTyCon, tyConKind ) +import Class ( Class, classSelIds, classTyCon ) +import Type ( mkTyConApp, mkSynTy, Type ) +import TyVar ( emptyTyVarEnv ) import TysWiredIn ( unitTy ) import PrelMods ( gHC_MAIN, mAIN ) import PrelInfo ( main_NAME, ioTyCon_NAME ) -import TyVar ( GenTyVar, SYN_IE(TyVarEnv), nullTyVarEnv ) import Unify ( unifyTauTy ) import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly, filterUFM, eltsUFM ) @@ -72,38 +61,21 @@ import Unique ( Unique ) import UniqSupply ( UniqSupply ) import Util import Bag ( Bag, isEmptyBag ) - import FiniteMap ( emptyFM, FiniteMap ) - -import Outputable ( Outputable(..), PprStyle, printErrs, pprDumpStyle, pprErrorsStyle ) - -tycon_specs = emptyFM +import Outputable \end{code} Outside-world interface: \begin{code} ---ToDo: put this in HsVersions -#if __GLASGOW_HASKELL__ >= 200 -# define REAL_WORLD RealWorld -#else -# define REAL_WORLD _RealWorld -#endif - -- Convenient type synonyms first: type TcResults = (TypecheckedMonoBinds, [TyCon], [Class], Bag InstInfo, -- Instance declaration information - TcSpecialiseRequests, TcDDumpDeriv) -type TcSpecialiseRequests - = FiniteMap TyCon [(Bool, [Maybe Type])] - -- source tycon specialisation requests - -type TcDDumpDeriv - = PprStyle -> Doc +type TcDDumpDeriv = SDoc --------------- typecheckModule @@ -113,26 +85,30 @@ typecheckModule -> IO (Maybe TcResults) typecheckModule us rn_name_supply mod - = case initTc us (tcModule rn_name_supply mod) of - Failed (errs, warns) -> - print_errs warns >> - print_errs errs >> - return Nothing - - Succeeded (results@(binds, _, _, _, _, dump_deriv), warns) -> - print_errs warns >> + = let + (maybe_result, warns, errs) = initTc us (tcModule rn_name_supply mod) + in + print_errs warns >> + print_errs errs >> - dumpIfSet opt_D_dump_tc "Typechecked" - (ppr pprDumpStyle binds) >> + dumpIfSet opt_D_dump_tc "Typechecked" + (case maybe_result of + Just (binds, _, _, _, _) -> ppr binds + Nothing -> text "Typecheck failed") >> - dumpIfSet opt_D_dump_deriv "Derived instances" - (dump_deriv pprDumpStyle) >> + dumpIfSet opt_D_dump_deriv "Derived instances" + (case maybe_result of + Just (_, _, _, _, dump_deriv) -> dump_deriv + Nothing -> empty) >> - return (Just results) + return (if isEmptyBag errs then + maybe_result + else + Nothing) print_errs errs | isEmptyBag errs = return () - | otherwise = printErrs (pprBagOfErrors pprErrorsStyle errs) + | otherwise = printErrs (pprBagOfErrors errs) \end{code} The internal monster: @@ -165,10 +141,10 @@ tcModule rn_name_supply tcSetEnv env ( -- trace "tcInstDecls:" $ tcInstDecls1 unf_env decls mod_name rn_name_supply - ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) -> + ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) -> -- trace "tc4" $ - buildInstanceEnvs inst_info `thenTc` \ inst_mapper -> + buildInstanceEnvs inst_info `thenNF_Tc` \ inst_mapper -> returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv) @@ -185,8 +161,10 @@ tcModule rn_name_supply -- Create any necessary record selector Ids and their bindings -- "Necessary" includes data and newtype declarations let - tycons = getEnv_TyCons env - classes = getEnv_Classes env + tycons = getEnv_TyCons env + classes = getEnv_Classes env + local_tycons = filter isLocallyDefined tycons + local_classes = filter isLocallyDefined classes in mkDataBinds tycons `thenTc` \ (data_ids, data_binds) -> @@ -198,6 +176,15 @@ tcModule rn_name_supply tcExtendGlobalValEnv data_ids $ tcExtendGlobalValEnv (concat (map classSelIds classes)) $ + -- Extend the TyCon envt with the tycons corresponding to + -- the classes, and the global value environment with the + -- corresponding data cons. + -- They are mentioned in types in interface files. + tcExtendGlobalValEnv (map classDataCon classes) $ + tcExtendTyConEnv [ (getName tycon, (kindToTcKind (tyConKind tycon), Nothing, tycon)) + | clas <- classes, + let tycon = classTyCon clas + ] $ -- Interface type signatures -- We tie a knot so that the Ids read out of interfaces are in scope @@ -212,7 +199,7 @@ tcModule rn_name_supply -- Value declarations next. -- We also typecheck any extra binds that came out of the "deriving" process -- trace "tcBinds:" $ - tcBindsAndThen + tcTopBindsAndThen (\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing)) (get_val_decls decls `ThenBinds` deriv_binds) ( tcGetEnv `thenNF_Tc` \ env -> @@ -256,27 +243,12 @@ tcModule rn_name_supply in zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) -> - returnTc (really_final_env, (all_binds', inst_info, ddump_deriv)) + returnTc (really_final_env, + (all_binds', local_tycons, local_classes, inst_info, ddump_deriv)) -- End of outer fix loop - ) `thenTc` \ (final_env, (all_binds', inst_info, ddump_deriv)) -> - - - let - tycons = getEnv_TyCons final_env - classes = getEnv_Classes final_env - - local_tycons = filter isLocallyDefined tycons - local_classes = filter isLocallyDefined classes - in - -- FINISHED AT LAST - returnTc ( - all_binds', - - local_tycons, local_classes, inst_info, tycon_specs, - - ddump_deriv - ) + ) `thenTc` \ (final_env, stuff) -> + returnTc stuff get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls] \end{code} @@ -292,32 +264,34 @@ tcCheckMainSig mod_name tcLookupTyCon ioTyCon_NAME `thenTc` \ (_,_,ioTyCon) -> tcLookupLocalValue main_NAME `thenNF_Tc` \ maybe_main_id -> case maybe_main_id of { - Nothing -> failTc noMainErr; + Nothing -> failWithTc noMainErr ; Just main_id -> -- Check that it has the right type (or a more general one) - let expected_ty = applyTyCon ioTyCon [unitTy] in - tcInstType [] expected_ty `thenNF_Tc` \ expected_tau -> - tcId main_NAME `thenNF_Tc` \ (_, lie, main_tau) -> + let + expected_ty = mkTyConApp ioTyCon [unitTy] + in + tcInstType emptyTyVarEnv expected_ty `thenNF_Tc` \ expected_tau -> + tcId main_NAME `thenNF_Tc` \ (_, lie, main_tau) -> tcSetErrCtxt mainTyCheckCtxt $ unifyTauTy expected_tau main_tau `thenTc_` checkTc (isEmptyBag lie) (mainTyMisMatch expected_ty (idType main_id)) } -mainTyCheckCtxt sty - = hsep [ptext SLIT("When checking that"), ppr sty main_NAME, - ptext SLIT("has the required type")] -noMainErr sty - = hsep [ptext SLIT("Module"), pprModule sty mAIN, - ptext SLIT("must include a definition for"), ppr sty main_NAME] +mainTyCheckCtxt + = hsep [ptext SLIT("When checking that"), ppr main_NAME, ptext SLIT("has the required type")] + +noMainErr + = hsep [ptext SLIT("Module"), quotes (pprModule mAIN), + ptext SLIT("must include a definition for"), quotes (ppr main_NAME)] -mainTyMisMatch :: Type -> TcType s -> Error -mainTyMisMatch expected actual sty - = hang (hsep [ppr sty main_NAME, ptext SLIT("has the wrong type")]) +mainTyMisMatch :: Type -> TcType s -> ErrMsg +mainTyMisMatch expected actual + = hang (hsep [ppr main_NAME, ptext SLIT("has the wrong type")]) 4 (vcat [ - hsep [ptext SLIT("Expected:"), ppr sty expected], - hsep [ptext SLIT("Inferred:"), ppr sty actual] + hsep [ptext SLIT("Expected:"), ppr expected], + hsep [ptext SLIT("Inferred:"), ppr actual] ]) \end{code} diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index a04c032d2b..ceb589f174 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -1,8 +1,6 @@ \begin{code} -#include "HsVersions.h" - module TcMonad( - SYN_IE(TcM), SYN_IE(NF_TcM), TcDown, TcEnv, + TcM, NF_TcM, TcDown, TcEnv, SST_R, FSST_R, initTc, @@ -12,12 +10,13 @@ module TcMonad( uniqSMToTcM, - returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, forkNF_Tc, + returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, + fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc, listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc, checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, - failTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc, + failTc, failWithTc, addErrTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc, tcGetEnv, tcSetEnv, tcGetDefaultTys, tcSetDefaultTys, @@ -27,35 +26,20 @@ module TcMonad( tcAddErrCtxtM, tcSetErrCtxtM, tcAddErrCtxt, tcSetErrCtxt, - tcNewMutVar, tcReadMutVar, tcWriteMutVar, + tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef, - SYN_IE(TcError), SYN_IE(TcWarning), - mkTcErr, arityErr, - - -- For closure - SYN_IE(MutableVar), -#if __GLASGOW_HASKELL__ == 201 - GHCbase.MutableArray -#elif __GLASGOW_HASKELL__ == 201 - GlaExts.MutableArray -#else - _MutableArray -#endif + TcError, TcWarning, + arityErr ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env -#else import {-# SOURCE #-} TcEnv ( TcEnv, initEnv ) import {-# SOURCE #-} TcType ( TcMaybe, TcTyVarSet ) -#endif -import Type ( SYN_IE(Type), GenType ) -import TyVar ( SYN_IE(TyVar), GenTyVar ) -import Usage ( SYN_IE(Usage), GenUsage ) -import ErrUtils ( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) ) +import Type ( Type, GenType ) +import TyVar ( TyVar, GenTyVar ) +import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg ) import CmdLineOpts ( opt_PprStyle_All, opt_PprUserLength ) import SST @@ -66,11 +50,12 @@ import Maybes ( MaybeErr(..) ) import SrcLoc ( SrcLoc, noSrcLoc ) import UniqFM ( UniqFM, emptyUFM ) import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply, - SYN_IE(UniqSM), initUs ) + UniqSM, initUs ) import Unique ( Unique ) import Util -import Pretty -import Outputable ( PprStyle(..), Outputable(..) ) +import Outputable + +import GlaExts ( State#, RealWorld ) infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_` @@ -86,19 +71,12 @@ type TcM s r = TcDown s -> TcEnv s -> FSST s r () \end{code} \begin{code} -#if __GLASGOW_HASKELL__ >= 200 -# define REAL_WORLD RealWorld -#else -# define REAL_WORLD _RealWorld -#endif - -- With a builtin polymorphic type for runSST the type for -- initTc should use TcM s r instead of TcM RealWorld r initTc :: UniqSupply - -> TcM REAL_WORLD r - -> MaybeErr (r, Bag Warning) - (Bag Error, Bag Warning) + -> TcM RealWorld r + -> (Maybe r, Bag WarnMsg, Bag ErrMsg) initTc us do_this = runSST ( @@ -117,9 +95,7 @@ initTc us do_this returnFSST (Just res)) `thenSST` \ maybe_res -> readMutVarSST errs_var `thenSST` \ (warns,errs) -> - case (maybe_res, isEmptyBag errs) of - (Just res, True) -> returnSST (Succeeded (res, warns)) - _ -> returnSST (Failed (errs, warns)) + returnSST (maybe_res, warns, errs) ) thenNF_Tc :: NF_TcM s a @@ -153,6 +129,16 @@ mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r -> mapNF_Tc f xs `thenNF_Tc` \ rs -> returnNF_Tc (r:rs) +foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b +foldrNF_Tc k z [] = returnNF_Tc z +foldrNF_Tc k z (x:xs) = foldrNF_Tc k z xs `thenNF_Tc` \r -> + k x r + +foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a +foldlNF_Tc k z [] = returnNF_Tc z +foldlNF_Tc k z (x:xs) = k z x `thenNF_Tc` \r -> + foldlNF_Tc k r xs + listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a] listNF_Tc [] = returnNF_Tc [] listNF_Tc (x:xs) = x `thenNF_Tc` \ r -> @@ -271,35 +257,47 @@ forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env Error handling ~~~~~~~~~~~~~~ \begin{code} -getErrsTc :: NF_TcM s (Bag Error, Bag Warning) +getErrsTc :: NF_TcM s (Bag ErrMsg, Bag WarnMsg) getErrsTc down env = readMutVarSST errs_var where errs_var = getTcErrs down -failTc :: Message -> TcM s a -failTc err_msg down env + +failTc :: TcM s a +failTc down env + = failFSST () + +failWithTc :: Message -> TcM s a -- Add an error message and fail +failWithTc err_msg + = addErrTc err_msg `thenNF_Tc_` + failTc + +addErrTc :: Message -> NF_TcM s () -- Add an error message but don't fail +addErrTc err_msg down env = readMutVarSST errs_var `thenSST` \ (warns,errs) -> listNF_Tc ctxt down env `thenSST` \ ctxt_msgs -> let - err = mkTcErr loc ctxt_msgs err_msg + err = addShortErrLocLine loc $ + hang err_msg 4 (vcat (ctxt_to_use ctxt_msgs)) in writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_` - failFSST () + returnSST () where errs_var = getTcErrs down ctxt = getErrCtxt down loc = getLoc down warnTc :: Bool -> Message -> NF_TcM s () -warnTc warn_if_true warn down env +warnTc warn_if_true warn_msg down env = if warn_if_true then - readMutVarSST errs_var `thenSST` \ (warns,errs) -> + readMutVarSST errs_var `thenSST` \ (warns,errs) -> listNF_Tc ctxt down env `thenSST` \ ctxt_msgs -> let - full_warn = mkTcErr loc ctxt_msgs warn + warn = addShortWarnLocLine loc $ + hang warn_msg 4 (vcat (ctxt_to_use ctxt_msgs)) in - writeMutVarSST errs_var (warns `snocBag` full_warn, errs) `thenSST_` + writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_` returnSST () else returnSST () @@ -329,26 +327,26 @@ checkNoErrsTc m down env = newMutVarSST (emptyBag,emptyBag) `thenSST` \ m_errs_var -> let errs_var = getTcErrs down - propagate_errs + propagate_errs _ = readMutVarSST m_errs_var `thenSST` \ (m_warns, m_errs) -> readMutVarSST errs_var `thenSST` \ (warns, errs) -> writeMutVarSST errs_var (warns `unionBags` m_warns, errs `unionBags` m_errs) `thenSST_` - returnSST m_errs + failFSST() in - recoverFSST (\ _ -> propagate_errs `thenSST_` failFSST ()) $ + recoverFSST propagate_errs $ m (setTcErrs down m_errs_var) env `thenFSST` \ result -> -- Check that m has no errors; if it has internal recovery -- mechanisms it might "succeed" but having found a bunch of -- errors along the way. - propagate_errs `thenSST` \ errs -> - if isEmptyBag errs then + readMutVarSST m_errs_var `thenSST` \ (m_warns, m_errs) -> + if isEmptyBag m_errs then returnFSST result else - failFSST () + failFSST () -- This triggers the recoverFSST -- (tryTc r m) tries m; if it succeeds it returns it, -- otherwise it returns r. Any error messages added by m are discarded, @@ -371,14 +369,17 @@ tryTc recover m down env recover down env -- Run the thing inside, but throw away all its error messages. -discardErrsTc :: TcM s r -> TcM s r +-- discardErrsTc :: TcM s r -> TcM s r +-- discardErrsTc :: NF_TcM s r -> NF_TcM s r +discardErrsTc :: (TcDown s -> TcEnv s -> State# s -> a) + -> (TcDown s -> TcEnv s -> State# s -> a) discardErrsTc m down env = newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var -> m (setTcErrs down new_errs_var) env checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true checkTc True err = returnTc () -checkTc False err = failTc err +checkTc False err = failWithTc err checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true checkTcM True err = returnTc () @@ -386,7 +387,7 @@ checkTcM False err = err checkMaybeTc :: Maybe val -> Message -> TcM s val checkMaybeTc (Just val) err = returnTc val -checkMaybeTc Nothing err = failTc err +checkMaybeTc Nothing err = failWithTc err checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val checkMaybeTcM (Just val) err = returnTc val @@ -396,13 +397,15 @@ checkMaybeTcM Nothing err = err Mutable variables ~~~~~~~~~~~~~~~~~ \begin{code} -tcNewMutVar :: a -> NF_TcM s (MutableVar s a) +type TcRef s a = SSTRef s a + +tcNewMutVar :: a -> NF_TcM s (TcRef s a) tcNewMutVar val down env = newMutVarSST val -tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s () +tcWriteMutVar :: TcRef s a -> a -> NF_TcM s () tcWriteMutVar var val down env = writeMutVarSST var val -tcReadMutVar :: MutableVar s a -> NF_TcM s a +tcReadMutVar :: TcRef s a -> NF_TcM s a tcReadMutVar var down env = readMutVarSST var \end{code} @@ -415,7 +418,7 @@ tcGetEnv down env = returnSST env tcSetEnv :: TcEnv s -> (TcDown s -> TcEnv s -> State# s -> b) - -> TcDown s -> TcEnv s -> State# s -> b + -> TcDown s -> TcEnv s -> State# s -> b -- tcSetEnv :: TcEnv s -> TcM s a -> TcM s a -- tcSetEnv :: TcEnv s -> NF_TcM s a -> NF_TcM s a @@ -445,7 +448,11 @@ tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env -tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a +tcSetErrCtxt, tcAddErrCtxt + :: Message + -> (TcDown s -> TcEnv s -> State# s -> b) + -> TcDown s -> TcEnv s -> State# s -> b +-- Usual thing tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env \end{code} @@ -499,12 +506,12 @@ data TcDown s = TcDown [Type] -- Types used for defaulting - (MutableVar s UniqSupply) -- Unique supply + (TcRef s UniqSupply) -- Unique supply SrcLoc -- Source location (ErrCtxt s) -- Error context - (MutableVar s (Bag Warning, - Bag Error)) + (TcRef s (Bag WarnMsg, + Bag ErrMsg)) type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance -- to deal with bound type variables just before error @@ -540,28 +547,16 @@ TypeChecking Errors type TcError = Message type TcWarning = Message -mkTcErr :: SrcLoc -- Where - -> [Message] -- Context - -> Message -- What went wrong - -> TcError -- The complete error report +ctxt_to_use ctxt | opt_PprStyle_All = ctxt + | otherwise = takeAtMost 3 ctxt + where + takeAtMost :: Int -> [a] -> [a] + takeAtMost 0 ls = [] + takeAtMost n [] = [] + takeAtMost n (x:xs) = x:takeAtMost (n-1) xs -mkTcErr locn ctxt msg sty - = hang (hcat [ppr (PprForUser opt_PprUserLength) locn, ptext SLIT(": "), msg sty]) - 4 (vcat [msg sty | msg <- ctxt_to_use]) - where - ctxt_to_use = - if opt_PprStyle_All then - ctxt - else - takeAtMost 4 ctxt - - takeAtMost :: Int -> [a] -> [a] - takeAtMost 0 ls = [] - takeAtMost n [] = [] - takeAtMost n (x:xs) = x:takeAtMost (n-1) xs - -arityErr kind name n m sty - = hsep [ ppr sty name, ptext SLIT("should have"), +arityErr kind name n m + = hsep [ ppr name, ptext SLIT("should have"), n_arguments <> comma, text "but has been given", int m, char '.'] where errmsg = kind ++ " has too " ++ quantity ++ " arguments" diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index ac34e2d1c3..dad3e7baf3 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -4,37 +4,31 @@ \section[TcMonoType]{Typechecking user-specified @MonoTypes@} \begin{code} -#include "HsVersions.h" - module TcMonoType ( tcHsType, tcHsTypeKind, tcContext, tcTyVarScope ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import HsSyn ( HsType(..), HsTyVar(..), Fake ) +import HsSyn ( HsType(..), HsTyVar(..), pprContext ) import RnHsSyn ( RenamedHsType(..), RenamedContext(..) ) import TcMonad import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv ) -import TcKind ( TcKind, mkTcTypeKind, mkBoxedTypeKind, - mkTcArrowKind, unifyKind, newKindVar, +import TcKind ( TcKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind, + unifyKind, unifyKinds, newKindVar, kindToTcKind, tcDefaultKind ) -import Type ( GenType, SYN_IE(Type), SYN_IE(ThetaType), - mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy, - mkSigmaTy, mkDictTy, mkAppTys +import Type ( Type, ThetaType, + mkTyVarTy, mkFunTy, mkAppTy, mkSynTy, + mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys ) -import TyVar ( GenTyVar, SYN_IE(TyVar), mkTyVar ) -import Outputable +import TyVar ( TyVar, mkTyVar ) import PrelInfo ( cCallishClassKeys ) import TyCon ( TyCon ) import Name ( Name, OccName, isTvOcc, getOccName ) import TysWiredIn ( mkListTy, mkTupleTy ) import Unique ( Unique, Uniquable(..) ) -import Pretty -import Util ( zipWithEqual, zipLazy, panic{-, pprPanic ToDo:rm-} ) - - - +import Util ( zipWithEqual, zipLazy ) +import Outputable \end{code} @@ -47,8 +41,13 @@ tcHsType checks that the type really is of kind Type! tcHsType :: RenamedHsType -> TcM s Type tcHsType ty - = tcHsTypeKind ty `thenTc` \ (kind,ty) -> - unifyKind kind mkTcTypeKind `thenTc_` + = tcAddErrCtxt (typeCtxt ty) $ + tc_hs_type ty + +tc_hs_type ty + = tc_hs_type_kind ty `thenTc` \ (kind,ty) -> + -- Check that it really is a type + unifyKind mkTypeKind kind `thenTc_` returnTc ty \end{code} @@ -57,45 +56,56 @@ tcHsTypeKind does the real work. It returns a kind and a type. \begin{code} tcHsTypeKind :: RenamedHsType -> TcM s (TcKind s, Type) +tcHsTypeKind ty + = tcAddErrCtxt (typeCtxt ty) $ + tc_hs_type_kind ty + + -- This equation isn't needed (the next one would handle it fine) -- but it's rather a common case, so we handle it directly -tcHsTypeKind (MonoTyVar name) +tc_hs_type_kind (MonoTyVar name) | isTvOcc (getOccName name) = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) -> returnTc (kind, mkTyVarTy tyvar) -tcHsTypeKind ty@(MonoTyVar name) +tc_hs_type_kind ty@(MonoTyVar name) = tcFunType ty [] -tcHsTypeKind (MonoListTy _ ty) - = tcHsType ty `thenTc` \ tau_ty -> - returnTc (mkTcTypeKind, mkListTy tau_ty) +tc_hs_type_kind (MonoListTy _ ty) + = tc_hs_type ty `thenTc` \ tau_ty -> + returnTc (mkBoxedTypeKind, mkListTy tau_ty) -tcHsTypeKind (MonoTupleTy _ tys) - = mapTc tcHsType tys `thenTc` \ tau_tys -> - returnTc (mkTcTypeKind, mkTupleTy (length tys) tau_tys) +tc_hs_type_kind (MonoTupleTy _ tys) + = mapTc tc_hs_type tys `thenTc` \ tau_tys -> + returnTc (mkBoxedTypeKind, mkTupleTy (length tys) tau_tys) -tcHsTypeKind (MonoFunTy ty1 ty2) - = tcHsType ty1 `thenTc` \ tau_ty1 -> - tcHsType ty2 `thenTc` \ tau_ty2 -> - returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2) +tc_hs_type_kind (MonoFunTy ty1 ty2) + = tc_hs_type ty1 `thenTc` \ tau_ty1 -> + tc_hs_type ty2 `thenTc` \ tau_ty2 -> + returnTc (mkBoxedTypeKind, mkFunTy tau_ty1 tau_ty2) -tcHsTypeKind (MonoTyApp ty1 ty2) +tc_hs_type_kind (MonoTyApp ty1 ty2) = tcTyApp ty1 [ty2] -tcHsTypeKind (HsForAllTy tv_names context ty) +tc_hs_type_kind (HsForAllTy tv_names context ty) = tcTyVarScope tv_names $ \ tyvars -> tcContext context `thenTc` \ theta -> - tcHsType ty `thenTc` \ tau -> + tc_hs_type ty `thenTc` \ tau -> -- For-all's are of kind type! - returnTc (mkTcTypeKind, mkSigmaTy tyvars theta tau) - --- for unfoldings only: -tcHsTypeKind (MonoDictTy class_name ty) - = tcHsTypeKind ty `thenTc` \ (arg_kind, arg_ty) -> - tcLookupClass class_name `thenTc` \ (class_kind, clas) -> - unifyKind class_kind arg_kind `thenTc_` - returnTc (mkTcTypeKind, mkDictTy clas arg_ty) + returnTc (mkBoxedTypeKind, mkSigmaTy tyvars theta tau) + +-- for unfoldings, and instance decls, only: +tc_hs_type_kind (MonoDictTy class_name tys) + = mapAndUnzipTc tc_hs_type_kind tys `thenTc` \ (arg_kinds, arg_tys) -> + tcLookupClass class_name `thenTc` \ (class_kinds, clas) -> + let + arity = length class_kinds + n_args = length arg_kinds + err = arityErr "Class" class_name arity n_args + in + checkTc (arity == n_args) err `thenTc_` + unifyKinds class_kinds arg_kinds `thenTc_` + returnTc (mkBoxedTypeKind, mkDictTy clas arg_tys) \end{code} Help functions for type applications @@ -109,12 +119,12 @@ tcTyApp ty tys = tcFunType ty [] | otherwise - = mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (arg_kinds, arg_tys) -> + = mapAndUnzipTc tc_hs_type_kind tys `thenTc` \ (arg_kinds, arg_tys) -> tcFunType ty arg_tys `thenTc` \ (fun_kind, result_ty) -> -- Check argument compatibility newKindVar `thenNF_Tc` \ result_kind -> - unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds) + unifyKind fun_kind (foldr mkArrowKind result_kind arg_kinds) `thenTc_` returnTc (result_kind, result_ty) @@ -130,8 +140,11 @@ tcFunType (MonoTyVar name) arg_tys | otherwise -- Must be a type constructor = tcLookupTyCon name `thenTc` \ (tycon_kind,maybe_arity, tycon) -> case maybe_arity of - Nothing -> returnTc (tycon_kind, mkAppTys (mkTyConTy tycon) arg_tys) - Just arity -> checkTc (arity <= n_args) err_msg `thenTc_` + Nothing -> -- Data type or newtype + returnTc (tycon_kind, mkTyConApp tycon arg_tys) + + Just arity -> -- Type synonym + checkTc (arity <= n_args) err_msg `thenTc_` returnTc (tycon_kind, result_ty) where -- It's OK to have an *over-applied* type synonym @@ -144,7 +157,7 @@ tcFunType (MonoTyVar name) arg_tys n_args = length arg_tys tcFunType ty arg_tys - = tcHsTypeKind ty `thenTc` \ (fun_kind, fun_ty) -> + = tc_hs_type_kind ty `thenTc` \ (fun_kind, fun_ty) -> returnTc (fun_kind, mkAppTys fun_ty arg_tys) \end{code} @@ -154,18 +167,19 @@ Contexts \begin{code} tcContext :: RenamedContext -> TcM s ThetaType -tcContext context = mapTc tcClassAssertion context +tcContext context = tcAddErrCtxt (thetaCtxt context) $ + mapTc tcClassAssertion context -tcClassAssertion (class_name, ty) +tcClassAssertion (class_name, tys) = checkTc (canBeUsedInContext class_name) (naughtyCCallContextErr class_name) `thenTc_` - tcLookupClass class_name `thenTc` \ (class_kind, clas) -> - tcHsTypeKind ty `thenTc` \ (ty_kind, ty) -> + tcLookupClass class_name `thenTc` \ (class_kinds, clas) -> + mapAndUnzipTc tc_hs_type_kind tys `thenTc` \ (ty_kinds, tc_tys) -> - unifyKind class_kind ty_kind `thenTc_` + unifyKinds class_kinds ty_kinds `thenTc_` - returnTc (clas, ty) + returnTc (clas, tc_tys) \end{code} HACK warning: Someone discovered that @CCallable@ and @CReturnable@ @@ -220,6 +234,10 @@ tcHsTyVar (IfaceTyVar name kind) Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} -naughtyCCallContextErr clas_name sty - = sep [ptext SLIT("Can't use class"), ppr sty clas_name, ptext SLIT("in a context")] +naughtyCCallContextErr clas_name + = sep [ptext SLIT("Can't use class"), quotes (ppr clas_name), ptext SLIT("in a context")] + +typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty) + +thetaCtxt theta = ptext SLIT("In the context") <+> quotes (pprContext theta) \end{code} diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index b5ddb0cee9..5ec7d7c0cc 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -4,40 +4,35 @@ \section[TcPat]{Typechecking patterns} \begin{code} -#include "HsVersions.h" - module TcPat ( tcPat ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..), - Match, HsBinds, HsType, Fixity, - ArithSeqInfo, Stmt, DoOrListComp, Fake ) -import RnHsSyn ( SYN_IE(RenamedPat) ) -import TcHsSyn ( SYN_IE(TcPat) ) +import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsExpr(..) ) +import RnHsSyn ( RenamedPat ) +import TcHsSyn ( TcPat ) import TcMonad import Inst ( Inst, OverloadedLit(..), InstOrigin(..), - emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE), + emptyLIE, plusLIE, plusLIEs, LIE, newMethod, newOverloadedLit ) import Name ( Name {- instance Outputable -} ) -import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey, - tcLookupLocalValueOK ) -import SpecEnv ( SpecEnv ) -import TcType ( TcIdOcc(..), SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId ) +import TcEnv ( TcIdOcc(..), tcLookupGlobalValue, tcLookupGlobalValueByKey, + tcLookupLocalValueOK, tcInstId + ) +import TcType ( TcType, TcMaybe, newTyVarTy, newTyVarTys ) import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) import Bag ( Bag ) import CmdLineOpts ( opt_IrrefutableTuples ) -import Id ( GenId, idType, SYN_IE(Id) ) +import Id ( GenId, idType, Id ) import Kind ( Kind, mkBoxedTypeKind, mkTypeKind ) import Maybes ( maybeToBool ) import PprType ( GenType, GenTyVar ) -import Pretty -import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys, - getFunTy_maybe, maybeAppDataTyCon, - SYN_IE(Type), GenType +import Type ( splitFunTys, splitRhoTy, splitSigmaTy, mkTyVarTys, + splitFunTy_maybe, splitAlgTyConApp_maybe, + Type, GenType ) import TyVar ( GenTyVar ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, @@ -46,10 +41,7 @@ import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, addrTy ) import Unique ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey ) import Util ( assertPanic, panic ) - -#if __GLASGOW_HASKELL__ >= 202 import Outputable -#endif \end{code} \begin{code} @@ -203,10 +195,10 @@ tcPat pat_in@(RecPatIn name rpats) -- Ignore the con_theta; overloaded constructors only -- behave differently when called, not when used for -- matching. - (_, record_ty) = splitFunTy con_tau + (_, record_ty) = splitFunTys con_tau in -- Con is syntactically constrained to be a data constructor - ASSERT( maybeToBool (maybeAppDataTyCon record_ty) ) + ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty) ) mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) -> @@ -221,10 +213,10 @@ tcPat pat_in@(RecPatIn name rpats) -- Record selectors all have type -- forall a1..an. T a1 .. an -> tau - ASSERT( maybeToBool (getFunTy_maybe tau) ) + ASSERT( maybeToBool (splitFunTy_maybe tau) ) let -- Selector must have type RecordType -> FieldType - Just (record_ty, field_ty) = getFunTy_maybe tau + Just (record_ty, field_ty) = splitFunTy_maybe tau in tcAddErrCtxt (recordLabel field_label) ( unifyTauTy expected_record_ty record_ty @@ -363,7 +355,7 @@ matchConArgTys con arg_tys -- behave differently when called, not when used for -- matching. let - (con_args, con_result) = splitFunTy con_tau + (con_args, con_result) = splitFunTys con_tau con_arity = length con_args no_of_args = length arg_tys in @@ -380,13 +372,14 @@ matchConArgTys con arg_tys Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} -patCtxt pat sty = hang (ptext SLIT("In the pattern:")) 4 (ppr sty pat) +patCtxt pat = hang (ptext SLIT("In the pattern:")) + 4 (ppr pat) -recordLabel field_label sty - = hang (hcat [ptext SLIT("When matching record field"), ppr sty field_label]) +recordLabel field_label + = hang (hcat [ptext SLIT("When matching record field"), ppr field_label]) 4 (hcat [ptext SLIT("with its immediately enclosing constructor")]) -recordRhs field_label pat sty +recordRhs field_label pat = hang (ptext SLIT("In the record field pattern")) - 4 (sep [ppr sty field_label, char '=', ppr sty pat]) + 4 (sep [ppr field_label, char '=', ppr pat]) \end{code} diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index e2737adef4..f38dc93af2 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -3,60 +3,169 @@ % \section[TcSimplify]{TcSimplify} -\begin{code} -#include "HsVersions.h" +Notes: + +Inference (local definitions) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the inst constrains a local type variable, then + [ReduceMe] if it's a literal or method inst, reduce it + + [DontReduce] otherwise see whether the inst is just a constant + if succeed, use it + if not, add original to context + This check gets rid of constant dictionaries without + losing sharing. + +If the inst does not constrain a local type variable then + [Free] then throw it out as free. + +Inference (top level definitions) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the inst does not constrain a local type variable, then + [FreeIfTautological] try for tautology; + if so, throw it out as free + (discarding result of tautology check) + if not, make original inst part of the context + (eliminating superclasses as usual) + +If the inst constrains a local type variable, then + as for inference (local defns) + + +Checking (local defns) +~~~~~~~~ +If the inst constrains a local type variable then + [ReduceMe] reduce (signal error on failure) + +If the inst does not constrain a local type variable then + [Free] throw it out as free. + +Checking (top level) +~~~~~~~~~~~~~~~~~~~~ +If the inst constrains a local type variable then + as for checking (local defns) + +If the inst does not constrain a local type variable then + as for checking (local defns) + + + +Checking once per module +~~~~~~~~~~~~~~~~~~~~~~~~~ +For dicts of the form (C a), where C is a std class + and "a" is a type variable, + [DontReduce] add to context + +otherwise [ReduceMe] always reduce + +[NB: we may generate one Tree [Int] dict per module, so + sharing is not complete.] + +Sort out ambiguity at the end. + +Principal types +~~~~~~~~~~~~~~~ +class C a where + op :: a -> a + +f x = let g y = op (y::Int) in True + +Here the principal type of f is (forall a. a->a) +but we'll produce the non-principal type + f :: forall a. C Int => a -> a + + +Ambiguity +~~~~~~~~~ +Consider this: + instance C (T a) Int where ... + instance C (T a) Bool where ... + +and suppose we infer a context + + C (T x) y + +from some expression, where x and y are type varibles, +and x is ambiguous, and y is being quantified over. +Should we complain, or should we generate the type + + forall x y. C (T x) y => <type not involving x> + +The idea is that at the call of the function we might +know that y is Int (say), so the "x" isn't really ambiguous. +Notice that we have to add "x" to the type variables over +which we generalise. + +Something similar can happen even if C constrains only ambiguous +variables. Suppose we infer the context + + C [x] + +where x is ambiguous. Then we could infer the type + + forall x. C [x] => <type not involving x> + +in the hope that at the call site there was an instance +decl such as + + instance Num a => C [a] where ... + +and hence the default mechanism would resolve the "a". + + +\begin{code} module TcSimplify ( tcSimplify, tcSimplifyAndCheck, - tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyRank2, + tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, bindInstsOfLocalFuns ) where -IMP_Ubiq() +#include "HsVersions.h" -import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit, - Match, HsBinds, HsType, ArithSeqInfo, Fixity, - GRHSsAndBinds, Stmt, DoOrListComp, Fake ) -import HsBinds ( andMonoBinds ) -import TcHsSyn ( SYN_IE(TcExpr), SYN_IE(TcMonoBinds), SYN_IE(TcDictBinds) ) +import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds ) +import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr, + TcMonoBinds, TcDictBinds + ) import TcMonad -import Inst ( lookupInst, lookupSimpleInst, - tyVarsOfInst, isTyVarDict, isDict, - matchesInst, instToId, instBindingRequired, - instCanBeGeneralised, newDictsAtLoc, - pprInst, - Inst(..), SYN_IE(LIE), zonkLIE, emptyLIE, pprLIE, pprLIEInFull, - plusLIE, unitLIE, consLIE, InstOrigin(..), - OverloadedLit ) -import TcEnv ( tcGetGlobalTyVars ) -import SpecEnv ( SpecEnv ) -import TcType ( TcIdOcc(..), SYN_IE(TcIdBndr), - SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), TcMaybe, tcInstType +import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), + tyVarsOfInst, + isTyVarDict, isDict, isStdClassTyVarDict, isMethodFor, + instToId, instBindingRequired, instCanBeGeneralised, + newDictFromOld, + instLoc, getDictClassTys, + pprInst, zonkInst, + Inst(..), LIE, pprInsts, pprInstsInFull, mkLIE, + InstOrigin(..), pprOrigin ) +import TcEnv ( TcIdOcc(..), tcGetGlobalTyVars ) +import TcType ( TcType, TcTyVar, TcTyVarSet, TcMaybe, tcInstType, tcInstTheta ) import Unify ( unifyTauTy ) +import Id ( mkIdSet ) import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList, snocBag, consBag, unionBags, isEmptyBag ) -import Class ( GenClass, SYN_IE(Class), SYN_IE(ClassInstEnv), - isSuperClassOf, classSuperDictSelId, classInstEnv - ) -import Id ( GenId ) -import PrelInfo ( isNumericClass, isStandardClass, isCcallishClass ) +import Class ( Class, ClassInstEnv, classBigSig, classInstEnv ) +import PrelInfo ( isNumericClass, isCcallishClass ) import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool ) -import Outputable ( PprStyle, Outputable(..){-instance * []-} ) -import PprType ( GenType, GenTyVar ) -import Pretty -import SrcLoc ( noSrcLoc ) -import Type ( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy, - getTyVar_maybe ) +import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar, + isTyVarTy, getTyVar_maybe, instantiateThetaTy + ) +import PprType ( pprConstraint ) import TysWiredIn ( intTy, unitTy ) -import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), - elementOfTyVarSet, emptyTyVarSet, unionTyVarSets, - isEmptyTyVarSet, tyVarSetToList ) +import TyVar ( elementOfTyVarSet, emptyTyVarSet, unionTyVarSets, + intersectTyVarSets, unionManyTyVarSets, + isEmptyTyVarSet, tyVarSetToList, + zipTyVarEnv, emptyTyVarEnv + ) +import FiniteMap +import BasicTypes ( TopLevelFlag(..) ) import Unique ( Unique ) +import Outputable import Util +import List ( partition ) \end{code} @@ -66,86 +175,6 @@ import Util %* * %************************************************************************ -* May modify the substitution to bind ambiguous type variables. - -Specification -~~~~~~~~~~~~~ -(1) If an inst constrains only ``global'' type variables, (or none), - return it as a ``global'' inst. - -OTHERWISE - -(2) Simplify it repeatedly (checking for (1) of course) until it is a dict - constraining only a type variable. - -(3) If it constrains a ``local'' type variable, return it as a ``local'' inst. - Otherwise it must be ambiguous, so try to resolve the ambiguity. - - -\begin{code} -tcSimpl :: Bool -- True <=> simplify const insts - -> TcTyVarSet s -- ``Global'' type variables - -> TcTyVarSet s -- ``Local'' type variables - -- ASSERT: both these tyvar sets are already zonked - -> LIE s -- Given; these constrain only local tyvars - -> LIE s -- Wanted - -> TcM s (LIE s, -- Free - TcMonoBinds s, -- Bindings - LIE s) -- Remaining wanteds; no dups - -tcSimpl squash_consts global_tvs local_tvs givens wanteds - = -- ASSSERT: global_tvs and local_tvs are already zonked - -- Make sure the insts fixed points of the substitution - zonkLIE givens `thenNF_Tc` \ givens -> - zonkLIE wanteds `thenNF_Tc` \ wanteds -> - - -- Deal with duplicates and type constructors - elimTyCons - squash_consts (\tv -> tv `elementOfTyVarSet` global_tvs) - givens wanteds `thenTc` \ (globals, tycon_binds, locals_and_ambigs) -> - - -- Now disambiguate if necessary - let - ambigs = filterBag is_ambiguous locals_and_ambigs - in - if not (isEmptyBag ambigs) then - -- Some ambiguous dictionaries. We now disambiguate them, - -- which binds the offending type variables to suitable types in the - -- substitution, and then we retry the whole process. This - -- time there won't be any ambiguous ones. - -- There's no need to back-substitute on global and local tvs, - -- because the ambiguous type variables can't be in either. - - -- Why do we retry the whole process? Because binding a type variable - -- to a particular type might enable a short-cut simplification which - -- elimTyCons will have missed the first time. - - disambiguateDicts ambigs `thenTc_` - tcSimpl squash_consts global_tvs local_tvs givens wanteds - - else - -- No ambiguous dictionaries. Just bash on with the results - -- of the elimTyCons - - -- Check for non-generalisable insts - let - locals = locals_and_ambigs -- ambigs is empty - cant_generalise = filterBag (not . instCanBeGeneralised) locals - in - checkTc (isEmptyBag cant_generalise) - (genCantGenErr cant_generalise) `thenTc_` - - - -- Deal with superclass relationships - elimSCs givens locals `thenNF_Tc` \ (sc_binds, locals2) -> - - -- Finished - returnTc (globals, sc_binds `AndMonoBinds` tycon_binds, locals2) - where - is_ambiguous (Dict _ _ ty _ _) - = not (getTyVar "is_ambiguous" ty `elementOfTyVarSet` local_tvs) -\end{code} - The main wrapper is @tcSimplify@. It just calls @tcSimpl@, but with the ``don't-squash-consts'' flag set depending on top-level ness. For top level defns we *do* squash constants, so that they stay local to a @@ -155,15 +184,16 @@ float them out if poss, after inlinings are sorted out. \begin{code} tcSimplify - :: TcTyVarSet s -- ``Local'' type variables + :: SDoc + -> TopLevelFlag + -> TcTyVarSet s -- ``Local'' type variables -> LIE s -- Wanted -> TcM s (LIE s, -- Free TcDictBinds s, -- Bindings LIE s) -- Remaining wanteds; no dups -tcSimplify local_tvs wanteds - = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs -> - tcSimpl False global_tvs local_tvs emptyBag wanteds +tcSimplify str top_lvl local_tvs wanteds + = tcSimpl str top_lvl local_tvs Nothing wanteds \end{code} @tcSimplifyAndCheck@ is similar to the above, except that it checks @@ -172,299 +202,464 @@ some of constant insts, which have to be resolved finally at the end. \begin{code} tcSimplifyAndCheck - :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint + :: SDoc + -> TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint -> LIE s -- Given -> LIE s -- Wanted -> TcM s (LIE s, -- Free TcDictBinds s) -- Bindings -tcSimplifyAndCheck local_tvs givens wanteds - = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs -> - tcSimpl False global_tvs local_tvs - givens wanteds `thenTc` \ (free_insts, binds, wanteds') -> - checkTc (isEmptyBag wanteds') - (reduceErr wanteds') `thenTc_` +tcSimplifyAndCheck str local_tvs givens wanteds + = tcSimpl str top_lvl local_tvs (Just givens) wanteds `thenTc` \ (free_insts, binds, new_wanteds) -> + ASSERT( isEmptyBag new_wanteds ) returnTc (free_insts, binds) + where + top_lvl = error "tcSimplifyAndCheck" -- Never needed \end{code} -@tcSimplifyRank2@ checks that the argument of a rank-2 polymorphic function -is not overloaded. - \begin{code} -tcSimplifyRank2 :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint - -> LIE s -- Given - -> TcM s (LIE s, -- Free - TcDictBinds s) -- Bindings +tcSimpl :: SDoc + -> TopLevelFlag + -> TcTyVarSet s -- ``Local'' type variables + -- ASSERT: this tyvar set is already zonked + -> Maybe (LIE s) -- Given; these constrain only local tyvars + -- Nothing => just simplify + -- Just g => check that g entails wanteds + -> LIE s -- Wanted + -> TcM s (LIE s, -- Free + TcMonoBinds s, -- Bindings + LIE s) -- Remaining wanteds; no dups +tcSimpl str top_lvl local_tvs maybe_given_lie wanted_lie + = -- ASSSERT: local_tvs are already zonked + reduceContext str try_me + givens + (bagToList wanted_lie) `thenTc` \ (binds, frees, irreds) -> -tcSimplifyRank2 local_tvs givens - = zonkLIE givens `thenNF_Tc` \ givens' -> - elimTyCons True - (\tv -> not (tv `elementOfTyVarSet` local_tvs)) - -- This predicate claims that all - -- any non-local tyvars are global, - -- thereby postponing dealing with - -- ambiguity until the enclosing Gen - emptyLIE givens' `thenTc` \ (free, dict_binds, wanteds) -> + -- Check for non-generalisable insts + let + cant_generalise = filter (not . instCanBeGeneralised) irreds + in + checkTc (null cant_generalise) + (genCantGenErr cant_generalise) `thenTc_` - checkTc (isEmptyBag wanteds) (reduceErr wanteds) `thenTc_` + -- Finished + returnTc (mkLIE frees, binds, mkLIE irreds) + where + givens = case maybe_given_lie of + Just given_lie -> bagToList given_lie + Nothing -> [] + + checking_against_signature = maybeToBool maybe_given_lie + is_top_level = case top_lvl of { TopLevel -> True; other -> False } + + try_me inst + -- Does not constrain a local tyvar + | isEmptyTyVarSet (inst_tyvars `intersectTyVarSets` local_tvs) + = -- if not checking_against_signature && is_top_level then + -- FreeIfTautological -- Special case for inference on + -- -- top-level defns + -- else + + Free + + -- When checking against a given signature we always reduce + -- until we find a match against something given, or can't reduce + | checking_against_signature + = ReduceMe CarryOn + + -- So we're infering (not checking) the type, and + -- the inst constrains a local type variable + | otherwise + = if isDict inst then + DontReduce -- Dicts + else + ReduceMe CarryOn -- Lits and Methods - returnTc (free, dict_binds) + where + inst_tyvars = tyVarsOfInst inst \end{code} -@tcSimplifyTop@ deals with constant @Insts@, using the standard simplification -mechansim with the extra flag to say ``beat out constant insts''. -\begin{code} -tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s) -tcSimplifyTop dicts - = tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts `thenTc` \ (_, binds, _) -> - returnTc binds -\end{code} %************************************************************************ %* * -\subsection[elimTyCons]{@elimTyCons@} +\subsection{Data types for the reduction mechanism} %* * %************************************************************************ +The main control over context reduction is here + \begin{code} -elimTyCons :: Bool -- True <=> Simplify const insts - -> (TcTyVar s -> Bool) -- Free tyvar predicate - -> LIE s -- Given - -> LIE s -- Wanted - -> TcM s (LIE s, -- Free - TcDictBinds s, -- Bindings - LIE s -- Remaining wanteds; no dups; - -- dicts only (no Methods) - ) -\end{code} +data WhatToDo + = ReduceMe -- Reduce this + NoInstanceAction -- What to do if there's no such instance -The bindings returned may mention any or all of ``givens'', so the -order in which the generated binds are put together is {\em tricky}. -Case~4 of @try@ is the general case to see. + | DontReduce -- Return as irreducible -When we do @eTC givens (wanted:wanteds)@ [some details omitted], we... + | Free -- Return as free - (1) first look up @wanted@; this gives us one binding to heave in: - wanted = rhs + | FreeIfTautological -- Return as free iff it's tautological; + -- if not, return as irreducible - (2) step (1) also gave us some @simpler_wanteds@; we simplify - these and get some (simpler-wanted-)bindings {\em that must be - in scope} for the @wanted=rhs@ binding above! +data NoInstanceAction + = CarryOn -- Produce an error message, but keep on with next inst - (3) we simplify the remaining @wanteds@ (recursive call), giving - us yet more bindings. + | Stop -- Produce an error message and stop reduction + + | AddToIrreds -- Just add the inst to the irreductible ones; don't + -- produce an error message of any kind. + -- It might be quite legitimate + -- such as (Eq a)! +\end{code} -The final arrangement of the {\em non-recursive} bindings is - let <simpler-wanted-binds> in - let wanted = rhs in - let <yet-more-bindings> ... \begin{code} -elimTyCons squash_consts is_free_tv givens wanteds - = eTC givens (bagToList wanteds) `thenTc` \ (_, free, binds, irreds) -> - returnTc (free,binds,irreds) +type RedState s + = (Avails s, -- What's available + [Inst s], -- Insts for which try_me returned Free + [Inst s] -- Insts for which try_me returned DontReduce + ) + +type Avails s = FiniteMap (Inst s) (Avail s) + +data Avail s + = Avail + (TcIdOcc s) -- The "main Id"; that is, the Id for the Inst that + -- caused this avail to be put into the finite map in the first place + -- It is this Id that is bound to the RHS. + + (RHS s) -- The RHS: an expression whose value is that Inst. + -- The main Id should be bound to this RHS + + [TcIdOcc s] -- Extra Ids that must all be bound to the main Id. + -- At the end we generate a list of bindings + -- { i1 = main_id; i2 = main_id; i3 = main_id; ... } + +data RHS s + = NoRhs -- Used for irreducible dictionaries, + -- which are going to be lambda bound, or for those that are + -- suppplied as "given" when checking againgst a signature. + -- + -- NoRhs is also used for Insts like (CCallable f) + -- where no witness is required. + + | Rhs -- Used when there is a RHS + (TcExpr s) + Bool -- True => the RHS simply selects a superclass dictionary + -- from a subclass dictionary. + -- False => not so. + -- This is useful info, because superclass selection + -- is cheaper than building the dictionary using its dfun, + -- and we can sometimes replace the latter with the former + + | PassiveScSel -- Used for as-yet-unactivated RHSs. For example suppose we have + -- an (Ord t) dictionary; then we put an (Eq t) entry in + -- the finite map, with an PassiveScSel. Then if the + -- the (Eq t) binding is ever *needed* we make it an Rhs + (TcExpr s) + [Inst s] -- List of Insts that are free in the RHS. + -- If the main Id is subsequently needed, we toss this list into + -- the needed-inst pool so that we make sure their bindings + -- will actually be produced. + -- + -- Invariant: these Insts are already in the finite mapping + + +pprAvails avails = vcat (map pp (eltsFM avails)) where --- eTC :: LIE s -> [Inst s] --- -> TcM s (LIE s, LIE s, TcDictBinds s, LIE s) - - eTC givens [] = returnTc (givens, emptyBag, EmptyMonoBinds, emptyBag) - - eTC givens (wanted:wanteds) - -- Case 0: same as an existing inst - | maybeToBool maybe_equiv - = eTC givens wanteds `thenTc` \ (givens1, frees, binds, irreds) -> - let - -- Create a new binding iff it's needed - this = expectJust "eTC" maybe_equiv - new_binds | instBindingRequired wanted = (VarMonoBind (instToId wanted) (HsVar (instToId this))) - `AndMonoBinds` binds - | otherwise = binds - in - returnTc (givens1, frees, new_binds, irreds) - - -- Case 1: constrains no type variables at all - -- In this case we have a quick go to see if it has an - -- instance which requires no inputs (ie a constant); if so we use - -- it; if not, we give up on the instance and just heave it out the - -- top in the free result - | isEmptyTyVarSet tvs_of_wanted - = simplify_it squash_consts {- If squash_consts is false, - simplify only if trival -} - givens wanted wanteds - - -- Case 2: constrains free vars only, so fling it out the top in free_ids - | all is_free_tv (tyVarSetToList tvs_of_wanted) - = eTC (wanted `consBag` givens) wanteds `thenTc` \ (givens1, frees, binds, irreds) -> - returnTc (givens1, wanted `consBag` frees, binds, irreds) - - -- Case 3: is a dict constraining only a tyvar, - -- so return it as part of the "wanteds" result - | isTyVarDict wanted - = eTC (wanted `consBag` givens) wanteds `thenTc` \ (givens1, frees, binds, irreds) -> - returnTc (givens1, frees, binds, wanted `consBag` irreds) - - -- Case 4: is not a simple dict, so look up in instance environment - | otherwise - = simplify_it True {- Simplify even if not trivial -} - givens wanted wanteds - where - tvs_of_wanted = tyVarsOfInst wanted - - -- Look for something in "givens" that matches "wanted" - Just the_equiv = maybe_equiv - maybe_equiv = foldBag seqMaybe try Nothing givens - try given | wanted `matchesInst` given = Just given - | otherwise = Nothing - - - simplify_it simplify_always givens wanted wanteds - -- Recover immediately on no-such-instance errors - = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, EmptyMonoBinds, emptyLIE)) - (simplify_one simplify_always givens wanted) - `thenTc` \ (givens1, frees1, binds1, irreds1) -> - eTC givens1 wanteds `thenTc` \ (givens2, frees2, binds2, irreds2) -> - returnTc (givens2, frees1 `plusLIE` frees2, - binds1 `AndMonoBinds` binds2, - irreds1 `plusLIE` irreds2) - - - simplify_one simplify_always givens wanted - | not (instBindingRequired wanted) - = -- No binding required for this chap, so squash right away - lookupInst wanted `thenTc` \ (simpler_wanteds, _) -> - eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) -> - returnTc (wanted `consBag` givens1, frees1, binds1, irreds1) - - | otherwise - = -- An binding is required for this inst - lookupInst wanted `thenTc` \ (simpler_wanteds, bind@(VarMonoBind _ rhs)) -> - - if (not_var rhs && not simplify_always) then - -- Ho ho! It isn't trivial to simplify "wanted", - -- because the rhs isn't a simple variable. Unless the flag - -- simplify_always is set, just give up now and - -- just fling it out the top. - returnTc (wanted `consLIE` givens, unitLIE wanted, EmptyMonoBinds, emptyLIE) - else - -- Aha! Either it's easy, or simplify_always is True - -- so we must do it right here. - eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) -> - returnTc (wanted `consLIE` givens1, frees1, - binds1 `AndMonoBinds` bind, - irreds1) - - not_var :: TcExpr s -> Bool - not_var (HsVar _) = False - not_var other = True + pp (Avail main_id rhs ids) + = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs + +pprRhs NoRhs = text "<no rhs>" +pprRhs (Rhs rhs b) = ppr rhs +pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs \end{code} %************************************************************************ %* * -\subsection[elimSCs]{@elimSCs@} +\subsection[reduce]{@reduce@} %* * %************************************************************************ -\begin{code} -elimSCs :: LIE s -- Given; no dups - -> LIE s -- Wanted; no dups; all dictionaries, all - -- constraining just a type variable - -> NF_TcM s (TcDictBinds s, -- Bindings - LIE s) -- Minimal wanted set - -elimSCs givens wanteds - = -- Sort the wanteds so that subclasses occur before superclasses - elimSCs_help - (filterBag isDict givens) -- Filter out non-dictionaries - (sortSC wanteds) - -elimSCs_help :: LIE s -- Given; no dups - -> [Inst s] -- Wanted; no dups; - -> NF_TcM s (TcDictBinds s, -- Bindings - LIE s) -- Minimal wanted set - -elimSCs_help given [] = returnNF_Tc (EmptyMonoBinds, emptyLIE) - -elimSCs_help givens (wanted:wanteds) - = trySC givens wanted `thenNF_Tc` \ (givens1, binds1, irreds1) -> - elimSCs_help givens1 wanteds `thenNF_Tc` \ (binds2, irreds2) -> - returnNF_Tc (binds1 `AndMonoBinds` binds2, irreds1 `plusLIE` irreds2) - - -trySC :: LIE s -- Givens - -> Inst s -- Wanted - -> NF_TcM s (LIE s, -- New givens, - TcDictBinds s, -- Bindings - LIE s) -- Irreducible wanted set - -trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc) - | not (maybeToBool maybe_best_subclass_chain) - = -- No superclass relationship - returnNF_Tc ((wanted `consLIE` givens), EmptyMonoBinds, unitLIE wanted) +The main entry point for context reduction is @reduceContext@: - | otherwise - = -- There's a subclass relationship with a "given" - -- Build intermediate dictionaries +\begin{code} +reduceContext :: SDoc -> (Inst s -> WhatToDo) + -> [Inst s] -- Given + -> [Inst s] -- Wanted + -> TcM s (TcDictBinds s, [Inst s], [Inst s]) + +reduceContext str try_me givens wanteds + = -- Zonking first + mapNF_Tc zonkInst givens `thenNF_Tc` \ givens -> + mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds -> + +{- + pprTrace "reduceContext" (vcat [ + text "----------------------", + str, + text "given" <+> ppr givens, + text "wanted" <+> ppr wanteds, + text "----------------------" + ]) $ +-} + + -- Build the Avail mapping from "givens" + foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails -> + + -- Do the real work + reduce try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) -> + + -- Extract the bindings from avails let - theta = [ (clas, wanted_ty) | clas <- reverse classes ] - -- The reverse is because the list comes back in the "wrong" order I think + binds = foldFM add_bind EmptyMonoBinds avails + + add_bind _ (Avail main_id rhs ids) binds + = foldr add_synonym (add_rhs_bind rhs binds) ids + where + add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs + add_rhs_bind other binds = binds + + -- Add the trivial {x = y} bindings + -- The main Id can end up in the list when it's first added passively + -- and then activated, so we have to filter it out. A bit of a hack. + add_synonym id binds + | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id) + | otherwise = binds in - newDictsAtLoc wanted_orig loc theta `thenNF_Tc` \ (intermediates, _) -> +{- + pprTrace ("reduceContext1") (vcat [ + text "----------------------", + str, + text "given" <+> ppr givens, + text "wanted" <+> ppr wanteds, + text "----", + pprAvails avails, + text "----------------------" + ]) $ +-} + returnTc (binds, frees, irreds) +\end{code} - -- Create bindings for the wanted dictionary and the intermediates. - -- Later binds may depend on earlier ones, so each new binding is pushed - -- on the front of the accumulating parameter list of bindings - let - mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _) - = ((dict_sub, dict_sub_class), - (VarMonoBind (instToId dict) - (DictApp (TyApp (HsVar (RealId (classSuperDictSelId dict_sub_class - clas))) - [ty]) - [instToId dict_sub]))) - (_, new_binds) = mapAccumR mk_bind (wanted,wanted_class) (given : intermediates) - in - returnNF_Tc (wanted `consLIE` givens `plusLIE` listToBag intermediates, - andMonoBinds new_binds, - emptyLIE) +The main context-reduction function is @reduce@. Here's its game plan. + +\begin{code} +reduce :: (Inst s -> WhatToDo) + -> [Inst s] + -> RedState s + -> TcM s (RedState s) +\end{code} + +@reduce@ is passed + try_me: given an inst, this function returns + Reduce reduce this + DontReduce return this in "irreds" + Free return this in "frees" + + wanteds: The list of insts to reduce + state: An accumulating parameter of type RedState + that contains the state of the algorithm + + It returns a RedState. + + +\begin{code} + -- Base case: we're done! +reduce try_me [] state = returnTc state + +reduce try_me (wanted:wanteds) state@(avails, frees, irreds) + + -- It's the same as an existing inst, or a superclass thereof + | wanted `elemFM` avails + = reduce try_me wanteds (activate avails wanted, frees, irreds) + + -- It should be reduced + | case try_me_result of { ReduceMe _ -> True; _ -> False } + = lookupInst wanted `thenNF_Tc` \ lookup_result -> + + case lookup_result of + GenInst wanteds' rhs -> use_instance wanteds' rhs + SimpleInst rhs -> use_instance [] rhs + + NoInstance -> -- No such instance! + -- Decide what to do based on the no_instance_action requested + case no_instance_action of + Stop -> -- Fail + addNoInstanceErr wanted `thenNF_Tc_` + failTc + + CarryOn -> -- Carry on. + -- Add the bad guy to the avails to suppress similar + -- messages from other insts in wanteds + addNoInstanceErr wanted `thenNF_Tc_` + addGiven avails wanted `thenNF_Tc` \ avails' -> + reduce try_me wanteds (avails', frees, irreds) -- Carry on + + AddToIrreds -> -- Add the offending insts to the irreds + add_to_irreds + + + + -- It's free and this isn't a top-level binding, so just chuck it upstairs + | case try_me_result of { Free -> True; _ -> False } + = -- First, see if the inst can be reduced to a constant in one step + lookupInst wanted `thenNF_Tc` \ lookup_result -> + case lookup_result of + SimpleInst rhs -> use_instance [] rhs + other -> add_to_frees + + -- It's free and this is a top level binding, so + -- check whether it's a tautology or not + | case try_me_result of { FreeIfTautological -> True; _ -> False } + = -- Try for tautology + tryTc + -- If tautology trial fails, add to irreds + (addGiven avails wanted `thenNF_Tc` \ avails' -> + returnTc (avails', frees, wanted:irreds)) + + -- If tautology succeeds, just add to frees + (reduce try_me_taut [wanted] (avails, [], []) `thenTc_` + returnTc (avails, wanted:frees, irreds)) + `thenTc` \ state' -> + reduce try_me wanteds state' + + + -- It's irreducible (or at least should not be reduced) + | otherwise + = ASSERT( case try_me_result of { DontReduce -> True; other -> False } ) + -- See if the inst can be reduced to a constant in one step + lookupInst wanted `thenNF_Tc` \ lookup_result -> + case lookup_result of + SimpleInst rhs -> use_instance [] rhs + other -> add_to_irreds where - maybe_best_subclass_chain = foldBag choose_best find_subclass_chain Nothing givens - Just (given, classes, _) = maybe_best_subclass_chain + -- The three main actions + add_to_frees = reduce try_me wanteds (avails, wanted:frees, irreds) + + add_to_irreds = addGiven avails wanted `thenNF_Tc` \ avails' -> + reduce try_me wanteds (avails', frees, wanted:irreds) + + use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' -> + reduce try_me (wanteds' ++ wanteds) (avails', frees, irreds) - choose_best c1@(Just (_,_,n1)) c2@(Just (_,_,n2)) | n1 <= n2 = c1 - | otherwise = c2 - choose_best Nothing c2 = c2 - choose_best c1 Nothing = c1 - find_subclass_chain given@(Dict _ given_class given_ty _ _) - | wanted_ty `eqSimpleTy` given_ty - = case (wanted_class `isSuperClassOf` given_class) of + try_me_result = try_me wanted + ReduceMe no_instance_action = try_me_result - Just classes -> Just (given, - classes, - length classes) + -- The try-me to use when trying to identify tautologies + -- It blunders on reducing as much as possible + try_me_taut inst = ReduceMe Stop -- No error recovery +\end{code} + + +\begin{code} +activate :: Avails s -> Inst s -> Avails s + -- Activate the binding for Inst, ensuring that a binding for the + -- wanted Inst will be generated. + -- (Activate its parent if necessary, recursively). + -- Precondition: the Inst is in Avails already - Nothing -> Nothing +activate avails wanted + | not (instBindingRequired wanted) + = avails - | otherwise = Nothing + | otherwise + = case lookupFM avails wanted of + Just (Avail main_id (PassiveScSel rhs insts) ids) -> + foldl activate avails' insts -- Activate anything it needs + where + avails' = addToFM avails wanted avail' + avail' = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it -sortSC :: LIE s -- Expected to be all dicts (no MethodIds), all of - -- which constrain type variables - -> [Inst s] -- Sorted with subclasses before superclasses + Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list + addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids)) -sortSC dicts = sortLt lt (bagToList dicts) + Nothing -> panic "activate" where - (Dict _ c1 ty1 _ _) `lt` (Dict _ c2 ty2 _ _) - = maybeToBool (c2 `isSuperClassOf` c1) - -- The ice is a bit thin here because this "lt" isn't a total order - -- But it *is* transitive, so it works ok -\end{code} + wanted_id = instToId wanted + +addWanted avails wanted rhs_expr + = ASSERT( not (wanted `elemFM` avails) ) + returnNF_Tc (addToFM avails wanted avail) + -- NB: we don't add the thing's superclasses too! + -- Why not? Because addWanted is used when we've successfully used an + -- instance decl to reduce something; e.g. + -- d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a) + -- Note that we pass the superclasses to the dfun, so they will be "wanted". + -- If we put the superclasses of "d" in avails, then we might end up + -- expressing "d1" in terms of "d", which would be a disaster. + where + avail = Avail (instToId wanted) rhs [] + + rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection + | otherwise = NoRhs + +addGiven :: Avails s -> Inst s -> NF_TcM s (Avails s) +addGiven avails given + = -- ASSERT( not (given `elemFM` avails) ) + -- This assertion isn' necessarily true. It's permitted + -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...) + -- and when typechecking instance decls we generate redundant "givens" too. + addAvail avails given avail + where + avail = Avail (instToId given) NoRhs [] + +addAvail avails wanted avail + = addSuperClasses (addToFM avails wanted avail) wanted + +addSuperClasses :: Avails s -> Inst s -> NF_TcM s (Avails s) + -- Add all the superclasses of the Inst to Avails + -- Invariant: the Inst is already in Avails. +addSuperClasses avails dict + | not (isDict dict) + = returnNF_Tc avails + + | otherwise -- It is a dictionary + = tcInstTheta env sc_theta `thenNF_Tc` \ sc_theta' -> + foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) + where + (clas, tys) = getDictClassTys dict + + (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas + env = zipTyVarEnv tyvars tys + + add_sc avails ((super_clas, super_tys), sc_sel) + = newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict -> + let + sc_sel_rhs = DictApp (TyApp (HsVar (RealId sc_sel)) + tys) + [instToId dict] + in + case lookupFM avails super_dict of + + Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) -> + -- Already there, but not as a superclass selector + -- No need to look at its superclasses; since it's there + -- already they must be already in avails + -- However, we must remember to activate the dictionary + -- from which it is (now) generated + returnNF_Tc (activate avails' dict) + where + avails' = addToFM avails super_dict avail + avail = Avail main_id (Rhs sc_sel_rhs True) ids -- Superclass selection + + Just (Avail _ _ _) -> returnNF_Tc avails + -- Already there; no need to do anything + + Nothing -> + -- Not there at all, so add it, and its superclasses + addAvail avails super_dict avail + where + avail = Avail (instToId super_dict) + (PassiveScSel sc_sel_rhs [dict]) + [] +\end{code} %************************************************************************ %* * @@ -478,16 +673,27 @@ Much simpler versions when there are no bindings to make! @deriving@ declarations and when specialising instances. We are only interested in the simplified bunch of class/type constraints. +It simplifies to constraints of the form (C a b c) where +a,b,c are type variables. This is required for the context of +instance declarations. + \begin{code} tcSimplifyThetas :: (Class -> ClassInstEnv) -- How to find the ClassInstEnv - -> [(Class, TauType)] -- Given - -> [(Class, TauType)] -- Wanted - -> TcM s [(Class, TauType)] + -> ThetaType -- Wanted + -> TcM s ThetaType -- Needed; of the form C a b c + -- where a,b,c are type variables - -tcSimplifyThetas inst_mapper given wanted - = elimTyConsSimple inst_mapper wanted `thenTc` \ wanted1 -> - returnTc (elimSCsSimple given wanted1) +tcSimplifyThetas inst_mapper wanteds + = reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds -> + let + -- Check that the returned dictionaries are of the form (C a b c) + bad_guys = [ct | ct@(clas,tys) <- irreds, not (all isTyVarTy tys)] + in + if null bad_guys then + returnTc irreds + else + mapNF_Tc addNoInstErr bad_guys `thenNF_Tc_` + failTc \end{code} @tcSimplifyCheckThetas@ just checks class-type constraints, essentially; @@ -495,55 +701,82 @@ used with \tr{default} declarations. We are only interested in whether it worked or not. \begin{code} -tcSimplifyCheckThetas :: [(Class, TauType)] -- Simplify this to nothing at all +tcSimplifyCheckThetas :: ThetaType -- Given + -> ThetaType -- Wanted -> TcM s () -tcSimplifyCheckThetas theta - = elimTyConsSimple classInstEnv theta `thenTc` \ theta1 -> - ASSERT( null theta1 ) - returnTc () +tcSimplifyCheckThetas givens wanteds + = reduceSimple classInstEnv givens wanteds `thenNF_Tc` \ irreds -> + if null irreds then + returnTc () + else + mapNF_Tc addNoInstErr irreds `thenNF_Tc_` + failTc + +addNoInstErr (c,ts) = addErrTc (noDictInstanceErr c ts) \end{code} \begin{code} -elimTyConsSimple :: (Class -> ClassInstEnv) - -> [(Class,Type)] - -> TcM s [(Class,Type)] -elimTyConsSimple inst_mapper theta - = elim theta +type AvailsSimple = FiniteMap (Class, [TauType]) Bool + -- True => irreducible + -- False => given, or can be derived from a given or from an irreducible + +reduceSimple :: (Class -> ClassInstEnv) + -> ThetaType -- Given + -> ThetaType -- Wanted + -> NF_TcM s ThetaType -- Irreducible + +reduceSimple inst_mapper givens wanteds + = reduce_simple inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' -> + returnNF_Tc [ct | (ct,True) <- fmToList givens_fm'] where - elim [] = returnTc [] - elim ((clas,ty):rest) = elim_one clas ty `thenTc` \ r1 -> - elim rest `thenTc` \ r2 -> - returnTc (r1++r2) - - elim_one clas ty - = case getTyVar_maybe ty of - - Just tv -> returnTc [(clas,ty)] - - otherwise -> recoverTc (returnTc []) $ - lookupSimpleInst (inst_mapper clas) clas ty `thenTc` \ theta -> - elim theta - -elimSCsSimple :: [(Class,Type)] -- Given - -> [(Class,Type)] -- Wanted - -> [(Class,Type)] -- Subset of wanted; no dups, no subclass relnships - -elimSCsSimple givens [] = [] -elimSCsSimple givens (c_t@(clas,ty) : rest) - | any (`subsumes` c_t) givens || - any (`subsumes` c_t) rest -- (clas,ty) is old hat - = elimSCsSimple givens rest - | otherwise -- (clas,ty) is new - = c_t : elimSCsSimple (c_t : givens) rest - where - rest' = elimSCsSimple rest - (c1,t1) `subsumes` (c2,t2) = t1 `eqSimpleTy` t2 && - (c1 == c2 || maybeToBool (c2 `isSuperClassOf` c1)) --- We deal with duplicates here ^^^^^^^^ --- It's a simple place to do it, although it's done in elimTyCons in the --- full-blown version of the simpifier. + givens_fm = foldl addNonIrred emptyFM givens + +reduce_simple :: (Class -> ClassInstEnv) + -> AvailsSimple + -> ThetaType + -> NF_TcM s AvailsSimple + +reduce_simple inst_mapper givens [] + = -- Finished, so pull out the needed ones + returnNF_Tc givens + +reduce_simple inst_mapper givens (wanted@(clas,tys) : wanteds) + | wanted `elemFM` givens + = reduce_simple inst_mapper givens wanteds + + | otherwise + = lookupSimpleInst (inst_mapper clas) clas tys `thenNF_Tc` \ maybe_theta -> + + case maybe_theta of + Nothing -> reduce_simple inst_mapper (addIrred givens wanted) wanteds + Just theta -> reduce_simple inst_mapper (addNonIrred givens wanted) (theta ++ wanteds) + +addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple +addIrred givens ct + = addSCs (addToFM givens ct True) ct + +addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple +addNonIrred givens ct + = addSCs (addToFM givens ct False) ct + +addSCs givens ct@(clas,tys) + = foldl add givens sc_theta + where + (tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas + sc_theta = instantiateThetaTy (zipTyVarEnv tyvars tys) sc_theta_tmpl + + add givens ct = case lookupFM givens ct of + Nothing -> -- Add it and its superclasses + addSCs (addToFM givens ct False) ct + + Just True -> -- Set its flag to False; superclasses already done + addToFM givens ct False + + Just False -> -- Already done + givens + \end{code} %************************************************************************ @@ -575,19 +808,16 @@ For each method @Inst@ in the @init_lie@ that mentions one of the bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s) bindInstsOfLocalFuns init_lie local_ids - = foldrTc bind_inst (emptyBag, EmptyMonoBinds) (bagToList init_lie) + = reduceContext (text "bindInsts" <+> ppr local_ids) + try_me [] (bagToList init_lie) `thenTc` \ (binds, frees, irreds) -> + ASSERT( null irreds ) + returnTc (mkLIE frees, binds) where - bind_inst inst@(Method uniq (TcId id) tys _ _ orig loc) (insts, binds) - | id `is_elem` local_ids - = lookupInst inst `thenTc` \ (dict_insts, bind) -> - returnTc (listToBag dict_insts `plusLIE` insts, - bind `AndMonoBinds` binds) - - bind_inst some_other_inst (insts, binds) - -- Either not a method, or a method instance for an id not in local_ids - = returnTc (some_other_inst `consBag` insts, binds) - - is_elem = isIn "bindInstsOfLocalFuns" + local_id_set = mkIdSet local_ids -- There can occasionally be a lot of them + -- so it's worth building a set, so that + -- lookup (in isMethodFor) is faster + try_me inst | isMethodFor local_id_set inst = ReduceMe CarryOn + | otherwise = Free \end{code} @@ -627,23 +857,55 @@ dictionaries and either resolves them (producing bindings) or complains. It works by splitting the dictionary list by type variable, and using @disambigOne@ to do the real business. -IMPORTANT: @disambiguate@ assumes that its argument dictionaries -constrain only a simple type variable. + +@tcSimplifyTop@ is called once per module to simplify +all the constant and ambiguous Insts. \begin{code} -type SimpleDictInfo s = (Inst s, Class, TcTyVar s) +tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s) +tcSimplifyTop wanteds + = reduceContext (text "tcSimplTop") try_me [] (bagToList wanteds) `thenTc` \ (binds1, frees, irreds) -> + ASSERT( null frees ) -disambiguateDicts :: LIE s -> TcM s () + let + -- All the non-std ones are definite errors + (stds, non_stds) = partition isStdClassTyVarDict irreds + + + -- Group by type variable + std_groups = equivClasses cmp_by_tyvar stds + + -- Pick the ones which its worth trying to disambiguate + (std_oks, std_bads) = partition worth_a_try std_groups + -- Have a try at disambiguation + -- if the type variable isn't bound + -- up with one of the non-standard classes + worth_a_try group@(d:_) = isEmptyTyVarSet (tyVarsOfInst d `intersectTyVarSets` non_std_tyvars) + non_std_tyvars = unionManyTyVarSets (map tyVarsOfInst non_stds) + + -- Collect together all the bad guys + bad_guys = non_stds ++ concat std_bads + in + + -- Disambiguate the ones that look feasible + mapTc disambigGroup std_oks `thenTc` \ binds_ambig -> -disambiguateDicts insts - = mapTc disambigOne inst_infos `thenTc` \ binds_lists -> - returnTc () + -- And complain about the ones that don't + mapNF_Tc complain bad_guys `thenNF_Tc_` + + returnTc (binds1 `AndMonoBinds` andMonoBinds binds_ambig) where - inst_infos = equivClasses cmp_tyvars (map mk_inst_info (bagToList insts)) - (_,_,tv1) `cmp_tyvars` (_,_,tv2) = tv1 `cmp` tv2 + try_me inst = ReduceMe AddToIrreds + + d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2 - mk_inst_info dict@(Dict _ clas ty _ _) - = (dict, clas, getTyVar "disambiguateDicts" ty) + complain d | isEmptyTyVarSet (tyVarsOfInst d) = addNoInstanceErr d + | otherwise = addAmbigErr [d] + +get_tv d = case getDictClassTys d of + (clas, [ty]) -> getTyVar "tcSimplifyTop" ty +get_clas d = case getDictClassTys d of + (clas, [ty]) -> clas \end{code} @disambigOne@ assumes that its arguments dictionaries constrain all @@ -659,10 +921,11 @@ Since we're not using the result of @foo@, the result if (presumably) @void@. \begin{code} -disambigOne :: [SimpleDictInfo s] -> TcM s () +disambigGroup :: [Inst s] -- All standard classes of form (C a) + -> TcM s (TcDictBinds s) -disambigOne dict_infos - | any isNumericClass classes && all isStandardClass classes +disambigGroup dicts + | any isNumericClass classes -- Guaranteed all standard classes = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT -- SO, TRY DEFAULT TYPES IN ORDER @@ -673,34 +936,44 @@ disambigOne dict_infos tcGetDefaultTys `thenNF_Tc` \ default_tys -> let try_default [] -- No defaults work, so fail - = failTc (ambigErr dicts) + = failTc try_default (default_ty : default_tys) = tryTc (try_default default_tys) $ -- If default_ty fails, we try -- default_tys instead - tcSimplifyCheckThetas thetas `thenTc` \ _ -> + tcSimplifyCheckThetas [] thetas `thenTc` \ _ -> returnTc default_ty where - thetas = classes `zip` repeat default_ty + thetas = classes `zip` repeat [default_ty] in -- See if any default works, and if so bind the type variable to it - try_default default_tys `thenTc` \ chosen_default_ty -> - tcInstType [] chosen_default_ty `thenNF_Tc` \ chosen_default_tc_ty -> -- Tiresome! - unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) + -- If not, add an AmbigErr + recoverTc (addAmbigErr dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $ + + try_default default_tys `thenTc` \ chosen_default_ty -> + + -- Bind the type variable and reduce the context, for real this time + tcInstType emptyTyVarEnv chosen_default_ty `thenNF_Tc` \ chosen_default_tc_ty -> -- Tiresome! + unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) `thenTc_` + reduceContext (text "disambig" <+> ppr dicts) + try_me [] dicts `thenTc` \ (binds, frees, ambigs) -> + ASSERT( null frees && null ambigs ) + returnTc binds | all isCcallishClass classes = -- Default CCall stuff to (); we don't even both to check that () is an -- instance of CCallable/CReturnable, because we know it is. - unifyTauTy (mkTyVarTy tyvar) unitTy + unifyTauTy (mkTyVarTy tyvar) unitTy `thenTc_` + returnTc EmptyMonoBinds | otherwise -- No defaults - = failTc (ambigErr dicts) + = addAmbigErr dicts `thenNF_Tc_` + returnTc EmptyMonoBinds where - (_,_,tyvar) = head dict_infos -- Should be non-empty - dicts = [dict | (dict,_,_) <- dict_infos] - classes = [clas | (_,clas,_) <- dict_infos] - + try_me inst = ReduceMe CarryOn + tyvar = get_tv (head dicts) -- Should be non-empty + classes = map get_clas dicts \end{code} @@ -712,28 +985,29 @@ from the insts, or just whatever seems to be around in the monad just now? \begin{code} -genCantGenErr insts sty -- Can't generalise these Insts - = hang (ptext SLIT("Cannot generalise these overloadings (in a _ccall_):")) - 4 (vcat (map (ppr sty) (bagToList insts))) -\end{code} - -\begin{code} -ambigErr dicts sty - = sep [text "Ambiguous context" <+> pprLIE sty lie, - nest 4 (pprLIEInFull sty lie) - ] +genCantGenErr insts -- Can't generalise these Insts + = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"), + nest 4 (pprInstsInFull insts) + ] + +addAmbigErr dicts + = tcAddSrcLoc (instLoc (head dicts)) $ + addErrTc (sep [text "Cannot resolve the ambiguous context" <+> pprInsts dicts, + nest 4 (pprInstsInFull dicts)]) + +addNoInstanceErr dict + = tcAddSrcLoc (instLoc dict) $ + tcAddErrCtxt (pprOrigin dict) $ + addErrTc (noDictInstanceErr clas tys) where - lie = listToBag dicts -- Yuk -\end{code} + (clas, tys) = getDictClassTys dict -@reduceErr@ complains if we can't express required dictionaries in -terms of the signature. +noDictInstanceErr clas tys + = ptext SLIT("No instance for:") <+> quotes (pprConstraint clas tys) -\begin{code} -reduceErr lie sty - = sep [text "Context" <+> pprLIE sty lie, - nest 4 (text "required by inferred type, but missing on a type signature"), - nest 4 (pprLIEInFull sty lie) +reduceSigCtxt lie + = sep [ptext SLIT("When matching against a type signature with context"), + nest 4 (quotes (pprInsts (bagToList lie))) ] \end{code} diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 7a585adb63..efcaa9de8f 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -4,45 +4,43 @@ \section[TcTyClsDecls]{Typecheck type and class declarations} \begin{code} -#include "HsVersions.h" - module TcTyClsDecls ( tcTyAndClassDecls1 ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import HsSyn ( HsDecl(..), TyDecl(..), ConDecl(..), ConDetails(..), BangType(..), - ClassDecl(..), HsType(..), HsTyVar, DefaultDecl, InstDecl, - IfaceSig, Sig(..), MonoBinds, Fake, InPat, HsBinds(..), HsExpr, NewOrData, +import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), + HsType(..), HsTyVar, + ConDecl(..), ConDetails(..), BangType(..), + Sig(..), hsDeclName ) -import RnHsSyn ( RenamedTyDecl(..), RenamedClassDecl(..), SYN_IE(RenamedHsDecl) - ) -import TcHsSyn ( SYN_IE(TcHsBinds) ) +import RnHsSyn ( RenamedTyDecl(..), RenamedClassDecl(..), RenamedHsDecl ) +import TcHsSyn ( TcHsBinds ) +import BasicTypes ( RecFlag(..) ) import TcMonad -import Inst ( SYN_IE(InstanceMapper) ) +import Inst ( InstanceMapper ) import TcClassDcl ( tcClassDecl1 ) -import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv ) -import SpecEnv ( SpecEnv ) -import TcKind ( TcKind, newKindVars ) +import TcEnv ( TcIdOcc(..), tcExtendTyConEnv, tcExtendClassEnv ) +import TcKind ( TcKind, newKindVar, newKindVars, tcDefaultKind, kindToTcKind ) import TcTyDecls ( tcTyDecl, mkDataBinds ) import TcMonoType ( tcTyVarScope ) -import TcType ( TcIdOcc(..) ) +import TyCon ( tyConKind, tyConArity, isSynTyCon ) +import Class ( Class, classBigSig ) +import TyVar ( tyVarKind ) import Bag -import Class ( SYN_IE(Class) ) import Digraph ( stronglyConnComp, SCC(..) ) -import Name ( Name, getSrcLoc, isTvOcc, nameOccName ) +import Name ( Name, NamedThing(..), getSrcLoc, isTvOcc, nameOccName ) import Outputable -import Pretty import Maybes ( mapMaybe ) -import UniqSet ( SYN_IE(UniqSet), emptyUniqSet, +import UniqSet ( UniqSet, emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, uniqSetToList ) import SrcLoc ( SrcLoc ) -import TyCon ( TyCon, SYN_IE(Arity) ) +import TyCon ( TyCon, Arity ) import Unique ( Unique, Uniquable(..) ) import Util ( panic{-, pprTrace-} ) @@ -64,80 +62,100 @@ tcGroups unf_env inst_mapper [] returnTc env tcGroups unf_env inst_mapper (group:groups) - = tcGroup unf_env inst_mapper group `thenTc` \ new_env -> + = tcGroup unf_env inst_mapper group `thenTc` \ (group_tycons, group_classes) -> -- Extend the environment using the new tycons and classes - tcSetEnv new_env $ + tcExtendTyConEnv [(getName tycon, (kindToTcKind (tyConKind tycon), + if isSynTyCon tycon then Just (tyConArity tycon) else Nothing, + tycon)) + | tycon <- group_tycons] $ + + tcExtendClassEnv [(getName clas, (classKind clas, clas)) + | clas <- group_classes] $ + -- Do the remaining groups tcGroups unf_env inst_mapper groups + where + classKind clas = map (kindToTcKind . tyVarKind) tyvars + where + (tyvars, _, _, _, _) = classBigSig clas \end{code} Dealing with a group ~~~~~~~~~~~~~~~~~~~~ + +Notice the uses of @zipLazy@, which makes sure +that the knot-tied TyVars, TyCons and Classes aren't looked at too early. + + \begin{code} -tcGroup :: TcEnv s -> InstanceMapper -> Bag RenamedHsDecl -> TcM s (TcEnv s) -tcGroup unf_env inst_mapper decls +tcGroup :: TcEnv s -> InstanceMapper -> SCC RenamedHsDecl -> TcM s ([TyCon], [Class]) +tcGroup unf_env inst_mapper scc = -- TIE THE KNOT - fixTc ( \ ~(tycons,classes,_) -> + fixTc ( \ ~(rec_tycons, rec_classes) -> -- EXTEND TYPE AND CLASS ENVIRONMENTS - -- NB: it's important that the tycons and classes come back in just - -- the same order from this fix as from get_binders, so that these - -- extend-env things work properly. A bit UGH-ish. - tcExtendTyConEnv tycon_names_w_arities tycons $ - tcExtendClassEnv class_names classes $ + let + mk_tycon_bind (name, arity) = newKindVar `thenNF_Tc` \ kind -> + returnNF_Tc (name, (kind, arity, find name rec_tycons)) - -- DEAL WITH TYPE VARIABLES - tcTyVarScope tyvar_names ( \ tyvars -> + mk_class_bind (name, arity) = newKindVars arity `thenNF_Tc` \ kinds -> + returnNF_Tc (name, (kinds, find name rec_classes)) - -- DEAL WITH THE DEFINITIONS THEMSELVES - foldBag combine (tcDecl unf_env inst_mapper) - (returnTc (emptyBag, emptyBag)) - decls - ) `thenTc` \ (tycon_bag,class_bag) -> - let - tycons = bagToList tycon_bag - classes = bagToList class_bag - in + find name [] = pprPanic "tcGroup" (ppr name) + find name (thing:things) | name == getName thing = thing + | otherwise = find name things - -- SNAFFLE ENV TO RETURN - tcGetEnv `thenNF_Tc` \ final_env -> + in + mapNF_Tc mk_tycon_bind tycon_names_w_arities `thenNF_Tc` \ tycon_binds -> + mapNF_Tc mk_class_bind class_names_w_arities `thenNF_Tc` \ class_binds -> + tcExtendTyConEnv tycon_binds $ + tcExtendClassEnv class_binds $ - returnTc (tycons, classes, final_env) - ) `thenTc` \ (_, _, final_env) -> + -- DEAL WITH TYPE VARIABLES + tcTyVarScope tyvar_names ( \ tyvars -> - returnTc final_env + -- DEAL WITH THE DEFINITIONS THEMSELVES + foldlTc (tcDecl is_rec_group unf_env inst_mapper) ([], []) decls + ) `thenTc` \ (tycons, classes) -> + returnTc (tycons, classes) + ) where - (tyvar_names, tycon_names_w_arities, class_names) = get_binders decls + is_rec_group = case scc of + AcyclicSCC _ -> NonRecursive + CyclicSCC _ -> Recursive + + decls = case scc of + AcyclicSCC decl -> [decl] + CyclicSCC decls -> decls - combine do_a do_b - = do_a `thenTc` \ (a1,a2) -> - do_b `thenTc` \ (b1,b2) -> - returnTc (a1 `unionBags` b1, a2 `unionBags` b2) + (tyvar_names, tycon_names_w_arities, class_names_w_arities) = get_binders decls \end{code} Dealing with one decl ~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tcDecl :: TcEnv s -> InstanceMapper +tcDecl :: RecFlag -- True => recursive group + -> TcEnv s -> InstanceMapper + -> ([TyCon], [Class]) -- Accumulating parameter -> RenamedHsDecl - -> TcM s (Bag TyCon, Bag Class) + -> TcM s ([TyCon], [Class]) -tcDecl unf_env inst_mapper (TyD decl) - = tcTyDecl decl `thenTc` \ tycon -> - returnTc (unitBag tycon, emptyBag) +tcDecl is_rec_group unf_env inst_mapper (tycons, classes) (TyD decl) + = tcTyDecl is_rec_group decl `thenTc` \ tycon -> + returnTc (tycon:tycons, classes) -tcDecl unf_env inst_mapper (ClD decl) +tcDecl is_rec_group unf_env inst_mapper (tycons, classes) (ClD decl) = tcClassDecl1 unf_env inst_mapper decl `thenTc` \ clas -> - returnTc (emptyBag, unitBag clas) + returnTc (tycons, clas:classes) \end{code} Dependency analysis ~~~~~~~~~~~~~~~~~~~ \begin{code} -sortByDependency :: [RenamedHsDecl] -> TcM s [Bag RenamedHsDecl] +sortByDependency :: [RenamedHsDecl] -> TcM s [SCC RenamedHsDecl] sortByDependency decls = let -- CHECK FOR SYNONYM CYCLES syn_sccs = stronglyConnComp (filter is_syn_decl edges) @@ -156,9 +174,8 @@ sortByDependency decls -- DO THE MAIN DEPENDENCY ANALYSIS let decl_sccs = stronglyConnComp (filter is_ty_cls_decl edges) - scc_bags = map bag_acyclic decl_sccs in - returnTc (scc_bags) + returnTc decl_sccs where edges = mapMaybe mk_edges decls @@ -188,7 +205,7 @@ mk_edges decl@(TyD (TyData _ ctxt name _ condecls derivs _ _)) mk_edges decl@(TyD (TySynonym name _ rhs _)) = Just (decl, uniqueOf name, uniqSetToList (get_ty rhs)) -mk_edges decl@(ClD (ClassDecl ctxt name _ sigs _ _ _)) +mk_edges decl@(ClD (ClassDecl ctxt name _ sigs _ _ _ _ _)) = Just (decl, uniqueOf name, uniqSetToList (get_ctxt ctxt `unionUniqSets` get_sigs sigs)) @@ -264,16 +281,16 @@ Monad c in bop's type signature means that D must have kind Type->Type. \begin{code} -get_binders :: Bag RenamedHsDecl +get_binders :: [RenamedHsDecl] -> ([HsTyVar Name], -- TyVars; no dups [(Name, Maybe Arity)], -- Tycons; no dups; arities for synonyms - [Name]) -- Classes; no dups + [(Name, Arity)]) -- Classes; no dups; with their arities get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes) where - (tyvars, tycons, classes) = foldBag union3 get_binders1 - (emptyBag,emptyBag,emptyBag) - decls + (tyvars, tycons, classes) = foldr (union3 . get_binders1) + (emptyBag,emptyBag,emptyBag) + decls union3 (a1,a2,a3) (b1,b2,b3) = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3) @@ -282,9 +299,9 @@ get_binders1 (TyD (TyData _ _ name tyvars _ _ _ _)) = (listToBag tyvars, unitBag (name,Nothing), emptyBag) get_binders1 (TyD (TySynonym name tyvars _ _)) = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag) -get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _)) - = (unitBag tyvar `unionBags` sigs_tvs sigs, - emptyBag, unitBag name) +get_binders1 (ClD (ClassDecl _ name tyvars sigs _ _ _ _ _)) + = (listToBag tyvars `unionBags` sigs_tvs sigs, + emptyBag, unitBag (name, length tyvars)) sigs_tvs sigs = unionManyBags (map sig_tvs sigs) where @@ -295,18 +312,18 @@ sigs_tvs sigs = unionManyBags (map sig_tvs sigs) \begin{code} -typeCycleErr syn_cycles sty - = vcat (map (pp_cycle sty "Cycle in type declarations ...") syn_cycles) +typeCycleErr syn_cycles + = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles) -classCycleErr cls_cycles sty - = vcat (map (pp_cycle sty "Cycle in class declarations ...") cls_cycles) +classCycleErr cls_cycles + = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles) -pp_cycle sty str decls +pp_cycle str decls = hang (text str) 4 (vcat (map pp_decl decls)) where pp_decl decl - = hsep [ppr sty name, ppr sty (getSrcLoc name)] + = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)] where name = hsDeclName decl \end{code} diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 84ad5faa80..bf34c9ce2a 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -4,83 +4,74 @@ \section[TcTyDecls]{Typecheck type declarations} \begin{code} -#include "HsVersions.h" - module TcTyDecls ( tcTyDecl, tcConDecl, mkDataBinds ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import HsSyn ( TyDecl(..), ConDecl(..), ConDetails(..), BangType(..), HsExpr(..), - Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..), - HsBinds(..), HsLit, Stmt, DoOrListComp, ArithSeqInfo, - SYN_IE(RecFlag), nonRecursive, andMonoBinds, - HsType, Fake, InPat, HsTyVar, Fixity, - MonoBinds(..), Sig +import HsSyn ( MonoBinds(..), + TyDecl(..), ConDecl(..), ConDetails(..), BangType(..), + andMonoBinds ) import HsTypes ( getTyVarName ) import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..) ) import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType, - SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds) + TcHsBinds, TcMonoBinds ) +import BasicTypes ( RecFlag(..) ) + import Inst ( newDicts, InstOrigin(..), Inst ) import TcMonoType ( tcHsTypeKind, tcHsType, tcContext ) -import TcSimplify ( tcSimplifyThetas ) -import TcType ( TcIdOcc(..), tcInstTyVars, tcInstType, tcInstId ) -import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass, +import TcSimplify ( tcSimplifyCheckThetas ) +import TcType ( tcInstTyVars ) +import TcEnv ( TcIdOcc(..), tcInstId, + tcLookupTyCon, tcLookupTyVar, tcLookupClass, newLocalId, newLocalIds, tcLookupClassByKey ) import TcMonad -import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind ) +import TcKind ( TcKind, unifyKind, mkArrowKind, mkBoxedTypeKind ) -import PprType ( GenClass, GenType{-instance Outputable-}, - GenTyVar{-instance Outputable-}{-ToDo:possibly rm-} - ) -import CoreUnfold ( getUnfoldingTemplate ) -import Class ( GenClass{-instance Eq-}, classInstEnv, SYN_IE(Class) ) +import Class ( classInstEnv, Class ) import Id ( mkDataCon, dataConSig, mkRecordSelId, idType, dataConFieldLabels, dataConStrictMarks, StrictnessMark(..), getIdUnfolding, - GenId{-instance NamedThing-}, - SYN_IE(Id) + Id ) +import CoreUnfold ( getUnfoldingTemplate ) import FieldLabel import Kind ( Kind, mkArrowKind, mkBoxedTypeKind ) -import SpecEnv ( SpecEnv, nullSpecEnv ) import Name ( nameSrcLoc, isLocallyDefined, getSrcLoc, - OccName(..), Name{-instance Ord3-}, + OccName(..), NamedThing(..) ) -import Outputable ( Outputable(..), interpp'SP ) -import Pretty -import TyCon ( TyCon, NewOrData, mkSynTyCon, mkDataTyCon, isAlgTyCon, +import Outputable +import TyCon ( TyCon, mkSynTyCon, mkDataTyCon, isAlgTyCon, isSynTyCon, tyConDataCons ) -import Type ( GenType, -- instances - typeKind, getTyVar, tyVarsOfTypes, eqTy, splitSigmaTy, - applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy, - splitFunTy, mkTyVarTy, getTyVar_maybe, - SYN_IE(Type) +import Type ( typeKind, getTyVar, tyVarsOfTypes, splitSigmaTy, + mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy, + splitFunTys, mkTyVarTy, getTyVar_maybe, + Type, ThetaType ) -import TyVar ( tyVarKind, elementOfTyVarSet, - GenTyVar{-instance Eq-}, SYN_IE(TyVar) ) -import Unique ( Unique {- instance Eq -}, evalClassKey ) -import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, SYN_IE(UniqSet) ) -import Util ( equivClasses, zipEqual, nOfThem, panic, assertPanic, Ord3(..) ) +import TyVar ( tyVarKind, elementOfTyVarSet, intersectTyVarSets, isEmptyTyVarSet, + TyVar ) +import Unique ( evalClassKey ) +import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet ) +import Util ( equivClasses, zipEqual, nOfThem, panic, assertPanic ) \end{code} \begin{code} -tcTyDecl :: RenamedTyDecl -> TcM s TyCon +tcTyDecl :: RecFlag -> RenamedTyDecl -> TcM s TyCon \end{code} Type synonym decls ~~~~~~~~~~~~~~~~~~ \begin{code} -tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc) +tcTyDecl is_rec (TySynonym tycon_name tyvar_names rhs src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (tySynCtxt tycon_name) $ @@ -94,7 +85,7 @@ tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc) -- Unify tycon kind with (k1->...->kn->rhs) unifyKind tycon_kind - (foldr mkTcArrowKind rhs_kind tyvar_kinds) + (foldr mkArrowKind rhs_kind tyvar_kinds) `thenTc_` let -- Getting the TyCon's kind is a bit of a nuisance. We can't use the tycon_kind, @@ -120,7 +111,7 @@ Algebraic data and newtype decls ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tcTyDecl (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc) +tcTyDecl is_rec (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (tyDataCtxt tycon_name) $ @@ -135,7 +126,7 @@ tcTyDecl (TyData data_or_new context tycon_name tyvar_names con_decls derivings -- Unify tycon kind with (k1->...->kn->Type) unifyKind tycon_kind - (foldr mkTcArrowKind mkTcTypeKind tyvar_kinds) + (foldr mkArrowKind mkBoxedTypeKind tyvar_kinds) `thenTc_` -- Walk the condecls @@ -152,7 +143,9 @@ tcTyDecl (TyData data_or_new context tycon_name tyvar_names con_decls derivings ctxt con_ids derived_classes + Nothing -- Not a dictionary data_or_new + is_rec in returnTc tycon @@ -199,7 +192,7 @@ mkDataBinds_one tycon -- groups is list of fields that share a common name groups = equivClasses cmp_name fields cmp_name (_, field1) (_, field2) - = fieldLabelName field1 `cmp` fieldLabelName field2 + = fieldLabelName field1 `compare` fieldLabelName field2 \end{code} -- Check that all the types of all the strict arguments are in Eval @@ -212,18 +205,16 @@ checkConstructorContext con_id | otherwise -- It is locally defined = tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas -> let - strict_marks = dataConStrictMarks con_id - (tyvars,theta,tau) = splitSigmaTy (idType con_id) - (arg_tys, result_ty) = splitFunTy tau + strict_marks = dataConStrictMarks con_id + (tyvars, theta, ext_tyvars, ext_theta, arg_tys, _) = dataConSig con_id - eval_theta = [ (eval_clas,arg_ty) + eval_theta = [ (eval_clas, [arg_ty]) | (arg_ty, MarkedStrict) <- zipEqual "strict_args" - arg_tys strict_marks + arg_tys strict_marks ] in - tcSimplifyThetas classInstEnv theta eval_theta `thenTc` \ eval_theta' -> - checkTc (null eval_theta') - (missingEvalErr con_id eval_theta') + tcAddErrCtxt (evalCtxt con_id eval_theta) $ + tcSimplifyCheckThetas theta eval_theta \end{code} \begin{code} @@ -233,7 +224,7 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) -- Check that all the fields in the group have the same type -- This check assumes that all the constructors of a given -- data type use the same type variables - = checkTc (all (eqTy field_ty) other_tys) + = checkTc (all (== field_ty) other_tys) (fieldTypeMisMatch field_name) `thenTc_` returnTc selector_id where @@ -241,7 +232,7 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) field_name = fieldLabelName first_field_label other_tys = [fieldLabelType fl | (_, fl) <- other_fields] (tyvars, _, _, _, _, _) = dataConSig first_con - data_ty = applyTyCon tycon (mkTyVarTys tyvars) + data_ty = mkTyConApp tycon (mkTyVarTys tyvars) -- tyvars of first_con may be free in field_ty -- Now build the selector @@ -257,7 +248,7 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) Constructors ~~~~~~~~~~~~ \begin{code} -tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id +tcConDecl :: TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM s Id tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (VanillaCon btys) src_loc) = tcDataCon tycon tyvars ctxt name btys src_loc @@ -274,7 +265,7 @@ tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (NewCon ty) src_loc) [{- No labelled fields -}] tyvars ctxt - [] [] -- Temporary + [] [] -- Temporary; existential chaps [arg_ty] tycon in @@ -296,7 +287,7 @@ tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (RecCon fields) src_loc) field_labels tyvars (thinContext arg_tys ctxt) - [] [] -- Temporary + [] [] -- Temporary; existential chaps arg_tys tycon in @@ -319,7 +310,7 @@ tcDataCon tycon tyvars ctxt name btys src_loc [{- No field labels -}] tyvars (thinContext arg_tys ctxt) - [] [] -- Temporary + [] [] -- Temporary existential chaps arg_tys tycon in @@ -331,7 +322,8 @@ thinContext arg_tys ctxt = filter in_arg_tys ctxt where arg_tyvars = tyVarsOfTypes arg_tys - in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars + in_arg_tys (clas,tys) = not $ isEmptyTyVarSet $ + tyVarsOfTypes tys `intersectTyVarSets` arg_tyvars get_strictness (Banged _) = MarkedStrict get_strictness (Unbanged _) = NotMarkedStrict @@ -345,20 +337,20 @@ get_pty (Unbanged ty) = ty Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} -tySynCtxt tycon_name sty - = hsep [ptext SLIT("In the type declaration for"), ppr sty tycon_name] +tySynCtxt tycon_name + = hsep [ptext SLIT("In the type declaration for"), quotes (ppr tycon_name)] -tyDataCtxt tycon_name sty - = hsep [ptext SLIT("In the data declaration for"), ppr sty tycon_name] +tyDataCtxt tycon_name + = hsep [ptext SLIT("In the data declaration for"), quotes (ppr tycon_name)] -tyNewCtxt tycon_name sty - = hsep [ptext SLIT("In the newtype declaration for"), ppr sty tycon_name] +tyNewCtxt tycon_name + = hsep [ptext SLIT("In the newtype declaration for"), quotes (ppr tycon_name)] -fieldTypeMisMatch field_name sty - = sep [ptext SLIT("Declared types differ for field"), ppr sty field_name] +fieldTypeMisMatch field_name + = sep [ptext SLIT("Declared types differ for field"), quotes (ppr field_name)] -missingEvalErr con eval_theta sty - = hsep [ptext SLIT("Missing Eval context for constructor"), - ppr sty con, - char ':', ppr sty eval_theta] +evalCtxt con eval_theta + = hsep [ptext SLIT("When checking the Eval context for constructor:"), + ppr con, + text "::", ppr eval_theta] \end{code} diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 3c10a45ad6..2944d90d2d 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -1,19 +1,15 @@ \begin{code} -#include "HsVersions.h" - module TcType ( - SYN_IE(TcIdBndr), TcIdOcc(..), - - ----------------------------------------- - SYN_IE(TcTyVar), - SYN_IE(TcTyVarSet), + + TcTyVar, TcBox, + TcTyVarSet, newTcTyVar, newTyVarTy, -- Kind -> NF_TcM s (TcType s) newTyVarTys, -- Int -> Kind -> NF_TcM s [TcType s] ----------------------------------------- - SYN_IE(TcType), TcMaybe(..), - SYN_IE(TcTauType), SYN_IE(TcThetaType), SYN_IE(TcRhoType), + TcType, TcMaybe(..), + TcTauType, TcThetaType, TcRhoType, -- Find the type to which a type variable is bound tcWriteTyVar, -- :: TcTyVar s -> TcType s -> NF_TcM (TcType s) @@ -24,50 +20,49 @@ module TcType ( tcInstTyVars, tcInstSigTyVars, - tcInstType, tcInstSigType, tcInstTcType, tcInstSigTcType, - tcInstTheta, tcInstId, + tcInstType, + tcInstSigType, tcInstTcType, tcInstSigTcType, + tcInstTheta, zonkTcTyVars, zonkSigTyVar, - zonkTcType, zonkTcTheta, + zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcTypeToType, zonkTcTyVar, zonkTcTyVarToTyVar ) where +#include "HsVersions.h" -- friends: -import Type ( SYN_IE(Type), SYN_IE(ThetaType), GenType(..), - tyVarsOfTypes, getTyVar_maybe, - splitForAllTy, splitRhoTy, isTyVarTy, +import Type ( Type, ThetaType, GenType(..), mkAppTy, + tyVarsOfTypes, getTyVar_maybe, splitDictTy_maybe, + splitForAllTys, splitRhoTy, isTyVarTy, mkForAllTys, instantiateTy ) -import TyVar ( SYN_IE(TyVar), GenTyVar(..), SYN_IE(TyVarSet), SYN_IE(GenTyVarSet), - SYN_IE(TyVarEnv), lookupTyVarEnv, addOneToTyVarEnv, - nullTyVarEnv, mkTyVarEnv, +import TyVar ( TyVar, GenTyVar(..), TyVarSet, GenTyVarSet, + TyVarEnv, lookupTyVarEnv, addToTyVarEnv, + emptyTyVarEnv, mkTyVarEnv, zipTyVarEnv, tyVarSetToList ) -import PprType ( GenType, GenTyVar ) -- Instances only -- others: -import Class ( GenClass, SYN_IE(Class) ) +import Class ( Class ) import TyCon ( isFunTyCon ) -import Id ( idType, GenId, SYN_IE(Id) ) import Kind ( Kind ) import TcKind ( TcKind ) import TcMonad -import Usage ( SYN_IE(Usage), GenUsage, SYN_IE(UVar), duffUsage ) import TysPrim ( voidTy ) -IMP_Ubiq() import Name ( NamedThing(..) ) import Unique ( Unique ) import UniqFM ( UniqFM ) import Maybes ( assocMaybe ) -import Outputable ( Outputable(..) ) -import Util ( zipEqual, nOfThem, panic{-, pprPanic, pprTrace ToDo:rm-} ) +import BasicTypes ( unused ) +import Util ( zipEqual, nOfThem ) +import Outputable \end{code} @@ -75,58 +70,33 @@ import Util ( zipEqual, nOfThem, panic{-, pprPanic, pprTrace ToDo:rm-} ) Data types ~~~~~~~~~~ -\begin{code} -type TcIdBndr s = GenId (TcType s) -- Binders are all TcTypes -data TcIdOcc s = TcId (TcIdBndr s) -- Bindees may be either - | RealId Id - -instance Eq (TcIdOcc s) where - (TcId id1) == (TcId id2) = id1 == id2 - (RealId id1) == (RealId id2) = id1 == id2 - _ == _ = False - -instance Outputable (TcIdOcc s) where - ppr sty (TcId id) = ppr sty id - ppr sty (RealId id) = ppr sty id - -instance NamedThing (TcIdOcc s) where - getName (TcId id) = getName id - getName (RealId id) = getName id -\end{code} - \begin{code} -type TcType s = GenType (TcTyVar s) UVar -- Used during typechecker +type TcType s = GenType (TcBox s) -- Used during typechecker -- Invariant on ForAllTy in TcTypes: -- forall a. T -- a cannot occur inside a MutTyVar in T; that is, -- T is "flattened" before quantifying over a -type TcThetaType s = [(Class, TcType s)] +type TcThetaType s = [(Class, [TcType s])] type TcRhoType s = TcType s -- No ForAllTys type TcTauType s = TcType s -- No DictTys or ForAllTys -type Box s = MutableVar s (TcMaybe s) +type TcBox s = TcRef s (TcMaybe s) data TcMaybe s = UnBound | BoundTo (TcType s) - | DontBind -- This variant is used for tyvars - -- arising from type signatures, or - -- existentially quantified tyvars; - -- The idea is that we must not unify - -- such tyvars with anything except - -- themselves. -- Interestingly, you can't use (Maybe (TcType s)) instead of (TcMaybe s), -- because you get a synonym loop if you do! -type TcTyVar s = GenTyVar (Box s) -type TcTyVarSet s = GenTyVarSet (Box s) +type TcTyVar s = GenTyVar (TcBox s) +type TcTyVarSet s = GenTyVarSet (TcBox s) \end{code} \begin{code} tcTyVarToTyVar :: TcTyVar s -> TyVar -tcTyVarToTyVar (TyVar uniq kind name _) = TyVar uniq kind name duffUsage +tcTyVarToTyVar (TyVar uniq kind name _) = TyVar uniq kind name unused \end{code} Utility functions @@ -140,27 +110,28 @@ tcSplitForAllTy t = go t t [] where go syn_t (ForAllTy tv t) tvs = go t t (tv:tvs) - go syn_t (SynTy _ _ t) tvs = go syn_t t tvs + go syn_t (SynTy _ t) tvs = go syn_t t tvs go syn_t (TyVarTy tv) tvs = tcReadTyVar tv `thenNF_Tc` \ maybe_ty -> case maybe_ty of BoundTo ty | not (isTyVarTy ty) -> go syn_t ty tvs other -> returnNF_Tc (reverse tvs, syn_t) go syn_t t tvs = returnNF_Tc (reverse tvs, syn_t) -tcSplitRhoTy :: TcType s -> NF_TcM s ([(Class,TcType s)], TcType s) +tcSplitRhoTy :: TcType s -> NF_TcM s (TcThetaType s, TcType s) tcSplitRhoTy t = go t t [] where - go syn_t (FunTy (DictTy c t _) r _) ts = go r r ((c,t):ts) - go syn_t (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts - | isFunTyCon tycon - = go r r ((c,t):ts) - go syn_t (SynTy _ _ t) ts = go syn_t t ts - go syn_t (TyVarTy tv) ts = tcReadTyVar tv `thenNF_Tc` \ maybe_ty -> - case maybe_ty of - BoundTo ty | not (isTyVarTy ty) -> go syn_t ty ts - other -> returnNF_Tc (reverse ts, syn_t) - go syn_t t ts = returnNF_Tc (reverse ts, syn_t) + -- A type variable is never instantiated to a dictionary type, + -- so we don't need to do a tcReadVar on the "arg". + go syn_t (FunTy arg res) ts = case splitDictTy_maybe arg of + Just pair -> go res res (pair:ts) + Nothing -> returnNF_Tc (reverse ts, syn_t) + go syn_t (SynTy _ t) ts = go syn_t t ts + go syn_t (TyVarTy tv) ts = tcReadTyVar tv `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + BoundTo ty | not (isTyVarTy ty) -> go syn_t ty ts + other -> returnNF_Tc (reverse ts, syn_t) + go syn_t t ts = returnNF_Tc (reverse ts, syn_t) \end{code} @@ -183,28 +154,37 @@ newTyVarTys :: Int -> Kind -> NF_TcM s [TcType s] newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind) --- For signature type variables, mark them as "DontBind" +-- For signature type variables, use the user name for the type variable tcInstTyVars, tcInstSigTyVars :: [GenTyVar flexi] - -> NF_TcM s ([TcTyVar s], [TcType s], [(GenTyVar flexi, TcType s)]) + -> NF_TcM s ([TcTyVar s], [TcType s], TyVarEnv (TcType s)) -tcInstTyVars tyvars = inst_tyvars UnBound tyvars -tcInstSigTyVars tyvars = inst_tyvars DontBind tyvars +tcInstTyVars tyvars = inst_tyvars inst_tyvar tyvars +tcInstSigTyVars tyvars = inst_tyvars inst_sig_tyvar tyvars -inst_tyvars initial_cts tyvars - = mapNF_Tc (inst_tyvar initial_cts) tyvars `thenNF_Tc` \ tc_tyvars -> +inst_tyvars inst tyvars + = mapNF_Tc inst tyvars `thenNF_Tc` \ tc_tyvars -> let tys = map TyVarTy tc_tyvars in - returnNF_Tc (tc_tyvars, tys, zipEqual "inst_tyvars" tyvars tys) + returnNF_Tc (tc_tyvars, tys, zipTyVarEnv tyvars tys) -inst_tyvar initial_cts (TyVar _ kind name _) +inst_tyvar (TyVar _ kind name _) = tcGetUnique `thenNF_Tc` \ uniq -> - tcNewMutVar initial_cts `thenNF_Tc` \ box -> + tcNewMutVar UnBound `thenNF_Tc` \ box -> returnNF_Tc (TyVar uniq kind Nothing box) -- The "Nothing" means that it'll always print with its -- unique (or something similar). If we leave the original (Just Name) -- in there then error messages will say "can't match (T a) against (T a)" + +inst_sig_tyvar (TyVar _ kind name _) + = tcGetUnique `thenNF_Tc` \ uniq -> + + tcNewMutVar UnBound `thenNF_Tc` \ box -> + -- Was DontBind, but we've nuked that "optimisation" + + returnNF_Tc (TyVar uniq kind name box) + -- We propagate the name of the sigature type variable \end{code} @tcInstType@ and @tcInstSigType@ both create a fresh instance of a @@ -212,8 +192,8 @@ type, returning a @TcType@. All inner for-alls are instantiated with fresh TcTyVars. The difference is that tcInstType instantiates all forall'd type -variables (and their bindees) with UnBound type variables, whereas -tcInstSigType instantiates them with DontBind types variables. +variables (and their bindees) with anonymous type variables, whereas +tcInstSigType instantiates them with named type variables. @tcInstSigType@ also doesn't take an environment. On the other hand, @tcInstTcType@ instantiates a TcType. It uses @@ -236,27 +216,28 @@ tcInstSigTcType ty other -> tcInstSigTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) -> returnNF_Tc (tyvars', instantiateTy tenv rho) -tcInstType :: [(GenTyVar flexi,TcType s)] - -> GenType (GenTyVar flexi) UVar +tcInstType :: TyVarEnv (TcType s) + -> GenType flexi -> NF_TcM s (TcType s) tcInstType tenv ty_to_inst - = tcConvert bind_fn occ_fn (mkTyVarEnv tenv) ty_to_inst + = tcConvert bind_fn occ_fn tenv ty_to_inst where - bind_fn = inst_tyvar UnBound + bind_fn = inst_tyvar occ_fn env tyvar = case lookupTyVarEnv env tyvar of Just ty -> returnNF_Tc ty - Nothing -> panic "tcInstType:1" --(vcat [ppr PprDebug ty_to_inst, - -- ppr PprDebug tyvar]) + Nothing -> panic "tcInstType:1" --(vcat [ppr ty_to_inst, + -- ppr tyvar]) -tcInstSigType :: GenType (GenTyVar flexi) UVar -> NF_TcM s (TcType s) +tcInstSigType :: GenType flexi -> NF_TcM s (TcType s) tcInstSigType ty_to_inst - = tcConvert bind_fn occ_fn nullTyVarEnv ty_to_inst + = tcConvert bind_fn occ_fn emptyTyVarEnv ty_to_inst where - bind_fn = inst_tyvar DontBind + bind_fn = inst_sig_tyvar -- Note: inst_sig_tyvar, not inst_tyvar + -- I don't think that can lead to strange error messages occ_fn env tyvar = case lookupTyVarEnv env tyvar of Just ty -> returnNF_Tc ty - Nothing -> panic "tcInstType:2"-- (vcat [ppr PprDebug ty_to_inst, - -- ppr PprDebug tyvar]) + Nothing -> panic "tcInstType:2"-- (vcat [ppr ty_to_inst, + -- ppr tyvar]) zonkTcTyVarToTyVar :: TcTyVar s -> NF_TcM s TyVar zonkTcTyVarToTyVar tv @@ -265,7 +246,7 @@ zonkTcTyVarToTyVar tv TyVarTy tv' -> returnNF_Tc (tcTyVarToTyVar tv') - _ -> --pprTrace "zonkTcTyVarToTyVar:" (hsep [ppr PprDebug tv, ppr PprDebug tv_ty]) $ + _ -> --pprTrace "zonkTcTyVarToTyVar:" (hsep [ppr tv, ppr tv_ty]) $ returnNF_Tc (tcTyVarToTyVar tv) @@ -288,25 +269,20 @@ zonkTcTypeToType env ty tcConvert bind_fn occ_fn env ty_to_convert = doo env ty_to_convert where - doo env (TyConTy tycon usage) = returnNF_Tc (TyConTy tycon usage) + doo env (TyConApp tycon tys) = mapNF_Tc (doo env) tys `thenNF_Tc` \ tys' -> + returnNF_Tc (TyConApp tycon tys') - doo env (SynTy tycon tys ty) = mapNF_Tc (doo env) tys `thenNF_Tc` \ tys' -> - doo env ty `thenNF_Tc` \ ty' -> - returnNF_Tc (SynTy tycon tys' ty') + doo env (SynTy ty1 ty2) = doo env ty1 `thenNF_Tc` \ ty1' -> + doo env ty2 `thenNF_Tc` \ ty2' -> + returnNF_Tc (SynTy ty1' ty2') - doo env (FunTy arg res usage) = doo env arg `thenNF_Tc` \ arg' -> + doo env (FunTy arg res) = doo env arg `thenNF_Tc` \ arg' -> doo env res `thenNF_Tc` \ res' -> - returnNF_Tc (FunTy arg' res' usage) - + returnNF_Tc (FunTy arg' res') + doo env (AppTy fun arg) = doo env fun `thenNF_Tc` \ fun' -> doo env arg `thenNF_Tc` \ arg' -> - returnNF_Tc (AppTy fun' arg') - - doo env (DictTy clas ty usage)= doo env ty `thenNF_Tc` \ ty' -> - returnNF_Tc (DictTy clas ty' usage) - - doo env (ForAllUsageTy u us ty) = doo env ty `thenNF_Tc` \ ty' -> - returnNF_Tc (ForAllUsageTy u us ty') + returnNF_Tc (mkAppTy fun' arg') -- The two interesting cases! doo env (TyVarTy tv) = occ_fn env tv @@ -314,36 +290,18 @@ tcConvert bind_fn occ_fn env ty_to_convert doo env (ForAllTy tyvar ty) = bind_fn tyvar `thenNF_Tc` \ tyvar' -> let - new_env = addOneToTyVarEnv env tyvar (TyVarTy tyvar') + new_env = addToTyVarEnv env tyvar (TyVarTy tyvar') in doo new_env ty `thenNF_Tc` \ ty' -> returnNF_Tc (ForAllTy tyvar' ty') -tcInstTheta :: [(TyVar,TcType s)] -> ThetaType -> NF_TcM s (TcThetaType s) +tcInstTheta :: TyVarEnv (TcType s) -> ThetaType -> NF_TcM s (TcThetaType s) tcInstTheta tenv theta = mapNF_Tc go theta where - go (clas,ty) = tcInstType tenv ty `thenNF_Tc` \ tc_ty -> - returnNF_Tc (clas, tc_ty) - --- A useful function that takes an occurrence of a global thing --- and instantiates its type with fresh type variables -tcInstId :: Id - -> NF_TcM s ([TcTyVar s], -- It's instantiated type - TcThetaType s, -- - TcType s) -- - -tcInstId id - = let - (tyvars, rho) = splitForAllTy (idType id) - in - tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) -> - tcInstType tenv rho `thenNF_Tc` \ rho' -> - let - (theta', tau') = splitRhoTy rho' - in - returnNF_Tc (tyvars', theta', tau') + go (clas,tys) = mapNF_Tc (tcInstType tenv) tys `thenNF_Tc` \ tc_tys -> + returnNF_Tc (clas, tc_tys) \end{code} Reading and writing TcTyVars @@ -420,6 +378,15 @@ zonkSigTyVar tyvar BoundTo other -> panic "zonkSigTyVar" -- Should only be bound to another tyvar other -> returnNF_Tc tyvar +zonkTcTypes :: [TcType s] -> NF_TcM s [TcType s] +zonkTcTypes tys = mapNF_Tc zonkTcType tys + +zonkTcThetaType :: TcThetaType s -> NF_TcM s (TcThetaType s) +zonkTcThetaType theta = mapNF_Tc zonk theta + where + zonk (c,ts) = zonkTcTypes ts `thenNF_Tc` \ new_ts -> + returnNF_Tc (c, new_ts) + zonkTcType :: TcType s -> NF_TcM s (TcType s) zonkTcType (TyVarTy tyvar) = zonkTcTyVar tyvar @@ -427,41 +394,28 @@ zonkTcType (TyVarTy tyvar) = zonkTcTyVar tyvar zonkTcType (AppTy ty1 ty2) = zonkTcType ty1 `thenNF_Tc` \ ty1' -> zonkTcType ty2 `thenNF_Tc` \ ty2' -> - returnNF_Tc (AppTy ty1' ty2') - -zonkTcType (TyConTy tc u) - = returnNF_Tc (TyConTy tc u) + returnNF_Tc (mkAppTy ty1' ty2') -zonkTcType (SynTy tc tys ty) +zonkTcType (TyConApp tc tys) = mapNF_Tc zonkTcType tys `thenNF_Tc` \ tys' -> - zonkTcType ty `thenNF_Tc` \ ty' -> - returnNF_Tc (SynTy tc tys' ty') + returnNF_Tc (TyConApp tc tys') + +zonkTcType (SynTy ty1 ty2) + = zonkTcType ty1 `thenNF_Tc` \ ty1' -> + zonkTcType ty2 `thenNF_Tc` \ ty2' -> + returnNF_Tc (SynTy ty1' ty2') zonkTcType (ForAllTy tv ty) = zonkTcTyVar tv `thenNF_Tc` \ tv_ty -> zonkTcType ty `thenNF_Tc` \ ty' -> case tv_ty of -- Should be a tyvar! - TyVarTy tv' -> - returnNF_Tc (ForAllTy tv' ty') - _ -> --pprTrace "zonkTcType:ForAllTy:" (hsep [ppr PprDebug tv, ppr PprDebug tv_ty]) $ - - returnNF_Tc (ForAllTy tv{-(tcTyVarToTyVar tv)-} ty') - -zonkTcType (ForAllUsageTy uv uvs ty) - = panic "zonk:ForAllUsageTy" + TyVarTy tv' -> returnNF_Tc (ForAllTy tv' ty') + _ -> panic "zonkTcType" + -- pprTrace "zonkTcType:ForAllTy:" (hsep [ppr tv, ppr tv_ty]) $ + -- returnNF_Tc (ForAllTy tv{-(tcTyVarToTyVar tv)-} ty') -zonkTcType (FunTy ty1 ty2 u) +zonkTcType (FunTy ty1 ty2) = zonkTcType ty1 `thenNF_Tc` \ ty1' -> zonkTcType ty2 `thenNF_Tc` \ ty2' -> - returnNF_Tc (FunTy ty1' ty2' u) - -zonkTcType (DictTy c ty u) - = zonkTcType ty `thenNF_Tc` \ ty' -> - returnNF_Tc (DictTy c ty' u) - - -zonkTcTheta theta = mapNF_Tc zonk theta - where - zonk (c,t) = zonkTcType t `thenNF_Tc` \ t' -> - returnNF_Tc (c,t') + returnNF_Tc (FunTy ty1' ty2') \end{code} diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs index cca9e33055..c5a29fc3a2 100644 --- a/ghc/compiler/typecheck/Unify.lhs +++ b/ghc/compiler/typecheck/Unify.lhs @@ -7,37 +7,31 @@ The unifier is now squarely in the typechecker monad (because of the updatable substitution). \begin{code} -#include "HsVersions.h" - module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, - unifyFunTy, unifyListTy, unifyTupleTy + unifyFunTy, unifyListTy, unifyTupleTy, + Subst, unifyTysX, unifyTyListsX ) where -IMP_Ubiq() - +#include "HsVersions.h" -- friends: import TcMonad -import Type ( GenType(..), typeKind, mkFunTy, getFunTy_maybe, splitAppTys ) -import TyCon ( TyCon, mkFunTyCon, isTupleTyCon, tyConArity, SYN_IE(Arity) ) -import Class ( GenClass ) -import TyVar ( GenTyVar(..), SYN_IE(TyVar), tyVarKind ) -import TcType ( SYN_IE(TcType), TcMaybe(..), SYN_IE(TcTauType), SYN_IE(TcTyVar), +import Type ( GenType(..), Type, tyVarsOfType, + typeKind, mkFunTy, splitFunTy_maybe, splitAppTys, splitTyConApp_maybe ) +import TyCon ( TyCon, mkFunTyCon, isTupleTyCon, tyConArity, Arity ) +import TyVar ( GenTyVar(..), TyVar, tyVarKind, tyVarSetToList, + TyVarEnv, lookupTyVarEnv, emptyTyVarEnv, addToTyVarEnv + ) +import TcType ( TcType, TcMaybe(..), TcTauType, TcTyVar, newTyVarTy, tcReadTyVar, tcWriteTyVar, zonkTcType ) -- others: import Kind ( Kind, hasMoreBoxityInfo, mkTypeKind, mkBoxedTypeKind ) import TysWiredIn ( listTyCon, mkListTy, mkTupleTy ) -import Usage ( duffUsage ) -import PprType ( GenTyVar, GenType ) -- instances -import Pretty -import Unique ( Unique ) -- instances +import Maybes ( maybeToBool ) +import PprType () -- Instances import Util - -#if __GLASGOW_HASKELL__ >= 202 import Outputable -#endif - \end{code} @@ -103,54 +97,54 @@ uTys :: TcTauType s -> TcTauType s -- Error reporting ty1 and real ty1 -> TcTauType s -> TcTauType s -- Error reporting ty2 and real ty2 -> TcM s () + -- Always expand synonyms (see notes at end) +uTys ps_ty1 (SynTy _ ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2 +uTys ps_ty1 ty1 ps_ty2 (SynTy _ ty2) = uTys ps_ty1 ty1 ps_ty2 ty2 + -- Variables; go for uVar uTys ps_ty1 (TyVarTy tyvar1) ps_ty2 ty2 = uVar tyvar1 ps_ty2 ty2 uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar tyvar2 ps_ty1 ty1 - -- Applications and functions; just check the two parts -uTys _ (FunTy fun1 arg1 _) _ (FunTy fun2 arg2 _) + -- Functions; just check the two parts +uTys _ (FunTy fun1 arg1) _ (FunTy fun2 arg2) = uTys fun1 fun1 fun2 fun2 `thenTc_` uTys arg1 arg1 arg2 arg2 + -- Type constructors must match +uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2) + = checkTc (con1 == con2 && length tys1 == length tys2) + (unifyMisMatch ps_ty1 ps_ty2) `thenTc_` + unifyTauTyLists tys1 tys2 + + -- Applications need a bit of care! + -- They can match FunTy and TyConApp uTys _ (AppTy s1 t1) _ (AppTy s2 t2) = uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2 - -- Special case: converts a -> b to (->) a b -uTys _ (AppTy s1 t1) _ (FunTy fun2 arg2 _) +uTys _ (AppTy s1 t1) _ (FunTy fun2 arg2) = uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2 where - s2 = AppTy (TyConTy mkFunTyCon duffUsage) fun2 + -- Converts a -> b to (->) a b + s2 = TyConApp mkFunTyCon [fun2] t2 = arg2 -uTys _ (FunTy fun1 arg1 _) _ (AppTy s2 t2) - = uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2 - where - s1 = AppTy (TyConTy mkFunTyCon duffUsage) fun1 - t1 = arg1 - - -- Type constructors must match -uTys ps_ty1 (TyConTy con1 _) ps_ty2 (TyConTy con2 _) - = checkTc (con1 == con2) (unifyMisMatch ps_ty1 ps_ty2) - - -- Dictionary types must match. (They can only occur when - -- unifying signature contexts in TcBinds.) -uTys ps_ty1 (DictTy c1 t1 _) ps_ty2 (DictTy c2 t2 _) - = checkTc (c1 == c2) (unifyMisMatch ps_ty1 ps_ty2) `thenTc_` - uTys t1 t1 t2 t2 +uTys _ (AppTy s1 t1) _ (TyConApp tc tys@(_:_)) + = case snocView tys of + (ts2, t2) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2 + where + -- Not efficient, but simple + s2 = TyConApp tc ts2 - -- Always expand synonyms (see notes at end) -uTys ps_ty1 (SynTy con1 args1 ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2 -uTys ps_ty1 ty1 ps_ty2 (SynTy con2 args2 ty2) = uTys ps_ty1 ty1 ps_ty2 ty2 +uTys ps1 s1 ps2 s2@(AppTy _ _) = uTys ps2 s2 ps1 s1 + -- Swap arguments if the App is in the second argument -- Not expecting for-alls in unification #ifdef DEBUG uTys ps_ty1 (ForAllTy _ _) ps_ty2 ty2 = panic "Unify.uTys:ForAllTy (1st arg)" uTys ps_ty1 ty1 ps_ty2 (ForAllTy _ _) = panic "Unify.uTys:ForAllTy (2nd arg)" -uTys ps_ty1 (ForAllUsageTy _ _ _) ps_ty2 ty2 = panic "Unify.uTys:ForAllUsageTy (1st arg)" -uTys ps_ty1 ty1 ps_ty2 (ForAllUsageTy _ _ _) = panic "Unify.uTys:ForAllUsageTy (2nd arg)" #endif -- Anything else fails -uTys ps_ty1 ty1 ps_ty2 ty2 = failTc (unifyMisMatch ps_ty1 ps_ty2) +uTys ps_ty1 ty1 ps_ty2 ty2 = failWithTc (unifyMisMatch ps_ty1 ps_ty2) \end{code} Notes on synonyms @@ -233,7 +227,7 @@ uVar tv1 ps_ty2 ty2 other -> uUnboundVar tv1 maybe_ty1 ps_ty2 ty2 -- Expand synonyms -uUnboundVar tv1 maybe_ty1 ps_ty2 (SynTy _ _ ty2) +uUnboundVar tv1 maybe_ty1 ps_ty2 (SynTy _ ty2) = uUnboundVar tv1 maybe_ty1 ps_ty2 ty2 @@ -251,58 +245,44 @@ uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) -- ASSERT maybe_ty1 /= BoundTo | otherwise = tcReadTyVar tv2 `thenNF_Tc` \ maybe_ty2 -> - case (maybe_ty1, maybe_ty2) of - (_, BoundTo ty2') -> uUnboundVar tv1 maybe_ty1 ty2' ty2' + case maybe_ty2 of + BoundTo ty2' -> uUnboundVar tv1 maybe_ty1 ty2' ty2' - (UnBound, _) | kind2 `hasMoreBoxityInfo` kind1 - -> tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_` returnTc () + UnBound | (kind1 == kind2 && not (maybeToBool name1)) -- Same kinds and tv1 is anonymous + -- so update tv1 + -> tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_` returnTc () - (_, UnBound) | kind1 `hasMoreBoxityInfo` kind2 - -> tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc () + | kind1 `hasMoreBoxityInfo` kind2 -- Update tv2 if possible + -> tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc () --- Allow two type-sig variables to be bound together. --- They may be from the same binding group, so it may be OK. - (DontBind,DontBind) | kind2 `hasMoreBoxityInfo` kind1 - -> tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_` returnTc () + | kind2 `hasMoreBoxityInfo` kind1 -- Update tv1 if possible + -> tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_` returnTc () - | kind1 `hasMoreBoxityInfo` kind2 - -> tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc () - - other -> failTc (unifyKindErr tv1 ps_ty2) + other -> failWithTc (unifyKindErr tv1 ps_ty2) -- Second one isn't a type variable uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) maybe_ty1 ps_ty2 non_var_ty2 - = case maybe_ty1 of - DontBind -> failTc (unifyDontBindErr tv1 ps_ty2) + | typeKind non_var_ty2 `hasMoreBoxityInfo` kind1 + = occur_check non_var_ty2 `thenTc_` + tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_` + returnTc () - UnBound | typeKind non_var_ty2 `hasMoreBoxityInfo` kind1 - -> occur_check non_var_ty2 `thenTc_` - tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_` - returnTc () + | otherwise + = failWithTc (unifyKindErr tv1 ps_ty2) - other -> failTc (unifyKindErr tv1 ps_ty2) where - occur_check (TyVarTy tv2@(TyVar uniq2 _ _ box2)) + occur_check ty = mapTc occur_check_tv (tyVarSetToList (tyVarsOfType ty)) `thenTc_` + returnTc () + + occur_check_tv tv2@(TyVar uniq2 _ _ box2) | uniq1 == uniq2 -- Same tyvar; fail - = failTc (unifyOccurCheck tv1 ps_ty2) + = failWithTc (unifyOccurCheck tv1 ps_ty2) | otherwise -- A different tyvar = tcReadTyVar tv2 `thenNF_Tc` \ maybe_ty2 -> case maybe_ty2 of BoundTo ty2' -> occur_check ty2' other -> returnTc () - - occur_check (AppTy fun arg) = occur_check fun `thenTc_` occur_check arg - occur_check (FunTy fun arg _) = occur_check fun `thenTc_` occur_check arg - occur_check (TyConTy _ _) = returnTc () - occur_check (SynTy _ _ ty2) = occur_check ty2 - - -- DictTys and ForAllTys can occur when pattern matching against - -- constructors with universally quantified fields. - occur_check (DictTy c ty2 _) = occur_check ty2 - occur_check (ForAllTy tv ty2) | tv == tv1 = returnTc () - | otherwise = occur_check ty2 - occur_check other = panic "Unexpected ForAllUsage in occurCheck" \end{code} %************************************************************************ @@ -324,7 +304,7 @@ unifyFunTy ty@(TyVarTy tyvar) other -> unify_fun_ty_help ty unifyFunTy ty - = case getFunTy_maybe ty of + = case splitFunTy_maybe ty of Just arg_and_res -> returnTc arg_and_res Nothing -> unify_fun_ty_help ty @@ -345,11 +325,10 @@ unifyListTy ty@(TyVarTy tyvar) BoundTo ty' -> unifyListTy ty' other -> unify_list_ty_help ty -unifyListTy (AppTy (TyConTy tycon _) arg_ty) - | tycon == listTyCon - = returnTc arg_ty - -unifyListTy ty = unify_list_ty_help ty +unifyListTy ty + = case splitTyConApp_maybe ty of + Just (tycon, [arg_ty]) | tycon == listTyCon -> returnTc arg_ty + other -> unify_list_ty_help ty unify_list_ty_help ty -- Revert to ordinary unification = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ elt_ty -> @@ -366,10 +345,10 @@ unifyTupleTy arity ty@(TyVarTy tyvar) other -> unify_tuple_ty_help arity ty unifyTupleTy arity ty - = case splitAppTys ty of - (TyConTy tycon _, arg_tys) | isTupleTyCon tycon - && tyConArity tycon == arity - -> returnTc arg_tys + = case splitTyConApp_maybe ty of + Just (tycon, arg_tys) | isTupleTyCon tycon + && tyConArity tycon == arity + -> returnTc arg_tys other -> unify_tuple_ty_help arity ty unify_tuple_ty_help arity ty @@ -380,6 +359,106 @@ unify_tuple_ty_help arity ty %************************************************************************ %* * +\subsection{Unification wih a explicit substitution} +%* * +%************************************************************************ + +Unify types with an explicit substitution and no monad. + +\begin{code} +type Subst = TyVarEnv Type -- Not necessarily idempotent + +unifyTysX :: Type -> Type -> Maybe Subst +unifyTysX ty1 ty2 = uTysX ty1 ty2 (\s -> Just s) emptyTyVarEnv + +unifyTyListsX :: [Type] -> [Type] -> Maybe Subst +unifyTyListsX tys1 tys2 = uTyListsX tys1 tys2 (\s -> Just s) emptyTyVarEnv + + +uTysX :: Type -> Type + -> (Subst -> Maybe Subst) + -> Subst + -> Maybe Subst + +uTysX ty1 (SynTy _ ty2) k subst = uTysX ty1 ty2 k subst + + -- Variables; go for uVar +uTysX (TyVarTy tyvar1) ty2 k subst = uVarX tyvar1 ty2 k subst +uTysX ty1 (TyVarTy tyvar2) k subst = uVarX tyvar2 ty1 k subst + + -- Functions; just check the two parts +uTysX (FunTy fun1 arg1) (FunTy fun2 arg2) k subst + = uTysX fun1 fun2 (uTysX arg1 arg2 k) subst + + -- Type constructors must match +uTysX (TyConApp con1 tys1) (TyConApp con2 tys2) k subst + | (con1 == con2 && length tys1 == length tys2) + = uTyListsX tys1 tys2 k subst + + -- Applications need a bit of care! + -- They can match FunTy and TyConApp +uTysX (AppTy s1 t1) (AppTy s2 t2) k subst + = uTysX s1 s2 (uTysX t1 t2 k) subst + +uTysX (AppTy s1 t1) (FunTy fun2 arg2) k subst + = uTysX s1 s2 (uTysX t1 t2 k) subst + where + -- Converts a -> b to (->) a b + s2 = TyConApp mkFunTyCon [fun2] + t2 = arg2 + +uTysX (AppTy s1 t1) (TyConApp tc tys@(_:_)) k subst + = case snocView tys of + (ts2, t2) -> uTysX s1 s2 (uTysX t1 t2 k) subst + where + -- Not efficient, but simple + s2 = TyConApp tc ts2 + +uTysX s1 s2@(AppTy _ _) k subst = uTysX s2 s1 k subst + -- Swap arguments if the App is in the second argument + + -- Not expecting for-alls in unification +#ifdef DEBUG +uTysX (ForAllTy _ _) ty2 k subst = panic "Unify.uTysX subst:ForAllTy (1st arg)" +uTysX ty1 (ForAllTy _ _) k subst = panic "Unify.uTysX subst:ForAllTy (2nd arg)" +#endif + + -- Anything else fails +uTysX ty1 ty2 k subst = Nothing + + +uTyListsX [] [] k subst = k subst +uTyListsX (ty1:tys1) (ty2:tys2) k subst = uTysX ty1 ty2 (uTyListsX tys1 tys2 k) subst +uTyListsX tys1 tys2 k subst = Nothing -- Fail if the lists are different lengths +\end{code} + +\begin{code} +uVarX tv1 (TyVarTy tv2) k subst | tv1 == tv2 = k subst + -- Binding a variable to itself is a no-op + +uVarX tv1 ty2 k subst + = case lookupTyVarEnv subst tv1 of + Just ty1 -> -- Already bound + uTysX ty1 ty2 k subst + + Nothing -- Not already bound + | typeKind ty2 `hasMoreBoxityInfo` tyVarKind tv1 + && occur_check_ok ty2 + -> -- No kind mismatch nor occur check + k (addToTyVarEnv subst tv1 ty2) + + | otherwise -> Nothing -- Fail if kind mis-match or occur check + where + occur_check_ok ty = all occur_check_ok_tv (tyVarSetToList (tyVarsOfType ty)) + occur_check_ok_tv tv | tv1 == tv = False + | otherwise = case lookupTyVarEnv subst tv of + Nothing -> True + Just ty -> occur_check_ok ty +\end{code} + + +%************************************************************************ +%* * \subsection[Unify-context]{Errors and contexts} %* * %************************************************************************ @@ -393,33 +472,27 @@ unifyCtxt ty1 ty2 -- ty1 expected, ty2 inferred zonkTcType ty2 `thenNF_Tc` \ ty2' -> returnNF_Tc (err ty1' ty2') where - err ty1' ty2' sty = vcat [ - hsep [ptext SLIT("Expected:"), ppr sty ty1'], - hsep [ptext SLIT("Inferred:"), ppr sty ty2'] + err ty1' ty2' = vcat [ + hsep [ptext SLIT("Expected:"), ppr ty1'], + hsep [ptext SLIT("Inferred:"), ppr ty2'] ] -unifyMisMatch ty1 ty2 sty +unifyMisMatch ty1 ty2 = hang (ptext SLIT("Couldn't match the type")) - 4 (sep [ppr sty ty1, ptext SLIT("against"), ppr sty ty2]) + 4 (sep [quotes (ppr ty1), ptext SLIT("against"), quotes (ppr ty2)]) -expectedFunErr ty sty +expectedFunErr ty = hang (text "Function type expected, but found the type") - 4 (ppr sty ty) + 4 (ppr ty) -unifyKindErr tyvar ty sty +unifyKindErr tyvar ty = hang (ptext SLIT("Compiler bug: kind mis-match between")) - 4 (sep [hsep [ppr sty tyvar, ptext SLIT("::"), ppr sty (tyVarKind tyvar)], - ptext SLIT("and"), - hsep [ppr sty ty, ptext SLIT("::"), ppr sty (typeKind ty)]]) - -unifyDontBindErr tyvar ty sty - = hang (ptext SLIT("Couldn't match the signature/existential type variable")) - 4 (sep [ppr sty tyvar, - ptext SLIT("with the type"), - ppr sty ty]) - -unifyOccurCheck tyvar ty sty - = hang (ptext SLIT("Cannot construct the infinite type (occur check)")) - 4 (sep [ppr sty tyvar, char '=', ppr sty ty]) + 4 (sep [quotes (hsep [ppr tyvar, ptext SLIT("::"), ppr (tyVarKind tyvar)]), + ptext SLIT("and"), + quotes (hsep [ppr ty, ptext SLIT("::"), ppr (typeKind ty)])]) + +unifyOccurCheck tyvar ty + = hang (ptext SLIT("Occurs check: cannot construct the infinite type:")) + 8 (sep [ppr tyvar, char '=', ppr ty]) \end{code} diff --git a/ghc/compiler/types/Class.hi-boot b/ghc/compiler/types/Class.hi-boot index fa446a153d..94c6e7ea4a 100644 --- a/ghc/compiler/types/Class.hi-boot +++ b/ghc/compiler/types/Class.hi-boot @@ -3,5 +3,5 @@ _exports_ Class Class GenClass; _instances_ _declarations_ -1 type Class = Class.GenClass TyVar.TyVar Usage.UVar; -1 data GenClass a b; +1 type Class = Class.GenClass BasicTypes.Unused ; +1 data GenClass a; diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 3f0520f307..6845415e8f 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -4,45 +4,30 @@ \section[Class]{The @Class@ datatype} \begin{code} -#include "HsVersions.h" - module Class ( - GenClass(..), SYN_IE(Class), + Class, mkClass, - classKey, classSelIds, classDictArgTys, - classSuperDictSelId, classDefaultMethodId, + classKey, classSelIds, classTyCon, + classSuperClassTheta, classBigSig, classInstEnv, - isSuperClassOf, - SYN_IE(ClassInstEnv) + ClassInstEnv ) where -CHK_Ubiq() -- debugging consistency check +#include "HsVersions.h" -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(TyLoop) -IMPORT_DELOOPER(IdLoop) -#else import {-# SOURCE #-} Id ( Id, idType, idName ) -import {-# SOURCE #-} Type -import {-# SOURCE #-} TysWiredIn -import {-# SOURCE #-} TysPrim -#endif - -#if __GLASGOW_HASKELL__ >= 202 -import Name -#endif +import {-# SOURCE #-} TyCon ( TyCon ) +import {-# SOURCE #-} Type ( Type ) +import {-# SOURCE #-} SpecEnv ( SpecEnv ) import TyCon ( TyCon ) -import TyVar ( SYN_IE(TyVar), GenTyVar ) -import Usage ( GenUsage, SYN_IE(Usage), SYN_IE(UVar) ) - -import MatchEnv ( MatchEnv ) +import TyVar ( TyVar ) import Maybes ( assocMaybe ) -import Name ( changeUnique, Name, OccName, occNameString ) -import Unique -- Keys for built-in classes -import Pretty ( Doc, hsep, ptext ) +import Name ( NamedThing(..), Name, getOccName ) +import Unique ( Unique, Uniquable(..) ) +import BasicTypes ( Unused ) import SrcLoc ( SrcLoc ) import Outputable import Util @@ -56,71 +41,49 @@ import Util A @Class@ corresponds to a Greek kappa in the static semantics: -The parameterisation wrt tyvar and uvar is only necessary to -get appropriately general instances of Ord3 for GenType. - \begin{code} -data GenClass tyvar uvar +data Class = Class Unique -- Key for fast comparison Name - tyvar -- The class type variable + [TyVar] -- The class type variables - [GenClass tyvar uvar] -- Immediate superclasses, and the + [(Class,[Type])] -- Immediate superclasses, and the [Id] -- corresponding selector functions to -- extract them from a dictionary of this -- class - [Id] -- * selector functions - [Maybe Id] -- * default methods - -- They are all ordered by tag. The - -- selector ids are less innocent than they - -- look, because their IdInfos contains - -- suitable specialisation information. In - -- particular, constant methods are - -- instances of selectors at suitably simple - -- types. - - ClassInstEnv -- Gives details of all the instances of this class - - [(GenClass tyvar uvar, [GenClass tyvar uvar])] - -- Indirect superclasses; - -- (k,[k1,...,kn]) means that - -- k is an immediate superclass of k1 - -- k1 is an immediate superclass of k2 - -- ... and kn is an immediate superclass - -- of this class. (This is all redundant - -- information, since it can be derived from - -- the superclass information above.) - -type Class = GenClass TyVar UVar - -type ClassInstEnv = MatchEnv Type Id -- The Ids are dfuns + [Id] -- * selector functions + [Maybe Id] -- * default methods + -- They are all ordered by tag. The + -- selector ids contain unfoldings. + + ClassInstEnv -- All the instances of this class + + TyCon -- The data type constructor for dictionaries + -- of this class + +type ClassInstEnv = SpecEnv Id -- The Ids are dfuns \end{code} The @mkClass@ function fills in the indirect superclasses. \begin{code} -mkClass :: Unique -> Name -> TyVar - -> [Class] -> [Id] +mkClass :: Name -> [TyVar] + -> [(Class,[Type])] -> [Id] -> [Id] -> [Maybe Id] + -> TyCon -> ClassInstEnv -> Class -mkClass uniq full_name tyvar super_classes superdict_sels - dict_sels defms class_insts - = Class uniq (changeUnique full_name uniq) tyvar - super_classes superdict_sels - dict_sels defms - class_insts - trans_clos - where - trans_clos :: [(Class,[Class])] - trans_clos = transitiveClosure succ (==) [ (clas, []) | clas <- super_classes ] - - succ (clas@(Class _ _ _ super_classes _ _ _ _ _), links) - = [(super, (clas:links)) | super <- super_classes] +mkClass name tyvars super_classes superdict_sels + dict_sels defms tycon class_insts + = Class (uniqueOf name) name tyvars + super_classes superdict_sels + dict_sels defms + class_insts + tycon \end{code} %************************************************************************ @@ -132,38 +95,16 @@ mkClass uniq full_name tyvar super_classes superdict_sels The rest of these functions are just simple selectors. \begin{code} -classKey (Class key _ _ _ _ _ _ _ _) = key -classSelIds (Class _ _ _ _ _ sels _ _ _) = sels - -classDefaultMethodId (Class _ _ _ _ _ _ defm_ids _ _) idx - = defm_ids !! idx - -classSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _) super_clas - = assoc "classSuperDictSelId" (scs `zip` scsel_ids) super_clas - -classBigSig (Class _ _ tyvar super_classes sdsels sels defms _ _) - = (tyvar, super_classes, sdsels, sels, defms) - -classInstEnv (Class _ _ _ _ _ _ _ inst_env _) = inst_env - -classDictArgTys :: Class -> Type -> [Type] -- Types of components of the dictionary (C ty) -classDictArgTys (Class _ _ _ _ sc_sel_ids meth_sel_ids _ _ _) ty - = map mk_arg_ty (sc_sel_ids ++ meth_sel_ids) - where - mk_arg_ty id = case splitRhoTy (applyTy (idType id) ty) of - (sel_theta, meth_ty) -> ASSERT( length sel_theta == 1 ) - meth_ty +classKey (Class key _ _ _ _ _ _ _ _) = key +classSuperClassTheta (Class _ _ _ scs _ _ _ _ _) = scs +classSelIds (Class _ _ _ _ _ sels _ _ _) = sels +classTyCon (Class _ _ _ _ _ _ _ _ tc) = tc +classInstEnv (Class _ _ _ _ _ _ _ env _) = env + +classBigSig (Class _ _ tyvars super_classes sdsels sels defms _ _) + = (tyvars, super_classes, sdsels, sels, defms) \end{code} -@a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of -@b@, but if it is, it returns $@Just@~[k_1,\ldots,k_n]$, where the -$k_1,\ldots,k_n$ are exactly as described in the definition of the -@GenClass@ constructor above. - -\begin{code} -isSuperClassOf :: Class -> Class -> Maybe [Class] -clas `isSuperClassOf` (Class _ _ _ _ _ _ _ _ links) = assocMaybe links clas -\end{code} %************************************************************************ %* * @@ -174,26 +115,23 @@ clas `isSuperClassOf` (Class _ _ _ _ _ _ _ _ links) = assocMaybe links clas We compare @Classes@ by their keys (which include @Uniques@). \begin{code} -instance Ord3 (GenClass tyvar uvar) where - cmp (Class k1 _ _ _ _ _ _ _ _) (Class k2 _ _ _ _ _ _ _ _) = cmp k1 k2 - -instance Eq (GenClass tyvar uvar) where - (Class k1 _ _ _ _ _ _ _ _) == (Class k2 _ _ _ _ _ _ _ _) = k1 == k2 - (Class k1 _ _ _ _ _ _ _ _) /= (Class k2 _ _ _ _ _ _ _ _) = k1 /= k2 - -instance Ord (GenClass tyvar uvar) where - (Class k1 _ _ _ _ _ _ _ _) <= (Class k2 _ _ _ _ _ _ _ _) = k1 <= k2 - (Class k1 _ _ _ _ _ _ _ _) < (Class k2 _ _ _ _ _ _ _ _) = k1 < k2 - (Class k1 _ _ _ _ _ _ _ _) >= (Class k2 _ _ _ _ _ _ _ _) = k1 >= k2 - (Class k1 _ _ _ _ _ _ _ _) > (Class k2 _ _ _ _ _ _ _ _) = k1 > k2 - _tagCmp a b = case cmp a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } +instance Eq Class where + c1 == c2 = classKey c1 == classKey c2 + c1 /= c2 = classKey c1 /= classKey c2 + +instance Ord Class where + c1 <= c2 = classKey c1 <= classKey c2 + c1 < c2 = classKey c1 < classKey c2 + c1 >= c2 = classKey c1 >= classKey c2 + c1 > c2 = classKey c1 > classKey c2 + compare c1 c2 = classKey c1 `compare` classKey c2 \end{code} \begin{code} -instance Uniquable (GenClass tyvar uvar) where - uniqueOf (Class u _ _ _ _ _ _ _ _) = u +instance Uniquable Class where + uniqueOf c = classKey c -instance NamedThing (GenClass tyvar uvar) where +instance NamedThing Class where getName (Class _ n _ _ _ _ _ _ _) = n \end{code} diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs index 6d6e8a39d7..d4fe4a3981 100644 --- a/ghc/compiler/types/Kind.lhs +++ b/ghc/compiler/types/Kind.lhs @@ -4,10 +4,9 @@ \section[Kind]{The @Kind@ datatype} \begin{code} -#include "HsVersions.h" - module Kind ( - Kind(..), -- Only visible to friends: TcKind + GenKind(..), -- Only visible to friends: TcKind + Kind, mkArrowKind, mkTypeKind, @@ -19,44 +18,53 @@ module Kind ( pprKind, pprParendKind, - isUnboxedTypeKind, isTypeKind, isBoxedTypeKind, - notArrowKind + isUnboxedTypeKind, isTypeKind, isBoxedTypeKind ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import Util ( panic, assertPanic ) - -import Outputable ( Outputable(..), pprQuote ) -import Pretty +import Unique ( Unique, pprUnique ) +import BasicTypes ( Unused ) +import Outputable \end{code} \begin{code} -data Kind +data GenKind flexi = TypeKind -- Any type (incl unboxed types) | BoxedTypeKind -- Any boxed type | UnboxedTypeKind -- Any unboxed type - | ArrowKind Kind Kind - deriving Eq + | ArrowKind (GenKind flexi) (GenKind flexi) + | VarKind Unique flexi + +type Kind = GenKind Unused -- No variables at all + +instance Eq (GenKind flexi) where + TypeKind == TypeKind = True + BoxedTypeKind == BoxedTypeKind = True + UnboxedTypeKind == UnboxedTypeKind = True + (ArrowKind j1 j2) == (ArrowKind k1 k2) = j1==k1 && j2==k2 + (VarKind u1 _) == (VarKind u2 _) = u1==u2 + k1 == k2 = False mkArrowKind = ArrowKind mkTypeKind = TypeKind mkUnboxedTypeKind = UnboxedTypeKind mkBoxedTypeKind = BoxedTypeKind -isTypeKind :: Kind -> Bool +isTypeKind :: GenKind flexi -> Bool isTypeKind TypeKind = True isTypeKind other = False -isBoxedTypeKind :: Kind -> Bool +isBoxedTypeKind :: GenKind flexi -> Bool isBoxedTypeKind BoxedTypeKind = True isBoxedTypeKind other = False -isUnboxedTypeKind :: Kind -> Bool +isUnboxedTypeKind :: GenKind flexi -> Bool isUnboxedTypeKind UnboxedTypeKind = True isUnboxedTypeKind other = False -hasMoreBoxityInfo :: Kind -> Kind -> Bool +hasMoreBoxityInfo :: GenKind flexi -> GenKind flexi -> Bool BoxedTypeKind `hasMoreBoxityInfo` TypeKind = True BoxedTypeKind `hasMoreBoxityInfo` BoxedTypeKind = True @@ -66,22 +74,21 @@ UnboxedTypeKind `hasMoreBoxityInfo` UnboxedTypeKind = True TypeKind `hasMoreBoxityInfo` TypeKind = True -kind1@(ArrowKind _ _) `hasMoreBoxityInfo` kind2@(ArrowKind _ _) = ASSERT( kind1 == kind2 ) - True +kind1@(ArrowKind _ _) `hasMoreBoxityInfo` kind2@(ArrowKind _ _) + = ASSERT( if kind1 == kind2 then True + else pprPanic "hadMoreBoxityInfo" (ppr kind1 <> comma <+> ppr kind2) ) + True -- The two kinds can be arrow kinds; for example when unifying -- (m1 Int) and (m2 Int) we end up unifying m1 and m2, which should -- have the same kind. kind1 `hasMoreBoxityInfo` kind2 = False -notArrowKind (ArrowKind _ _) = False -notArrowKind other_kind = True - -resultKind :: Kind -> Kind -- Get result from arrow kind +resultKind :: GenKind flexi -> GenKind flexi -- Get result from arrow kind resultKind (ArrowKind _ res_kind) = res_kind resultKind other_kind = panic "resultKind" -argKind :: Kind -> Kind -- Get argument from arrow kind +argKind :: GenKind flexi -> GenKind flexi -- Get argument from arrow kind argKind (ArrowKind arg_kind _) = arg_kind argKind other_kind = panic "argKind" \end{code} @@ -89,13 +96,14 @@ argKind other_kind = panic "argKind" Printing ~~~~~~~~ \begin{code} -instance Outputable Kind where - ppr sty kind = pprQuote sty $ \ _ -> pprKind kind +instance Outputable (GenKind flexi) where + ppr kind = pprKind kind -pprKind TypeKind = text "**" -- Can be boxed or unboxed -pprKind BoxedTypeKind = char '*' -pprKind UnboxedTypeKind = text "*#" -- Unboxed +pprKind TypeKind = text "**" -- Can be boxed or unboxed +pprKind BoxedTypeKind = char '*' +pprKind UnboxedTypeKind = text "*#" -- Unboxed pprKind (ArrowKind k1 k2) = sep [pprParendKind k1, text "->", pprKind k2] +pprKind (VarKind u _) = char 'k' <> pprUnique u pprParendKind k@(ArrowKind _ _) = parens (pprKind k) pprParendKind k = pprKind k diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 051ad922cb..3762e632a7 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -4,85 +4,66 @@ \section[PprType]{Printing Types, TyVars, Classes, TyCons} \begin{code} -#include "HsVersions.h" - module PprType( - GenTyVar, pprGenTyVar, pprTyVarBndr, + GenTyVar, pprGenTyVar, pprTyVarBndr, pprTyVarBndrs, TyCon, pprTyCon, showTyCon, GenType, pprGenType, pprParendGenType, pprType, pprParendType, pprMaybeTy, - getTypeString, - specMaybeTysSuffix, getTyDescription, - GenClass, + pprConstraint, pprTheta, nmbrType, nmbrGlobalType ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(IdLoop) -#else -import {-# SOURCE #-} Id -#endif - +#include "HsVersions.h" -- friends: -- (PprType can see all the representations it's trying to print) -import Type ( GenType(..), maybeAppTyCon, Type(..), splitFunTy, - splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTys ) -import TyVar ( GenTyVar(..), TyVar(..), cloneTyVar ) +import Type ( GenType(..), Type, ThetaType, splitFunTys, splitDictTy_maybe, + splitForAllTys, splitSigmaTy, splitRhoTy, splitAppTys ) +import TyVar ( GenTyVar(..), TyVar, cloneTyVar ) import TyCon ( TyCon, NewOrData, isFunTyCon, isTupleTyCon, tyConArity ) -import Class ( SYN_IE(Class), GenClass(..) ) -import Kind ( Kind(..), isBoxedTypeKind, pprParendKind ) -import Usage ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar), cloneUVar ) +import Class ( Class ) +import Kind ( GenKind(..), isBoxedTypeKind, pprParendKind ) -- others: -import CStrings ( identToC ) -import CmdLineOpts ( opt_OmitInterfacePragmas, opt_PprUserLength ) +import CmdLineOpts ( opt_PprUserLength ) import Maybes ( maybeToBool ) -import Name ( nameString, Name{-instance Outputable-}, - OccName, pprOccName, getOccString, NamedThing(..) - ) -import Outputable ( PprStyle(..), codeStyle, userStyle, ifaceStyle, - ifPprShowAll, interpp'SP, Outputable(..) - ) +import Name ( nameString, pprOccName, getOccString, OccName, NamedThing(..) ) +import Outputable import PprEnv -import Pretty +import BasicTypes ( Unused ) import UniqFM ( UniqFM, addToUFM, emptyUFM, lookupUFM ) -import Unique ( Unique, Uniquable(..), pprUnique10, pprUnique, +import Unique ( Unique, Uniquable(..), pprUnique, incrUnique, listTyConKey, initTyVarUnique ) import Util \end{code} \begin{code} -instance (Eq tyvar, Outputable tyvar, - Eq uvar, Outputable uvar ) => Outputable (GenType tyvar uvar) where - ppr PprQuote ty = quotes (pprGenType (PprForUser opt_PprUserLength) ty) - ppr sty ty = pprGenType sty ty +instance Outputable (GenType flexi) where + ppr ty = pprGenType ty instance Outputable TyCon where - ppr sty tycon = pprTyCon sty tycon + ppr tycon = pprTyCon tycon -instance Outputable (GenClass tyvar uvar) where +instance Outputable Class where -- we use pprIfaceClass for printing in interfaces - ppr sty (Class u n _ _ _ _ _ _ _) = ppr sty n + ppr clas = ppr (getName clas) instance Outputable (GenTyVar flexi) where - ppr PprQuote ty = quotes (pprGenTyVar (PprForUser opt_PprUserLength) ty) - ppr sty tv = pprGenTyVar sty tv + ppr tv = pprGenTyVar tv -- and two SPECIALIZEd ones: -instance Outputable {-Type, i.e.:-}(GenType TyVar UVar) where - ppr PprQuote ty = quotes (pprGenType (PprForUser opt_PprUserLength) ty) - ppr other_sty ty = pprGenType other_sty ty +{- +instance Outputable {-Type, i.e.:-}(GenType Unused) where + ppr ty = pprGenType ty -instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where - ppr PprQuote ty = quotes (pprGenTyVar (PprForUser opt_PprUserLength) ty) - ppr other_sty ty = pprGenTyVar other_sty ty +instance Outputable {-TyVar, i.e.:-}(GenTyVar Unused) where + ppr ty = pprGenTyVar ty +-} \end{code} %************************************************************************ @@ -118,146 +99,133 @@ parens around the type, except for the atomic cases. @pprParendGenType@ works just by setting the initial context precedence very high. \begin{code} -pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> GenType tyvar uvar -> Doc +pprGenType, pprParendGenType :: GenType flexi -> SDoc + +pprGenType ty = ppr_ty init_ppr_env tOP_PREC ty +pprParendGenType ty = ppr_ty init_ppr_env tYCON_PREC ty -pprGenType sty ty = ppr_ty (init_ppr_env sty) tOP_PREC ty -pprParendGenType sty ty = ppr_ty (init_ppr_env sty) tYCON_PREC ty +pprType, pprParendType :: Type -> SDoc +pprType ty = ppr_ty init_ppr_env_type tOP_PREC ty +pprParendType ty = ppr_ty init_ppr_env_type tYCON_PREC ty -pprType, pprParendType :: PprStyle -> Type -> Doc -pprType sty ty = ppr_ty (init_ppr_env_type sty) tOP_PREC ty -pprParendType sty ty = ppr_ty (init_ppr_env_type sty) tYCON_PREC ty +pprConstraint :: Class -> [GenType flexi] -> SDoc +pprConstraint clas tys = hsep [ppr clas, hsep (map (pprParendGenType) tys)] -pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> Maybe (GenType tyvar uvar) -> Doc -pprMaybeTy sty Nothing = char '*' -pprMaybeTy sty (Just ty) = pprParendGenType sty ty +pprTheta :: ThetaType -> SDoc +pprTheta theta = parens (hsep (punctuate comma (map ppr_dict theta))) + where + ppr_dict (c,tys) = pprConstraint c tys + +pprMaybeTy :: Maybe (GenType flexi) -> SDoc +pprMaybeTy Nothing = char '*' +pprMaybeTy (Just ty) = pprParendGenType ty \end{code} \begin{code} -ppr_ty :: PprEnv tyvar uvar bndr occ -> Int - -> GenType tyvar uvar - -> Doc +ppr_ty :: PprEnv flexi bndr occ -> Int + -> GenType flexi + -> SDoc ppr_ty env ctxt_prec (TyVarTy tyvar) = pTyVarO env tyvar -ppr_ty env ctxt_prec (TyConTy tycon usage) + -- TUPLE CASE +ppr_ty env ctxt_prec (TyConApp tycon tys) + | isTupleTyCon tycon + && length tys == tyConArity tycon -- no magic if partially applied + = parens tys_w_commas + where + tys_w_commas = hsep (punctuate comma (map (ppr_ty env tOP_PREC) tys)) + + -- LIST CASE +ppr_ty env ctxt_prec (TyConApp tycon [ty]) + | uniqueOf tycon == listTyConKey + = brackets (ppr_ty env tOP_PREC ty) + + -- DICTIONARY CASE, prints {C a} + -- This means that instance decls come out looking right in interfaces + -- and that in turn means they get "gated" correctly when being slurped in +ppr_ty env ctxt_prec ty@(TyConApp tycon tys) + | maybeToBool maybe_dict + = braces (ppr_dict env tYCON_PREC ctys) + where + Just ctys = maybe_dict + maybe_dict = splitDictTy_maybe ty + + -- NO-ARGUMENT CASE (=> no parens) +ppr_ty env ctxt_prec (TyConApp tycon []) = ppr_tycon env tycon -ppr_ty env ctxt_prec ty@(ForAllTy _ _) - | show_forall = maybeParen ctxt_prec fUN_PREC $ - sep [ ptext SLIT("_forall_"), pp_tyvars, - ppr_theta env theta, ptext SLIT("=>"), pp_body - ] - | null theta = ppr_ty env ctxt_prec body_ty - | otherwise = maybeParen ctxt_prec fUN_PREC $ - sep [ppr_theta env theta, ptext SLIT("=>"), pp_body] + -- GENERAL CASE +ppr_ty env ctxt_prec (TyConApp tycon tys) + = maybeParen ctxt_prec tYCON_PREC (hsep [ppr_tycon env tycon, tys_w_spaces]) where - (tyvars, rho_ty) = splitForAllTy ty - (theta, body_ty) | show_context = splitRhoTy rho_ty - | otherwise = ([], rho_ty) + tys_w_spaces = hsep (map (ppr_ty env tYCON_PREC) tys) + - pp_tyvars = brackets (hsep (map (pTyVarB env) tyvars)) - pp_body = ppr_ty env tOP_PREC body_ty +ppr_ty env ctxt_prec ty@(ForAllTy _ _) + = getPprStyle $ \ sty -> + let + (tyvars, rho_ty) = splitForAllTys ty + (theta, body_ty) | show_context = splitRhoTy rho_ty + | otherwise = ([], rho_ty) + + pp_tyvars = brackets (hsep (map (pTyVarB env) tyvars)) + pp_body = ppr_ty env tOP_PREC body_ty + + show_forall = not (userStyle sty) + show_context = ifaceStyle sty || userStyle sty + in + if show_forall then + maybeParen ctxt_prec fUN_PREC $ + sep [ ptext SLIT("_forall_"), pp_tyvars, + ppr_theta env theta, ptext SLIT("=>"), pp_body + ] - sty = pStyle env - show_forall = not (userStyle sty) - show_context = ifaceStyle sty || userStyle sty + else if null theta then + ppr_ty env ctxt_prec body_ty -ppr_ty env ctxt_prec (ForAllUsageTy uv uvs ty) - = panic "ppr_ty:ForAllUsageTy" + else + maybeParen ctxt_prec fUN_PREC $ + sep [ppr_theta env theta, ptext SLIT("=>"), pp_body] -ppr_ty env ctxt_prec (FunTy ty1 ty2 usage) +ppr_ty env ctxt_prec (FunTy ty1 ty2) -- We fiddle the precedences passed to left/right branches, -- so that right associativity comes out nicely... = maybeParen ctxt_prec fUN_PREC (sep (ppr_ty env fUN_PREC ty1 : pp_rest)) where - (arg_tys, result_ty) = splitFunTy ty2 + (arg_tys, result_ty) = splitFunTys ty2 pp_rest = [ ptext SLIT("-> ") <> ppr_ty env fUN_PREC ty | ty <- arg_tys ++ [result_ty] ] -ppr_ty env ctxt_prec ty@(AppTy _ _) - = ppr_corner env ctxt_prec fun_ty arg_tys - where - (fun_ty, arg_tys) = splitAppTys ty - -ppr_ty env ctxt_prec (SynTy tycon tys expansion) - | codeStyle (pStyle env) - -- always expand types that squeak into C-variable names - = ppr_ty env ctxt_prec expansion - - | otherwise - = (<>) - (ppr_app env ctxt_prec (ppr_tycon env tycon) tys) - (ifPprShowAll (pStyle env) (hsep [text " {- expansion:", - ppr_ty env tOP_PREC expansion, - text "-}"])) - -ppr_ty env ctxt_prec (DictTy clas ty usage) - = braces (ppr_dict env tOP_PREC (clas, ty)) - -- Curlies are temporary - - --- Some help functions -ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys - | isFunTyCon tycon && length arg_tys == 2 - = ppr_ty env ctxt_prec (FunTy ty1 ty2 usage) - where - (ty1:ty2:_) = arg_tys - -ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys - | isTupleTyCon tycon - && not (codeStyle (pStyle env)) -- no magic in that case - && length arg_tys == tyConArity tycon -- no magic if partially applied - = parens arg_tys_w_commas - where - arg_tys_w_commas = hsep (punctuate comma (map (ppr_ty env tOP_PREC) arg_tys)) - -ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys - | not (codeStyle (pStyle env)) && uniqueOf tycon == listTyConKey - = ASSERT(length arg_tys == 1) - brackets (ppr_ty env tOP_PREC ty1) - where - (ty1:_) = arg_tys - -ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys - = ppr_app env ctxt_prec (ppr_tycon env tycon) arg_tys - -ppr_corner env ctxt_prec (TyVarTy tyvar) arg_tys - = ppr_app env ctxt_prec (pTyVarO env tyvar) arg_tys - - -ppr_app env ctxt_prec pp_fun [] - = pp_fun -ppr_app env ctxt_prec pp_fun arg_tys - = maybeParen ctxt_prec tYCON_PREC (hsep [pp_fun, arg_tys_w_spaces]) - where - arg_tys_w_spaces = hsep (map (ppr_ty env tYCON_PREC) arg_tys) +ppr_ty env ctxt_prec (AppTy ty1 ty2) + = maybeParen ctxt_prec tYCON_PREC $ + ppr_ty env tOP_PREC ty1 <+> ppr_ty env tYCON_PREC ty2 +ppr_ty env ctxt_prec (SynTy ty expansion) + = ppr_ty env ctxt_prec ty ppr_theta env [] = empty ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta))) -ppr_dict env ctxt_prec (clas, ty) - = maybeParen ctxt_prec tYCON_PREC - (hsep [ppr_class env clas, ppr_ty env tYCON_PREC ty]) +ppr_dict env ctxt (clas, tys) = ppr_class env clas <+> + hsep (map (ppr_ty env tYCON_PREC) tys) \end{code} \begin{code} -- This one uses only "ppr" -init_ppr_env sty - = initPprEnv sty b b b b (Just (ppr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b +init_ppr_env + = initPprEnv b b b b (Just ppr) (Just ppr) b b b where b = panic "PprType:init_ppr_env" -- This one uses pprTyVarBndr, and thus is specific to GenTyVar's types -init_ppr_env_type sty - = initPprEnv sty b b b b (Just (pprTyVarBndr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b +init_ppr_env_type + = initPprEnv b b b b (Just pprTyVarBndr) (Just ppr) b b b where b = panic "PprType:init_ppr_env" -ppr_tycon env tycon = ppr (pStyle env) tycon -ppr_class env clas = ppr (pStyle env) clas +ppr_tycon env tycon = ppr tycon +ppr_class env clas = ppr clas \end{code} %************************************************************************ @@ -267,35 +235,33 @@ ppr_class env clas = ppr (pStyle env) clas %************************************************************************ \begin{code} -pprGenTyVar sty (TyVar uniq kind maybe_name usage) +pprGenTyVar (TyVar uniq kind maybe_name _) = case maybe_name of -- If the tyvar has a name we can safely use just it, I think - Just n -> pprOccName sty (getOccName n) <> debug_extra - Nothing -> pp_kind <> pprUnique uniq + Just n -> pprOccName (getOccName n) <> ifPprDebug pp_debug + Nothing -> pprUnique uniq where + pp_debug = text "_" <> pp_kind <> pprUnique uniq + pp_kind = case kind of TypeKind -> char 'o' BoxedTypeKind -> char 't' UnboxedTypeKind -> char 'u' ArrowKind _ _ -> char 'a' - - debug_extra = case sty of - PprDebug -> pp_debug - PprShowAll -> pp_debug - other -> empty - - pp_debug = text "_" <> pp_kind <> pprUnique uniq \end{code} We print type-variable binders with their kinds in interface files. \begin{code} -pprTyVarBndr sty@PprInterface tyvar@(TyVar uniq kind name usage) - | not (isBoxedTypeKind kind) - = hcat [pprGenTyVar sty tyvar, text " :: ", pprParendKind kind] +pprTyVarBndr tyvar@(TyVar uniq kind name _) + = getPprStyle $ \ sty -> + if ifaceStyle sty && not (isBoxedTypeKind kind) then + hcat [pprGenTyVar tyvar, text " :: ", pprParendKind kind] -- See comments with ppDcolon in PprCore.lhs + else + pprGenTyVar tyvar -pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar +pprTyVarBndrs tyvars = hsep (map pprTyVarBndr tyvars) \end{code} %************************************************************************ @@ -307,11 +273,11 @@ pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar ToDo; all this is suspiciously like getOccName! \begin{code} -showTyCon :: PprStyle -> TyCon -> String -showTyCon sty tycon = show (pprTyCon sty tycon) +showTyCon :: TyCon -> String +showTyCon tycon = showSDoc (pprTyCon tycon) -pprTyCon :: PprStyle -> TyCon -> Doc -pprTyCon sty tycon = ppr sty (getName tycon) +pprTyCon :: TyCon -> SDoc +pprTyCon tycon = ppr (getName tycon) \end{code} @@ -322,46 +288,6 @@ pprTyCon sty tycon = ppr sty (getName tycon) %* * %************************************************************************ -\begin{code} - -- Shallowly magical; converts a type into something - -- vaguely close to what can be used in C identifier. - -- Produces things like what we have in mkCompoundName, - -- which can be "dot"ted together... - -getTypeString :: Type -> FAST_STRING - -getTypeString ty - = case (splitAppTys ty) of { (tc, args) -> - _CONCAT_ (do_tc tc : map do_arg_ty args) } - where - do_tc (TyConTy tc _) = nameString (getName tc) - do_tc (SynTy _ _ ty) = do_tc ty - do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $ - (_PK_ (show (pprType PprForC other))) - - do_arg_ty (TyConTy tc _) = nameString (getName tc) - do_arg_ty (TyVarTy tv) = _PK_ (show (ppr PprForC tv)) - do_arg_ty (SynTy _ _ ty) = do_arg_ty ty - do_arg_ty other = --pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $ - _PK_ (show (pprType PprForC other)) - - -- PprForC expands type synonyms as it goes; - -- it also forces consistent naming of tycons - -- (e.g., can't have both "(,) a b" and "(a,b)": - -- must be consistent! - -specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING -specMaybeTysSuffix ty_maybes - = panic "PprType.specMaybeTysSuffix" -{- LATER: - = let - ty_strs = concat (map typeMaybeString ty_maybes) - dotted_tys = [ _CONS_ '.' str | str <- ty_strs ] - in - _CONCAT_ dotted_tys --} -\end{code} - Grab a name for the type. This is used to determine the type description for profiling. \begin{code} @@ -370,18 +296,16 @@ getTyDescription :: Type -> String getTyDescription ty = case (splitSigmaTy ty) of { (_, _, tau_ty) -> case tau_ty of - TyVarTy _ -> "*" - AppTy fun _ -> getTyDescription fun - FunTy _ res _ -> '-' : '>' : fun_result res - TyConTy tycon _ -> getOccString tycon - SynTy tycon _ _ -> getOccString tycon - DictTy _ _ _ -> "dict" - ForAllTy _ ty -> getTyDescription ty - _ -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty) + TyVarTy _ -> "*" + AppTy fun _ -> getTyDescription fun + FunTy _ res -> '-' : '>' : fun_result res + TyConApp tycon _ -> getOccString tycon + SynTy ty1 _ -> getTyDescription ty1 + ForAllTy _ ty -> getTyDescription ty } where - fun_result (FunTy _ res _) = '>' : fun_result res - fun_result other = getTyDescription other + fun_result (FunTy _ res) = '>' : fun_result res + fun_result other = getTyDescription other \end{code} @@ -398,15 +322,15 @@ consistent Uniques on everything from run to run. \begin{code} nmbrGlobalType :: Type -> Type -- Renumber a top-level type -nmbrGlobalType ty = nmbrType (\tyvar -> tyvar) (\uvar -> uvar) initTyVarUnique ty +nmbrGlobalType ty = nmbrType (\tyvar -> tyvar) initTyVarUnique ty -nmbrType :: (TyVar -> TyVar) -> (UVar -> UVar) -- Mapping for free vars +nmbrType :: (TyVar -> TyVar) -- Mapping for free vars -> Unique -> Type -> Type -nmbrType tyvar_env uvar_env uniq ty - = initNmbr tyvar_env uvar_env uniq (nmbrTy ty) +nmbrType tyvar_env uniq ty + = initNmbr tyvar_env uniq (nmbrTy ty) nmbrTy :: Type -> NmbrM Type @@ -419,94 +343,56 @@ nmbrTy (AppTy t1 t2) nmbrTy t2 `thenNmbr` \ new_t2 -> returnNmbr (AppTy new_t1 new_t2) -nmbrTy (TyConTy tc use) - = nmbrUsage use `thenNmbr` \ new_use -> - returnNmbr (TyConTy tc new_use) +nmbrTy (TyConApp tc tys) + = nmbrTys tys `thenNmbr` \ new_tys -> + returnNmbr (TyConApp tc new_tys) -nmbrTy (SynTy tc args expand) - = mapNmbr nmbrTy args `thenNmbr` \ new_args -> - nmbrTy expand `thenNmbr` \ new_expand -> - returnNmbr (SynTy tc new_args new_expand) +nmbrTy (SynTy ty1 ty2) + = nmbrTy ty1 `thenNmbr` \ new_ty1 -> + nmbrTy ty2 `thenNmbr` \ new_ty2 -> + returnNmbr (SynTy new_ty1 new_ty2) nmbrTy (ForAllTy tv ty) = addTyVar tv $ \ new_tv -> nmbrTy ty `thenNmbr` \ new_ty -> returnNmbr (ForAllTy new_tv new_ty) -nmbrTy (ForAllUsageTy u us ty) - = addUVar u $ \ new_u -> - mapNmbr lookupUVar us `thenNmbr` \ new_us -> - nmbrTy ty `thenNmbr` \ new_ty -> - returnNmbr (ForAllUsageTy new_u new_us new_ty) - -nmbrTy (FunTy t1 t2 use) +nmbrTy (FunTy t1 t2) = nmbrTy t1 `thenNmbr` \ new_t1 -> nmbrTy t2 `thenNmbr` \ new_t2 -> - nmbrUsage use `thenNmbr` \ new_use -> - returnNmbr (FunTy new_t1 new_t2 new_use) - -nmbrTy (DictTy c ty use) - = nmbrTy ty `thenNmbr` \ new_ty -> - nmbrUsage use `thenNmbr` \ new_use -> - returnNmbr (DictTy c new_ty new_use) + returnNmbr (FunTy new_t1 new_t2) +nmbrTys tys = mapNmbr nmbrTy tys -lookupTyVar tyvar (NmbrEnv tv_fn tv_env _ _) uniq +lookupTyVar tyvar (NmbrEnv tv_fn tv_env) uniq = (uniq, tyvar') where tyvar' = case lookupUFM tv_env tyvar of Just tyvar' -> tyvar' Nothing -> tv_fn tyvar -addTyVar tv m (NmbrEnv f_tv tv_ufm f_uv uv_ufm) u +addTyVar tv m (NmbrEnv f_tv tv_ufm) u = m tv' nenv u' where - nenv = NmbrEnv f_tv tv_ufm' f_uv uv_ufm + nenv = NmbrEnv f_tv tv_ufm' tv_ufm' = addToUFM tv_ufm tv tv' tv' = cloneTyVar tv u u' = incrUnique u \end{code} -Usage stuff - -\begin{code} -nmbrUsage (UsageVar v) - = lookupUVar v `thenNmbr` \ v' -> - returnNmbr (UsageVar v) - -nmbrUsage u = returnNmbr u - - -lookupUVar uvar (NmbrEnv _ _ uv_fn uv_env) uniq - = (uniq, uvar') - where - uvar' = case lookupUFM uv_env uvar of - Just uvar' -> uvar' - Nothing -> uv_fn uvar - -addUVar uv m (NmbrEnv f_tv tv_ufm f_uv uv_ufm) u - = m uv' nenv u' - where - nenv = NmbrEnv f_tv tv_ufm f_uv uv_ufm' - uv_ufm' = addToUFM uv_ufm uv uv' - uv' = cloneUVar uv u - u' = incrUnique u -\end{code} - Monad stuff \begin{code} data NmbrEnv - = NmbrEnv (TyVar -> TyVar) (UniqFM TyVar) -- Global and local map for tyvars - (UVar -> UVar) (UniqFM UVar) -- ... for usage vars + = NmbrEnv (TyVar -> TyVar) (UniqFM TyVar) -- Global and local map for tyvars type NmbrM a = NmbrEnv -> Unique -> (Unique, a) -- Unique is name supply -initNmbr :: (TyVar -> TyVar) -> (UVar -> UVar) -> Unique -> NmbrM a -> a -initNmbr tyvar_env uvar_env uniq m +initNmbr :: (TyVar -> TyVar) -> Unique -> NmbrM a -> a +initNmbr tyvar_env uniq m = let - init_nmbr_env = NmbrEnv tyvar_env emptyUFM uvar_env emptyUFM + init_nmbr_env = NmbrEnv tyvar_env emptyUFM in snd (m init_nmbr_env uniq) diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 370faf5765..530af857e5 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -4,15 +4,13 @@ \section[TyCon]{The @TyCon@ datatype} \begin{code} -#include "HsVersions.h" - module TyCon( TyCon, - SYN_IE(Arity), NewOrData(..), + Arity, NewOrData(..), - isFunTyCon, isPrimTyCon, isBoxedTyCon, - isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, maybeNewTyCon, + isFunTyCon, isPrimTyCon, isBoxedTyCon, isProductTyCon, + isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isEnumerationTyCon, isTupleTyCon, mkDataTyCon, @@ -32,55 +30,45 @@ module TyCon( tyConTheta, tyConPrimRep, tyConArity, + tyConClass_maybe, getSynTyConDefn, - maybeTyConSingleCon, - derivedClasses + maybeTyConSingleCon ) where -CHK_Ubiq() -- debugging consistency check +#include "HsVersions.h" -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(TyLoop) ( SYN_IE(Type), GenType, - SYN_IE(Class), GenClass, - SYN_IE(Id), GenId, - splitSigmaTy, splitFunTy, - tupleCon, isNullaryDataCon, idType - --LATER: specMaybeTysSuffix - ) -#else -import {-# SOURCE #-} Type ( Type, splitSigmaTy, splitFunTy ) +import {-# SOURCE #-} Type ( Type ) import {-# SOURCE #-} Class ( Class ) import {-# SOURCE #-} Id ( Id, isNullaryDataCon, idType ) import {-# SOURCE #-} TysWiredIn ( tupleCon ) -#endif -import BasicTypes ( SYN_IE(Arity), NewOrData(..) ) -import TyVar ( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar, SYN_IE(TyVar) ) -import Usage ( GenUsage, SYN_IE(Usage) ) + +import BasicTypes ( Arity, NewOrData(..), RecFlag(..) ) +import TyVar ( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar, TyVar ) import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkUnboxedTypeKind, mkArrowKind, resultKind, argKind ) import Maybes import Name ( Name, nameUnique, mkWiredInTyConName, NamedThing(getName) ) import Unique ( Unique, funTyConKey, Uniquable(..) ) -import Pretty ( Doc ) -import PrimRep ( PrimRep(..) ) +import PrimRep ( PrimRep(..), isFollowableRep ) import PrelMods ( gHC__, pREL_TUP, pREL_BASE ) import Lex ( mkTupNameStr ) import SrcLoc ( SrcLoc, mkBuiltinSrcLoc ) -import Util ( nOfThem, isIn, Ord3(..), panic, panic#, assertPanic ) +import Util ( nOfThem, isIn ) +import Outputable \end{code} \begin{code} data TyCon = FunTyCon -- Kind = Type -> Type -> Type - | DataTyCon Unique{-TyConKey-} + | DataTyCon Unique Name Kind [TyVar] - [(Class,Type)] -- Its context + [(Class,[Type])] -- Its context [Id{-DataCon-}] -- Its data constructors, with fully polymorphic types -- This list can be empty, when we import a data type abstractly, -- either (a) the interface is hand-written and doesn't give @@ -88,7 +76,11 @@ data TyCon -- (b) in a quest for fast compilation we don't import -- the constructors [Class] -- Classes which have derived instances + (Maybe Class) -- Nothing for ordinary types; Just c for the type constructor + -- for dictionaries of class c. NewOrData + RecFlag -- Tells whether the data type is part of + -- a mutually-recursive group or not | TupleTyCon Unique -- cached Name -- again, we could do without this, but @@ -100,10 +92,10 @@ data TyCon -- -> BoxedTypeKind | PrimTyCon -- Primitive types; cannot be defined in Haskell - Unique -- Always unboxed; hence never represented by a closure + Unique -- Always unpointed; hence never represented by a closure Name -- Often represented by a bit-pattern for the thing Kind -- itself (eg Int#), but sometimes by a pointer to - Arity + Arity -- the thing. PrimRep | SpecTyCon -- A specialised TyCon; eg (Arr# Int#), or (List Int#) @@ -140,7 +132,8 @@ mkDataTyCon name = DataTyCon (nameUnique name) name mkPrimTyCon name arity rep = PrimTyCon (nameUnique name) name (mk_kind arity) arity rep where - mk_kind 0 = mkUnboxedTypeKind + mk_kind 0 | isFollowableRep rep = mkBoxedTypeKind -- Represented by a GC-ish ptr + | otherwise = mkUnboxedTypeKind -- Represented by a non-ptr mk_kind n = mkTypeKind `mkArrowKind` mk_kind (n-1) mkSynTyCon name = SynTyCon (nameUnique name) name @@ -156,35 +149,32 @@ isPrimTyCon _ = False isBoxedTyCon = not . isPrimTyCon -- isAlgTyCon returns True for both @data@ and @newtype@ -isAlgTyCon (DataTyCon _ _ _ _ _ _ _ _) = True -isAlgTyCon (TupleTyCon _ _ _) = True -isAlgTyCon other = False +isAlgTyCon (DataTyCon _ _ _ _ _ _ _ _ _ _) = True +isAlgTyCon (TupleTyCon _ _ _) = True +isAlgTyCon other = False -- isDataTyCon returns False for @newtype@. -isDataTyCon (DataTyCon _ _ _ _ _ _ _ DataType) = True -isDataTyCon (TupleTyCon _ _ _) = True -isDataTyCon other = False - -maybeNewTyCon :: TyCon -> Maybe ([TyVar], Type) -- Returns representation type info -maybeNewTyCon (DataTyCon _ _ _ _ _ (con:null_cons) _ NewType) - = ASSERT( null null_cons && null null_tys) - Just (tyvars, rep_ty) - where - (tyvars, theta, tau) = splitSigmaTy (idType con) - (rep_ty:null_tys, res_ty) = splitFunTy tau +isDataTyCon (DataTyCon _ _ _ _ _ _ _ _ DataType _) = True +isDataTyCon (TupleTyCon _ _ _) = True +isDataTyCon other = False -maybeNewTyCon other = Nothing +isNewTyCon (DataTyCon _ _ _ _ _ _ _ _ NewType _) = True +isNewTyCon other = False -isNewTyCon (DataTyCon _ _ _ _ _ _ _ NewType) = True -isNewTyCon other = False +-- A "product" tycon is non-recursive and has one constructor, +-- whether DataType or NewType +isProductTyCon (TupleTyCon _ _ _) = True +isProductTyCon (DataTyCon _ _ _ _ _ [c] _ _ _ NonRecursive) = True +isProductTyCon other = False isSynTyCon (SynTyCon _ _ _ _ _ _) = True isSynTyCon _ = False isEnumerationTyCon (TupleTyCon _ _ arity) = arity == 0 -isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _) +isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _ DataType _) = not (null data_cons) && all isNullaryDataCon data_cons +isEnumerationTyCon other = False isTupleTyCon (TupleTyCon _ _ arity) = arity >= 2 -- treat "0-tuple" specially isTupleTyCon (SpecTyCon tc tys) = isTupleTyCon tc @@ -197,10 +187,10 @@ kind1 = mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind kind2 = mkBoxedTypeKind `mkArrowKind` kind1 tyConKind :: TyCon -> Kind -tyConKind FunTyCon = kind2 -tyConKind (DataTyCon _ _ kind _ _ _ _ _) = kind -tyConKind (PrimTyCon _ _ kind _ _) = kind -tyConKind (SynTyCon _ _ k _ _ _) = k +tyConKind FunTyCon = kind2 +tyConKind (DataTyCon _ _ kind _ _ _ _ _ _ _) = kind +tyConKind (PrimTyCon _ _ kind _ _) = kind +tyConKind (SynTyCon _ _ k _ _ _) = k tyConKind (TupleTyCon _ _ n) = mkArrow n @@ -221,28 +211,28 @@ tyConKind (SpecTyCon tc tys) \begin{code} tyConUnique :: TyCon -> Unique -tyConUnique FunTyCon = funTyConKey -tyConUnique (DataTyCon uniq _ _ _ _ _ _ _) = uniq -tyConUnique (TupleTyCon uniq _ _) = uniq -tyConUnique (PrimTyCon uniq _ _ _ _) = uniq -tyConUnique (SynTyCon uniq _ _ _ _ _) = uniq -tyConUnique (SpecTyCon _ _ ) = panic "tyConUnique:SpecTyCon" +tyConUnique FunTyCon = funTyConKey +tyConUnique (DataTyCon uniq _ _ _ _ _ _ _ _ _) = uniq +tyConUnique (TupleTyCon uniq _ _) = uniq +tyConUnique (PrimTyCon uniq _ _ _ _) = uniq +tyConUnique (SynTyCon uniq _ _ _ _ _) = uniq +tyConUnique (SpecTyCon _ _ ) = panic "tyConUnique:SpecTyCon" tyConArity :: TyCon -> Arity -tyConArity FunTyCon = 2 -tyConArity (DataTyCon _ _ _ tyvars _ _ _ _) = length tyvars -tyConArity (TupleTyCon _ _ arity) = arity -tyConArity (PrimTyCon _ _ _ arity _) = arity -tyConArity (SynTyCon _ _ _ arity _ _) = arity -tyConArity (SpecTyCon _ _ ) = panic "tyConArity:SpecTyCon" +tyConArity FunTyCon = 2 +tyConArity (DataTyCon _ _ _ tyvars _ _ _ _ _ _) = length tyvars +tyConArity (TupleTyCon _ _ arity) = arity +tyConArity (PrimTyCon _ _ _ arity _) = arity +tyConArity (SynTyCon _ _ _ arity _ _) = arity +tyConArity (SpecTyCon _ _ ) = panic "tyConArity:SpecTyCon" \end{code} \begin{code} tyConTyVars :: TyCon -> [TyVar] -tyConTyVars FunTyCon = [alphaTyVar,betaTyVar] -tyConTyVars (DataTyCon _ _ _ tvs _ _ _ _) = tvs -tyConTyVars (TupleTyCon _ _ arity) = take arity alphaTyVars -tyConTyVars (SynTyCon _ _ _ _ tvs _) = tvs +tyConTyVars FunTyCon = [alphaTyVar,betaTyVar] +tyConTyVars (DataTyCon _ _ _ tvs _ _ _ _ _ _) = tvs +tyConTyVars (TupleTyCon _ _ arity) = take arity alphaTyVars +tyConTyVars (SynTyCon _ _ _ _ tvs _) = tvs #ifdef DEBUG tyConTyVars (PrimTyCon _ _ _ _ _) = panic "tyConTyVars:PrimTyCon" tyConTyVars (SpecTyCon _ _ ) = panic "tyConTyVars:SpecTyCon" @@ -253,34 +243,34 @@ tyConTyVars (SpecTyCon _ _ ) = panic "tyConTyVars:SpecTyCon" tyConDataCons :: TyCon -> [Id] tyConFamilySize :: TyCon -> Int -tyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _) = data_cons -tyConDataCons (TupleTyCon _ _ a) = [tupleCon a] -tyConDataCons other = [] +tyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _ _ _) = data_cons +tyConDataCons (TupleTyCon _ _ a) = [tupleCon a] +tyConDataCons other = [] -- You may think this last equation should fail, -- but it's quite convenient to return no constructors for -- a synonym; see for example the call in TcTyClsDecls. -tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _) = length data_cons -tyConFamilySize (TupleTyCon _ _ _) = 1 +tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _ _ _) = length data_cons +tyConFamilySize (TupleTyCon _ _ _) = 1 #ifdef DEBUG ---tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon PprDebug other) +--tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon other) #endif tyConPrimRep :: TyCon -> PrimRep tyConPrimRep (PrimTyCon _ __ _ rep) = rep -tyConPrimRep _ = PtrRep +tyConPrimRep _ = PtrRep \end{code} \begin{code} tyConDerivings :: TyCon -> [Class] -tyConDerivings (DataTyCon _ _ _ _ _ _ derivs _) = derivs -tyConDerivings other = [] +tyConDerivings (DataTyCon _ _ _ _ _ _ derivs _ _ _) = derivs +tyConDerivings other = [] \end{code} \begin{code} -tyConTheta :: TyCon -> [(Class,Type)] -tyConTheta (DataTyCon _ _ _ _ theta _ _ _) = theta -tyConTheta (TupleTyCon _ _ _) = [] +tyConTheta :: TyCon -> [(Class, [Type])] +tyConTheta (DataTyCon _ _ _ _ theta _ _ _ _ _) = theta +tyConTheta (TupleTyCon _ _ _) = [] -- should ask about anything else \end{code} @@ -292,14 +282,20 @@ getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty) \begin{code} maybeTyConSingleCon :: TyCon -> Maybe Id -maybeTyConSingleCon (TupleTyCon _ _ arity) = Just (tupleCon arity) -maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _) = Just c -maybeTyConSingleCon (DataTyCon _ _ _ _ _ _ _ _) = Nothing -maybeTyConSingleCon (PrimTyCon _ _ _ _ _) = Nothing -maybeTyConSingleCon (SpecTyCon tc tys) = panic "maybeTyConSingleCon:SpecTyCon" +maybeTyConSingleCon (TupleTyCon _ _ arity) = Just (tupleCon arity) +maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _ _ _) = Just c +maybeTyConSingleCon (DataTyCon _ _ _ _ _ _ _ _ _ _) = Nothing +maybeTyConSingleCon (PrimTyCon _ _ _ _ _) = Nothing +maybeTyConSingleCon (SpecTyCon tc tys) = panic "maybeTyConSingleCon:SpecTyCon" -- requires DataCons of TyCon \end{code} +\begin{code} +tyConClass_maybe :: TyCon -> Maybe Class +tyConClass_maybe (DataTyCon _ _ _ _ _ _ _ maybe_cls _ _) = maybe_cls +tyConClass_maybe other_tycon = Nothing +\end{code} + @derivedFor@ reports if we have an {\em obviously}-derived instance for the given class/tycon. Of course, you might be deriving something because it a superclass of some other obviously-derived class --- this @@ -307,12 +303,6 @@ function doesn't deal with that. ToDo: what about derivings for specialised tycons !!! -\begin{code} -derivedClasses :: TyCon -> [Class] -derivedClasses (DataTyCon _ _ _ _ _ _ derivs _) = derivs -derivedClasses something_weird = [] -\end{code} - %************************************************************************ %* * \subsection[TyCon-instances]{Instance declarations for @TyCon@} @@ -325,19 +315,16 @@ The strictness analyser needs @Ord@. It is a lexicographic order with the property @(a<=b) || (b<=a)@. \begin{code} -instance Ord3 TyCon where - cmp tc1 tc2 = uniqueOf tc1 `cmp` uniqueOf tc2 - instance Eq TyCon where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } instance Ord TyCon where - a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = uniqueOf a `compare` uniqueOf b instance Uniquable TyCon where uniqueOf tc = tyConUnique tc @@ -345,13 +332,12 @@ instance Uniquable TyCon where \begin{code} instance NamedThing TyCon where - getName (DataTyCon _ n _ _ _ _ _ _) = n - getName (PrimTyCon _ n _ _ _) = n - getName (SpecTyCon tc _) = getName tc - getName (SynTyCon _ n _ _ _ _) = n - getName FunTyCon = mkFunTyConName - getName (TupleTyCon _ n _) = n - getName tc = panic "TyCon.getName" + getName (DataTyCon _ n _ _ _ _ _ _ _ _) = n + getName (PrimTyCon _ n _ _ _) = n + getName (SpecTyCon tc _) = getName tc + getName (SynTyCon _ n _ _ _ _) = n + getName FunTyCon = mkFunTyConName + getName (TupleTyCon _ n _) = n {- LATER: getName (SpecTyCon tc tys) = let (OrigName m n) = origName "????" tc in @@ -359,5 +345,4 @@ instance NamedThing TyCon where getName other_tc = moduleNamePair (expectJust "tycon1" (getName other_tc)) getName other = Nothing -} - \end{code} diff --git a/ghc/compiler/types/TyLoop.lhi b/ghc/compiler/types/TyLoop.lhi deleted file mode 100644 index ec3c65c2df..0000000000 --- a/ghc/compiler/types/TyLoop.lhi +++ /dev/null @@ -1,57 +0,0 @@ -Breaks the TyCon/types loop and the types/Id loop. - -\begin{code} -interface TyLoop where - ---import PreludePS(_PackedString) -import FastString (FastString) -import PreludeStdIO ( Maybe ) -import Unique ( Unique ) - -import FieldLabel ( FieldLabel ) -import Id ( Id, GenId, StrictnessMark, mkDataCon, mkTupleCon, - isNullaryDataCon, dataConArgTys, idType ) -import TysWiredIn ( tupleCon, tupleTyCon ) -import PprType ( specMaybeTysSuffix ) -import Name ( Name ) -import TyCon ( TyCon ) -import TyVar ( GenTyVar, TyVar ) -import Type ( splitSigmaTy, splitFunTy, splitRhoTy, applyTy, GenType, Type ) -import Usage ( GenUsage ) -import Class ( Class, GenClass ) -import TysPrim ( voidTy ) - -data GenId ty -data GenType tyvar uvar -data GenTyVar uvar -data GenClass tyvar uvar -data GenUsage u - -type Type = GenType (GenTyVar (GenUsage Unique)) Unique -type TyVar = GenTyVar (GenUsage Unique) -type Class = GenClass (GenTyVar (GenUsage Unique)) Unique -type Id = GenId (GenType (GenTyVar (GenUsage Unique)) Unique) - --- Needed in TyCon -tupleCon :: Int -> Id -isNullaryDataCon :: Id -> Bool -specMaybeTysSuffix :: [Maybe Type] -> FastString -idType :: Id -> Type -splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u) -splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u) -applyTy :: Type -> Type -> Type -splitFunTy :: GenType t u -> ([GenType t u], GenType t u) -instance Eq (GenClass a b) - --- Needed in Type -tupleTyCon :: Int -> TyCon -dataConArgTys :: Id -> [Type] -> [Type] -voidTy :: Type - --- Needed in TysWiredIn -data StrictnessMark = MarkedStrict | NotMarkedStrict -mkDataCon :: Name -> [StrictnessMark] -> [FieldLabel] - -> [TyVar] -> [(Class,Type)] -> [TyVar] -> [(Class,Type)] -> [Type] -> TyCon - -> Id -mkTupleCon :: Int -> Name -> Type -> Id -\end{code} diff --git a/ghc/compiler/types/TyVar.hi-boot b/ghc/compiler/types/TyVar.hi-boot deleted file mode 100644 index c36f6d8396..0000000000 --- a/ghc/compiler/types/TyVar.hi-boot +++ /dev/null @@ -1,7 +0,0 @@ -_interface_ TyVar 1 -_exports_ -TyVar TyVar GenTyVar; -_declarations_ -1 type TyVar = TyVar.GenTyVar Usage.Usage ; -1 data GenTyVar a; - diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs index 7c4373b0eb..0ca0d1a8f9 100644 --- a/ghc/compiler/types/TyVar.lhs +++ b/ghc/compiler/types/TyVar.lhs @@ -1,8 +1,7 @@ \begin{code} -#include "HsVersions.h" - module TyVar ( - GenTyVar(..), SYN_IE(TyVar), + GenTyVar(..), TyVar, + mkTyVar, mkSysTyVar, tyVarKind, -- TyVar -> Kind cloneTyVar, nameTyVar, @@ -12,21 +11,20 @@ module TyVar ( -- We also export "environments" keyed off of -- TyVars and "sets" containing TyVars: - SYN_IE(TyVarEnv), - nullTyVarEnv, mkTyVarEnv, addOneToTyVarEnv, - growTyVarEnvList, isNullTyVarEnv, lookupTyVarEnv, delFromTyVarEnv, + TyVarEnv, + emptyTyVarEnv, mkTyVarEnv, zipTyVarEnv, addToTyVarEnv, plusTyVarEnv, + growTyVarEnvList, isEmptyTyVarEnv, lookupTyVarEnv, delFromTyVarEnv, - SYN_IE(GenTyVarSet), SYN_IE(TyVarSet), + GenTyVarSet, TyVarSet, emptyTyVarSet, unitTyVarSet, unionTyVarSets, unionManyTyVarSets, intersectTyVarSets, mkTyVarSet, tyVarSetToList, elementOfTyVarSet, minusTyVarSet, isEmptyTyVarSet ) where -CHK_Ubiq() -- debugging consistency check +#include "HsVersions.h" -- friends -import Usage ( GenUsage, SYN_IE(Usage), usageOmega ) import Kind ( Kind, mkBoxedTypeKind, mkTypeKind ) -- others @@ -34,12 +32,12 @@ import UniqSet -- nearly all of it import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM, plusUFM, sizeUFM, delFromUFM, UniqFM ) +import BasicTypes ( Unused, unused ) import Name ( mkSysLocalName, mkLocalName, Name, NamedThing(..), OccName ) -import Pretty ( Doc, (<>), ptext ) -import Outputable ( PprStyle(..), Outputable(..) ) import SrcLoc ( noSrcLoc, SrcLoc ) import Unique ( mkAlphaTyVarUnique, Unique, Uniquable(..) ) -import Util ( panic, Ord3(..) ) +import Util ( zipEqual ) +import Outputable \end{code} \begin{code} @@ -51,7 +49,7 @@ data GenTyVar flexi_slot flexi_slot -- Extra slot used during type and usage -- inference, and to contain usages. -type TyVar = GenTyVar Usage -- Usage slot makes sense only if Kind = Type +type TyVar = GenTyVar Unused \end{code} @@ -62,20 +60,20 @@ mkTyVar :: Name -> Kind -> TyVar mkTyVar name kind = TyVar (uniqueOf name) kind (Just name) - usageOmega + unused mkSysTyVar :: Unique -> Kind -> TyVar mkSysTyVar uniq kind = TyVar uniq kind Nothing - usageOmega + unused tyVarKind :: GenTyVar flexi -> Kind tyVarKind (TyVar _ kind _ _) = kind cloneTyVar :: GenTyVar flexi -> Unique -> GenTyVar flexi -cloneTyVar (TyVar _ k n x) u = TyVar u k n x - -- Dodgy: doesn't (yet) change the unique in the Name) +cloneTyVar (TyVar _ k n x) u = TyVar u k Nothing x + -- Zaps its name nameTyVar :: GenTyVar flexi -> OccName -> GenTyVar flexi -- Give the TyVar a print-name @@ -89,9 +87,9 @@ Fixed collection of type variables -- openAlphaTyVar is prepared to be instantiated -- to a boxed or unboxed type variable. It's used for the -- result type for "error", so that we can have (error Int# "Help") -openAlphaTyVar = TyVar (mkAlphaTyVarUnique 1) mkTypeKind Nothing usageOmega +openAlphaTyVar = TyVar (mkAlphaTyVarUnique 1) mkTypeKind Nothing unused -alphaTyVars = [ TyVar u mkBoxedTypeKind Nothing usageOmega +alphaTyVars = [ TyVar u mkBoxedTypeKind Nothing unused | u <- map mkAlphaTyVarUnique [2..] ] (alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars @@ -104,22 +102,26 @@ Environments \begin{code} type TyVarEnv elt = UniqFM elt -nullTyVarEnv :: TyVarEnv a +emptyTyVarEnv :: TyVarEnv a mkTyVarEnv :: [(GenTyVar flexi, a)] -> TyVarEnv a -addOneToTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> a -> TyVarEnv a +zipTyVarEnv :: [GenTyVar flexi] -> [a] -> TyVarEnv a +addToTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> a -> TyVarEnv a growTyVarEnvList :: TyVarEnv a -> [(GenTyVar flexi, a)] -> TyVarEnv a -isNullTyVarEnv :: TyVarEnv a -> Bool +isEmptyTyVarEnv :: TyVarEnv a -> Bool lookupTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> Maybe a delFromTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> TyVarEnv a +plusTyVarEnv :: TyVarEnv a -> TyVarEnv a -> TyVarEnv a -nullTyVarEnv = emptyUFM +emptyTyVarEnv = emptyUFM mkTyVarEnv = listToUFM -addOneToTyVarEnv = addToUFM +addToTyVarEnv = addToUFM lookupTyVarEnv = lookupUFM delFromTyVarEnv = delFromUFM +plusTyVarEnv = plusUFM +zipTyVarEnv tyvars tys = listToUFM (zipEqual "zipTyVarEnv" tyvars tys) growTyVarEnvList env pairs = plusUFM env (listToUFM pairs) -isNullTyVarEnv env = sizeUFM env == 0 +isEmptyTyVarEnv env = sizeUFM env == 0 \end{code} Sets @@ -157,8 +159,8 @@ Instance delarations instance Eq (GenTyVar a) where (TyVar u1 _ _ _) == (TyVar u2 _ _ _) = u1 == u2 -instance Ord3 (GenTyVar a) where - cmp (TyVar u1 _ _ _) (TyVar u2 _ _ _) = u1 `cmp` u2 +instance Ord (GenTyVar a) where + compare (TyVar u1 _ _ _) (TyVar u2 _ _ _) = u1 `compare` u2 instance Uniquable (GenTyVar a) where uniqueOf (TyVar u _ _ _) = u diff --git a/ghc/compiler/types/Type.hi-boot b/ghc/compiler/types/Type.hi-boot index 8a2b03588f..70e81f165c 100644 --- a/ghc/compiler/types/Type.hi-boot +++ b/ghc/compiler/types/Type.hi-boot @@ -1,13 +1,8 @@ _interface_ Type 1 -_usages_ -TyVar 1 :: TyVar 1; -Usage 1 :: Uage 1; _exports_ -Type Type GenType splitFunTy splitSigmaTy splitRhoTy applyTy; +Type Type GenType ; _declarations_ -1 type Type = GenType TyVar!TyVar Usage.UVar ; -1 data GenType a b; -1 splitFunTy _:_ _forall_ [a b] => GenType a b -> ([GenType a b], GenType a b) ;; -1 splitSigmaTy _:_ _forall_ [a b] => GenType a b -> ([a],[(Class.Class,GenType a b)], GenType a b) ;; -1 splitRhoTy _:_ _forall_ [t u] => GenType t u -> ([(Class.Class,GenType t u)], GenType t u) ;; -1 applyTy _:_ Type -> Type -> Type ;; + +1 type Type = GenType BasicTypes.Unused ; +1 data GenType a ; + diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index d419223d1c..d84f41a5c9 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -1,675 +1,471 @@ \begin{code} -#include "HsVersions.h" - module Type ( - GenType(..), SYN_IE(Type), SYN_IE(TauType), - mkTyVarTy, mkTyVarTys, - getTyVar, getTyVar_maybe, isTyVarTy, + GenType(..), Type, + + mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, + mkAppTy, mkAppTys, splitAppTy, splitAppTys, - mkFunTy, mkFunTys, - splitFunTy, splitFunTyExpandingDicts, splitFunTyExpandingDictsAndPeeking, - getFunTy_maybe, getFunTyExpandingDicts_maybe, - mkTyConTy, getTyCon_maybe, applyTyCon, - mkSynTy, - mkForAllTy, mkForAllTys, getForAllTy_maybe, getForAllTyExpandingDicts_maybe, - splitForAllTy, splitForAllTyExpandingDicts, - mkForAllUsageTy, getForAllUsageTy, - applyTy, specialiseTy, -#ifdef DEBUG - expandTy, -- only let out for debugging (ToDo: rm?) -#endif - isPrimType, isUnboxedType, typePrimRep, - - SYN_IE(RhoType), SYN_IE(SigmaType), SYN_IE(ThetaType), - mkDictTy, - mkRhoTy, splitRhoTy, mkTheta, isDictTy, - mkSigmaTy, splitSigmaTy, - maybeAppTyCon, getAppTyCon, - maybeAppDataTyCon, getAppDataTyCon, getAppSpecDataTyCon, - maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts, - getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts, - maybeBoxedPrimType, + mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, + + mkTyConApp, mkTyConTy, splitTyConApp_maybe, + splitAlgTyConApp_maybe, splitAlgTyConApp, + mkDictTy, splitDictTy_maybe, isDictTy, - matchTy, matchTys, eqTy, eqSimpleTy, eqSimpleTheta, + mkSynTy, isSynTy, - instantiateTy, instantiateTauTy, instantiateUsage, - applyTypeEnvToTy, + mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, applyTy, + TauType, RhoType, SigmaType, ThetaType, isTauTy, + mkRhoTy, splitRhoTy, + mkSigmaTy, splitSigmaTy, + + isUnpointedType, isUnboxedType, typePrimRep, + + matchTy, matchTys, tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind, - showTypeCategory + + instantiateTy, instantiateTauTy, instantiateThetaTy, + + showTypeCategory ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(IdLoop) -- for paranoia checking -IMPORT_DELOOPER(TyLoop) ---IMPORT_DELOOPER(PrelLoop) -- for paranoia checking -#else -import {-# SOURCE #-} Id ( Id, dataConArgTys ) -import {-# SOURCE #-} TysPrim ( voidTy ) -import {-# SOURCE #-} TysWiredIn ( tupleTyCon ) -#endif +#include "HsVersions.h" + +import {-# SOURCE #-} Id ( Id ) -- friends: -import Class ( classDictArgTys, GenClass{-instances-}, SYN_IE(Class) ) -import Kind ( mkBoxedTypeKind, resultKind, notArrowKind, Kind ) +import Class ( classTyCon, Class ) +import Kind ( mkBoxedTypeKind, resultKind, Kind ) import TyCon ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon, - isPrimTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon, - tyConKind, tyConDataCons, getSynTyConDefn, TyCon ) -import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet), - emptyTyVarSet, unionTyVarSets, minusTyVarSet, - unitTyVarSet, nullTyVarEnv, lookupTyVarEnv, delFromTyVarEnv, - addOneToTyVarEnv, SYN_IE(TyVarEnv), SYN_IE(TyVar) ) -import Usage ( usageOmega, GenUsage, SYN_IE(Usage), SYN_IE(UVar), SYN_IE(UVarEnv), - nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar, - eqUsage ) - + isPrimTyCon, isAlgTyCon, isSynTyCon, tyConArity, + tyConKind, tyConDataCons, getSynTyConDefn, + tyConPrimRep, tyConClass_maybe, TyCon ) +import TyVar ( GenTyVarSet, TyVarEnv, GenTyVar, TyVar, + tyVarKind, emptyTyVarSet, unionTyVarSets, minusTyVarSet, + unitTyVarSet, lookupTyVarEnv, delFromTyVarEnv, zipTyVarEnv, mkTyVarEnv, + emptyTyVarEnv, isEmptyTyVarEnv, addToTyVarEnv ) import Name ( NamedThing(..), NameSet(..), unionNameSets, emptyNameSet, unitNameSet, minusNameSet ) -- others +import BasicTypes ( Unused ) import Maybes ( maybeToBool, assocMaybe ) import PrimRep ( PrimRep(..) ) import Unique -- quite a few *Keys -import Util ( thenCmp, zipEqual, assoc, - panic, panic#, assertPanic, pprPanic, - Ord3(..){-instances-} - ) +import Util ( thenCmp, zipEqual, zipWithEqual, assoc ) +import Outputable \end{code} -Data types -~~~~~~~~~~ -\begin{code} -type Type = GenType TyVar UVar -- Used after typechecker -data GenType tyvar uvar -- Parameterised over type and usage variables - = TyVarTy tyvar +%************************************************************************ +%* * +\subsection{The data type} +%* * +%************************************************************************ - | AppTy - (GenType tyvar uvar) - (GenType tyvar uvar) - | TyConTy -- Constants of a specified kind - TyCon -- Must *not* be a SynTyCon - (GenUsage uvar) -- Usage gives uvar of the full application, - -- iff the full application is of kind Type - -- c.f. the Usage field in TyVars +\begin{code} +type Type = GenType Unused -- Used after typechecker - | SynTy -- Synonyms must be saturated, and contain their expansion - TyCon -- Must be a SynTyCon - [GenType tyvar uvar] - (GenType tyvar uvar) -- Expansion! +data GenType flexi -- Parameterised over the "flexi" part of a type variable + = TyVarTy (GenTyVar flexi) - | ForAllTy - tyvar - (GenType tyvar uvar) -- TypeKind - - | ForAllUsageTy - uvar -- Quantify over this - [uvar] -- Bounds; the quantified var must be - -- less than or equal to all these - (GenType tyvar uvar) - - -- Two special cases that save a *lot* of administrative - -- overhead: - - | FunTy -- BoxedTypeKind - (GenType tyvar uvar) -- Both args are of TypeKind - (GenType tyvar uvar) - (GenUsage uvar) - - | DictTy -- TypeKind - Class -- Class - (GenType tyvar uvar) -- Arg has kind TypeKind - (GenUsage uvar) -\end{code} + | AppTy + (GenType flexi) -- Function is *not* a TyConApp + (GenType flexi) -\begin{code} -type RhoType = Type -type TauType = Type -type ThetaType = [(Class, Type)] -type SigmaType = Type -\end{code} + | TyConApp -- Application of a TyCon + TyCon -- *Invariant* saturated appliations of FunTyCon and + -- synonyms have their own constructors, below. + [GenType flexi] -- Might not be saturated. + | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2] + (GenType flexi) + (GenType flexi) -Notes on type synonyms -~~~~~~~~~~~~~~~~~~~~~~ -The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try -to return type synonyms whereever possible. Thus + | SynTy -- Saturated application of a type synonym + (GenType flexi) -- The unexpanded version; always a TyConTy + (GenType flexi) -- The expanded version - type Foo a = a -> a + | ForAllTy + (GenTyVar flexi) + (GenType flexi) -- TypeKind +\end{code} -we want - splitFunTys (a -> Foo a) = ([a], Foo a) -not ([a], a -> a) -The reason is that we then get better (shorter) type signatures in -interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. +%************************************************************************ +%* * +\subsection{Constructor-specific functions} +%* * +%************************************************************************ -Simple construction and analysis functions -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +--------------------------------------------------------------------- + TyVarTy + ~~~~~~~ \begin{code} -mkTyVarTy :: t -> GenType t u -mkTyVarTys :: [t] -> [GenType t y] +mkTyVarTy :: GenTyVar flexi -> GenType flexi mkTyVarTy = TyVarTy + +mkTyVarTys :: [GenTyVar flexi] -> [GenType flexi] mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy -getTyVar :: String -> GenType t u -> t -getTyVar msg (TyVarTy tv) = tv -getTyVar msg (SynTy _ _ t) = getTyVar msg t -getTyVar msg other = panic ("getTyVar: " ++ msg) +getTyVar :: String -> GenType flexi -> GenTyVar flexi +getTyVar msg (TyVarTy tv) = tv +getTyVar msg (SynTy _ t) = getTyVar msg t +getTyVar msg other = panic ("getTyVar: " ++ msg) -getTyVar_maybe :: GenType t u -> Maybe t -getTyVar_maybe (TyVarTy tv) = Just tv -getTyVar_maybe (SynTy _ _ t) = getTyVar_maybe t -getTyVar_maybe other = Nothing +getTyVar_maybe :: GenType flexi -> Maybe (GenTyVar flexi) +getTyVar_maybe (TyVarTy tv) = Just tv +getTyVar_maybe (SynTy _ t) = getTyVar_maybe t +getTyVar_maybe other = Nothing -isTyVarTy :: GenType t u -> Bool -isTyVarTy (TyVarTy tv) = True -isTyVarTy (SynTy _ _ t) = isTyVarTy t -isTyVarTy other = False +isTyVarTy :: GenType flexi -> Bool +isTyVarTy (TyVarTy tv) = True +isTyVarTy (SynTy _ ty) = isTyVarTy ty +isTyVarTy other = False \end{code} -\begin{code} -mkAppTy = AppTy - -mkAppTys :: GenType t u -> [GenType t u] -> GenType t u -mkAppTys t ts = foldl AppTy t ts -splitAppTy :: GenType t u -> (GenType t u, GenType t u) -splitAppTy (AppTy t arg) = (t,arg) -splitAppTy (SynTy _ _ t) = splitAppTy t -splitAppTy other = panic "splitAppTy" +--------------------------------------------------------------------- + AppTy + ~~~~~ +We need to be pretty careful with AppTy to make sure we obey the +invariant that a TyConApp is always visibly so. mkAppTy maintains the +invariant: use it. -splitAppTys :: GenType t u -> (GenType t u, [GenType t u]) -splitAppTys t = go t [] +\begin{code} +mkAppTy orig_ty1 orig_ty2 = mk_app orig_ty1 + where + mk_app (SynTy _ ty1) = mk_app ty1 + mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2]) + mk_app ty1 = AppTy orig_ty1 orig_ty2 + +mkAppTys :: GenType flexi -> [GenType flexi] -> GenType flexi +mkAppTys orig_ty1 [] = orig_ty1 + -- This check for an empty list of type arguments + -- avoids the needless of a type synonym constructor. + -- For example: mkAppTys Rational [] + -- returns to (Ratio Integer), which has needlessly lost + -- the Rational part. +mkAppTys orig_ty1 orig_tys2 = mk_app orig_ty1 + where + mk_app (SynTy _ ty1) = mk_app ty1 + mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2) + mk_app ty1 = foldl AppTy orig_ty1 orig_tys2 + +splitAppTy :: GenType flexi -> (GenType flexi, GenType flexi) +splitAppTy (FunTy ty1 ty2) = (TyConApp mkFunTyCon [ty1], ty2) +splitAppTy (AppTy ty1 ty2) = (ty1, ty2) +splitAppTy (SynTy _ ty) = splitAppTy ty +splitAppTy (TyConApp tc tys) = split tys [] + where + split [ty2] acc = (TyConApp tc (reverse acc), ty2) + split (ty:tys) acc = split tys (ty:acc) +splitAppTy other = panic "splitAppTy" + +splitAppTys :: GenType flexi -> (GenType flexi, [GenType flexi]) +splitAppTys ty = split ty ty [] where - go (AppTy t arg) ts = go t (arg:ts) - go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts) - go (SynTy _ _ t) ts = go t ts - go t ts = (t,ts) + split orig_ty (AppTy ty arg) args = split ty ty (arg:args) + split orig_ty (SynTy _ ty) args = split orig_ty ty args + split orig_ty (FunTy ty1 ty2) args = ASSERT( null args ) + (TyConApp mkFunTyCon [], [ty1,ty2]) + split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args) + split orig_ty ty args = (orig_ty, args) \end{code} + +--------------------------------------------------------------------- + FunTy + ~~~~~ + \begin{code} --- NB mkFunTy, mkFunTys puts in Omega usages, for now at least -mkFunTy arg res = FunTy arg res usageOmega - -mkFunTys :: [GenType t u] -> GenType t u -> GenType t u -mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts - - -- getFunTy_maybe and splitFunTy *must* have the general type given, which - -- means they *can't* do the DictTy jiggery-pokery that - -- *is* sometimes required. Hence we also have the ExpandingDicts variants - -- The relationship between these - -- two functions is like that between eqTy and eqSimpleTy. - -- ToDo: NUKE when we do dicts via newtype - -getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u) -getFunTy_maybe t - = go t t - where - -- See notes on type synonyms above - go syn_t (FunTy arg result _) = Just (arg,result) - go syn_t (AppTy (AppTy (TyConTy tycon _) arg) res) - | isFunTyCon tycon = Just (arg, res) - go syn_t (SynTy _ _ t) = go syn_t t - go syn_t other = Nothing - -getFunTyExpandingDicts_maybe :: Bool -- True <=> peek inside newtype applicatons - -> Type - -> Maybe (Type, Type) - -getFunTyExpandingDicts_maybe peek (FunTy arg result _) = Just (arg,result) -getFunTyExpandingDicts_maybe peek - (AppTy (AppTy (TyConTy tycon _) arg) res) | isFunTyCon tycon = Just (arg, res) -getFunTyExpandingDicts_maybe peek (SynTy _ _ t) = getFunTyExpandingDicts_maybe peek t -getFunTyExpandingDicts_maybe peek ty@(DictTy _ _ _) = getFunTyExpandingDicts_maybe peek (expandTy ty) - -getFunTyExpandingDicts_maybe True (ForAllTy _ ty) = getFunTyExpandingDicts_maybe True ty - -- Ignore for-alls when peeking. See note with defn of getFunTyExpandingDictsAndPeeking - - -{- This is a truly disgusting bit of code. - It's used by the code generator to look at the rep of a newtype. - The code gen will have thrown away coercions involving that newtype, so - this is the other side of the coin. - Gruesome in the extreme. --} - -getFunTyExpandingDicts_maybe peek other - | not peek = Nothing -- that was easy - | otherwise - = case (maybeAppTyCon other) of - Just (tc, arg_tys) - | isNewTyCon tc && not (null data_cons) - -> getFunTyExpandingDicts_maybe peek inside_ty - where - data_cons = tyConDataCons tc - [the_con] = data_cons - [inside_ty] = dataConArgTys the_con arg_tys - - other -> Nothing - - -splitFunTy :: GenType t u -> ([GenType t u], GenType t u) -splitFunTyExpandingDicts :: Type -> ([Type], Type) -splitFunTyExpandingDictsAndPeeking :: Type -> ([Type], Type) - -splitFunTy t = split_fun_ty getFunTy_maybe t -splitFunTyExpandingDicts t = split_fun_ty (getFunTyExpandingDicts_maybe False) t -splitFunTyExpandingDictsAndPeeking t = split_fun_ty (getFunTyExpandingDicts_maybe True) t - -- This "peeking" stuff is used only by the code generator. - -- It's interested in the representation type of things, ignoring: - -- newtype Why??? Nuked SLPJ May 97. We may not know the - -- rep of an abstractly imported newtype - -- foralls - -- expanding dictionary reps - -- synonyms, of course - -split_fun_ty get t = go t [] +mkFunTy :: GenType flexi -> GenType flexi -> GenType flexi +mkFunTy arg res = FunTy arg res + +mkFunTys :: [GenType flexi] -> GenType flexi -> GenType flexi +mkFunTys tys ty = foldr FunTy ty tys + +splitFunTy_maybe :: GenType flexi -> Maybe (GenType flexi, GenType flexi) +splitFunTy_maybe (FunTy arg res) = Just (arg, res) +splitFunTy_maybe (SynTy _ ty) = splitFunTy_maybe ty +splitFunTy_maybe other = Nothing + + +splitFunTys :: GenType flexi -> ([GenType flexi], GenType flexi) +splitFunTys ty = split [] ty ty where - go t ts = case (get t) of - Just (arg,res) -> go res (arg:ts) - Nothing -> (reverse ts, t) + split args orig_ty (FunTy arg res) = split (arg:args) res res + split args orig_ty (SynTy _ ty) = split args orig_ty ty + split args orig_ty ty = (reverse args, orig_ty) \end{code} -\begin{code} --- NB applyTyCon puts in usageOmega, for now at least -mkTyConTy tycon - = ASSERT(not (isSynTyCon tycon)) - TyConTy tycon usageOmega -applyTyCon :: TyCon -> [GenType t u] -> GenType t u -applyTyCon tycon tys - = ASSERT (not (isSynTyCon tycon)) - --(if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $ - foldl AppTy (TyConTy tycon usageOmega) tys -getTyCon_maybe :: GenType t u -> Maybe TyCon +--------------------------------------------------------------------- + TyConApp + ~~~~~~~~ -getTyCon_maybe (TyConTy tycon _) = Just tycon -getTyCon_maybe (SynTy _ _ t) = getTyCon_maybe t -getTyCon_maybe other_ty = Nothing +\begin{code} +mkTyConApp :: TyCon -> [GenType flexi] -> GenType flexi +mkTyConApp tycon tys + | isFunTyCon tycon && length tys == 2 + = case tys of + (ty1:ty2:_) -> FunTy ty1 ty2 + + | otherwise + = ASSERT(not (isSynTyCon tycon)) + TyConApp tycon tys + +mkTyConTy :: TyCon -> GenType flexi +mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) ) + TyConApp tycon [] + +-- splitTyConApp "looks through" synonyms, because they don't +-- mean a distinct type, but all other type-constructor applications +-- including functions are returned as Just .. + +splitTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi]) +splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +splitTyConApp_maybe (FunTy arg res) = Just (mkFunTyCon, [arg,res]) +splitTyConApp_maybe (SynTy _ ty) = splitTyConApp_maybe ty +splitTyConApp_maybe other = Nothing + +-- splitAlgTyConApp_maybe looks for +-- *saturated* applications of *algebraic* data types +-- "Algebraic" => newtype, data type, or dictionary (not function types) +-- We return the constructors too. + +splitAlgTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi], [Id]) +splitAlgTyConApp_maybe (TyConApp tc tys) + | isAlgTyCon tc && + tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc) +splitAlgTyConApp_maybe (SynTy _ ty) = splitAlgTyConApp_maybe ty +splitAlgTyConApp_maybe other = Nothing + +splitAlgTyConApp :: GenType flexi -> (TyCon, [GenType flexi], [Id]) + -- Here the "algebraic" property is an *assertion* +splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys ) + (tc, tys, tyConDataCons tc) +splitAlgTyConApp (SynTy _ ty) = splitAlgTyConApp ty \end{code} +y"Dictionary" types are just ordinary data types, but you can +tell from the type constructor whether it's a dictionary or not. + \begin{code} -specialiseTy :: Type -- The type of the Id of which the SpecId - -- is a specialised version - -> [Maybe Type] -- The types at which it is specialised - -> Int -- Number of leading dictionary args to ignore - -> Type - -specialiseTy main_ty maybe_tys dicts_to_ignore - = --false:ASSERT(isTauTy tau) TauType?? - mkSigmaTy remaining_tyvars - (instantiateThetaTy inst_env remaining_theta) - (instantiateTauTy inst_env tau) +mkDictTy :: Class -> [GenType flexi] -> GenType flexi +mkDictTy clas tys = TyConApp (classTyCon clas) tys + +splitDictTy_maybe :: GenType flexi -> Maybe (Class, [GenType flexi]) +splitDictTy_maybe (TyConApp tc tys) + | maybeToBool maybe_class + && tyConArity tc == length tys = Just (clas, tys) where - (tyvars, theta, tau) = splitSigmaTy main_ty -- A prefix of, but usually all, - -- the theta is discarded! - remaining_theta = drop dicts_to_ignore theta - tyvars_and_maybe_tys = tyvars `zip` maybe_tys - remaining_tyvars = [tyvar | (tyvar, Nothing) <- tyvars_and_maybe_tys] - inst_env = [(tyvar,ty) | (tyvar, Just ty) <- tyvars_and_maybe_tys] + maybe_class = tyConClass_maybe tc + Just clas = maybe_class + +splitDictTy_maybe (SynTy _ ty) = splitDictTy_maybe ty +splitDictTy_maybe other = Nothing + +isDictTy :: GenType flexi -> Bool + -- This version is slightly more efficient than (maybeToBool . splitDictTy) +isDictTy (TyConApp tc tys) + | maybeToBool (tyConClass_maybe tc) + && tyConArity tc == length tys + = True +isDictTy (SynTy _ ty) = isDictTy ty +isDictTy other = False \end{code} + +--------------------------------------------------------------------- + SynTy + ~~~~~ + \begin{code} mkSynTy syn_tycon tys = ASSERT(isSynTyCon syn_tycon) - SynTy syn_tycon tys (instantiateTauTy (zipEqual "mkSynTy" tyvars tys) body) + SynTy (TyConApp syn_tycon tys) + (instantiateTauTy (zipTyVarEnv tyvars tys) body) where (tyvars, body) = getSynTyConDefn syn_tycon -\end{code} -Tau stuff -~~~~~~~~~ -\begin{code} -isTauTy :: GenType t u -> Bool -isTauTy (TyVarTy v) = True -isTauTy (TyConTy _ _) = True -isTauTy (AppTy a b) = isTauTy a && isTauTy b -isTauTy (FunTy a b _) = isTauTy a && isTauTy b -isTauTy (SynTy _ _ ty) = isTauTy ty -isTauTy other = False +isSynTy (SynTy _ _) = True +isSynTy other = False \end{code} -Rho stuff -~~~~~~~~~ -NB mkRhoTy and mkDictTy put in usageOmega, for now at least +Notes on type synonyms +~~~~~~~~~~~~~~~~~~~~~~ +The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try +to return type synonyms whereever possible. Thus -\begin{code} -mkDictTy :: Class -> GenType t u -> GenType t u -mkDictTy clas ty = DictTy clas ty usageOmega + type Foo a = a -> a + +we want + splitFunTys (a -> Foo a) = ([a], Foo a) +not ([a], a -> a) + +The reason is that we then get better (shorter) type signatures in +interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. -mkRhoTy :: [(Class, GenType t u)] -> GenType t u -> GenType t u -mkRhoTy theta ty = - foldr (\(c,t) r -> FunTy (DictTy c t usageOmega) r usageOmega) ty theta -splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u) -splitRhoTy t = - go t t [] - where - -- See notes on type synonyms above - go syn_t (FunTy (DictTy c t _) r _) ts = go r r ((c,t):ts) - go syn_t (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts - | isFunTyCon tycon - = go r r ((c,t):ts) - go syn_t (SynTy _ _ t) ts = go syn_t t ts - go syn_t t ts = (reverse ts, syn_t) - - -mkTheta :: [Type] -> ThetaType - -- recover a ThetaType from the types of some dictionaries -mkTheta dict_tys - = map cvt dict_tys - where - cvt (DictTy clas ty _) = (clas, ty) - cvt other = panic "Type.mkTheta" -- pprPanic "mkTheta:" (pprType PprDebug other) -isDictTy (DictTy _ _ _) = True -isDictTy (SynTy _ _ t) = isDictTy t -isDictTy _ = False -\end{code} +--------------------------------------------------------------------- + ForAllTy + ~~~~~~~~ -Forall stuff -~~~~~~~~~~~~ \begin{code} mkForAllTy = ForAllTy -mkForAllTys :: [t] -> GenType t u -> GenType t u +mkForAllTys :: [GenTyVar flexi] -> GenType flexi -> GenType flexi mkForAllTys tyvars ty = foldr ForAllTy ty tyvars -getForAllTy_maybe :: GenType t u -> Maybe (t,GenType t u) -getForAllTy_maybe (SynTy _ _ t) = getForAllTy_maybe t -getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t) -getForAllTy_maybe _ = Nothing - -getForAllTyExpandingDicts_maybe :: Type -> Maybe (TyVar, Type) -getForAllTyExpandingDicts_maybe (SynTy _ _ t) = getForAllTyExpandingDicts_maybe t -getForAllTyExpandingDicts_maybe (ForAllTy tyvar t) = Just(tyvar,t) -getForAllTyExpandingDicts_maybe ty@(DictTy _ _ _) = getForAllTyExpandingDicts_maybe (expandTy ty) -getForAllTyExpandingDicts_maybe _ = Nothing - -splitForAllTy :: GenType t u -> ([t], GenType t u) -splitForAllTy t = go t t [] - where - -- See notes on type synonyms above - go syn_t (ForAllTy tv t) tvs = go t t (tv:tvs) - go syn_t (SynTy _ _ t) tvs = go syn_t t tvs - go syn_t t tvs = (reverse tvs, syn_t) - -splitForAllTyExpandingDicts :: Type -> ([TyVar], Type) -splitForAllTyExpandingDicts ty - = go [] ty - where - go tvs ty = case getForAllTyExpandingDicts_maybe ty of - Just (tv, ty') -> go (tv:tvs) ty' - Nothing -> (reverse tvs, ty) +splitForAllTy_maybe :: GenType flexi -> Maybe (GenTyVar flexi, GenType flexi) +splitForAllTy_maybe (SynTy _ ty) = splitForAllTy_maybe ty +splitForAllTy_maybe (ForAllTy tyvar ty) = Just(tyvar, ty) +splitForAllTy_maybe _ = Nothing + +splitForAllTys :: GenType flexi -> ([GenTyVar flexi], GenType flexi) +splitForAllTys ty = split ty ty [] + where + split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) + split orig_ty (SynTy _ ty) tvs = split orig_ty ty tvs + split orig_ty t tvs = (reverse tvs, orig_ty) \end{code} -\begin{code} -mkForAllUsageTy :: u -> [u] -> GenType t u -> GenType t u -mkForAllUsageTy = ForAllUsageTy -getForAllUsageTy :: GenType t u -> Maybe (u,[u],GenType t u) -getForAllUsageTy (ForAllUsageTy uvar bounds t) = Just(uvar,bounds,t) -getForAllUsageTy (SynTy _ _ t) = getForAllUsageTy t -getForAllUsageTy _ = Nothing -\end{code} - -Applied tycons (includes FunTyCons) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -maybeAppTyCon - :: GenType tyvar uvar - -> Maybe (TyCon, -- the type constructor - [GenType tyvar uvar]) -- types to which it is applied - -maybeAppTyCon ty - = case (getTyCon_maybe app_ty) of - Nothing -> Nothing - Just tycon -> Just (tycon, arg_tys) - where - (app_ty, arg_tys) = splitAppTys ty +applyTy :: GenType flexi -> GenType flexi -> GenType flexi +applyTy (SynTy _ fun) arg = applyTy fun arg +applyTy (ForAllTy tv ty) arg = instantiateTy (mkTyVarEnv [(tv,arg)]) ty +applyTy other arg = panic "applyTy" +\end{code} -getAppTyCon - :: GenType tyvar uvar - -> (TyCon, -- the type constructor - [GenType tyvar uvar]) -- types to which it is applied +%************************************************************************ +%* * +\subsection{Stuff to do with the source-language types} +%* * +%************************************************************************ -getAppTyCon ty - = case maybeAppTyCon ty of - Just stuff -> stuff -#ifdef DEBUG - Nothing -> panic "Type.getAppTyCon" -- (ppr PprShowAll ty) -#endif +\begin{code} +type RhoType = Type +type TauType = Type +type ThetaType = [(Class, [Type])] +type SigmaType = Type \end{code} -Applied data tycons (give back constrs) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Nota Bene: all these functions suceed for @newtype@ applications too! +@isTauTy@ tests for nested for-alls. \begin{code} -maybeAppDataTyCon - :: GenType (GenTyVar any) uvar - -> Maybe (TyCon, -- the type constructor - [GenType (GenTyVar any) uvar], -- types to which it is applied - [Id]) -- its family of data-constructors -maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts - :: Type -> Maybe (TyCon, [Type], [Id]) - -maybeAppDataTyCon ty = maybe_app_data_tycon (\x->x) ty -maybeAppDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty -maybeAppSpecDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty - - -maybe_app_data_tycon expand ty - = let - expanded_ty = expand ty - (app_ty, arg_tys) = splitAppTys expanded_ty - in - case (getTyCon_maybe app_ty) of - Just tycon | isAlgTyCon tycon && -- NB "Alg"; succeeds for newtype too - notArrowKind (typeKind expanded_ty) - -- Must be saturated for ty to be a data type - -> Just (tycon, arg_tys, tyConDataCons tycon) - - other -> Nothing - -getAppDataTyCon, getAppSpecDataTyCon - :: GenType (GenTyVar any) uvar - -> (TyCon, -- the type constructor - [GenType (GenTyVar any) uvar], -- types to which it is applied - [Id]) -- its family of data-constructors -getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts - :: Type -> (TyCon, [Type], [Id]) - -getAppDataTyCon ty = get_app_data_tycon maybeAppDataTyCon ty -getAppDataTyConExpandingDicts ty = --pprTrace "getAppDataTyConEx...:" (pprType PprDebug ty) $ - get_app_data_tycon maybeAppDataTyConExpandingDicts ty - --- these should work like the UniTyFuns.getUniDataSpecTyCon* things of old (ToDo) -getAppSpecDataTyCon = getAppDataTyCon -getAppSpecDataTyConExpandingDicts = getAppDataTyConExpandingDicts - -get_app_data_tycon maybe ty - = case maybe ty of - Just stuff -> stuff -#ifdef DEBUG - Nothing -> panic "Type.getAppDataTyCon"-- (pprGenType PprShowAll ty) -#endif - - -maybeBoxedPrimType :: Type -> Maybe (Id, Type) - -maybeBoxedPrimType ty - = case (maybeAppDataTyCon ty) of -- Data type, - Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon -- with exactly one constructor - -> case (dataConArgTys data_con tys_applied) of - [data_con_arg_ty] -- Applied to exactly one type, - | isPrimType data_con_arg_ty -- which is primitive - -> Just (data_con, data_con_arg_ty) - other_cases -> Nothing - other_cases -> Nothing +isTauTy :: GenType flexi -> Bool +isTauTy (TyVarTy v) = True +isTauTy (TyConApp _ tys) = all isTauTy tys +isTauTy (AppTy a b) = isTauTy a && isTauTy b +isTauTy (FunTy a b) = isTauTy a && isTauTy b +isTauTy (SynTy _ ty) = isTauTy ty +isTauTy other = False \end{code} \begin{code} -splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u) +mkRhoTy :: [(Class, [GenType flexi])] -> GenType flexi -> GenType flexi +mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta + +splitRhoTy :: GenType flexi -> ([(Class, [GenType flexi])], GenType flexi) +splitRhoTy ty = split ty ty [] + where + split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of + Just pair -> split res res (pair:ts) + Nothing -> (reverse ts, orig_ty) + split orig_ty (SynTy _ ty) ts = split orig_ty ty ts + split orig_ty ty ts = (reverse ts, orig_ty) +\end{code} + + + +\begin{code} +mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) + +splitSigmaTy :: GenType flexi -> ([GenTyVar flexi], [(Class, [GenType flexi])], GenType flexi) splitSigmaTy ty = (tyvars, theta, tau) where - (tyvars,rho) = splitForAllTy ty + (tyvars,rho) = splitForAllTys ty (theta,tau) = splitRhoTy rho - -mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) \end{code} -Finding the kind of a type -~~~~~~~~~~~~~~~~~~~~~~~~~~ +%************************************************************************ +%* * +\subsection{Kinds and free variables} +%* * +%************************************************************************ + +--------------------------------------------------------------------- + Finding the kind of a type + ~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -typeKind :: GenType (GenTyVar any) u -> Kind +typeKind :: GenType flexi -> Kind typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (TyConTy tycon usage) = tyConKind tycon -typeKind (SynTy _ _ ty) = typeKind ty -typeKind (FunTy fun arg _) = mkBoxedTypeKind -typeKind (DictTy clas arg _) = mkBoxedTypeKind +typeKind (TyConApp tycon tys) = foldr (\_ k -> resultKind k) (tyConKind tycon) tys +typeKind (SynTy _ ty) = typeKind ty +typeKind (FunTy fun arg) = mkBoxedTypeKind typeKind (AppTy fun arg) = resultKind (typeKind fun) typeKind (ForAllTy _ _) = mkBoxedTypeKind -typeKind (ForAllUsageTy _ _ _) = mkBoxedTypeKind \end{code} -Free variables of a type -~~~~~~~~~~~~~~~~~~~~~~~~ +--------------------------------------------------------------------- + Free variables of a type + ~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi +tyVarsOfType :: GenType flexi -> GenTyVarSet flexi tyVarsOfType (TyVarTy tv) = unitTyVarSet tv -tyVarsOfType (TyConTy tycon usage) = emptyTyVarSet -tyVarsOfType (SynTy _ tys ty) = tyVarsOfTypes tys -tyVarsOfType (FunTy arg res _) = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res +tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys +tyVarsOfType (SynTy ty1 ty2) = tyVarsOfType ty1 +tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg -tyVarsOfType (DictTy clas ty _) = tyVarsOfType ty tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar -tyVarsOfType (ForAllUsageTy _ _ ty) = tyVarsOfType ty -tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi +tyVarsOfTypes :: [GenType flexi] -> GenTyVarSet flexi tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys -- Find the free names of a type, including the type constructors and classes it mentions -namesOfType :: GenType (GenTyVar flexi) uvar -> NameSet +namesOfType :: GenType flexi -> NameSet namesOfType (TyVarTy tv) = unitNameSet (getName tv) -namesOfType (TyConTy tycon usage) = unitNameSet (getName tycon) -namesOfType (SynTy tycon tys ty) = unitNameSet (getName tycon) `unionNameSets` - namesOfType ty -namesOfType (FunTy arg res _) = namesOfType arg `unionNameSets` namesOfType res +namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` + namesOfTypes tys +namesOfType (SynTy ty1 ty2) = namesOfType ty1 +namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg -namesOfType (DictTy clas ty _) = unitNameSet (getName clas) `unionNameSets` - namesOfType ty namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar) -namesOfType (ForAllUsageTy _ _ ty) = panic "forall usage" -\end{code} - - -Instantiating a type -~~~~~~~~~~~~~~~~~~~~ -\begin{code} --- applyTy :: GenType (GenTyVar flexi) uvar --- -> GenType (GenTyVar flexi) uvar --- -> GenType (GenTyVar flexi) uvar -applyTy :: Type -> Type -> Type - -applyTy (SynTy _ _ fun) arg = applyTy fun arg -applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty -applyTy ty@(DictTy _ _ _) arg = applyTy (expandTy ty) arg -applyTy other arg = panic "applyTy" +namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys \end{code} -\begin{code} -instantiateTy :: [(GenTyVar flexi, GenType (GenTyVar flexi) uvar)] - -> GenType (GenTyVar flexi) uvar - -> GenType (GenTyVar flexi) uvar - -instantiateTauTy :: Eq tv => - [(tv, GenType tv' u)] - -> GenType tv u - -> GenType tv' u -applyTypeEnvToTy :: TyVarEnv Type -> SigmaType -> SigmaType - --- instantiateTauTy works only (a) on types with no ForAlls, --- and when (b) all the type variables are being instantiated --- In return it is more polymorphic than instantiateTy +%************************************************************************ +%* * +\subsection{Instantiating a type} +%* * +%************************************************************************ -instant_help ty lookup_tv deflt_tv choose_tycon - if_usage if_forall bound_forall_tv_BAD deflt_forall_tv - = go ty - where - go (TyVarTy tv) = case (lookup_tv tv) of - Nothing -> deflt_tv tv - Just ty -> ty - go ty@(TyConTy tycon usage) = choose_tycon ty tycon usage - go (SynTy tycon tys ty) = SynTy tycon (map go tys) (go ty) - go (FunTy arg res usage) = FunTy (go arg) (go res) usage - go (AppTy fun arg) = AppTy (go fun) (go arg) - go (DictTy clas ty usage) = DictTy clas (go ty) usage - go (ForAllUsageTy uvar bds ty) = if_usage $ - ForAllUsageTy uvar bds (go ty) - go (ForAllTy tv ty) = if_forall $ - (if (bound_forall_tv_BAD && maybeToBool (lookup_tv tv)) then - trace "instantiateTy: unexpected forall hit" - else - \x->x) ForAllTy (deflt_forall_tv tv) (go ty) - -instantiateTy [] ty = ty +\begin{code} +instantiateTy :: TyVarEnv (GenType flexi) -> GenType flexi -> GenType flexi +instantiateTauTy :: TyVarEnv (GenType flexi2) -> GenType flexi1 -> GenType flexi2 -instantiateTy tenv ty - = instant_help ty lookup_tv deflt_tv choose_tycon - if_usage if_forall bound_forall_tv_BAD deflt_forall_tv - where - lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of - [] -> Nothing - [ty] -> Just ty - _ -> panic "instantiateTy:lookup_tv" - - deflt_tv tv = TyVarTy tv - choose_tycon ty _ _ = ty - if_usage ty = ty - if_forall ty = ty - bound_forall_tv_BAD = True - deflt_forall_tv tv = tv - -instantiateTauTy tenv ty - = instant_help ty lookup_tv deflt_tv choose_tycon - if_usage if_forall bound_forall_tv_BAD deflt_forall_tv - where - lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of - [] -> Nothing - [ty] -> Just ty - _ -> panic "instantiateTauTy:lookup_tv" - - deflt_tv tv = panic "instantiateTauTy" - choose_tycon _ tycon usage = TyConTy tycon usage - if_usage ty = panic "instantiateTauTy:ForAllUsageTy" - if_forall ty = panic "instantiateTauTy:ForAllTy" - bound_forall_tv_BAD = panic "instantiateTauTy:bound_forall_tv" - deflt_forall_tv tv = panic "instantiateTauTy:deflt_forall_tv" -instantiateThetaTy tenv theta - = [(clas,instantiateTauTy tenv ty) | (clas,ty) <- theta] - --- applyTypeEnv applies a type environment to a type. +-- instantiateTy applies a type environment to a type. -- It can handle shadowing; for example: -- f = /\ t1 t2 -> \ d -> -- letrec f' = /\ t1 -> \x -> ...(f' t1 x')... @@ -680,130 +476,91 @@ instantiateThetaTy tenv theta -- As a sanity check, we should also check that name capture -- doesn't occur, but that means keeping track of the free variables of the -- range of the TyVarEnv, which I don't do just yet. --- --- We don't use instant_help because we need to carry in the environment -applyTypeEnvToTy tenv ty +instantiateTy tenv ty + | isEmptyTyVarEnv tenv + = ty + + | otherwise = go tenv ty where - go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of - Nothing -> ty - Just ty -> ty - go tenv ty@(TyConTy tycon usage) = ty - go tenv (SynTy tycon tys ty) = SynTy tycon (map (go tenv) tys) (go tenv ty) - go tenv (FunTy arg res usage) = FunTy (go tenv arg) (go tenv res) usage - go tenv (AppTy fun arg) = AppTy (go tenv fun) (go tenv arg) - go tenv (DictTy clas ty usage) = DictTy clas (go tenv ty) usage - go tenv (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go tenv ty) - go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty) - where - tenv' = case lookupTyVarEnv tenv tv of - Nothing -> tenv - Just _ -> delFromTyVarEnv tenv tv -\end{code} + go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of + Nothing -> ty + Just ty -> ty + go tenv (TyConApp tc tys) = TyConApp tc (map (go tenv) tys) + go tenv (SynTy ty1 ty2) = SynTy (go tenv ty1) (go tenv ty2) + go tenv (FunTy arg res) = FunTy (go tenv arg) (go tenv res) + go tenv (AppTy fun arg) = mkAppTy (go tenv fun) (go tenv arg) + go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty) + where + tenv' = case lookupTyVarEnv tenv tv of + Nothing -> tenv + Just _ -> delFromTyVarEnv tenv tv -\begin{code} -instantiateUsage - :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u' - -instantiateUsage = panic "instantiateUsage: not implemented" -\end{code} - -Expand abbreviations -~~~~~~~~~~~~~~~~~~~~ -Removes just the top level of any abbreviations. - -\begin{code} -expandTy :: Type -> Type -- Restricted to Type due to Dict expansion - -expandTy (FunTy t1 t2 u) = AppTy (AppTy (TyConTy mkFunTyCon u) t1) t2 -expandTy (SynTy _ _ t) = expandTy t -expandTy (DictTy clas ty u) - = case all_arg_tys of - - [] -> voidTy -- Empty dictionary represented by Void - - [arg_ty] -> expandTy arg_ty -- just the <whatever> itself - - -- The extra expandTy is to make sure that - -- the result isn't still a dict, which it might be - -- if the original guy was a dict with one superdict and - -- no methods! - - other -> ASSERT(not (null all_arg_tys)) - foldl AppTy (TyConTy (tupleTyCon (length all_arg_tys)) u) all_arg_tys +-- instantiateTauTy works only (a) on types with no ForAlls, +-- and when (b) all the type variables are being instantiated +-- In return it is more polymorphic than instantiateTy - -- A tuple of 'em - -- Note: length of all_arg_tys can be 0 if the class is - -- CCallable, CReturnable (and anything else - -- *really weird* that the user writes). +instantiateTauTy tenv ty = go ty where - all_arg_tys = classDictArgTys clas ty + go ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of + Just ty -> ty -- Must succeed + go (TyConApp tc tys) = TyConApp tc (map go tys) + go (SynTy ty1 ty2) = SynTy (go ty1) (go ty2) + go (FunTy arg res) = FunTy (go arg) (go res) + go (AppTy fun arg) = mkAppTy (go fun) (go arg) + go (ForAllTy tv ty) = panic "instantiateTauTy" + -expandTy ty = ty +instantiateThetaTy :: TyVarEnv Type -> ThetaType -> ThetaType +instantiateThetaTy tenv theta + = [(clas, map (instantiateTauTy tenv) tys) | (clas, tys) <- theta] \end{code} -At present there are no unboxed non-primitive types, so -isUnboxedType is the same as isPrimType. -We're a bit cavalier about finding out whether something is -primitive/unboxed or not. Rather than deal with the type -arguemnts we just zoom into the function part of the type. -That is, given (T a) we just recurse into the "T" part, -ignoring "a". +%************************************************************************ +%* * +\subsection{Boxedness and pointedness} +%* * +%************************************************************************ -\begin{code} -isPrimType, isUnboxedType :: Type -> Bool +A type is + *unboxed* iff its representation is other than a pointer + Unboxed types cannot instantiate a type variable + Unboxed types are always unpointed. -isPrimType (AppTy ty _) = isPrimType ty -isPrimType (SynTy _ _ ty) = isPrimType ty -isPrimType (TyConTy tycon _) = case maybeNewTyCon tycon of - Just (tyvars, ty) -> isPrimType ty - Nothing -> isPrimTyCon tycon + *unpointed* iff it can't be a thunk, and cannot have value bottom + An unpointed type may or may not be unboxed. + (E.g. Array# is unpointed, but boxed.) + An unpointed type *can* instantiate a type variable, + provided it is boxed. -isPrimType _ = False + *primitive* iff it is a built-in type that can't be expressed + in Haskell -isUnboxedType = isPrimType -\end{code} +Currently, all primitive types are unpointed, but that's not necessarily +the case. (E.g. Int could be primitive.) -This is *not* right: it is a placeholder (ToDo 96/03 WDP): \begin{code} -typePrimRep :: Type -> PrimRep +isUnboxedType :: Type -> Bool +isUnboxedType ty = case typePrimRep ty of + PtrRep -> False + other -> True + +-- Danger! Currently the unpointed types are precisely +-- the primitive ones, but that might not always be the case +isUnpointedType :: Type -> Bool +isUnpointedType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> isPrimTyCon tc + other -> False -typePrimRep (SynTy _ _ ty) = typePrimRep ty -typePrimRep (AppTy ty _) = typePrimRep ty -typePrimRep (TyConTy tc _) - | isPrimTyCon tc = case (assocMaybe tc_primrep_list (uniqueOf tc)) of - Just xx -> xx - Nothing -> panic "Type.typePrimRep" -- pprPanic "typePrimRep:" (pprTyCon PprDebug tc) - - | otherwise = case maybeNewTyCon tc of - Just (tyvars, ty) | isPrimType ty -> typePrimRep ty - _ -> PtrRep -- Default - -typePrimRep _ = PtrRep -- the "default" - -tc_primrep_list - = [(addrPrimTyConKey, AddrRep) - ,(arrayPrimTyConKey, ArrayRep) - ,(byteArrayPrimTyConKey, ByteArrayRep) - ,(charPrimTyConKey, CharRep) - ,(doublePrimTyConKey, DoubleRep) - ,(floatPrimTyConKey, FloatRep) - ,(foreignObjPrimTyConKey, ForeignObjRep) - ,(intPrimTyConKey, IntRep) - ,(mutableArrayPrimTyConKey, ArrayRep) - ,(mutableByteArrayPrimTyConKey, ByteArrayRep) - ,(stablePtrPrimTyConKey, StablePtrRep) - ,(statePrimTyConKey, VoidRep) - ,(synchVarPrimTyConKey, PtrRep) - ,(voidTyConKey, PtrRep) -- Not VoidRep! That's just for Void# - -- The type Void is represented by a pointer to - -- a bottom closure. - ,(wordPrimTyConKey, WordRep) - ] +typePrimRep :: Type -> PrimRep +typePrimRep ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> tyConPrimRep tc + other -> PtrRep \end{code} + %************************************************************************ %* * \subsection{Matching on types} @@ -820,47 +577,60 @@ types. It also fails on nested foralls. types. \begin{code} -matchTy :: GenType t1 u1 -- Template - -> GenType t2 u2 -- Proposed instance of template - -> Maybe [(t1,GenType t2 u2)] -- Matching substitution +matchTy :: GenType flexi1 -- Template + -> GenType flexi2 -- Proposed instance of template + -> Maybe (TyVarEnv (GenType flexi2)) -- Matching substitution -matchTys :: [GenType t1 u1] -- Templates - -> [GenType t2 u2] -- Proposed instance of template - -> Maybe ([(t1,GenType t2 u2)],-- Matching substitution - [GenType t2 u2]) -- Left over instance types - -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) [] = trace "matchTys" Nothing - go s (ty1:tys1) (ty2:tys2) = match ty1 ty2 (\s' -> go s' tys1 tys2) s +matchTys :: [GenType flexi1] -- Templates + -> [GenType flexi2] -- Proposed instance of template + -> Maybe (TyVarEnv (GenType flexi2), -- Matching substitution + [GenType flexi2]) -- Left over instance types + +matchTy ty1 ty2 = match ty1 ty2 (\s -> Just s) emptyTyVarEnv +matchTys tys1 tys2 = match_list tys1 tys2 (\pr -> Just pr) emptyTyVarEnv \end{code} @match@ is the main function. \begin{code} -match :: GenType t1 u1 -> GenType t2 u2 -- Current match pair - -> ([(t1, GenType t2 u2)] -> Maybe result) -- Continuation - -> [(t1, GenType t2 u2)] -- Current substitution +match :: GenType flexi1 -> GenType flexi2 -- Current match pair + -> (TyVarEnv (GenType flexi2) -> Maybe result) -- Continuation + -> TyVarEnv (GenType flexi2) -- Current substitution -> Maybe result -match (TyVarTy v) ty k = \s -> k ((v,ty) : s) -match (FunTy fun1 arg1 _) (FunTy fun2 arg2 _) k = match fun1 fun2 (match arg1 arg2 k) -match (AppTy fun1 arg1) (AppTy fun2 arg2) k = match fun1 fun2 (match arg1 arg2 k) -match (TyConTy con1 _) (TyConTy con2 _) k | con1 == con2 = k -match (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) k | clas1 == clas2 = match ty1 ty2 k -match (SynTy _ _ ty1) ty2 k = match ty1 ty2 k -match ty1 (SynTy _ _ ty2) k = match ty1 ty2 k +-- When matching against a type variable, see if the variable +-- has already been bound. If so, check that what it's bound to +-- is the same as ty; if not, bind it and carry on. + +match (TyVarTy v) ty k = \s -> case lookupTyVarEnv s v of + Nothing -> k (addToTyVarEnv s v ty) + Just ty' | ty' == ty -> k s -- Succeeds + | otherwise -> Nothing -- Fails + +match (FunTy arg1 res1) (FunTy arg2 res2) k = match arg1 arg2 (match res1 res2 k) +match (AppTy fun1 arg1) (AppTy fun2 arg2) k = match fun1 fun2 (match arg1 arg2 k) +match (TyConApp tc1 tys1) (TyConApp tc2 tys2) k | tc1 == tc2 + = match_list tys1 tys2 ( \(s,tys2') -> + if null tys2' then + k s -- Succeed + else + Nothing -- Fail + ) -- With type synonyms, we have to be careful for the exact -- same reasons as in the unifier. Please see the -- considerable commentary there before changing anything -- here! (WDP 95/05) +match (SynTy _ ty1) ty2 k = match ty1 ty2 k +match ty1 (SynTy _ ty2) k = match ty1 ty2 k -- Catch-all fails match _ _ _ = \s -> Nothing + +match_list [] tys2 k = \s -> k (s, tys2) +match_list (ty1:tys1) [] k = panic "match_list" +match_list (ty1:tys1) (ty2:tys2) k = match ty1 ty2 (match_list tys1 tys2 k) \end{code} %************************************************************************ @@ -869,123 +639,67 @@ match _ _ _ = \s -> Nothing %* * %************************************************************************ -The functions eqSimpleTy and eqSimpleTheta are polymorphic in the types t -and u, but ONLY WORK FOR SIMPLE TYPES (ie. they panic if they see -dictionaries or polymorphic types). The function eqTy has a more -specific type, but does the `right thing' for all types. +For the moment at least, type comparisons don't work if +there are embedded for-alls. \begin{code} -eqSimpleTheta :: (Eq t,Eq u) => - [(Class,GenType t u)] -> [(Class,GenType t u)] -> Bool +instance Eq (GenType flexi) where + ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False } -eqSimpleTheta [] [] = True -eqSimpleTheta ((c1,t1):th1) ((c2,t2):th2) = - c1==c2 && t1 `eqSimpleTy` t2 && th1 `eqSimpleTheta` th2 -eqSimpleTheta other1 other2 = False -\end{code} +instance Ord (GenType flexi) where + compare ty1 ty2 = cmpTy ty1 ty2 -\begin{code} -eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool - -(TyVarTy tv1) `eqSimpleTy` (TyVarTy tv2) = - tv1 == tv2 -(AppTy f1 a1) `eqSimpleTy` (AppTy f2 a2) = - f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 -(TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) = - tc1 == tc2 --ToDo: later: && u1 == u2 - -(FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) = - f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2 -(FunTy f1 a1 u1) `eqSimpleTy` t2 = - -- Expand t1 just in case t2 matches that version - (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) `eqSimpleTy` t2 -t1 `eqSimpleTy` (FunTy f2 a2 u2) = - -- Expand t2 just in case t1 matches that version - t1 `eqSimpleTy` (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2) - -(SynTy tc1 ts1 t1) `eqSimpleTy` (SynTy tc2 ts2 t2) = - (tc1 == tc2 && and (zipWith eqSimpleTy ts1 ts2) && length ts1 == length ts2) - || t1 `eqSimpleTy` t2 -(SynTy _ _ t1) `eqSimpleTy` t2 = - t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again -t1 `eqSimpleTy` (SynTy _ _ t2) = - t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again - -(DictTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got DictTy" -_ `eqSimpleTy` (DictTy _ _ _) = panic "eqSimpleTy: got DictTy" - -(ForAllTy _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllTy" -_ `eqSimpleTy` (ForAllTy _ _) = panic "eqSimpleTy: got ForAllTy" - -(ForAllUsageTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllUsageTy" -_ `eqSimpleTy` (ForAllUsageTy _ _ _) = panic "eqSimpleTy: got ForAllUsageTy" - -_ `eqSimpleTy` _ = False +cmpTy :: GenType flexi -> GenType flexi -> Ordering +cmpTy ty1 ty2 + = cmp emptyTyVarEnv ty1 ty2 + where + -- The "env" maps type variables in ty1 to type variables in ty2 + -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2) + -- we in effect substitute tv2 for tv1 in t1 before continuing + lookup env tv1 = case lookupTyVarEnv env tv1 of + Just tv2 -> tv2 + Nothing -> tv1 + + -- Get rid of SynTy + cmp env (SynTy _ ty1) ty2 = cmp env ty1 ty2 + cmp env ty1 (SynTy _ ty2) = cmp env ty1 ty2 + + -- Deal with equal constructors + cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2 + cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2 + cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2 + cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2) + cmp env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmp (addToTyVarEnv env tv1 tv2) t1 t2 + + -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy + cmp env (AppTy _ _) (TyVarTy _) = GT + + cmp env (FunTy _ _) (TyVarTy _) = GT + cmp env (FunTy _ _) (AppTy _ _) = GT + + cmp env (TyConApp _ _) (TyVarTy _) = GT + cmp env (TyConApp _ _) (AppTy _ _) = GT + cmp env (TyConApp _ _) (FunTy _ _) = GT + + cmp env (ForAllTy _ _) other = GT + + cmp env _ _ = LT + + cmps env [] [] = EQ + cmps env (t:ts) [] = GT + cmps env [] (t:ts) = LT + cmps env (t1:t1s) (t2:t2s) = cmp env t1 t2 `thenCmp` cmps env t1s t2s \end{code} -Types are ordered so we can sort on types in the renamer etc. DNT: Since -this class is also used in CoreLint and other such places, we DO expand out -Fun/Syn/Dict types (if necessary). -\begin{code} -eqTy :: Type -> Type -> Bool -eqTy t1 t2 = - eq nullTyVarEnv nullUVarEnv t1 t2 - where - eq tve uve (TyVarTy tv1) (TyVarTy tv2) = - tv1 == tv2 || - case (lookupTyVarEnv tve tv1) of - Just tv -> tv == tv2 - Nothing -> False - eq tve uve (AppTy f1 a1) (AppTy f2 a2) = - eq tve uve f1 f2 && eq tve uve a1 a2 - eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) = - tc1 == tc2 -- ToDo: LATER: && eqUsage uve u1 u2 - - eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) = - eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2 - eq tve uve (FunTy f1 a1 u1) t2 = - -- Expand t1 just in case t2 matches that version - eq tve uve (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) t2 - eq tve uve t1 (FunTy f2 a2 u2) = - -- Expand t2 just in case t1 matches that version - eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2) - - eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2) - | c1 == c2 - = eq tve uve t1 t2 && eqUsage uve u1 u2 - -- NB we use a guard for c1==c2 so that if they aren't equal we - -- fall through into expanding the type. Why? Because brain-dead - -- people might write - -- class Foo a => Baz a where {} - -- and that means that a Foo dictionary and a Baz dictionary are identical - -- Sigh. Let's hope we don't spend too much time in here! - - eq tve uve t1@(DictTy _ _ _) t2 = - eq tve uve (expandTy t1) t2 -- Expand the dictionary and try again - eq tve uve t1 t2@(DictTy _ _ _) = - eq tve uve t1 (expandTy t2) -- Expand the dictionary and try again - - eq tve uve (SynTy tc1 ts1 t1) (SynTy tc2 ts2 t2) = - (tc1 == tc2 && and (zipWith (eq tve uve) ts1 ts2) && length ts1 == length ts2) - || eq tve uve t1 t2 - eq tve uve (SynTy _ _ t1) t2 = - eq tve uve t1 t2 -- Expand the abbrevation and try again - eq tve uve t1 (SynTy _ _ t2) = - eq tve uve t1 t2 -- Expand the abbrevation and try again - - eq tve uve (ForAllTy tv1 t1) (ForAllTy tv2 t2) = - eq (addOneToTyVarEnv tve tv1 tv2) uve t1 t2 - eq tve uve (ForAllUsageTy u1 b1 t1) (ForAllUsageTy u2 b2 t2) = - eqBounds uve b1 b2 && eq tve (addOneToUVarEnv uve u1 u2) t1 t2 - - eq _ _ _ _ = False - - eqBounds uve [] [] = True - eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2 - eqBounds uve _ _ = False -\end{code} +%************************************************************************ +%* * +\subsection{Grime} +%* * +%************************************************************************ + + \begin{code} showTypeCategory :: Type -> Char @@ -1012,12 +726,12 @@ showTypeCategory ty = if isDictTy ty then '+' else - case getTyCon_maybe ty of - Nothing -> if maybeToBool (getFunTy_maybe ty) + case splitTyConApp_maybe ty of + Nothing -> if maybeToBool (splitFunTy_maybe ty) then '>' else '.' - Just tycon -> + Just (tycon, _) -> let utc = uniqueOf tycon in if utc == charDataConKey then 'C' else if utc == intDataConKey then 'I' diff --git a/ghc/compiler/types/Usage.lhs b/ghc/compiler/types/Usage.lhs deleted file mode 100644 index 5ea9e4cb69..0000000000 --- a/ghc/compiler/types/Usage.lhs +++ /dev/null @@ -1,116 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 -% -\section[Usage]{The @Usage@ datatype} - -\begin{code} -#include "HsVersions.h" - -module Usage ( - GenUsage(..), SYN_IE(Usage), SYN_IE(UVar), SYN_IE(UVarEnv), - usageOmega, pprUVar, duffUsage, - nullUVarEnv, mkUVarEnv, addOneToUVarEnv, - growUVarEnvList, isNullUVarEnv, lookupUVarEnv, - eqUVar, eqUsage, cloneUVar -) where - -IMP_Ubiq(){-uitous-} - -import Outputable -import Pretty ( Doc, Mode, ptext, (<>) ) -import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM, - plusUFM, sizeUFM, UniqFM - ) -import Unique ( Unique{-instances-} ) -import Util ( panic ) -\end{code} - -\begin{code} -data GenUsage uvar - = UsageVar uvar - | UsageOne - | UsageOmega - -type UVar = Unique -type Usage = GenUsage UVar - -usageOmega = UsageOmega - -cloneUVar :: UVar -> Unique -> UVar -cloneUVar uvar uniq = uniq - -duffUsage :: GenUsage uvar -duffUsage = panic "Usage of non-Type kind doesn't make sense" -\end{code} - -%************************************************************************ -%* * -\subsection{Environments} -%* * -%************************************************************************ - -\begin{code} -type UVarEnv a = UniqFM a - -nullUVarEnv :: UVarEnv a -mkUVarEnv :: [(UVar, a)] -> UVarEnv a -addOneToUVarEnv :: UVarEnv a -> UVar -> a -> UVarEnv a -growUVarEnvList :: UVarEnv a -> [(UVar, a)] -> UVarEnv a -isNullUVarEnv :: UVarEnv a -> Bool -lookupUVarEnv :: UVarEnv a -> UVar -> Maybe a - -nullUVarEnv = emptyUFM -mkUVarEnv = listToUFM -addOneToUVarEnv = addToUFM -lookupUVarEnv = lookupUFM - -growUVarEnvList env pairs = plusUFM env (listToUFM pairs) -isNullUVarEnv env = sizeUFM env == 0 -\end{code} - -%************************************************************************ -%* * -\subsection{Equality on usages} -%* * -%************************************************************************ - -Equaltity (with respect to an environment mapping usage variables -to equivalent usage variables). - -\begin{code} -eqUVar :: UVarEnv UVar -> UVar -> UVar -> Bool -eqUVar uve u1 u2 = - u1 == u2 || - case lookupUVarEnv uve u1 of - Just u -> u == u2 - Nothing -> False - -eqUsage :: UVarEnv UVar -> Usage -> Usage -> Bool -eqUsage uve (UsageVar u1) (UsageVar u2) = eqUVar uve u1 u2 -eqUsage uve UsageOne UsageOne = True -eqUsage uve UsageOmega UsageOmega = True -eqUsage _ _ _ = False -\end{code} - -%************************************************************************ -%* * -\subsection{Instances} -%* * -%************************************************************************ - -\begin{code} -instance Eq u => Eq (GenUsage u) where - (UsageVar u1) == (UsageVar u2) = u1 == u2 - UsageOne == UsageOne = True - UsageOmega == UsageOmega = True - _ == _ = False -\end{code} - -\begin{code} -instance Outputable uvar => Outputable (GenUsage uvar) where - ppr sty UsageOne = ptext SLIT("UsageOne") - ppr sty UsageOmega = ptext SLIT("UsageOmega") - ppr sty (UsageVar u) = pprUVar sty u - -pprUVar sty u = (<>) (ptext SLIT("u")) (ppr sty u) -\end{code} diff --git a/ghc/compiler/utils/Argv.lhs b/ghc/compiler/utils/Argv.lhs index c9fc6a589b..4793b127dc 100644 --- a/ghc/compiler/utils/Argv.lhs +++ b/ghc/compiler/utils/Argv.lhs @@ -4,36 +4,19 @@ \section[Argv]{@Argv@: direct (non-standard) access to command-line arguments} \begin{code} -#include "HsVersions.h" - module Argv ( argv ) where -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 200 -import PreludeGlaST ( indexAddrOffAddr ) -#endif +#include "HsVersions.h" -CHK_Ubiq() -- debugging consistency check -IMP_FASTSTRING() +import FastString -#if __GLASGOW_HASKELL__ == 201 -# define ADDR GHCbase.Addr -# define PACK_STR packCString -#elif __GLASGOW_HASKELL__ >= 202 -# define ADDR GlaExts.Addr -# define PACK_STR mkFastCharString -#else -# define ADDR _Addr -# define PACK_STR mkFastCharString -/* -# define ADDR _Addr -# define PACK_STR _packCString -*/ -#endif +import GlaExts ( Addr ) +import ArrBase ( indexAddrOffAddr ) argv :: [FAST_STRING] argv = unpackArgv ``prog_argv'' (``prog_argc''::Int) -unpackArgv :: ADDR -> Int -> [FAST_STRING] -- argv[1 .. argc-1] +unpackArgv :: Addr -> Int -> [FAST_STRING] -- argv[1 .. argc-1] unpackArgv argv argc = unpack 1 where @@ -42,6 +25,6 @@ unpackArgv argv argc = unpack 1 = if (n >= argc) then ([] :: [FAST_STRING]) else case (indexAddrOffAddr argv n) of { item -> - PACK_STR item : unpack (n + 1) + mkFastCharString item : unpack (n + 1) } \end{code} diff --git a/ghc/compiler/utils/Bag.lhs b/ghc/compiler/utils/Bag.lhs index fcb9a9c40b..546ad2fbc3 100644 --- a/ghc/compiler/utils/Bag.lhs +++ b/ghc/compiler/utils/Bag.lhs @@ -4,8 +4,6 @@ \section[Bags]{@Bag@: an unordered collection with duplicates} \begin{code} -#include "HsVersions.h" - module Bag ( Bag, -- abstract type @@ -17,12 +15,14 @@ module Bag ( listToBag, bagToList ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(List(partition)) +#include "HsVersions.h" + +import Outputable +import List ( partition ) +\end{code} -import Outputable --( interpp'SP ) -import Pretty +\begin{code} data Bag a = EmptyBag | UnitBag a @@ -149,10 +149,10 @@ bagToList b = foldrBag (:) [] b \begin{code} instance (Outputable a) => Outputable (Bag a) where - ppr sty EmptyBag = ptext SLIT("emptyBag") - ppr sty (UnitBag a) = ppr sty a - ppr sty (TwoBags b1 b2) = hsep [ppr sty b1 <> comma, ppr sty b2] - ppr sty (ListBag as) = interpp'SP sty as - ppr sty (ListOfBags bs) = brackets (interpp'SP sty bs) + ppr EmptyBag = ptext SLIT("emptyBag") + ppr (UnitBag a) = ppr a + ppr (TwoBags b1 b2) = hsep [ppr b1 <> comma, ppr b2] + ppr (ListBag as) = interpp'SP as + ppr (ListOfBags bs) = brackets (interpp'SP bs) \end{code} diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs index 3c69ce29e9..15df0baa14 100644 --- a/ghc/compiler/utils/Digraph.lhs +++ b/ghc/compiler/utils/Digraph.lhs @@ -1,15 +1,13 @@ \begin{code} -# include "HsVersions.h" - module Digraph( -- At present the only one with a "nice" external interface stronglyConnComp, stronglyConnCompR, SCC(..), - SYN_IE(Graph), SYN_IE(Vertex), + Graph, Vertex, graphFromEdges, buildG, transposeG, reverseE, outdegree, indegree, - Tree(..), SYN_IE(Forest), + Tree(..), Forest, showTree, showForest, dfs, dff, @@ -22,6 +20,8 @@ module Digraph( ) where +# include "HsVersions.h" + ------------------------------------------------------------------------------ -- A version of the graph algorithms described in: -- @@ -31,7 +31,6 @@ module Digraph( -- Also included is some additional code for printing tree structures ... ------------------------------------------------------------------------------ -#ifdef REALLY_HASKELL_1_3 #define ARR_ELT (COMMA) @@ -40,26 +39,7 @@ import List import ST import ArrBase import Maybe - -# if __GLASGOW_HASKELL__ >= 209 -import GlaExts ( thenST, returnST ) -# endif - -#else - -#define ARR_ELT (:=) -#define runST _runST -#define MutableArray _MutableArray -#define Show Text - -import PreludeGlaST -import Maybes ( mapMaybe ) - -#endif - -import Util ( Ord3(..), - sortLt - ) +import Util ( sortLt ) \end{code} @@ -74,7 +54,7 @@ data SCC vertex = AcyclicSCC vertex | CyclicSCC [vertex] stronglyConnComp - :: Ord3 key + :: Ord key => [(node, key, [key])] -- The graph; its ok for the -- out-list to contain keys which arent -- a vertex key, they are ignored @@ -89,7 +69,7 @@ stronglyConnComp edges -- The "R" interface is used when you expect to apply SCC to -- the (some of) the result of SCC, so you dont want to lose the dependency info stronglyConnCompR - :: Ord3 key + :: Ord key => [(node, key, [key])] -- The graph; its ok for the -- out-list to contain keys which arent -- a vertex key, they are ignored @@ -132,13 +112,13 @@ edges :: Graph -> [Edge] edges g = [ (v, w) | v <- vertices g, w <- g!v ] mapT :: (Vertex -> a -> b) -> Table a -> Table b -mapT f t = array (bounds t) [ ARR_ELT v (f v (t!v)) | v <- indices t ] +mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ] buildG :: Bounds -> [Edge] -> Graph #ifdef REALLY_HASKELL_1_3 buildG bounds edges = accumArray (flip (:)) [] bounds edges #else -buildG bounds edges = accumArray (flip (:)) [] bounds [ARR_ELT k v | (k,v) <- edges] +buildG bounds edges = accumArray (flip (:)) [] bounds [(,) k v | (k,v) <- edges] #endif transposeG :: Graph -> Graph @@ -158,7 +138,7 @@ indegree = outdegree . transposeG \begin{code} graphFromEdges - :: Ord3 key + :: Ord key => [(node, key, [key])] -> (Graph, Vertex -> (node, key, [key])) graphFromEdges edges @@ -167,13 +147,13 @@ graphFromEdges edges max_v = length edges - 1 bounds = (0,max_v) :: (Vertex, Vertex) sorted_edges = sortLt lt edges - edges1 = zipWith ARR_ELT [0..] sorted_edges + edges1 = zipWith (,) [0..] sorted_edges - graph = array bounds [ARR_ELT v (mapMaybe key_vertex ks) | ARR_ELT v (_, _, ks) <- edges1] - key_map = array bounds [ARR_ELT v k | ARR_ELT v (_, k, _ ) <- edges1] + graph = array bounds [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1] + key_map = array bounds [(,) v k | (,) v (_, k, _ ) <- edges1] vertex_map = array bounds edges1 - (_,k1,_) `lt` (_,k2,_) = case k1 `cmp` k2 of { LT_ -> True; other -> False } + (_,k1,_) `lt` (_,k2,_) = case k1 `compare` k2 of { LT -> True; other -> False } -- key_vertex :: key -> Maybe Vertex -- returns Nothing for non-interesting vertices @@ -181,10 +161,10 @@ graphFromEdges edges where find a b | a > b = Nothing - find a b = case cmp k (key_map ! mid) of - LT_ -> find a (mid-1) - EQ_ -> Just mid - GT_ -> find (mid+1) b + find a b = case compare k (key_map ! mid) of + LT -> find a (mid-1) + EQ -> Just mid + GT -> find (mid+1) b where mid = (a + b) `div` 2 \end{code} @@ -264,20 +244,20 @@ generate :: Graph -> Vertex -> Tree Vertex generate g v = Node v (map (generate g) (g!v)) prune :: Bounds -> Forest Vertex -> Forest Vertex -prune bnds ts = runST (mkEmpty bnds `thenST` \m -> +prune bnds ts = runST (mkEmpty bnds >>= \m -> chop m ts) chop :: Set s -> Forest Vertex -> ST s (Forest Vertex) -chop m [] = returnST [] +chop m [] = return [] chop m (Node v ts : us) - = contains m v `thenStrictlyST` \visited -> + = contains m v >>= \visited -> if visited then chop m us else - include m v `thenStrictlyST` \_ -> - chop m ts `thenStrictlyST` \as -> - chop m us `thenStrictlyST` \bs -> - returnST (Node v as : bs) + include m v >>= \_ -> + chop m ts >>= \as -> + chop m us >>= \bs -> + return (Node v as : bs) \end{code} @@ -302,7 +282,7 @@ preOrd :: Graph -> [Vertex] preOrd = preorderF . dff tabulate :: Bounds -> [Vertex] -> Table Int -tabulate bnds vs = array bnds (zipWith ARR_ELT vs [1..]) +tabulate bnds vs = array bnds (zipWith (,) vs [1..]) preArr :: Bounds -> Forest Vertex -> Table Int preArr bnds = tabulate bnds . preorderF diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs index e9624be6d9..0d6b055214 100644 --- a/ghc/compiler/utils/FastString.lhs +++ b/ghc/compiler/utils/FastString.lhs @@ -7,24 +7,27 @@ Compact representations of character strings with unique identifiers (hash-cons'ish). \begin{code} -#include "HsVersions.h" - module FastString ( FastString(..), -- not abstract, for now. --names? mkFastString, -- :: String -> FastString - mkFastCharString, -- :: _Addr -> FastString - mkFastCharString2, -- :: _Addr -> Int -> FastString - mkFastSubString, -- :: _Addr -> Int -> Int -> FastString + mkFastSubString, -- :: Addr -> Int -> Int -> FastString mkFastSubStringFO, -- :: ForeignObj -> Int -> Int -> FastString + -- These ones hold on to the Addr after they return, and aren't hashed; + -- they are used for literals + mkFastCharString, -- :: Addr -> FastString + mkFastCharString#, -- :: Addr# -> FastString + mkFastCharString2, -- :: Addr -> Int -> FastString + mkFastString#, -- :: Addr# -> Int# -> FastString mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString mkFastSubString#, -- :: Addr# -> Int# -> Int# -> FastString mkFastSubStringFO#, -- :: ForeignObj# -> Int# -> Int# -> FastString + uniqueOfFS, -- :: FastString -> Int# lengthFS, -- :: FastString -> Int nullFastString, -- :: FastString -> Bool @@ -37,43 +40,32 @@ module FastString concatFS, -- :: [FastString] -> FastString consFS, -- :: Char -> FastString -> FastString - hPutFS, -- :: Handle -> FastString -> IO () - tagCmpFS -- :: FastString -> FastString -> _CMP_TAG + hPutFS -- :: Handle -> FastString -> IO () ) where -#if __GLASGOW_HASKELL__ <= 201 -import PreludeGlaST -import PreludeGlaMisc -import HandleHack -import Ubiq -#else -import GlaExts -import Foreign -import IOBase -import IOHandle -import ST -import STBase -import {-# SOURCE #-} Unique ( mkUniqueGrimily, Unique, Uniquable(..) ) -#if __GLASGOW_HASKELL__ == 202 -import PrelBase ( Char (..) ) -#endif -#if __GLASGOW_HASKELL__ >= 206 -import PackBase -#endif -#if __GLASGOW_HASKELL__ >= 209 -import Addr -import IOExts -# define newVar newIORef -# define readVar readIORef -# define writeVar writeIORef -#endif - -#endif +-- This #define suppresses the "import FastString" that +-- HsVersions otherwise produces +#define COMPILING_FAST_STRING +#include "HsVersions.h" +import PackBase import PrimPacked +import GlaExts +import Addr ( Addr(..) ) +import STBase ( StateAndPtr#(..) ) +import ArrBase ( MutableArray(..) ) +import Foreign ( ForeignObj(..) ) +import IOExts ( IOArray(..), newIOArray, + IORef, newIORef, readIORef, writeIORef + ) +import IO +import IOHandle ( filePtr, readHandle, writeHandle ) +import IOBase ( Handle__(..), IOError(..), IOErrorType(..), + IOResult(..), IO(..), + constructError + ) #define hASH_TBL_SIZE 993 - \end{code} @FastString@s are packed representations of strings @@ -96,32 +88,19 @@ data FastString Int# -- length (cached) instance Eq FastString where - a == b = case tagCmpFS a b of { _LT -> False; _EQ -> True; _GT -> False } - a /= b = case tagCmpFS a b of { _LT -> True; _EQ -> False; _GT -> True } - -{- - (FastString u1# _ _) == (FastString u2# _ _) = u1# ==# u2# --} - -instance Uniquable FastString where - uniqueOf (FastString u# _ _) = mkUniqueGrimily u# - uniqueOf (CharStr a# l#) = - {- - [A somewhat moby hack]: to avoid entering all sorts - of junk into the hash table, all C char strings - are by default left out. The benefit of being in - the table is that string comparisons are lightning fast, - just an Int# comparison. - - But, if you want to get the Unique of a CharStr, we - enter it into the table and return that unique. This - works, but causes the CharStr to be looked up in the hash - table each time it is accessed.. - -} - mkUniqueGrimily (case mkFastString# a# l# of { FastString u# _ _ -> u#}) -- Ugh! + a == b = case cmpFS a b of { LT -> False; EQ -> True; GT -> False } + a /= b = case cmpFS a b of { LT -> True; EQ -> False; GT -> True } -instance Uniquable Int where - uniqueOf (I# i#) = mkUniqueGrimily i# +instance Ord FastString where + a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False } + a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False } + a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True } + a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True } + max x y | x >= y = x + | otherwise = y + min x y | x <= y = x + | otherwise = y + compare a b = cmpFS a b instance Text FastString where showsPrec p ps@(FastString u# _ _) r = showsPrec p (unpackFS ps) r @@ -130,8 +109,8 @@ instance Text FastString where getByteArray# :: FastString -> ByteArray# getByteArray# (FastString _ _ ba#) = ba# -getByteArray :: FastString -> _ByteArray Int -getByteArray (FastString _ l# ba#) = _ByteArray (0,I# l#) ba# +getByteArray :: FastString -> ByteArray Int +getByteArray (FastString _ l# ba#) = ByteArray (0,I# l#) ba# lengthFS :: FastString -> Int lengthFS (FastString _ l# _) = I# l# @@ -142,11 +121,7 @@ nullFastString (FastString _ l# _) = l# ==# 0# nullFastString (CharStr _ l#) = l# ==# 0# unpackFS :: FastString -> String -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 205 -unpackFS (FastString _ l# ba#) = byteArrayToString (_ByteArray (0,I# l#) ba#) -#else unpackFS (FastString _ l# ba#) = unpackCStringBA# ba# l# -#endif unpackFS (CharStr addr len#) = unpack 0# where @@ -174,6 +149,21 @@ tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#) consFS :: Char -> FastString -> FastString consFS c fs = mkFastString (c:unpackFS fs) +uniqueOfFS :: FastString -> Int# +uniqueOfFS (FastString u# _ _) = u# +uniqueOfFS (CharStr a# l#) = case mkFastString# a# l# of { FastString u# _ _ -> u#} -- Ugh! + {- + [A somewhat moby hack]: to avoid entering all sorts + of junk into the hash table, all C char strings + are by default left out. The benefit of being in + the table is that string comparisons are lightning fast, + just an Int# comparison. + + But, if you want to get the Unique of a CharStr, we + enter it into the table and return that unique. This + works, but causes the CharStr to be looked up in the hash + table each time it is accessed.. + -} \end{code} Internally, the compiler will maintain a fast string symbol @@ -185,54 +175,46 @@ new @FastString@s then covertly does a lookup, re-using the data FastStringTable = FastStringTable Int# - (MutableArray# _RealWorld [FastString]) + (MutableArray# RealWorld [FastString]) -#if __GLASGOW_HASKELL__ < 209 -type FastStringTableVar = MutableVar _RealWorld FastStringTable -#else type FastStringTableVar = IORef FastStringTable -#endif string_table :: FastStringTableVar string_table = - unsafePerformPrimIO ( - ST_TO_PrimIO (newArray (0::Int,hASH_TBL_SIZE) []) `thenPrimIO` \ (_MutableArray _ arr#) -> - newVar (FastStringTable 0# arr#)) + unsafePerformIO ( + stToIO (newArray (0::Int,hASH_TBL_SIZE) []) >>= \ (MutableArray _ arr#) -> + newIORef (FastStringTable 0# arr#)) -lookupTbl :: FastStringTable -> Int# -> PrimIO [FastString] +lookupTbl :: FastStringTable -> Int# -> IO [FastString] lookupTbl (FastStringTable _ arr#) i# = - ST_TO_PrimIO ( - MkST ( \ STATE_TOK(s#) -> + IO ( \ s# -> case readArray# arr# i# s# of { StateAndPtr# s2# r -> - ST_RET(r, STATE_TOK(s2#)) })) + IOok s2# r }) -updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> PrimIO () -updTbl ref (FastStringTable uid# arr#) i# ls = - ST_TO_PrimIO ( - MkST ( \ STATE_TOK(s#) -> - case writeArray# arr# i# ls s# of { s2# -> - ST_RET((), STATE_TOK(s2#)) })) `thenPrimIO` \ _ -> - writeVar ref (FastStringTable (uid# +# 1#) arr#) +updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> IO () +updTbl fs_table_var (FastStringTable uid# arr#) i# ls = + IO (\ s# -> case writeArray# arr# i# ls s# of { s2# -> IOok s2# () }) >> + writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#) mkFastString# :: Addr# -> Int# -> FastString mkFastString# a# len# = - unsafePerformPrimIO ( - readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) -> + unsafePerformIO ( + readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) -> let h = hashStr a# len# in -- _trace ("hashed: "++show (I# h)) $ - lookupTbl ft h `thenPrimIO` \ lookup_result -> + lookupTbl ft h >>= \ lookup_result -> case lookup_result of [] -> -- no match, add it to table by copying out the -- the string into a ByteArray -- _trace "empty bucket" $ case copyPrefixStr (A# a#) (I# len#) of - (_ByteArray _ barr#) -> + (ByteArray _ barr#) -> let f_str = FastString uid# len# barr# in - updTbl string_table ft h [f_str] `seqPrimIO` - ({- _trace ("new: " ++ show f_str) $ -} returnPrimIO f_str) + updTbl string_table ft h [f_str] >> + ({- _trace ("new: " ++ show f_str) $ -} return f_str) ls -> -- non-empty `bucket', scan the list looking -- entry with same length and compare byte by byte. @@ -240,11 +222,11 @@ mkFastString# a# len# = case bucket_match ls len# a# of Nothing -> case copyPrefixStr (A# a#) (I# len#) of - (_ByteArray _ barr#) -> + (ByteArray _ barr#) -> let f_str = FastString uid# len# barr# in - updTbl string_table ft h (f_str:ls) `seqPrimIO` - ( {- _trace ("new: " ++ show f_str) $ -} returnPrimIO f_str) - Just v -> {- _trace ("re-use: "++show v) $ -} returnPrimIO v) + updTbl string_table ft h (f_str:ls) >> + ( {- _trace ("new: " ++ show f_str) $ -} return f_str) + Just v -> {- _trace ("re-use: "++show v) $ -} return v) where bucket_match [] _ _ = Nothing bucket_match (v@(FastString _ l# ba#):ls) len# a# = @@ -258,32 +240,32 @@ mkFastSubString# a# start# len# = mkFastCharString2 (A# (addrOffset# a# start#)) mkFastSubStringFO# :: ForeignObj# -> Int# -> Int# -> FastString mkFastSubStringFO# fo# start# len# = - unsafePerformPrimIO ( - readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) -> + unsafePerformIO ( + readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) -> let h = hashSubStrFO fo# start# len# in - lookupTbl ft h `thenPrimIO` \ lookup_result -> + lookupTbl ft h >>= \ lookup_result -> case lookup_result of [] -> -- no match, add it to table by copying out the -- the string into a ByteArray case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of - (_ByteArray _ barr#) -> + (ByteArray _ barr#) -> let f_str = FastString uid# len# barr# in - updTbl string_table ft h [f_str] `seqPrimIO` - returnPrimIO f_str + updTbl string_table ft h [f_str] >> + return f_str ls -> -- non-empty `bucket', scan the list looking -- entry with same length and compare byte by byte. case bucket_match ls start# len# fo# of Nothing -> case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of - (_ByteArray _ barr#) -> + (ByteArray _ barr#) -> let f_str = FastString uid# len# barr# in - updTbl string_table ft h (f_str:ls) `seqPrimIO` - ( {- _trace ("new: " ++ show f_str) $ -} returnPrimIO f_str) - Just v -> {- _trace ("re-use: "++show v) $ -} returnPrimIO v) + updTbl string_table ft h (f_str:ls) >> + ( {- _trace ("new: " ++ show f_str) $ -} return f_str) + Just v -> {- _trace ("re-use: "++show v) $ -} return v) where bucket_match [] _ _ _ = Nothing bucket_match (v@(FastString _ l# barr#):ls) start# len# fo# = @@ -295,39 +277,39 @@ mkFastSubStringFO# fo# start# len# = mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString mkFastSubStringBA# barr# start# len# = - unsafePerformPrimIO ( - readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) -> + unsafePerformIO ( + readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) -> let h = hashSubStrBA barr# start# len# in -- _trace ("hashed(b): "++show (I# h)) $ - lookupTbl ft h `thenPrimIO` \ lookup_result -> + lookupTbl ft h >>= \ lookup_result -> case lookup_result of [] -> -- no match, add it to table by copying out the -- the string into a ByteArray -- _trace "empty bucket(b)" $ - case copySubStrBA (_ByteArray btm barr#) (I# start#) (I# len#) of - (_ByteArray _ ba#) -> + case copySubStrBA (ByteArray btm barr#) (I# start#) (I# len#) of + (ByteArray _ ba#) -> let f_str = FastString uid# len# ba# in - updTbl string_table ft h [f_str] `seqPrimIO` + updTbl string_table ft h [f_str] >> -- _trace ("new(b): " ++ show f_str) $ - returnPrimIO f_str + return f_str ls -> -- non-empty `bucket', scan the list looking -- entry with same length and compare byte by byte. -- _trace ("non-empty bucket(b)"++show ls) $ case bucket_match ls start# len# barr# of Nothing -> - case copySubStrBA (_ByteArray (error "") barr#) (I# start#) (I# len#) of - (_ByteArray _ ba#) -> + case copySubStrBA (ByteArray (error "") barr#) (I# start#) (I# len#) of + (ByteArray _ ba#) -> let f_str = FastString uid# len# ba# in - updTbl string_table ft h (f_str:ls) `seqPrimIO` + updTbl string_table ft h (f_str:ls) >> -- _trace ("new(b): " ++ show f_str) $ - returnPrimIO f_str + return f_str Just v -> -- _trace ("re-use(b): "++show v) $ - returnPrimIO v + return v ) where btm = error "" @@ -341,33 +323,32 @@ mkFastSubStringBA# barr# start# len# = else bucket_match ls start# len# ba# -mkFastCharString :: _Addr -> FastString +mkFastCharString :: Addr -> FastString mkFastCharString a@(A# a#) = case strLength a of{ (I# len#) -> CharStr a# len# } -mkFastCharString2 :: _Addr -> Int -> FastString +mkFastCharString# :: Addr# -> FastString +mkFastCharString# a# = + case strLength (A# a#) of { (I# len#) -> CharStr a# len# } + +mkFastCharString2 :: Addr -> Int -> FastString mkFastCharString2 a@(A# a#) (I# len#) = CharStr a# len# mkFastString :: String -> FastString mkFastString str = -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 205 - case stringToByteArray str of -#else case packString str of -#endif - (_ByteArray (_,I# len#) frozen#) -> + (ByteArray (_,I# len#) frozen#) -> mkFastSubStringBA# frozen# 0# len# {- 0-indexed array, len# == index to one beyond end of string, i.e., (0,1) => empty string. -} -mkFastSubString :: _Addr -> Int -> Int -> FastString +mkFastSubString :: Addr -> Int -> Int -> FastString mkFastSubString (A# a#) (I# start#) (I# len#) = mkFastString# (addrOffset# a# start#) len# mkFastSubStringFO :: _ForeignObj -> Int -> Int -> FastString mkFastSubStringFO (_ForeignObj fo#) (I# start#) (I# len#) = mkFastSubStringFO# fo# start# len# - \end{code} \begin{code} @@ -424,58 +405,47 @@ hashSubStrBA ba# start# len# = \end{code} \begin{code} -tagCmpFS :: FastString -> FastString -> _CMP_TAG -tagCmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars +cmpFS :: FastString -> FastString -> Ordering +cmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars if u1# ==# u2# then - _EQ + EQ else - unsafePerformPrimIO ( - _ccall_ strcmp (_ByteArray bottom b1#) (_ByteArray bottom b2#) `thenPrimIO` \ (I# res) -> - returnPrimIO ( - if res <# 0# then _LT - else if res ==# 0# then _EQ - else _GT + unsafePerformIO ( + _ccall_ strcmp (ByteArray bottom b1#) (ByteArray bottom b2#) >>= \ (I# res) -> + return ( + if res <# 0# then LT + else if res ==# 0# then EQ + else GT )) where bottom :: (Int,Int) bottom = error "tagCmp" -tagCmpFS (CharStr bs1 len1) (CharStr bs2 len2) - = unsafePerformPrimIO ( - _ccall_ strcmp ba1 ba2 `thenPrimIO` \ (I# res) -> - returnPrimIO ( - if res <# 0# then _LT - else if res ==# 0# then _EQ - else _GT +cmpFS (CharStr bs1 len1) (CharStr bs2 len2) + = unsafePerformIO ( + _ccall_ strcmp ba1 ba2 >>= \ (I# res) -> + return ( + if res <# 0# then LT + else if res ==# 0# then EQ + else GT )) where ba1 = A# bs1 ba2 = A# bs2 -tagCmpFS (FastString _ len1 bs1) (CharStr bs2 len2) - = unsafePerformPrimIO ( - _ccall_ strcmp ba1 ba2 `thenPrimIO` \ (I# res) -> - returnPrimIO ( - if res <# 0# then _LT - else if res ==# 0# then _EQ - else _GT +cmpFS (FastString _ len1 bs1) (CharStr bs2 len2) + = unsafePerformIO ( + _ccall_ strcmp ba1 ba2 >>= \ (I# res) -> + return ( + if res <# 0# then LT + else if res ==# 0# then EQ + else GT )) where - ba1 = _ByteArray ((error "")::(Int,Int)) bs1 + ba1 = ByteArray ((error "")::(Int,Int)) bs1 ba2 = A# bs2 -tagCmpFS a@(CharStr _ _) b@(FastString _ _ _) +cmpFS a@(CharStr _ _) b@(FastString _ _ _) = -- try them the other way 'round - case (tagCmpFS b a) of { _LT -> _GT; _EQ -> _EQ; _GT -> _LT } - -instance Ord FastString where - a <= b = case tagCmpFS a b of { _LT -> True; _EQ -> True; _GT -> False } - a < b = case tagCmpFS a b of { _LT -> True; _EQ -> False; _GT -> False } - a >= b = case tagCmpFS a b of { _LT -> False; _EQ -> True; _GT -> True } - a > b = case tagCmpFS a b of { _LT -> False; _EQ -> False; _GT -> True } - max x y | x >= y = x - | otherwise = y - min x y | x <= y = x - | otherwise = y - _tagCmp a b = tagCmpFS a b + case (cmpFS b a) of { LT -> GT; EQ -> EQ; GT -> LT } \end{code} @@ -483,16 +453,6 @@ Outputting @FastString@s is quick, just block copying the chunk (using @fwrite@). \begin{code} -#if __GLASGOW_HASKELL__ >= 201 -#define _ErrorHandle IOBase.ErrorHandle -#define _ReadHandle IOBase.ReadHandle -#define _ClosedHandle IOBase.ClosedHandle -#define _SemiClosedHandle IOBase.SemiClosedHandle -#define _constructError IOBase.constructError -#define _filePtr IOHandle.filePtr -#define failWith fail -#endif - hPutFS :: Handle -> FastString -> IO () hPutFS handle (FastString _ l# ba#) = if l# ==# 0# then @@ -500,54 +460,54 @@ hPutFS handle (FastString _ l# ba#) = else _readHandle handle >>= \ htype -> case htype of - _ErrorHandle ioError -> + ErrorHandle ioError -> _writeHandle handle htype >> - failWith ioError - _ClosedHandle -> + fail ioError + ClosedHandle -> _writeHandle handle htype >> - failWith MkIOError(handle,IllegalOperation,"handle is closed") - _SemiClosedHandle _ _ -> + fail MkIOError(handle,IllegalOperation,"handle is closed") + SemiClosedHandle _ _ -> _writeHandle handle htype >> - failWith MkIOError(handle,IllegalOperation,"handle is closed") - _ReadHandle _ _ _ -> + fail MkIOError(handle,IllegalOperation,"handle is closed") + ReadHandle _ _ _ -> _writeHandle handle htype >> - failWith MkIOError(handle,IllegalOperation,"handle is not open for writing") + fail MkIOError(handle,IllegalOperation,"handle is not open for writing") other -> - let fp = _filePtr htype in + let fp = filePtr htype in -- here we go.. - _ccall_ writeFile (_ByteArray ((error "")::(Int,Int)) ba#) fp (I# l#) `CCALL_THEN` \rc -> + _ccall_ writeFile (ByteArray ((error "")::(Int,Int)) ba#) fp (I# l#) >>= \rc -> if rc==0 then return () else - _constructError "hPutFS" `CCALL_THEN` \ err -> - failWith err + constructError "hPutFS" >>= \ err -> + fail err hPutFS handle (CharStr a# l#) = if l# ==# 0# then return () else _readHandle handle >>= \ htype -> case htype of - _ErrorHandle ioError -> + ErrorHandle ioError -> _writeHandle handle htype >> - failWith ioError - _ClosedHandle -> + fail ioError + ClosedHandle -> _writeHandle handle htype >> - failWith MkIOError(handle,IllegalOperation,"handle is closed") - _SemiClosedHandle _ _ -> + fail MkIOError(handle,IllegalOperation,"handle is closed") + SemiClosedHandle _ _ -> _writeHandle handle htype >> - failWith MkIOError(handle,IllegalOperation,"handle is closed") - _ReadHandle _ _ _ -> + fail MkIOError(handle,IllegalOperation,"handle is closed") + ReadHandle _ _ _ -> _writeHandle handle htype >> - failWith MkIOError(handle,IllegalOperation,"handle is not open for writing") + fail MkIOError(handle,IllegalOperation,"handle is not open for writing") other -> - let fp = _filePtr htype in + let fp = filePtr htype in -- here we go.. - _ccall_ writeFile (A# a#) fp (I# l#) `CCALL_THEN` \rc -> + _ccall_ writeFile (A# a#) fp (I# l#) >>= \rc -> if rc==0 then return () else - _constructError "hPutFS" `CCALL_THEN` \ err -> - failWith err + constructError "hPutFS" >>= \ err -> + fail err --ToDo: avoid silly code duplic. \end{code} diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs index 09e63592e2..432d4f2cf9 100644 --- a/ghc/compiler/utils/FiniteMap.lhs +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -18,14 +18,6 @@ The code is SPECIALIZEd to various highly-desirable types (e.g., Id) near the end. \begin{code} -#include "HsVersions.h" -#define IF_NOT_GHC(a) {--} - -#if defined(DEBUG_FINITEMAPS)/* NB NB NB */ -#define OUTPUTABLE_key , Outputable key -#else -#define OUTPUTABLE_key {--} -#endif module FiniteMap ( FiniteMap, -- abstract type @@ -53,27 +45,26 @@ module FiniteMap ( fmToList, keysFM, eltsFM , bagToFM - , SYN_IE(FiniteSet), emptySet, mkSet, isEmptySet + , FiniteSet, emptySet, mkSet, isEmptySet , elementOf, setToList, union, minusSet ) where -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(SpecLoop) +#include "HsVersions.h" +#define IF_NOT_GHC(a) {--} + +#if defined(DEBUG_FINITEMAPS)/* NB NB NB */ +#define OUTPUTABLE_key , Outputable key #else -import {-# SOURCE #-} Name +#define OUTPUTABLE_key {--} #endif -#if __GLASGOW_HASKELL__ >= 202 +import {-# SOURCE #-} Name import GlaExts -#endif -#if defined(USE_FAST_STRINGS) import FastString -#endif import Maybes import Bag ( Bag, foldrBag ) -import Outputable ( PprStyle, Outputable(..) ) -import Pretty ( Doc ) +import Outputable #if ! OMIT_NATIVE_CODEGEN # define IF_NCG(a) a @@ -223,16 +214,10 @@ addToFM fm key elt = addToFM_C (\ old new -> new) fm key elt addToFM_C combiner EmptyFM key elt = unitFM key elt addToFM_C combiner (Branch key elt size fm_l fm_r) new_key new_elt -#ifdef __GLASGOW_HASKELL__ - = case _tagCmp new_key key of - _LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r - _GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt) - _EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r -#else - | new_key < key = mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r - | new_key > key = mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt) - | otherwise = Branch new_key (combiner elt new_elt) size fm_l fm_r -#endif + = case compare new_key key of + LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r + GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt) + EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r addListToFM fm key_elt_pairs = addListToFM_C (\ old new -> new) fm key_elt_pairs @@ -245,21 +230,10 @@ addListToFM_C combiner fm key_elt_pairs \begin{code} delFromFM EmptyFM del_key = emptyFM delFromFM (Branch key elt size fm_l fm_r) del_key -#ifdef __GLASGOW_HASKELL__ - = case _tagCmp del_key key of - _GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key) - _LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r - _EQ -> glueBal fm_l fm_r -#else - | del_key > key - = mkBalBranch key elt fm_l (delFromFM fm_r del_key) - - | del_key < key - = mkBalBranch key elt (delFromFM fm_l del_key) fm_r - - | key == del_key - = glueBal fm_l fm_r -#endif + = case compare del_key key of + GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key) + LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r + EQ -> glueBal fm_l fm_r delListFromFM fm keys = foldl delFromFM fm keys \end{code} @@ -365,16 +339,10 @@ isEmptyFM fm = sizeFM fm == 0 lookupFM EmptyFM key = Nothing lookupFM (Branch key elt _ fm_l fm_r) key_to_find -#ifdef __GLASGOW_HASKELL__ - = case _tagCmp key_to_find key of - _LT -> lookupFM fm_l key_to_find - _GT -> lookupFM fm_r key_to_find - _EQ -> Just elt -#else - | key_to_find < key = lookupFM fm_l key_to_find - | key_to_find > key = lookupFM fm_r key_to_find - | otherwise = Just elt -#endif + = case compare key_to_find key of + LT -> lookupFM fm_l key_to_find + GT -> lookupFM fm_r key_to_find + EQ -> Just elt key `elemFM` fm = case (lookupFM fm key) of { Nothing -> False; Just elt -> True } @@ -427,10 +395,10 @@ mkBranch which key elt fm_l fm_r = --ASSERT( left_ok && right_ok && balance_ok ) #if defined(DEBUG_FINITEMAPS) if not ( left_ok && right_ok && balance_ok ) then - pprPanic ("mkBranch:"++show which) (vcat [ppr PprDebug [left_ok, right_ok, balance_ok], - ppr PprDebug key, - ppr PprDebug fm_l, - ppr PprDebug fm_r]) + pprPanic ("mkBranch:"++show which) (vcat [ppr [left_ok, right_ok, balance_ok], + ppr key, + ppr fm_l, + ppr fm_r]) else #endif let @@ -439,7 +407,7 @@ mkBranch which key elt fm_l fm_r -- if sizeFM result <= 8 then result -- else --- pprTrace ("mkBranch:"++(show which)) (ppr PprDebug result) ( +-- pprTrace ("mkBranch:"++(show which)) (ppr result) ( -- result -- ) where @@ -639,29 +607,17 @@ splitLT, splitGT :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> Fini splitLT EmptyFM split_key = emptyFM splitLT (Branch key elt _ fm_l fm_r) split_key -#ifdef __GLASGOW_HASKELL__ - = case _tagCmp split_key key of - _LT -> splitLT fm_l split_key - _GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key) - _EQ -> fm_l -#else - | split_key < key = splitLT fm_l split_key - | split_key > key = mkVBalBranch key elt fm_l (splitLT fm_r split_key) - | otherwise = fm_l -#endif + = case compare split_key key of + LT -> splitLT fm_l split_key + GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key) + EQ -> fm_l splitGT EmptyFM split_key = emptyFM splitGT (Branch key elt _ fm_l fm_r) split_key -#ifdef __GLASGOW_HASKELL__ - = case _tagCmp split_key key of - _GT -> splitGT fm_r split_key - _LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r - _EQ -> fm_r -#else - | split_key > key = splitGT fm_r split_key - | split_key < key = mkVBalBranch key elt (splitGT fm_l split_key) fm_r - | otherwise = fm_r -#endif + = case compare split_key key of + GT -> splitGT fm_r split_key + LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r + EQ -> fm_r findMin :: FiniteMap key elt -> (key,elt) findMin (Branch key elt _ EmptyFM _) = (key,elt) @@ -690,13 +646,13 @@ deleteMax (Branch key elt _ fm_l fm_r) = mkBalBranch key elt fm_l (deleteMax #if defined(DEBUG_FINITEMAPS) instance (Outputable key) => Outputable (FiniteMap key elt) where - ppr sty fm = pprX sty fm + ppr fm = pprX fm -pprX sty EmptyFM = char '!' -pprX sty (Branch key elt sz fm_l fm_r) - = parens (hcat [pprX sty fm_l, space, - ppr sty key, space, int (IF_GHC(I# sz, sz)), space, - pprX sty fm_r]) +pprX EmptyFM = char '!' +pprX (Branch key elt sz fm_l fm_r) + = parens (hcat [pprX fm_l, space, + ppr key, space, int (IF_GHC(I# sz, sz)), space, + pprX fm_r]) #endif #if 0 diff --git a/ghc/compiler/utils/HandleHack.lhi b/ghc/compiler/utils/HandleHack.lhi deleted file mode 100644 index d0fad80e42..0000000000 --- a/ghc/compiler/utils/HandleHack.lhi +++ /dev/null @@ -1,26 +0,0 @@ - -The implementation of FastString output need to get at the representation -to Handles to do a Good Job. Prelude modules in 0.29 does not export -the Handle repr., this little hack fixes this :-) - -Also added mkUniqueGrimily to avoid bootstrap trouble - -\begin{code} -interface HandleHack where - -import PreludeStdIO (Handle(..), _Handle(..), _filePtr,_readHandle, _writeHandle, BufferMode, Maybe) -import PreludeIOError (_constructError,IOError13(..)) -import PreludeGlaST (_MutableArray, _RealWorld) -import Unique ( Unique, mkUniqueGrimily ) - -type Handle = _MutableArray _RealWorld Int _Handle -data _Handle = _ErrorHandle IOError13 | _ClosedHandle | _SemiClosedHandle _Addr (_Addr, Int) | _ReadHandle _Addr (Maybe BufferMode) Bool | _WriteHandle _Addr (Maybe BufferMode) Bool | _AppendHandle _Addr (Maybe BufferMode) Bool | _ReadWriteHandle _Addr (Maybe BufferMode) Bool -data Unique - -mkUniqueGrimily :: Int# -> Unique - -_filePtr :: _Handle -> _Addr -_readHandle :: Handle -> IO _Handle -_writeHandle :: Handle -> _Handle -> IO () -_constructError :: String -> PrimIO IOError13 -\end{code} diff --git a/ghc/compiler/utils/ListSetOps.lhs b/ghc/compiler/utils/ListSetOps.lhs index d2737a4b7f..dfa2cd023f 100644 --- a/ghc/compiler/utils/ListSetOps.lhs +++ b/ghc/compiler/utils/ListSetOps.lhs @@ -4,8 +4,6 @@ \section[ListSetOps]{Set-like operations on lists} \begin{code} -#include "HsVersions.h" - module ListSetOps ( unionLists, --UNUSED: intersectLists, @@ -13,13 +11,10 @@ module ListSetOps ( ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import Util ( isIn, isn'tIn ) - -#if __GLASGOW_HASKELL__ >= 202 -import List -#endif +import List ( union ) \end{code} \begin{code} diff --git a/ghc/compiler/utils/MatchEnv.lhs b/ghc/compiler/utils/MatchEnv.lhs deleted file mode 100644 index 6c09616e29..0000000000 --- a/ghc/compiler/utils/MatchEnv.lhs +++ /dev/null @@ -1,116 +0,0 @@ -%************************************************************************ -%* * -\subsection[MatchEnv]{Matching environments} -%* * -%************************************************************************ - -\begin{code} -#include "HsVersions.h" - -module MatchEnv ( - MatchEnv, nullMEnv, mkMEnv, - isEmptyMEnv, lookupMEnv, insertMEnv, - mEnvToList -) where - -CHK_Ubiq() -- debugging consistency check - -import Maybes ( MaybeErr(..), returnMaB, thenMaB, failMaB ) -\end{code} - -``Matching'' environments allow you to bind a template to a value; -when you look up in it, you supply a value which is matched against -the template. - -\begin{code} -data MatchEnv key value - = EmptyME -- Common, so special-cased - | ME [(key, value)] -\end{code} - -For now we just use association lists. The list is maintained sorted -in order of {\em decreasing specificness} of @key@, so that the first -match will be the most specific. - -\begin{code} -nullMEnv :: MatchEnv a b -nullMEnv = EmptyME - -isEmptyMEnv EmptyME = True -isEmptyMEnv _ = False - -mkMEnv :: [(key, value)] -> MatchEnv key value -mkMEnv [] = EmptyME -mkMEnv stuff = ME stuff - -mEnvToList :: MatchEnv key value -> [(key, value)] -mEnvToList EmptyME = [] -mEnvToList (ME stuff) = stuff -\end{code} - -@lookupMEnv@ looks up in a @MatchEnv@. It simply takes the first -match, which should be the most specific. - -\begin{code} -lookupMEnv :: (key1 {- template -} -> -- Matching function - key2 {- instance -} -> - Maybe match_info) - -> MatchEnv key1 value -- The envt - -> key2 -- Key - -> Maybe (value, -- Value - match_info) -- Match info returned by matching fn - - -lookupMEnv key_match EmptyME key = Nothing -lookupMEnv key_match (ME alist) key - = find alist - where - find [] = Nothing - find ((tpl, val) : rest) - = case (key_match tpl key) of - Nothing -> find rest - Just match_info -> Just (val,match_info) -\end{code} - -@insertMEnv@ extends a match environment, checking for overlaps. - -\begin{code} -insertMEnv :: (key {- template -} -> -- Matching function - key {- instance -} -> - Maybe match_info) - -> MatchEnv key value -- Envt - -> key -> value -- New item - -> MaybeErr (MatchEnv key value) -- Success... - (key, value) -- Failure: Offending overlap - -insertMEnv match_fn EmptyME key value = returnMaB (ME [(key, value)]) -insertMEnv match_fn (ME alist) key value - = insert alist - where - -- insertMEnv has to put the new item in BEFORE any keys which are - -- LESS SPECIFIC than the new key, and AFTER any keys which are - -- MORE SPECIFIC The list is maintained in specific-ness order, so - -- we just stick it in either last, or just before the first key - -- of which the new key is an instance. We check for overlap at - -- that point. - - insert [] = returnMaB (ME [(key, value)]) - insert ls@(r@(t,v) : rest) - = case (match_fn t key) of - Nothing -> - -- New key is not an instance of this existing one, so - -- continue down the list. - insert rest `thenMaB` \ (ME rest') -> - returnMaB (ME(r:rest')) - - Just match_info -> - -- New key *is* an instance of the old one, so check the - -- other way round in case of identity. - - case (match_fn key t) of - Just _ -> failMaB r - -- Oops; overlap - - Nothing -> returnMaB (ME ((key,value):ls)) - -- All ok; insert here -\end{code} diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs index 37a12e06b9..ce92316d6c 100644 --- a/ghc/compiler/utils/Maybes.lhs +++ b/ghc/compiler/utils/Maybes.lhs @@ -4,8 +4,6 @@ \section[Maybes]{The `Maybe' types and associated utility functions} \begin{code} -#include "HsVersions.h" - module Maybes ( -- Maybe(..), -- no, it's in 1.3 MaybeErr(..), @@ -28,10 +26,9 @@ module Maybes ( catMaybes ) where -#if __GLASGOW_HASKELL__ >= 204 -import Maybe ( catMaybes, mapMaybe ) -#endif +#include "HsVersions.h" +import Maybe( catMaybes, mapMaybe ) \end{code} @@ -60,19 +57,6 @@ allMaybes (Just x : ms) = case (allMaybes ms) of Nothing -> Nothing Just xs -> Just (x:xs) -#if __GLASGOW_HASKELL__ < 204 - -- After 2.04 we get these from the library Maybe -catMaybes :: [Maybe a] -> [a] -catMaybes [] = [] -catMaybes (Nothing : xs) = catMaybes xs -catMaybes (Just x : xs) = (x : catMaybes xs) - -mapMaybe :: (a -> Maybe b) -> [a] -> [b] -mapMaybe f [] = [] -mapMaybe f (x:xs) = case f x of - Just y -> y : mapMaybe f xs - Nothing -> mapMaybe f xs -#endif \end{code} @firstJust@ takes a list of @Maybes@ and returns the diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index ea11887957..861f4b5f09 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -7,47 +7,47 @@ Defines classes for pretty-printing and forcing, both forms of ``output.'' \begin{code} -#include "HsVersions.h" - module Outputable ( - Outputable(..), -- class - - PprStyle(..), - codeStyle, ifaceStyle, userStyle, - ifPprDebug, - ifnotPprForUser, - ifPprShowAll, ifnotPprShowAll, - ifPprInterface, - pprQuote, - - printDoc, printErrs, pprCols, pprDumpStyle, pprErrorsStyle, - - interppSP, interpp'SP, - - speakNth - -#if __GLASGOW_HASKELL__ <= 200 - , Mode -#endif - + Outputable(..), -- Class + + PprStyle, + getPprStyle, withPprStyle, pprDeeper, + codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle, + ifPprDebug, ifNotPprForUser, + + SDoc, -- Abstract + interppSP, interpp'SP, pprQuotedList, + empty, nest, + text, char, ptext, + int, integer, float, double, rational, + parens, brackets, braces, quotes, doubleQuotes, + semi, comma, colon, space, equals, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + hang, punctuate, + speakNth, speakNTimes, + + showSDoc, printSDoc, printErrs, printDump, + printForC, printForAsm, printForIface, + pprCols, + + -- error handling + pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, + panic, panic#, assertPanic ) where -#if __GLASGOW_HASKELL__ >= 202 -import IO -import GlaExts -# if __GLASGOW_HASKELL__ >= 209 -import Addr -# endif - -#else -import Ubiq ( Uniquable(..), Unique, Name ) -- FastString mentions it; todo: rm - -#endif +#include "HsVersions.h" -import CmdLineOpts ( opt_PprStyle_All, opt_PprStyle_Debug, opt_PprStyle_User ) +import IO ( Handle, hPutChar, hPutStr, stderr, stdout ) +import CmdLineOpts ( opt_PprStyle_All, opt_PprStyle_Debug, opt_PprStyle_User, opt_PprUserLength ) import FastString -import Pretty -import Util ( cmpPString ) +import qualified Pretty +import Pretty ( Doc, Mode(..), TextDetails(..), fullRender ) +import Util ( panic, assertPanic, panic# ) +import GlaExts ( trace ) \end{code} @@ -59,26 +59,23 @@ import Util ( cmpPString ) \begin{code} data PprStyle - = PprForUser Int -- Pretty-print in a way that will + = PprUser Depth -- Pretty-print in a way that will -- make sense to the ordinary user; -- must be very close to Haskell -- syntax, etc. - -- Parameterised over how much to expand - -- a pretty-printed value (<= 0 => stop pp). - | PprQuote -- Like PprForUser, but also quote the whole thing | PprDebug -- Standard debugging output - | PprShowAll -- Debugging output which leaves - -- nothing to the imagination | PprInterface -- Interface generation - | PprForC -- must print out C-acceptable names + | PprCode CodeStyle -- Print code; either C or assembler - | PprForAsm -- must print out assembler-acceptable names - Bool -- prefix CLabel with underscore? - (String -> String) -- format AsmTempLabel +data CodeStyle = CStyle -- The format of labels differs for C and assembler + | AsmStyle + +data Depth = AllTheWay + | PartWay Int -- 0 => stop \end{code} Orthogonal to the above printing styles are (possibly) some @@ -88,37 +85,152 @@ shown. The following test decides whether or not we are actually generating code (either C or assembly), or generating interface files. + +%************************************************************************ +%* * +\subsection{The @SDoc@ data type} +%* * +%************************************************************************ + +\begin{code} +type SDoc = PprStyle -> Doc + +withPprStyle :: PprStyle -> SDoc -> SDoc +withPprStyle sty d sty' = d sty + +pprDeeper :: SDoc -> SDoc +pprDeeper d (PprUser (PartWay 0)) = Pretty.text "..." +pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1))) +pprDeeper d other_sty = d other_sty + +getPprStyle :: (PprStyle -> SDoc) -> SDoc +getPprStyle df sty = df sty sty +\end{code} + \begin{code} codeStyle :: PprStyle -> Bool -codeStyle PprForC = True -codeStyle (PprForAsm _ _) = True +codeStyle (PprCode _) = True codeStyle _ = False +asmStyle :: PprStyle -> Bool +asmStyle (PprCode AsmStyle) = True +asmStyle other = False + ifaceStyle :: PprStyle -> Bool ifaceStyle PprInterface = True ifaceStyle other = False +debugStyle :: PprStyle -> Bool +debugStyle PprDebug = True +debugStyle other = False + userStyle :: PprStyle -> Bool -userStyle PprQuote = True -userStyle (PprForUser _) = True -userStyle other = False +userStyle (PprUser _) = True +userStyle other = False \end{code} \begin{code} -ifPprDebug sty p = case sty of PprDebug -> p ; _ -> empty -ifPprShowAll sty p = case sty of PprShowAll -> p ; _ -> empty -ifPprInterface sty p = case sty of PprInterface -> p ; _ -> empty +ifNotPprForUser :: SDoc -> SDoc -- Returns empty document for User style +ifNotPprForUser d sty@(PprUser _) = Pretty.empty +ifNotPprForUser d sty = d sty -ifnotPprForUser sty p = case sty of { PprForUser _ -> empty ; PprQuote -> empty; _ -> p } -ifnotPprShowAll sty p = case sty of { PprShowAll -> empty ; _ -> p } +ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style +ifPprDebug d sty@PprDebug = d sty +ifPprDebug d sty = Pretty.empty \end{code} \begin{code} -pprQuote :: PprStyle -> (PprStyle -> Doc) -> Doc -pprQuote PprQuote fn = quotes (fn (PprForUser 5{-opt_PprUserLength-})) -pprQuote sty fn = fn sty +printSDoc :: SDoc -> PprStyle -> IO () +printSDoc d sty = printDoc PageMode stdout (d sty) + +-- I'm not sure whether the direct-IO approach of printDoc +-- above is better or worse than the put-big-string approach here +printErrs :: SDoc -> IO () +printErrs doc = printDoc PageMode stderr (final_doc user_style) + where + final_doc = doc $$ text "" + user_style = mkUserStyle (PartWay opt_PprUserLength) + +printDump :: SDoc -> IO () +printDump doc = printDoc PageMode stderr (final_doc PprDebug) + where + final_doc = doc $$ text "" + + +-- printForC, printForAsm doe what they sound like +printForC :: Handle -> SDoc -> IO () +printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle)) + +printForAsm :: Handle -> SDoc -> IO () +printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle)) + +-- printForIface prints all on one line for interface files. +-- It's called repeatedly for successive lines +printForIface :: Handle -> SDoc -> IO () +printForIface handle doc = printDoc OneLineMode handle (doc PprInterface) + + +-- showSDoc just blasts it out as a string +showSDoc :: SDoc -> String +showSDoc d = show (d (mkUserStyle AllTheWay)) + +mkUserStyle depth | opt_PprStyle_Debug + || opt_PprStyle_All = PprDebug + | otherwise = PprUser depth \end{code} +\begin{code} +empty sty = Pretty.empty +text s sty = Pretty.text s +char c sty = Pretty.char c +ptext s sty = Pretty.ptext s +int n sty = Pretty.int n +integer n sty = Pretty.integer n +float n sty = Pretty.float n +double n sty = Pretty.double n +rational n sty = Pretty.rational n + +parens d sty = Pretty.parens (d sty) +braces d sty = Pretty.braces (d sty) +brackets d sty = Pretty.brackets (d sty) +quotes d sty = Pretty.quotes (d sty) +doubleQuotes d sty = Pretty.doubleQuotes (d sty) + +semi sty = Pretty.semi +comma sty = Pretty.comma +colon sty = Pretty.colon +equals sty = Pretty.equals +space sty = Pretty.space +lparen sty = Pretty.lparen +rparen sty = Pretty.rparen +lbrack sty = Pretty.lbrack +rbrack sty = Pretty.rbrack +lbrace sty = Pretty.lbrace +rbrace sty = Pretty.rbrace + +nest n d sty = Pretty.nest n (d sty) +(<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty) +(<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty) +($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty) +($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty) + +hcat ds sty = Pretty.hcat [d sty | d <- ds] +hsep ds sty = Pretty.hsep [d sty | d <- ds] +vcat ds sty = Pretty.vcat [d sty | d <- ds] +sep ds sty = Pretty.sep [d sty | d <- ds] +cat ds sty = Pretty.cat [d sty | d <- ds] +fsep ds sty = Pretty.fsep [d sty | d <- ds] +fcat ds sty = Pretty.fcat [d sty | d <- ds] + +hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty) + +punctuate :: SDoc -> [SDoc] -> [SDoc] +punctuate p [] = [] +punctuate p (d:ds) = go d ds + where + go d [] = [d] + go d (e:es) = (d <> p) : go e es +\end{code} %************************************************************************ @@ -129,30 +241,29 @@ pprQuote sty fn = fn sty \begin{code} class Outputable a where - ppr :: PprStyle -> a -> Doc + ppr :: a -> SDoc \end{code} \begin{code} instance Outputable Bool where - ppr sty True = ptext SLIT("True") - ppr sty False = ptext SLIT("False") + ppr False = ptext SLIT("False") instance Outputable Int where - ppr sty n = int n + ppr n = int n instance (Outputable a) => Outputable [a] where - ppr sty xs = brackets (fsep (punctuate comma (map (ppr sty) xs))) + ppr xs = brackets (fsep (punctuate comma (map ppr xs))) instance (Outputable a, Outputable b) => Outputable (a, b) where - ppr sty (x,y) = - hang (hcat [lparen, ppr sty x, comma]) 4 ((<>) (ppr sty y) rparen) + ppr (x,y) = + hang (hcat [lparen, ppr x, comma]) 4 ((<>) (ppr y) rparen) -- ToDo: may not be used instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where - ppr sty (x,y,z) = - parens (sep [ (<>) (ppr sty x) comma, - (<>) (ppr sty y) comma, - ppr sty z ]) + ppr (x,y,z) = + parens (sep [ (<>) (ppr x) comma, + (<>) (ppr y) comma, + ppr z ]) \end{code} @@ -165,13 +276,6 @@ instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) wher \begin{code} pprCols = (100 :: Int) -- could make configurable --- pprErrorsStyle is the style to print ordinary error messages with --- pprDumpStyle is the style to print -ddump-xx information in -(pprDumpStyle, pprErrorsStyle) - | opt_PprStyle_All = (PprShowAll, PprShowAll) - | opt_PprStyle_Debug = (PprDebug, PprDebug) - | otherwise = (PprDebug, PprQuote) - printDoc :: Mode -> Handle -> Doc -> IO () printDoc mode hdl doc = fullRender mode pprCols 1.5 put done doc @@ -181,21 +285,19 @@ printDoc mode hdl doc put (PStr s) next = hPutFS hdl s >> next done = hPutChar hdl '\n' - --- I'm not sure whether the direct-IO approach of printDoc --- above is better or worse than the put-big-string approach here -printErrs :: Doc -> IO () -printErrs doc = hPutStr stderr (show (doc $$ text "")) \end{code} \begin{code} -interppSP :: Outputable a => PprStyle -> [a] -> Doc -interppSP sty xs = hsep (map (ppr sty) xs) +interppSP :: Outputable a => [a] -> SDoc +interppSP xs = hsep (map ppr xs) -interpp'SP :: Outputable a => PprStyle -> [a] -> Doc -interpp'SP sty xs - = hsep (punctuate comma (map (ppr sty) xs)) +interpp'SP :: Outputable a => [a] -> SDoc +interpp'SP xs = hsep (punctuate comma (map ppr xs)) + +pprQuotedList :: Outputable a => [a] -> SDoc +-- [x,y,z] ==> `x', `y', `z' +pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs)) \end{code} @@ -211,7 +313,7 @@ interpp'SP sty xs ``first'' etc. \begin{code} -speakNth :: Int -> Doc +speakNth :: Int -> SDoc speakNth 1 = ptext SLIT("first") speakNth 2 = ptext SLIT("second") @@ -228,3 +330,41 @@ speakNth n = hcat [ int n, text st_nd_rd_th ] n_rem_10 = n `rem` 10 \end{code} + +\begin{code} +speakNTimes :: Int {- >=1 -} -> SDoc +speakNTimes t | t == 1 = ptext SLIT("once") + | t == 2 = ptext SLIT("twice") + | otherwise = int t <+> ptext SLIT("times") +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-errors]{Error handling} +%* * +%************************************************************************ + +\begin{code} +pprPanic heading pretty_msg = panic (show (doc PprDebug)) + where + doc = text heading <+> pretty_msg + +pprError heading pretty_msg = error (heading++ " " ++ (show pretty_msg)) + +pprTrace heading pretty_msg = trace (show (doc PprDebug)) + where + doc = text heading <+> pretty_msg + +pprPanic# heading pretty_msg = panic# (show (doc PprDebug)) + where + doc = text heading <+> pretty_msg + +assertPprPanic :: String -> Int -> SDoc -> a +assertPprPanic file line msg + = panic (show (doc PprDebug)) + where + doc = sep [hsep[text "ASSERT failed! file", + text file, + text "line", int line], + msg] +\end{code} diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs index 54abced398..41cdb1a5d0 100644 --- a/ghc/compiler/utils/Pretty.lhs +++ b/ghc/compiler/utils/Pretty.lhs @@ -98,8 +98,6 @@ Relative to John's original paper, there are the following new features: \begin{code} -#include "HsVersions.h" - module Pretty ( Doc, -- Abstract Mode(..), TextDetails(..), @@ -124,22 +122,10 @@ module Pretty ( ) where #include "HsVersions.h" -#if defined(__GLASGOW_HASKELL__) import FastString - -#if __GLASGOW_HASKELL__ >= 202 - import GlaExts -#else - - -- Horrible import to satisfy GHC 0.29 -import Ubiq ( Unique, Uniquable(..), Name ) - -#endif -#endif - -- Don't import Util( assertPanic ) because it makes a loop in the module structure infixl 6 <> diff --git a/ghc/compiler/utils/PrimPacked.lhs b/ghc/compiler/utils/PrimPacked.lhs index 78f0071463..10216452f6 100644 --- a/ghc/compiler/utils/PrimPacked.lhs +++ b/ghc/compiler/utils/PrimPacked.lhs @@ -8,20 +8,13 @@ of bytes (character strings). Used by the interface lexer input subsystem, mostly. \begin{code} -#include "HsVersions.h" - module PrimPacked ( strLength, -- :: _Addr -> Int - copyPrefixStr, -- :: _Addr -> Int -> _ByteArray Int - copySubStr, -- :: _Addr -> Int -> Int -> _ByteArray Int - copySubStrFO, -- :: ForeignObj -> Int -> Int -> _ByteArray Int - copySubStrBA, -- :: _ByteArray Int -> Int -> Int -> _ByteArray Int - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 205 - stringToByteArray, -- :: String -> _ByteArray Int - byteArrayToString, -- :: _ByteArray Int -> String -#endif + copyPrefixStr, -- :: _Addr -> Int -> ByteArray Int + copySubStr, -- :: _Addr -> Int -> Int -> ByteArray Int + copySubStrFO, -- :: ForeignObj -> Int -> Int -> ByteArray Int + copySubStrBA, -- :: ByteArray Int -> Int -> Int -> ByteArray Int eqStrPrefix, -- :: Addr# -> ByteArray# -> Int# -> Bool eqCharStrPrefix, -- :: Addr# -> Addr# -> Int# -> Bool @@ -33,41 +26,29 @@ module PrimPacked indexCharOffFO# -- :: ForeignObj# -> Int# -> Char# ) where -#if __GLASGOW_HASKELL__ <= 201 -import PreludeGlaST -import PreludeGlaMisc -#else +-- This #define suppresses the "import FastString" that +-- HsVersions otherwise produces +#define COMPILING_FAST_STRING +#include "HsVersions.h" + import GlaExts -import Foreign +import Addr ( Addr(..) ) import GHC import ArrBase import ST import STBase - -# if __GLASGOW_HASKELL__ == 202 -import PrelBase ( Char(..) ) -# endif - -# if __GLASGOW_HASKELL__ >= 206 -import PackBase -# endif - -# if __GLASGOW_HASKELL__ >= 209 -import Addr -# endif - -#endif - +import IOBase ( ForeignObj(..) ) +import PackBase ( unpackCStringBA, packString ) \end{code} Return the length of a @\\NUL@ terminated character string: \begin{code} -strLength :: _Addr -> Int +strLength :: Addr -> Int strLength a = - unsafePerformPrimIO ( - _ccall_ strlen a `thenPrimIO` \ len@(I# _) -> - returnPrimIO len + unsafePerformIO ( + _ccall_ strlen a >>= \ len@(I# _) -> + return len ) \end{code} @@ -77,21 +58,24 @@ Copying a char string prefix into a byte array, NULs. \begin{code} - -copyPrefixStr :: _Addr -> Int -> _ByteArray Int +copyPrefixStr :: Addr -> Int -> ByteArray Int copyPrefixStr (A# a) len@(I# length#) = - unsafePerformST ( + runST ( {- allocate an array that will hold the string (not forgetting the NUL at the end) -} - new_ps_array (length# +# 1#) `thenStrictlyST` \ ch_array -> + (new_ps_array (length# +# 1#)) >>= \ ch_array -> +{- Revert back to Haskell-only solution for the moment. + _ccall_ memcpy ch_array (A# a) len >>= \ () -> + write_ps_array ch_array length# (chr# 0#) >> +-} -- fill in packed string from "addr" - fill_in ch_array 0# `thenStrictlyST` \ _ -> + fill_in ch_array 0# >> -- freeze the puppy: - freeze_ps_array ch_array `thenStrictlyST` \ barr -> + freeze_ps_array ch_array length# `thenStrictlyST` \ barr -> returnStrictlyST barr ) where - fill_in :: _MutableByteArray s Int -> Int# -> _ST s () + fill_in :: MutableByteArray s Int -> Int# -> ST s () fill_in arr_in# idx | idx ==# length# @@ -108,20 +92,20 @@ Copying out a substring, assume a 0-indexed string: (and positive lengths, thank you). \begin{code} -copySubStr :: _Addr -> Int -> Int -> _ByteArray Int +copySubStr :: Addr -> Int -> Int -> ByteArray Int copySubStr a start length = - unsafePerformPrimIO ( + unsafePerformIO ( _casm_ `` %r= (char *)((char *)%0 + (int)%1); '' a start - `thenPrimIO` \ a_start -> - returnPrimIO (copyPrefixStr a_start length)) + >>= \ a_start -> + return (copyPrefixStr a_start length)) \end{code} -Copying a sub-string out of a ForeignObj +pCopying a sub-string out of a ForeignObj \begin{code} -copySubStrFO :: _ForeignObj -> Int -> Int -> _ByteArray Int -copySubStrFO (_ForeignObj fo) (I# start#) len@(I# length#) = - unsafePerformST ( +copySubStrFO :: ForeignObj -> Int -> Int -> ByteArray Int +copySubStrFO (ForeignObj fo) (I# start#) len@(I# length#) = + runST ( {- allocate an array that will hold the string (not forgetting the NUL at the end) -} @@ -129,9 +113,9 @@ copySubStrFO (_ForeignObj fo) (I# start#) len@(I# length#) = -- fill in packed string from "addr" fill_in ch_array 0# `seqStrictlyST` -- freeze the puppy: - freeze_ps_array ch_array) + freeze_ps_array ch_array length#) where - fill_in :: _MutableByteArray s Int -> Int# -> _ST s () + fill_in :: MutableByteArray s Int -> Int# -> ST s () fill_in arr_in# idx | idx ==# length# @@ -146,7 +130,7 @@ copySubStrFO (_ForeignObj fo) (I# start#) len@(I# length#) = #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <=205 indexCharOffFO# :: ForeignObj# -> Int# -> Char# indexCharOffFO# fo# i# = - case unsafePerformPrimIO (_casm_ ``%r=(char)*((char *)%0 + (int)%1); '' (_ForeignObj fo#) (I# i#)) of + case unsafePerformIO (_casm_ ``%r=(char)*((char *)%0 + (int)%1); '' (ForeignObj fo#) (I# i#)) of C# c -> c #else indexCharOffFO# :: ForeignObj# -> Int# -> Char# @@ -156,22 +140,22 @@ indexCharOffFO# fo i = indexCharOffForeignObj# fo i -- step on (char *) pointer by x units. addrOffset# :: Addr# -> Int# -> Addr# addrOffset# a# i# = - case unsafePerformPrimIO (_casm_ ``%r=(char *)((char *)%0 + (int)%1); '' (A# a#) (I# i#)) of + case unsafePerformIO (_casm_ ``%r=(char *)((char *)%0 + (int)%1); '' (A# a#) (I# i#)) of A# a -> a -copySubStrBA :: _ByteArray Int -> Int -> Int -> _ByteArray Int -copySubStrBA (_ByteArray _ barr#) (I# start#) len@(I# length#) = - unsafePerformST ( +copySubStrBA :: ByteArray Int -> Int -> Int -> ByteArray Int +copySubStrBA (ByteArray _ barr#) (I# start#) len@(I# length#) = + runST ( {- allocate an array that will hold the string (not forgetting the NUL at the end) -} new_ps_array (length# +# 1#) `thenStrictlyST` \ ch_array -> -- fill in packed string from "addr" - fill_in ch_array 0# `seqStrictlyST` + fill_in ch_array 0# `seqStrictlyST` -- freeze the puppy: - freeze_ps_array ch_array) + freeze_ps_array ch_array length#) where - fill_in :: _MutableByteArray s Int -> Int# -> _ST s () + fill_in :: MutableByteArray s Int -> Int# -> ST s () fill_in arr_in# idx | idx ==# length# @@ -185,146 +169,98 @@ copySubStrBA (_ByteArray _ barr#) (I# start#) len@(I# length#) = \end{code} (Very :-) ``Specialised'' versions of some CharArray things... +[Copied from PackBase; no real reason -- UGH] \begin{code} -new_ps_array :: Int# -> _ST s (_MutableByteArray s Int) -write_ps_array :: _MutableByteArray s Int -> Int# -> Char# -> _ST s () -freeze_ps_array :: _MutableByteArray s Int -> _ST s (_ByteArray Int) +new_ps_array :: Int# -> ST s (MutableByteArray s Int) +write_ps_array :: MutableByteArray s Int -> Int# -> Char# -> ST s () +freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int) -new_ps_array size = - MkST ( \ STATE_TOK(s#) -> - case (newCharArray# size s#) of { StateAndMutableByteArray# s2# barr# -> - ST_RET(_MutableByteArray (0, max 0 (I# (size -# 1#))) barr#, STATE_TOK(s2#))}) +new_ps_array size = ST $ \ s -> + case (newCharArray# size s) of { StateAndMutableByteArray# s2# barr# -> + STret s2# (MutableByteArray bot barr#) } + where + bot = error "new_ps_array" -write_ps_array (_MutableByteArray _ barr#) n ch = - MkST ( \ STATE_TOK(s#) -> +write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# -> case writeCharArray# barr# n ch s# of { s2# -> - ST_RET((), STATE_TOK(s2#) )}) + STret s2# () } -- same as unsafeFreezeByteArray -freeze_ps_array (_MutableByteArray ixs arr#) = - MkST ( \ STATE_TOK(s#) -> +freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# -> case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# -> - ST_RET((_ByteArray ixs frozen#), STATE_TOK(s2#))}) + STret s2# (ByteArray (0,I# len#) frozen#) } \end{code} + Compare two equal-length strings for equality: \begin{code} eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool eqStrPrefix a# barr# len# = - unsafePerformPrimIO ( - _ccall_ strncmp (A# a#) (_ByteArray bottom barr#) (I# len#) `thenPrimIO` \ (I# x#) -> - returnPrimIO (x# ==# 0#)) + unsafePerformIO ( + _ccall_ strncmp (A# a#) (ByteArray bottom barr#) (I# len#) >>= \ (I# x#) -> + return (x# ==# 0#)) where bottom :: (Int,Int) bottom = error "eqStrPrefix" eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool eqCharStrPrefix a1# a2# len# = - unsafePerformPrimIO ( - _ccall_ strncmp (A# a1#) (A# a2#) (I# len#) `thenPrimIO` \ (I# x#) -> - returnPrimIO (x# ==# 0#)) + unsafePerformIO ( + _ccall_ strncmp (A# a1#) (A# a2#) (I# len#) >>= \ (I# x#) -> + return (x# ==# 0#)) where bottom :: (Int,Int) bottom = error "eqStrPrefix" eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool eqStrPrefixBA b1# b2# start# len# = - unsafePerformPrimIO ( + unsafePerformIO ( _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); '' - (_ByteArray bottom b2#) + (ByteArray bottom b2#) (I# start#) - (_ByteArray bottom b1#) - (I# len#) `thenPrimIO` \ (I# x#) -> - returnPrimIO (x# ==# 0#)) + (ByteArray bottom b1#) + (I# len#) >>= \ (I# x#) -> + return (x# ==# 0#)) where bottom :: (Int,Int) bottom = error "eqStrPrefixBA" eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool eqCharStrPrefixBA a# b2# start# len# = - unsafePerformPrimIO ( + unsafePerformIO ( _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); '' - (_ByteArray bottom b2#) + (ByteArray bottom b2#) (I# start#) (A# a#) - (I# len#) `thenPrimIO` \ (I# x#) -> - returnPrimIO (x# ==# 0#)) + (I# len#) >>= \ (I# x#) -> + return (x# ==# 0#)) where bottom :: (Int,Int) bottom = error "eqCharStrPrefixBA" eqStrPrefixFO :: ForeignObj# -> ByteArray# -> Int# -> Int# -> Bool eqStrPrefixFO fo# barr# start# len# = - unsafePerformPrimIO ( + unsafePerformIO ( _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); '' - (_ForeignObj fo#) + (ForeignObj fo#) (I# start#) - (_ByteArray bottom barr#) - (I# len#) `thenPrimIO` \ (I# x#) -> - returnPrimIO (x# ==# 0#)) + (ByteArray bottom barr#) + (I# len#) >>= \ (I# x#) -> + return (x# ==# 0#)) where bottom :: (Int,Int) bottom = error "eqStrPrefixFO" \end{code} \begin{code} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 205 -byteArrayToString :: _ByteArray Int -> String -byteArrayToString (_ByteArray (I# start#,I# end#) barr#) = - unpack start# - where - unpack nh# - | nh# >=# end# = [] - | otherwise = C# ch : unpack (nh# +# 1#) - where - ch = indexCharArray# barr# nh# -#elif defined(__GLASGOW_HASKELL__) -byteArrayToString :: _ByteArray Int -> String +byteArrayToString :: ByteArray Int -> String byteArrayToString = unpackCStringBA -#else -#error "byteArrayToString: cannot handle this!" -#endif - \end{code} \begin{code} -stringToByteArray :: String -> (_ByteArray Int) -#if __GLASGOW_HASKELL__ >= 206 +stringToByteArray :: String -> (ByteArray Int) stringToByteArray = packString -#elif defined(__GLASGOW_HASKELL__) -stringToByteArray str = _runST (packStringST str) - -packStringST :: [Char] -> _ST s (_ByteArray Int) -packStringST str = - let len = length str in - packNCharsST len str - -packNCharsST :: Int -> [Char] -> _ST s (_ByteArray Int) -packNCharsST len@(I# length#) str = - {- - allocate an array that will hold the string - (not forgetting the NUL byte at the end) - -} - new_ps_array (length# +# 1#) `thenStrictlyST` \ ch_array -> - -- fill in packed string from "str" - fill_in ch_array 0# str `seqStrictlyST` - -- freeze the puppy: - freeze_ps_array ch_array `thenStrictlyST` \ (_ByteArray _ frozen#) -> - returnStrictlyST (_ByteArray (0,len) frozen#) - where - fill_in :: _MutableByteArray s Int -> Int# -> [Char] -> _ST s () - fill_in arr_in# idx [] = - write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST` - returnStrictlyST () - - fill_in arr_in# idx (C# c : cs) = - write_ps_array arr_in# idx c `seqStrictlyST` - fill_in arr_in# (idx +# 1#) cs -#else -#error "stringToByteArray: cannot handle this" -#endif - \end{code} diff --git a/ghc/compiler/utils/SST.lhs b/ghc/compiler/utils/SST.lhs index 110375056a..ac147dc920 100644 --- a/ghc/compiler/utils/SST.lhs +++ b/ghc/compiler/utils/SST.lhs @@ -2,86 +2,83 @@ %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -#include "HsVersions.h" - module SST( - SYN_IE(SST), SST_R, SYN_IE(FSST), FSST_R, + SST, SST_R, FSST, FSST_R, - runSST, sstToST, stToSST, + runSST, sstToST, stToSST, ioToSST, thenSST, thenSST_, returnSST, fixSST, thenFSST, thenFSST_, returnFSST, failFSST, recoverFSST, recoverSST, fixFSST, unsafeInterleaveSST, - newMutVarSST, readMutVarSST, writeMutVarSST -#if __GLASGOW_HASKELL__ >= 200 - , MutableVar -#else - , MutableVar(..), _MutableArray -#endif + newMutVarSST, readMutVarSST, writeMutVarSST, + SSTRef ) where -#if __GLASGOW_HASKELL__ == 201 -import GHCbase -#elif __GLASGOW_HASKELL__ >= 202 +#include "HsVersions.h" + import GlaExts import STBase +import IOBase ( IO(..), IOResult(..) ) import ArrBase import ST -#else -import PreludeGlaST ( MutableVar(..), _MutableArray(..), ST(..) ) -#endif - -CHK_Ubiq() -- debugging consistency check \end{code} +@SST@ is very like the standard @ST@ monad, but it comes with its +friend @FSST@. Because we want the monadic bind operator to work +for mixtures of @SST@ and @FSST@, we can't use @ST@ at all. + +For simplicity we don't even dress them up in newtypes. + +%************************************************************************ +%* * +\subsection{The data types} +%* * +%************************************************************************ + \begin{code} +type SST s r = State# s -> SST_R s r +type FSST s r err = State# s -> FSST_R s r err + data SST_R s r = SST_R r (State# s) -type SST s r = State# s -> SST_R s r +data FSST_R s r err + = FSST_R_OK r (State# s) + | FSST_R_Fail err (State# s) \end{code} -\begin{code} --- converting to/from ST +Converting to/from ST +\begin{code} sstToST :: SST s r -> ST s r stToSST :: ST s r -> SST s r -#if __GLASGOW_HASKELL__ >= 200 && __GLASGOW_HASKELL__ < 209 - -sstToST sst = ST $ \ (S# s) -> - case sst s of SST_R r s' -> (r, S# s') +sstToST sst = ST (\ s -> case sst s of SST_R r s' -> STret s' r) -stToSST (ST st) = \ s -> - case st (S# s) of (r, S# s') -> SST_R r s' - -#elif __GLASGOW_HASKELL__ >= 209 +stToSST (ST st) = \ s -> case st s of STret s' r -> SST_R r s' +\end{code} -sstToST sst = ST $ \ s -> - case sst s of SST_R r s' -> STret s' r +...and IO -stToSST (ST st) = \ s -> - case st s of STret s' r -> SST_R r s' +\begin{code} +ioToSST :: IO a -> SST RealWorld (Either IOError a) +ioToSST (IO io) + = \s -> case io s of + IOok s' r -> SST_R (Right r) s' + IOfail s' err -> SST_R (Left err) s' +\end{code} -#else -sstToST sst (S# s) - = case sst s of SST_R r s' -> (r, S# s') -stToSST st s - = case st (S# s) of (r, S# s') -> SST_R r s' -#endif +%************************************************************************ +%* * +\subsection{The @SST@ operations} +%* * +%************************************************************************ +\begin{code} -- Type of runSST should be builtin ... -- runSST :: forall r. (forall s. SST s r) -> r -#if __GLASGOW_HASKELL__ >= 200 -# define REAL_WORLD RealWorld -# define MUT_ARRAY MutableArray -#else -# define REAL_WORLD _RealWorld -# define MUT_ARRAY _MutableArray -#endif - -runSST :: SST REAL_WORLD r -> r +runSST :: SST RealWorld r -> r runSST m = case m realWorld# of SST_R r s -> r unsafeInterleaveSST :: SST s r -> SST s r @@ -90,13 +87,24 @@ unsafeInterleaveSST m s = SST_R r s -- Duplicates the state! SST_R r _ = m s returnSST :: r -> SST s r -thenSST :: SST s r -> (r -> State# s -> b) -> State# s -> b -thenSST_ :: SST s r -> (State# s -> b) -> State# s -> b fixSST :: (r -> SST s r) -> SST s r {-# INLINE returnSST #-} {-# INLINE thenSST #-} {-# INLINE thenSST_ #-} +returnSST r s = SST_R r s + +fixSST m s = result + where + result = m loop s + SST_R loop _ = result +\end{code} + +OK, here comes the clever bind operator. + +\begin{code} +thenSST :: SST s r -> (r -> State# s -> b) -> State# s -> b +thenSST_ :: SST s r -> (State# s -> b) -> State# s -> b -- Hence: -- thenSST :: SST s r -> (r -> SST s r') -> SST s r' -- and thenSST :: SST s r -> (r -> FSST s r' err) -> FSST s r' err @@ -108,26 +116,14 @@ fixSST :: (r -> SST s r) -> SST s r thenSST m k s = case m s of { SST_R r s' -> k r s' } thenSST_ m k s = case m s of { SST_R r s' -> k s' } - -returnSST r s = SST_R r s - -fixSST m s = result - where - result = m loop s - SST_R loop _ = result \end{code} -\section{FSST: the failable strict state transformer monad} -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -\begin{code} -data FSST_R s r err - = FSST_R_OK r (State# s) - | FSST_R_Fail err (State# s) - -type FSST s r err = State# s -> FSST_R s r err -\end{code} +%************************************************************************ +%* * +\subsection{FSST: the failable strict state transformer monad} +%* * +%************************************************************************ \begin{code} failFSST :: err -> FSST s r err @@ -170,26 +166,32 @@ fixFSST m s = result FSST_R_OK loop _ = result \end{code} -Mutables -~~~~~~~~ +%************************************************************************ +%* * +\subsection{Mutables} +%* * +%************************************************************************ + Here we implement mutable variables. ToDo: get rid of the array impl. \begin{code} -newMutVarSST :: a -> SST s (MutableVar s a) -readMutVarSST :: MutableVar s a -> SST s a -writeMutVarSST :: MutableVar s a -> a -> SST s () +type SSTRef s a = MutableArray s Int a + +newMutVarSST :: a -> SST s (SSTRef s a) +readMutVarSST :: SSTRef s a -> SST s a +writeMutVarSST :: SSTRef s a -> a -> SST s () newMutVarSST init s# = case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# -> - SST_R (MUT_ARRAY vAR_IXS arr#) s2# } + SST_R (MutableArray vAR_IXS arr#) s2# } where vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n" -readMutVarSST (MUT_ARRAY _ var#) s# +readMutVarSST (MutableArray _ var#) s# = case readArray# var# 0# s# of { StateAndPtr# s2# r -> SST_R r s2# } -writeMutVarSST (MUT_ARRAY _ var#) val s# +writeMutVarSST (MutableArray _ var#) val s# = case writeArray# var# 0# val s# of { s2# -> SST_R () s2# } \end{code} diff --git a/ghc/compiler/utils/SpecLoop.lhi b/ghc/compiler/utils/SpecLoop.lhi deleted file mode 100644 index a85c98f5a1..0000000000 --- a/ghc/compiler/utils/SpecLoop.lhi +++ /dev/null @@ -1,62 +0,0 @@ -This loop-breaking module is used solely to braek the loops caused by -SPECIALIZE pragmas. - -\begin{code} -interface SpecLoop where - -import RdrHsSyn ( RdrName ) -import Name ( Name, OccName ) -import TyVar ( GenTyVar ) -import TyCon ( TyCon ) -import Class ( GenClass, GenClassOp ) -import Id ( GenId ) -import Unique ( Unique, Uniquable(..) ) -import MachRegs ( Reg ) -import CLabel ( CLabel ) - -data RdrName -data GenClass a b -data GenClassOp a -data GenId a -- NB: fails the optimisation criterion -data GenTyVar a -- NB: fails the optimisation criterion -data Name -data OccName -data TyCon -data Unique -data Reg -data CLabel - - -class Uniquable a where - uniqueOf :: a -> Unique - --- SPECIALIZing in FiniteMap -instance Eq Reg -instance Eq CLabel -instance Eq OccName -instance Eq RdrName -instance Eq (GenId a) -instance Eq TyCon -instance Eq (GenClass a b) -instance Eq Unique -instance Eq Name - -instance Ord Reg -instance Ord CLabel -instance Ord OccName -instance Ord RdrName -instance Ord (GenId a) -instance Ord TyCon -instance Ord (GenClass a b) -instance Ord Unique -instance Ord Name - --- SPECIALIZing in UniqFM, UniqSet -instance Uniquable (GenId a) -instance Uniquable TyCon -instance Uniquable (GenClass a b) -instance Uniquable Unique -instance Uniquable Name - --- SPECIALIZing in Name -\end{code} diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs index 5c070daf4f..3119a13c49 100644 --- a/ghc/compiler/utils/StringBuffer.lhs +++ b/ghc/compiler/utils/StringBuffer.lhs @@ -6,7 +6,12 @@ Buffers for scanning string input stored in external arrays. \begin{code} -#include "HsVersions.h" + +{-# OPTIONS -fno-prune-tydecls #-} +-- Don't really understand this! +-- ERROR: Can't see the data constructor(s) for _ccall_/_casm_ argument; +-- type: ForeignObj(try compiling with -fno-prune-tydecls ..) + module StringBuffer ( @@ -56,32 +61,20 @@ module StringBuffer lexemeToBuffer, -- :: StringBuffer -> StringBuffer FastString, - _ByteArray + ByteArray ) where -#if __GLASGOW_HASKELL__ <= 200 -import PreludeGlaST -import PreludeGlaMisc -import HandleHack -import Ubiq -#else +#include "HsVersions.h" + import GlaExts +import Addr ( Addr(..) ) import Foreign import IOBase import IOHandle import ST import STBase -import Char (isDigit) -# if __GLASGOW_HASKELL__ == 202 -import PrelBase ( Char(..) ) -# endif -# if __GLASGOW_HASKELL__ >= 206 +import Char (isDigit) import PackBase -# endif -# if __GLASGOW_HASKELL__ >= 209 -import Addr -# endif -#endif import PrimPacked import FastString @@ -112,36 +105,36 @@ hGetStringBuffer fname = -- Allocate an array for system call to store its bytes into. -- ToDo: make it robust -- trace (show ((len_i::Int)+1)) $ - (_casm_ `` %r=(char *)malloc(sizeof(char)*(int)%0); '' (len_i::Int)) `CCALL_THEN` \ arr@(A# a#) -> + _casm_ `` %r=(char *)malloc(sizeof(char)*(int)%0); '' (len_i::Int) >>= \ arr@(A# a#) -> if addr2Int# a# ==# 0# then failWith MkIOError(hndl,UserError,("hGetStringBuffer: Could not allocate "++show len_i ++ " bytes")) else --- _casm_ `` %r=NULL; '' `thenPrimIO` \ free_p -> --- makeForeignObj arr free_p `thenPrimIO` \ fo@(_ForeignObj fo#) -> - _readHandle hndl >>= \ hndl_ -> - _writeHandle hndl hndl_ >> +-- _casm_ `` %r=NULL; '' >>= \ free_p -> +-- makeForeignObj arr free_p >>= \ fo@(_ForeignObj fo#) -> + readHandle hndl >>= \ hndl_ -> + writeHandle hndl hndl_ >> let ptr = _filePtr hndl_ in - _ccall_ fread arr (1::Int) len_i ptr `CCALL_THEN` \ (I# read#) -> + _ccall_ fread arr (1::Int) len_i ptr >>= \ (I# read#) -> -- trace ("DEBUG: opened " ++ fname ++ show (I# read#)) $ hClose hndl >> if read# ==# 0# then -- EOF or other error failWith MkIOError(hndl,UserError,"hGetStringBuffer: EOF reached or some other error") else -- Add a sentinel NUL - _casm_ `` ((char *)%0)[(int)%1]=(char)0; '' arr (I# (read# -# 1#)) `CCALL_THEN` \ () -> + _casm_ `` ((char *)%0)[(int)%1]=(char)0; '' arr (I# (read# -# 1#)) >>= \ () -> return (StringBuffer a# read# 0# 0#) freeStringBuffer :: StringBuffer -> IO () freeStringBuffer (StringBuffer a# _ _ _) = - _casm_ `` free((char *)%0); '' (A# a#) `CCALL_THEN` \ () -> - return () + _casm_ `` free((char *)%0); '' (A# a#) unsafeWriteBuffer :: StringBuffer -> Int# -> Char# -> StringBuffer unsafeWriteBuffer s@(StringBuffer a _ _ _) i# ch# = - unsafePerformPrimIO ( - _casm_ `` ((char *)%0)[(int)%1]=(char)%2; '' (A# a) (I# i#) (C# ch#) `thenPrimIO` \ () -> - returnPrimIO s) + unsafePerformIO ( + _casm_ `` ((char *)%0)[(int)%1]=(char)%2; '' (A# a) (I# i#) (C# ch#) >>= \ () -> + return s + ) \end{code} diff --git a/ghc/compiler/utils/Ubiq.hs b/ghc/compiler/utils/Ubiq.hs deleted file mode 100644 index c66085da1f..0000000000 --- a/ghc/compiler/utils/Ubiq.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Ubiq - ( - module Unique, - module UniqFM - - ) where - -import Unique -import UniqFM - diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi deleted file mode 100644 index dc0b46586a..0000000000 --- a/ghc/compiler/utils/Ubiq.lhi +++ /dev/null @@ -1,152 +0,0 @@ -Things which are ubiquitous in the GHC compiler. - -\begin{code} -interface Ubiq where - -import FastString(FastString) - -import BasicTypes ( Module(..), Arity(..) ) -import Bag ( Bag ) -import BinderInfo ( BinderInfo ) -import CgBindery ( CgIdInfo ) -import CLabel ( CLabel ) -import Class ( GenClass, GenClassOp, Class(..), ClassOp ) -import ClosureInfo ( ClosureInfo, LambdaFormInfo ) -import CmdLineOpts ( SimplifierSwitch, SwitchResult ) -import CoreSyn ( GenCoreArg, GenCoreBinder, GenCoreBinding, GenCoreExpr, - GenCoreCaseAlts, GenCoreCaseDefault, Coercion - ) -import CoreUnfold ( Unfolding, UnfoldingGuidance ) -import CostCentre ( CostCentre ) -import FieldLabel ( FieldLabel ) -import FiniteMap ( FiniteMap ) -import HeapOffs ( HeapOffset ) -import HsPat ( OutPat ) -import HsPragmas ( ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas, InstancePragmas ) -import Id ( StrictnessMark, GenId, Id(..) ) -import IdInfo ( IdInfo, ArityInfo, StrictnessInfo, UpdateInfo ) -import Demand ( Demand ) -import Kind ( Kind ) -import Literal ( Literal ) -import MachRegs ( Reg ) -import Maybes ( MaybeErr ) -import MatchEnv ( MatchEnv ) -import Name ( OccName, Name, ExportFlag, NamedThing(..) ) -import Outputable ( Outputable(..), PprStyle ) -import PragmaInfo ( PragmaInfo ) -import Pretty ( Doc ) -import PrimOp ( PrimOp ) -import PrimRep ( PrimRep ) -import SMRep ( SMRep ) -import SrcLoc ( SrcLoc ) -import TcType ( TcMaybe ) -import TyCon ( TyCon ) -import TyVar ( GenTyVar, TyVar(..) ) -import Type ( GenType, Type(..) ) -import UniqFM ( UniqFM ) -import UniqSupply ( UniqSupply ) -import Unique ( Unique, Uniquable(..) ) -import Usage ( GenUsage, Usage(..) ) -import Util ( Ord3(..) ) - --- All the classes in GHC go; life is just too short --- to try to contain their visibility. - -class NamedThing a where - getOccName :: a -> OccName - getName :: a -> Name - -class Ord3 a where - cmp :: a -> a -> Int# -class Outputable a where - ppr :: PprStyle -> a -> Doc -class Uniquable a where - uniqueOf :: a -> Unique - --- For datatypes, we ubiquitize those types that (a) are --- used everywhere and (b) the compiler doesn't lose much --- optimisation-wise by not seeing their pragma-gunk. - -data ArityInfo -data Bag a -data BinderInfo -data CgIdInfo -data CLabel -data ClassOpPragmas a -data ClassPragmas a -data ClosureInfo -data Coercion -data CostCentre -data DataPragmas a -data Demand -data ExportFlag -data FieldLabel -data FiniteMap a b -data GenClass a b -data GenClassOp a -data GenCoreArg a b c -data GenCoreBinder a b c -data GenCoreBinding a b c d -data GenCoreCaseAlts a b c d -data GenCoreCaseDefault a b c d -data GenCoreExpr a b c d -data GenId a -- NB: fails the optimisation criterion -data GenPragmas a -data GenTyVar a -- NB: fails the optimisation criterion -data GenType a b -data GenUsage a -data HeapOffset -data IdInfo -data InstancePragmas a -data Kind -data LambdaFormInfo -data Literal -data MaybeErr a b -data MatchEnv a b -data Name -data OccName -data Reg -data OutPat a b c -data PprStyle -data PragmaInfo -data Doc -data PrimOp -data PrimRep -- NB: an enumeration -data SimplifierSwitch -data SMRep -data SrcLoc -data StrictnessInfo -data StrictnessMark -data SwitchResult -data TcMaybe s -data TyCon -data UniqFM a -data UpdateInfo -data UniqSupply -data Unfolding -data UnfoldingGuidance -data Unique -- NB: fails the optimisation criterion - --- don't get clever and unexpand some of these synonyms --- (GHC 0.26 will barf) -type Module = FastString -type Arity = Int -type Class = GenClass (GenTyVar (GenUsage Unique)) Unique -type ClassOp = GenClassOp (GenType (GenTyVar (GenUsage Unique)) Unique) -type Id = GenId (GenType (GenTyVar (GenUsage Unique)) Unique) -type Type = GenType (GenTyVar (GenUsage Unique)) Unique -type TyVar = GenTyVar (GenUsage Unique) -type Usage = GenUsage Unique - --- These are here only for SPECIALIZing in FiniteMap (ToDo:move?) -instance Ord Reg -instance Ord CLabel -instance Ord TyCon -instance Eq Reg -instance Eq CLabel -instance Eq TyCon --- specializing in UniqFM, UniqSet -instance Uniquable Unique -instance Uniquable Name --- specializing in Name -\end{code} diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs index 3ce6713a92..2fec976bc3 100644 --- a/ghc/compiler/utils/UniqFM.lhs +++ b/ghc/compiler/utils/UniqFM.lhs @@ -11,8 +11,6 @@ Basically, the things need to be in class @Uniquable@, and we use the (A similar thing to @UniqSet@, as opposed to @Set@.) \begin{code} -#include "HsVersions.h" - module UniqFM ( UniqFM, -- abstract type @@ -41,23 +39,19 @@ module UniqFM ( lookupUFM, lookupUFM_Directly, lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, eltsUFM, keysUFM, - ufmToList - ,FAST_STRING + ufmToList, + FastString ) where -IMP_Ubiq() +#include "HsVersions.h" -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER( SpecLoop ) -#else -import {-# SOURCE #-} Name -#endif +import {-# SOURCE #-} Name ( Name ) import Unique ( Uniquable(..), Unique, u2i, mkUniqueGrimily ) import Util -import Pretty ( Doc ) -import Outputable ( PprStyle, Outputable(..) ) +import Outputable ( Outputable(..) ) import SrcLoc ( SrcLoc ) +import GlaExts -- Lots of Int# operations #if ! OMIT_NATIVE_CODEGEN #define IF_NCG(a) a diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs index 2f53d068bc..13b3eae53f 100644 --- a/ghc/compiler/utils/UniqSet.lhs +++ b/ghc/compiler/utils/UniqSet.lhs @@ -8,10 +8,8 @@ Based on @UniqFMs@ (as you would expect). Basically, the things need to be in class @Uniquable@. \begin{code} -#include "HsVersions.h" - module UniqSet ( - SYN_IE(UniqSet), -- abstract type: NOT + UniqSet, -- abstract type: NOT mkUniqSet, uniqSetToList, emptyUniqSet, unitUniqSet, addOneToUniqSet, addListToUniqSet, @@ -20,19 +18,15 @@ module UniqSet ( isEmptyUniqSet, filterUniqSet, sizeUniqSet ) where -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER( SpecLoop ) -#else +#include "HsVersions.h" + import {-# SOURCE #-} Name -#endif import Maybes ( maybeToBool ) import UniqFM import Unique ( Unique, Uniquable(..) ) import SrcLoc ( SrcLoc ) -import Outputable ( PprStyle, Outputable(..) ) -import Pretty ( Doc ) -import Util ( Ord3(..) ) +import Outputable ( Outputable(..) ) #if ! OMIT_NATIVE_CODEGEN #define IF_NCG(a) a diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 97ca5242ff..34d36ae472 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -4,25 +4,12 @@ \section[Util]{Highly random utility functions} \begin{code} -#include "HsVersions.h" -#define IF_NOT_GHC(a) {--} - -#ifndef __GLASGOW_HASKELL__ -# undef TAG_ -# undef LT_ -# undef EQ_ -# undef GT_ -# undef tagCmp_ -#endif +-- IF_NOT_GHC is meant to make this module useful outside the context of GHC +#define IF_NOT_GHC(a) module Util ( - -- Haskell-version support -#ifndef __GLASGOW_HASKELL__ - tagCmp_, - TAG_(..), -#endif -- The Eager monad - SYN_IE(Eager), thenEager, returnEager, mapEager, appEager, runEager, + Eager, thenEager, returnEager, mapEager, appEager, runEager, -- general list processing IF_NOT_GHC(forall COMMA exists COMMA) @@ -30,7 +17,7 @@ module Util ( zipLazy, mapAndUnzip, mapAndUnzip3, nOfThem, lengthExceeds, isSingleton, - startsWith, endsWith, + startsWith, endsWith, snocView, isIn, isn'tIn, -- association lists @@ -52,23 +39,23 @@ module Util ( mapAccumL, mapAccumR, mapAccumB, -- comparisons - Ord3(..), thenCmp, cmpList, - cmpPString, FAST_STRING, + thenCmp, cmpList, + FastString, -- pairs IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA) IF_NOT_GHC(applyToSnd COMMA foldPair COMMA) - unzipWith + unzipWith, -- error handling - , panic, panic#, pprPanic, pprPanic#, pprError, pprTrace - , assertPanic, assertPprPanic + panic, panic#, assertPanic ) where -CHK_Ubiq() -- debugging consistency check -IMPORT_1_3(List(zipWith4)) -import Pretty +#include "HsVersions.h" + +import FastString ( FastString ) +import List ( zipWith4 ) infixr 9 `thenCmp` \end{code} @@ -107,22 +94,6 @@ mapEager f (x:xs) = f x `thenEager` \ y -> %************************************************************************ %* * -\subsection[Utils-version-support]{Functions to help pre-1.2 versions of (non-Glasgow) Haskell} -%* * -%************************************************************************ - -This is our own idea: -\begin{code} -#ifndef __GLASGOW_HASKELL__ -data TAG_ = LT_ | EQ_ | GT_ - -tagCmp_ :: Ord a => a -> a -> TAG_ -tagCmp_ a b = if a == b then EQ_ else if a < b then LT_ else GT_ -#endif -\end{code} - -%************************************************************************ -%* * \subsection[Utils-lists]{General list processing} %* * %************************************************************************ @@ -232,7 +203,16 @@ endsWith cs ss Just rs -> Just (reverse rs) \end{code} +\begin{code} +snocView :: [a] -> ([a], a) -- Split off the last element +snocView xs = go xs [] + where + go [x] acc = (reverse acc, x) + go (x:xs) acc = go xs (x:acc) +\end{code} + Debugging/specialising versions of \tr{elem} and \tr{notElem} + \begin{code} isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool @@ -314,7 +294,7 @@ hasNoDups xs = f [] xs \end{code} \begin{code} -equivClasses :: (a -> a -> TAG_) -- Comparison +equivClasses :: (a -> a -> Ordering) -- Comparison -> [a] -> [[a]] @@ -323,8 +303,8 @@ equivClasses cmp stuff@[item] = [stuff] equivClasses cmp items = runs eq (sortLt lt items) where - eq a b = case cmp a b of { EQ_ -> True; _ -> False } - lt a b = case cmp a b of { LT_ -> True; _ -> False } + eq a b = case cmp a b of { EQ -> True; _ -> False } + lt a b = case cmp a b of { LT -> True; _ -> False } \end{code} The first cases in @equivClasses@ above are just to cut to the point @@ -345,7 +325,7 @@ runs p (x:xs) = case (span (p x) xs) of \end{code} \begin{code} -removeDups :: (a -> a -> TAG_) -- Comparison function +removeDups :: (a -> a -> Ordering) -- Comparison function -> [a] -> ([a], -- List with no duplicates [[a]]) -- List of duplicate groups. One representative from @@ -361,6 +341,7 @@ removeDups cmp xs collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x) \end{code} + %************************************************************************ %* * \subsection[Utils-sorting]{Sorting} @@ -452,12 +433,12 @@ rqpart lt x (y:ys) rle rgt r = %************************************************************************ \begin{code} -mergesort :: (a -> a -> TAG_) -> [a] -> [a] +mergesort :: (a -> a -> Ordering) -> [a] -> [a] mergesort cmp xs = merge_lists (split_into_runs [] xs) where - a `le` b = case cmp a b of { LT_ -> True; EQ_ -> True; GT__ -> False } - a `ge` b = case cmp a b of { LT_ -> False; EQ_ -> True; GT__ -> True } + a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False } + a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True } split_into_runs [] [] = [] split_into_runs run [] = [run] @@ -473,9 +454,9 @@ mergesort cmp xs = merge_lists (split_into_runs [] xs) merge xs [] = xs merge xl@(x:xs) yl@(y:ys) = case cmp x y of - EQ_ -> x : y : (merge xs ys) - LT_ -> x : (merge xs yl) - GT__ -> y : (merge xl ys) + EQ -> x : y : (merge xs ys) + LT -> x : (merge xs yl) + GT -> y : (merge xl ys) \end{code} %************************************************************************ @@ -676,68 +657,37 @@ mapAccumB f a b (x:xs) = (a'',b'',y:ys) %* * %************************************************************************ -See also @tagCmp_@ near the versions-compatibility section. - -The Ord3 class will be subsumed into Ord in Haskell 1.3. - \begin{code} -class Ord3 a where - cmp :: a -> a -> TAG_ - -thenCmp :: TAG_ -> TAG_ -> TAG_ +thenCmp :: Ordering -> Ordering -> Ordering {-# INLINE thenCmp #-} -thenCmp EQ_ any = any +thenCmp EQ any = any thenCmp other any = other -cmpList :: (a -> a -> TAG_) -> [a] -> [a] -> TAG_ +cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering -- `cmpList' uses a user-specified comparer -cmpList cmp [] [] = EQ_ -cmpList cmp [] _ = LT_ -cmpList cmp _ [] = GT_ +cmpList cmp [] [] = EQ +cmpList cmp [] _ = LT +cmpList cmp _ [] = GT cmpList cmp (a:as) (b:bs) - = case cmp a b of { EQ_ -> cmpList cmp as bs; xxx -> xxx } -\end{code} - -\begin{code} -instance Ord3 a => Ord3 [a] where - cmp [] [] = EQ_ - cmp (x:xs) [] = GT_ - cmp [] (y:ys) = LT_ - cmp (x:xs) (y:ys) = (x `cmp` y) `thenCmp` (xs `cmp` ys) - -instance Ord3 a => Ord3 (Maybe a) where - cmp Nothing Nothing = EQ_ - cmp Nothing (Just y) = LT_ - cmp (Just x) Nothing = GT_ - cmp (Just x) (Just y) = x `cmp` y - -instance Ord3 Int where - cmp a b | a < b = LT_ - | a > b = GT_ - | otherwise = EQ_ + = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx } \end{code} \begin{code} -cmpString :: String -> String -> TAG_ +cmpString :: String -> String -> Ordering -cmpString [] [] = EQ_ +cmpString [] [] = EQ cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys - else if x < y then LT_ - else GT_ -cmpString [] ys = LT_ -cmpString xs [] = GT_ + else if x < y then LT + else GT +cmpString [] ys = LT +cmpString xs [] = GT -cmpString _ _ = panic# "cmpString" +cmpString _ _ = panic "cmpString" \end{code} -\begin{code} -cmpPString :: FAST_STRING -> FAST_STRING -> TAG_ - -cmpPString x y - = case (tagCmpFS x y) of { _LT -> LT_ ; _EQ -> EQ_ ; _GT -> GT_ } -\end{code} +y %************************************************************************ %* * \subsection[Utils-pairs]{Pairs} @@ -775,6 +725,7 @@ unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs \end{code} + %************************************************************************ %* * \subsection[Utils-errors]{Error handling} @@ -787,33 +738,13 @@ panic x = error ("panic! (the `impossible' happened):\n\t" ++ "Please report it as a compiler bug " ++ "to glasgow-haskell-bugs@dcs.gla.ac.uk.\n\n" ) -pprPanic heading pretty_msg = panic (heading++ " " ++ (show pretty_msg)) -pprError heading pretty_msg = error (heading++ " " ++ (show pretty_msg)) -# if __GLASGOW_HASKELL__ == 201 -pprTrace heading pretty_msg = GHCbase.trace (heading++" "++(show pretty_msg)) -# elif __GLASGOW_HASKELL__ >= 202 -pprTrace heading pretty_msg = GlaExts.trace (heading++" "++(show pretty_msg)) -# else -pprTrace heading pretty_msg = trace (heading++" "++(show pretty_msg)) -# endif - -- #-versions because panic can't return an unboxed int, and that's -- what TAG_ is with GHC at the moment. Ugh. (Simon) -- No, man -- Too Beautiful! (Will) -panic# :: String -> TAG_ -panic# s = case (panic s) of () -> EQ_ - -pprPanic# heading pretty_msg = panic# (heading++(show pretty_msg)) +panic# :: String -> FAST_INT +panic# s = case (panic s) of () -> ILIT(0) assertPanic :: String -> Int -> a -assertPanic file line = panic ("ASSERT failed! file "++file++", line "++show line) - -assertPprPanic :: String -> Int -> Doc -> a -assertPprPanic file line msg - = panic (show (sep [hsep[text "ASSERT failed! file", - text file, - text "line", int line], - msg])) - +assertPanic file line = panic ("ASSERT failed! file " ++ file ++ ", line " ++ show line) \end{code} diff --git a/ghc/driver/ghc-iface.lprl b/ghc/driver/ghc-iface.lprl index 67657b5793..b1fae52782 100644 --- a/ghc/driver/ghc-iface.lprl +++ b/ghc/driver/ghc-iface.lprl @@ -148,6 +148,20 @@ sub constructNewHiFile { } \end{code} +Read the .hi file made by the compiler, or the old one. +All the declarations in the file are stored in + + $Decl{"$mod:$v"} + +where $mod is "new" or "old", depending on whether it's the new or old + .hi file that's being read. + +and $v is + for values v "v" + for tycons T "type T" or "data T" + for classes C "class C" + + \begin{code} sub readHiFile { local($mod, # module to read; can be special tag 'old' @@ -219,25 +233,29 @@ sub readHiFile { } if ( /^(\S+)\s+_:_\s+/ ) { + # Value declaration $current_name = $1; $Decl{"$mod:$current_name"} = $_; if ($mod eq "old") { $OldVersion{$current_name} = $version; } } elsif ( /^type\s+(\S+)/ ) { - $current_name = $1; + # Type declaration + $current_name = "type $1"; $Decl{"$mod:$current_name"} = $_; if ($mod eq "old") { $OldVersion{$current_name} = $version; } } elsif ( /^(newtype|data)\s+(.*\s+=>\s+)?(\S+)\s+/ ) { - $current_name = $3; + # Data declaration + $current_name = "data $3"; $Decl{"$mod:$current_name"} = $_; if ($mod eq "old") { $OldVersion{$current_name} = $version; } } elsif ( /^class\s+(\{[^{}]*\}\s+=>\s+)?(\S+)\s+/ ) { + # Class declaration # must be wary of => bit matching after "where"... # ..hence the [^{}] part # NB: a class decl may not have a where part at all - $current_name = $2; + $current_name = "class $2"; $Decl{"$mod:$current_name"} = $_; if ($mod eq "old") { $OldVersion{$current_name} = $version; } diff --git a/ghc/lib/ghc/GHC.hi-boot b/ghc/lib/ghc/GHC.hi-boot index b4b12d0879..35e2fc293f 100644 --- a/ghc/lib/ghc/GHC.hi-boot +++ b/ghc/lib/ghc/GHC.hi-boot @@ -11,6 +11,8 @@ GHC -> All -- Pseudo class used for universal quantification + CCallable + CReturnable Void -- void CAF is defined in PrelBase @@ -60,6 +62,7 @@ GHC +# -# *# + /# quotInt# remInt# negateInt# @@ -227,6 +230,10 @@ indexDoubleOffForeignObj# StablePtr# makeStablePtr# deRefStablePtr# - reallyUnsafePtrEquality# ; + +_declarations_ + +1 class CCallable a :: ** ; +1 class CReturnable a :: ** ; diff --git a/ghc/lib/ghc/IOBase.lhs b/ghc/lib/ghc/IOBase.lhs index 39fe2542c3..807dba22a8 100644 --- a/ghc/lib/ghc/IOBase.lhs +++ b/ghc/lib/ghc/IOBase.lhs @@ -98,10 +98,9 @@ instance Show (IO a) where \begin{code} stToIO :: ST RealWorld a -> IO a -ioToST :: IO a -> ST RealWorld a - stToIO (ST m) = IO $ \ s -> case (m s) of STret new_s r -> IOok new_s r +ioToST :: IO a -> ST RealWorld a ioToST (IO io) = ST $ \ s -> case (io s) of IOok new_s a -> STret new_s a @@ -122,8 +121,8 @@ fputs :: Addr{-FILE*-} -> String -> IO Bool fputs stream [] = return True fputs stream (c : cs) - = _ccall_ stg_putc c stream >> -- stg_putc expands to putc - fputs stream cs -- (just does some casting stream) + = _ccall_ stg_putc c stream >> -- stg_putc expands to putc + fputs stream cs -- (just does some casting stream) \end{code} @@ -307,9 +306,9 @@ data MVar a = MVar (SynchVar# RealWorld a) data ForeignObj = ForeignObj ForeignObj# -- another one #if defined(__CONCURRENT_HASKELL__) -type Handle = MVar Handle__ +newtype Handle = Handle (MVar Handle__) #else -type Handle = MutableVar RealWorld Handle__ +newtype Handle = Handle (MutableVar RealWorld Handle__) #endif data Handle__ diff --git a/ghc/lib/ghc/IOHandle.lhs b/ghc/lib/ghc/IOHandle.lhs index b0c3c81dbc..a2787815a9 100644 --- a/ghc/lib/ghc/IOHandle.lhs +++ b/ghc/lib/ghc/IOHandle.lhs @@ -58,15 +58,24 @@ readHandle :: Handle -> IO Handle__ writeHandle :: Handle -> Handle__ -> IO () #if defined(__CONCURRENT_HASKELL__) -newHandle = newMVar -readHandle = takeMVar -writeHandle = putMVar + +-- Use MVars for concurrent Haskell +newHandle hc = newMVar hc >>= \ h -> + return (Handle h) + +readHandle (Handle h) = takeMVar h +writeHandle (Handle h) hc = putMVar h hc + #else -newHandle v = stToIO (newVar v) -readHandle h = stToIO (readVar h) -writeHandle h v = stToIO (writeVar h v) -#endif +-- Use ordinary MutableVars for non-concurrent Haskell +newHandle hc = stToIO (newVar hc >>= \ h -> + return (Handle h)) + +readHandle (Handle h) = stToIO (readVar h) +writeHandle (Handle h) hc = stToIO (writeVar h hc) + +#endif \end{code} %********************************************************* @@ -885,5 +894,4 @@ access of a closed file. ioe_closedHandle :: Handle -> IO a ioe_closedHandle h = fail (IOError (Just h) IllegalOperation "handle is closed") - \end{code} diff --git a/ghc/lib/ghc/PackBase.lhs b/ghc/lib/ghc/PackBase.lhs index dc0a835b62..1f8614b9aa 100644 --- a/ghc/lib/ghc/PackBase.lhs +++ b/ghc/lib/ghc/PackBase.lhs @@ -36,9 +36,15 @@ module PackBase unpackFoldrCString#, -- ** - unpackAppendCString# -- ** + unpackAppendCString#, -- ** - ) where + new_ps_array, -- Int# -> ST s (MutableByteArray s Int) + write_ps_array, -- MutableByteArray s Int -> Int# -> Char# -> ST s () + freeze_ps_array -- MutableByteArray s Int -> Int# -> ST s (ByteArray Int) + + + ) + where import PrelBase import {-# SOURCE #-} Error ( error ) diff --git a/ghc/lib/ghc/PrelBase.lhs b/ghc/lib/ghc/PrelBase.lhs index 891d45c964..cfe4a83cfc 100644 --- a/ghc/lib/ghc/PrelBase.lhs +++ b/ghc/lib/ghc/PrelBase.lhs @@ -28,6 +28,107 @@ infixl 1 >>, >>= infixr 0 $ \end{code} + +\begin{code} +{- +class Eval a +data Bool = False | True +data Int = I# Int# +data Double = D# Double# +data () = () --easier to do explicitly: deriving (Eq, Ord, Enum, Show, Bounded) + -- (avoids weird-named functions, e.g., con2tag_()# + +data Maybe a = Nothing | Just a +data Ordering = LT | EQ | GT deriving( Eq ) + +type String = [Char] + +data Char = C# Char# +data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord) + -- to avoid weird names like con2tag_[]# + + +-------------- Stage 2 ----------------------- +not True = False +not False = True +True && x = x +False && x = False +otherwise = True + +maybe :: b -> (a -> b) -> Maybe a -> b +maybe n f Nothing = n +maybe n f (Just x) = f x + +-------------- Stage 3 ----------------------- +class Eq a where + (==), (/=) :: a -> a -> Bool + + x /= y = not (x == y) + +-- f :: Eq a => a -> a -> Bool +f x y = x == y + +g :: Eq a => a -> a -> Bool +g x y = f x y + +-------------- Stage 4 ----------------------- + +class (Eq a) => Ord a where + compare :: a -> a -> Ordering + (<), (<=), (>=), (>):: a -> a -> Bool + max, min :: a -> a -> a + +-- An instance of Ord should define either compare or <= +-- Using compare can be more efficient for complex types. + compare x y + | x == y = EQ + | x <= y = LT + | otherwise = GT + + x <= y = compare x y /= GT + x < y = compare x y == LT + x >= y = compare x y /= LT + x > y = compare x y == GT + max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x } + min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y } + +eqInt (I# x) (I# y) = x ==# y + +instance Eq Int where + (==) x y = x `eqInt` y + +instance Ord Int where + compare x y = error "help" + +class Bounded a where + minBound, maxBound :: a + + +type ShowS = String -> String + +class Show a where + showsPrec :: Bool -> a -> ShowS + showList :: [a] -> ShowS + + showList ls = showList__ (showsPrec True) ls + +showList__ :: (a -> ShowS) -> [a] -> ShowS +showList__ showx [] = showString "[]" + +showString :: String -> ShowS +showString = (++) + +[] ++ [] = [] + +shows :: (Show a) => a -> ShowS +shows = showsPrec True + +-- show :: (Show a) => a -> String +--show x = shows x "" +-} +\end{code} + + %********************************************************* %* * \subsection{Standard classes @Eq@, @Ord@, @Bounded@, @Eval@} @@ -323,6 +424,7 @@ it here seems more direct. \begin{code} data () = () --easier to do explicitly: deriving (Eq, Ord, Enum, Show, Bounded) -- (avoids weird-named functions, e.g., con2tag_()# + instance Eq () where () == () = True () /= () = False diff --git a/ghc/lib/ghc/PrelList.lhs b/ghc/lib/ghc/PrelList.lhs index 4ed206b78a..7fd2d20aeb 100644 --- a/ghc/lib/ghc/PrelList.lhs +++ b/ghc/lib/ghc/PrelList.lhs @@ -330,10 +330,16 @@ tuples are in the List library \begin{code} zip :: [a] -> [b] -> [(a,b)] -zip = zipWith (,) +-- Specification +-- zip = zipWith (,) +zip (a:as) (b:bs) = (a,b) : zip as bs +zip _ _ = [] zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] -zip3 = zipWith3 (,,) +-- Specification +-- zip3 = zipWith3 (,,) +zip3 (a:as) (b:bs) (c:cs) = (a,b,c) : zip3 as bs cs +zip3 _ _ _ = [] -- The zipWith family generalises the zip family by zipping with the -- function given as the first argument, instead of a tupling function. diff --git a/ghc/lib/ghc/PrelNum.lhs b/ghc/lib/ghc/PrelNum.lhs index 041214df1d..434406021e 100644 --- a/ghc/lib/ghc/PrelNum.lhs +++ b/ghc/lib/ghc/PrelNum.lhs @@ -192,7 +192,7 @@ instance Integral Int where a@(I# _) `quotRem` b@(I# _) = (a `quotInt` b, a `remInt` b) -- OK, so I made it a little stricter. Shoot me. (WDP 94/10) - -- following chks for zero divisor are non-standard (WDP) + -- Following chks for zero divisor are non-standard (WDP) a `quot` b = if b /= 0 then a `quotInt` b else error "Integral.Int.quot{PreludeCore}: divide by 0\n" @@ -716,7 +716,7 @@ numericEnumFromThenTo n m p = takeWhile (if m >= n then (<= p) else (>= p)) %********************************************************* \begin{code} -data (Integral a) => Ratio a = !a :% !a deriving (Eq) +data (Eval a, Integral a) => Ratio a = !a :% !a deriving (Eq) type Rational = Ratio Integer \end{code} diff --git a/ghc/lib/glaExts/CCall.lhs b/ghc/lib/glaExts/CCall.lhs index 6de7fbf2c8..f1205e89fd 100644 --- a/ghc/lib/glaExts/CCall.lhs +++ b/ghc/lib/glaExts/CCall.lhs @@ -23,9 +23,6 @@ import GHC %********************************************************* \begin{code} -class CCallable a -class CReturnable a - instance CCallable Char instance CCallable Char# instance CReturnable Char diff --git a/ghc/lib/required/IO.lhs b/ghc/lib/required/IO.lhs index 6234592935..ef97220450 100644 --- a/ghc/lib/required/IO.lhs +++ b/ghc/lib/required/IO.lhs @@ -107,6 +107,12 @@ instance Eq IOError where e1==e2 && str1==str2 && h1==h2 instance Eq Handle where + (Handle h1) == (Handle h2) = h1 == h2 + +{- OLD equality instance. The simpler one above + seems more accurate! + +instance Eq Handle where h1 == h2 = unsafePerformIO (do h1_ <- readHandle h1 @@ -123,6 +129,7 @@ instance Eq Handle where (AppendHandle v1 _ _ , AppendHandle v2 _ _) -> v1 == v2 (ReadWriteHandle v1 _ _ , ReadWriteHandle v2 _ _) -> v1 == v2 _ -> False)) +-} instance Show Handle where {showsPrec p h = showString "<<Handle>>"} diff --git a/ghc/lib/required/List.lhs b/ghc/lib/required/List.lhs index d48c5bf9dd..08952a6dae 100644 --- a/ghc/lib/required/List.lhs +++ b/ghc/lib/required/List.lhs @@ -34,7 +34,9 @@ module List ( ) where import Prelude -import Maybe (listToMaybe) +import Maybe (listToMaybe) +import PrelBase ( Int(..) ) +import GHC ( (+#) ) infix 5 \\ \end{code} @@ -59,7 +61,16 @@ findIndex :: (a -> Bool) -> [a] -> Maybe Int findIndex p = listToMaybe . findIndices p findIndices :: (a -> Bool) -> [a] -> [Int] -findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] + +-- One line definition +-- findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] + +-- Efficient definition +findIndices p xs = loop 0# p xs + where + loop n p [] = [] + loop n p (x:xs) | p x = I# n : loop (n +# 1#) p xs + | otherwise = loop (n +# 1#) p xs isPrefixOf :: (Eq a) => [a] -> [a] -> Bool isPrefixOf [] _ = True |