diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h
index a5159181735956821de142962180c13ff2e2f419..2e1b15404495f86f590c438813d7609948b3cb68 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 3e4dcb7a26df2e21d58a7c2c8adee5f37616f6d3..777b1384d713d02a1bfbbd91b05e7aa2acf17349 100644
--- a/ghc/compiler/Makefile
+++ b/ghc/compiler/Makefile
@@ -31,6 +31,13 @@ LIBRARY=libhsp.a
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
#
@@ -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 b28900e54838be4d296dfeb8ea631c3efc17f3c7..0000000000000000000000000000000000000000
--- 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 ce5d77735c2149823251d24e22941f4996f3c579..afa43049b7661c6a12a591040ecfa64cef87fe05 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 46e72ab94e16eccf38cd5e715eb55ba89677c0d3..202b8f7709a17beea7363a6538ed70eff3a626e4 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 814b1d518ccd5fd33b5e2f885930959116031d3d..ce23e2b039ae4c163f7d3724855cdbb7790fdf12 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 b47da2bf0c936765a99604c16a709d7dcb83f3c1..5a40e344f5a1c857cbfa62389a325fcf64467e8d 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 eb641bc88f759db40517e251a1d682aac78bfab2..c1cb316019803fbe6c9e6b20cc9b089438c58107 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 10a5f6583fd6c96974b9127aa326b43fa368b7bf..a76987aa72be95080ebe84652085afcbe350c60a 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 fe822b41243ef4ca6047c8f54971961ac067cdad..8483c9ba214acf65f39a76553c4b7b1fabad9520 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 82a446bbade39d4a92a96ec166644c998174e586..b10fec9390583fe6dd0912baea3d0f41b7ba4928 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 bd9c7c3e108bcbf3eeb4132187d332b09eba0817..8592da40c8b692f5aecb98b410cdb1563994cb5f 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 ccaf094620116c2d4f42624f5174acb383c9e232..683d8fd91f16d1a85a098ba0a6090c64348a27fe 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 c9591e87e071fae42f0fa2cbcd0b2015124994ce..7b3f99d6a6d6e1026531e0089ab4b5a84ae327b6 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 3f4d8e170e762e2955364f34c2cd4df3d02dfc96..dc1cca8b5571d73aa2e07b3d1f750e1b25b66035 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 b9e81f9d6c2c34d56379bc55be9f3e4bcbe44472..da096ebc19b1da696301c93966c0426ece898be3 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 48ea6b101df4d7ecaf94f43d33e476a2af69d901..0000000000000000000000000000000000000000
--- 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 a0d7020605dab53123db9451421ea0814fd1b3d6..fa75ed4ae3b7496d3fc7de376b9a11fe88ff871c 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 738dcf108c9c192607d85aaa0147d0511b6a5004..eeddb56823648ab3217f5f2ce6017c70dbc861cd 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 79ffa108a986c8da67cd49f432d50f7518cf928e..e01e8c07cc2f1fd05ce05dc7e3ce2c9cf4196416 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 0962f9ac325a45770f3380fe00eb97b8ed4d347f..6e07e395c83f444b83b17b72db8c5f59cc82f9e6 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 d7f514a82a29b36f266316dba604874560e11d46..874a7f375ee99d7e13ce4a402ad4f703f6b2df3e 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 20bc49a65effee2debab81350227aa5a0537bdf5..cfd42a6f641a845d6d116e9e1908f5d318788ba2 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 1c651cb62b1a268d7b7f9ebf0d095469accff422..23bd2c051e9e76c74daad8a8b06b5625031e5fb0 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 34d05c48baf9ea7615007287dbdec583c1b68489..4021d24276f5852315b46f4ba8af565117968ee5 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 e2c06aa4f739b4a573e9f5394883cbc3ec9d6850..b3b26b0940627fc006ef3d73fbb5b5036fc61b17 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 d43313392b8430d589a04723d23f2f801ad71728..f21d393b8326e4ad134ccba807c637074bb8f7b3 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 c6eb9f06f3cbb92b6fa70696cd3915fa57b9d23f..85cc41cf28e6ffc2d3d1969cc7a81e3cb20e7f8a 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 673dd7ab76f0af5eae932ce890c5ac63cd7d745a..8fbf5c689af54b97959b99c8f5f6305cb05fdc23 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 a4110434d5970414ec6516ab2d00c7d490cab7c1..305b7eae89880c66f717abe8894bb9e84601a1fb 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 09d9c109a1bde373be0631520db18bd9044d0ad5..a80322654f99cb2b65e590468564b1392540d0ee 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 b600193b56c7b42ffb0d97a29587986ea909c594..904dd5504e47b8e8e697f8d2f34b718e0afcea43 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 903d072cac1ef839b637739e7ffdffffd10daafe..01b2ed9461defb6108ad5cf870b6c81c6e8e0753 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 935b441910d0f9c8dbccc3978b374d387f49cb4a..c7dee225982efcd53f378be687bdf6ee2e35325a 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 985529ba8402be3a2b1b37ccb84e16a2d30f5b0d..0000000000000000000000000000000000000000
--- 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 421fbfa78290830513dc0b0e3f189ef918e5ecc5..0000000000000000000000000000000000000000
--- 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 6c9e31f83f01e3aa27edb7e42d4e8b5ace9717cd..5f8e1d2d97549c50f2033b4dd4eb6d99e6a11bab 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 a50c659604887c476a27476de951dd1cf1cdcd86..d6342e2c3f638d2017bcce064985324ce25f7087 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 cc845bf539703a0b2edd562662e73ee084fb7e3a..cba5106b4fa7080d7e7967d96e511d75db03b629 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 87cd59c8b9304ac27130cc27e0b0b4d577df7d6a..fb09a0e96b4555787cbddff4a556afd508d1e123 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 5c0accd6920f3f167e04cf6b3c5d7973c2ed8b72..43a21943d47b7d49bedd81cdf7c6d279f6b4904a 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 3ff49808fa9c757148ffa62b99c35eecc3c26d02..adf6035796d5d083c9a853ee00523c72f4646cd7 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 a71f3c05ad74ad52d2930f05fb11535904952b6e..d14a8a7a1371355ac4df6808a42c9b7de94772ce 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 7f151456ef8981ea9f521cd65cc338b2ae9a1d1c..a9437eb3efc9fa9a117dc1d581baeba576172b78 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 78934e8668f55f1852e3a662f0f87dad8dca910d..4f106b3281ecbdaa1c39f814910fc42560fedbe0 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 59db4a5d19b34bc2014281638ec5b0b2144e05ea..7c74fd70ea7e51f1aa993f247751046098a284e7 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 cf63b8bdf2f389464f5bb7900ccc76731d5e26c2..eb284c185bdb66378b2aa23c5e86b1083e737cb5 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 981c0c495ef7c9af99328379fb553c2da83edd90..d4dffadb7849445a69470fa65bfc996ea469dc80 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 6e28cf431d16105fa444ababd2c1427e382ed848..596a7c2a69a0e525caca387ed41f932affdafe6d 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 e25495862570a6fc74e3c2bb130ceb0a71717d42..c92ffe6bdf6559c1ba04f426ac8ea11946449711 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 6ace516408a24077f7ef750bc8cd5a4569dcf1c5..bfc21df7426c66958dc23eebc5e091e1e004114f 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 d2a0588ab6d076bc7a5c434e289e8ace5baef677..614016472c7921130acc7362c11c83be4c855239 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 e822513a6778e3bcf2c1b96eafdfaf67d22a660c..0c29fa035140af3550fd10635d80a8580f976636 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 dbbbea4742665a8daf1f1897f6975982e1ef193b..fba9b3ae41bd3892c6eb295e15fcfc4592c945bd 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 14db54b456626bb1582bd41fe2a89bbea1cbbf7b..87d90b2a2bb8b43576dec4f4099a28c5b3f137c7 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 bfd4634dc88249842e91c0bfa2c09648672e0494..c365d145003560f895a6bfe2342334ded4a4ae21 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 1cae7d022b7a512d3bc50cf54890f731d5f40492..019e207330dc13fcd75e1ac243d487d76f35e197 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 1b46e7779e53766539908861a83b1e7d2bad8c87..06e7f875bf1809ff7fa805fe7d4df1756f2f5808 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 2ba429ef0fb5f3c9e778a4ee4ff32e92e7f2b227..40b625cbe72dbd2fc81df582bfa3fce7801cde4d 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 070b243f4f2d81b1e720430c74e6b59c658a7f0e..2e6b8882efec9c1e061618e592493d9102515921 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 a202ad92e418043745023c4d818c5ba878951c64..56440968a2dbcbd5711fb13e30d8b6836b6fcfdf 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 4464a5396f9c97ef65e2072dff1cc1d1be12693a..0000000000000000000000000000000000000000
--- 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 7ed81cfe2bce160fdae3b5118d5bdc80e01f1cba..90e9958846baa5b877a7ff883f2fe3f34fb3a3b7 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 ec7d25231e6b385f4591dce9bf6096e049dc483f..1254d9a6744471a828592006380e1beac1c3fa44 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 ee9e8aa8406470786d11e437bc654c70e8b1cc67..55a94542a91203f0089f42d4a6ccd625a0838976 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 280103b05637ec3144f6f9609bf8a119ced20a64..152d082050ee212ca89fa7329acec8c118c68278 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 8b40044a3d6c9be489b95b65a3a01a7c977ac951..b3e645d4a1675eeebd3c24717e9f02c1a937d9e2 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 afe2516b8362d6e958dada980544b91b9d140f58..73e408671b7d5e9ac3b7498bf5636a0016cf8cc3 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 dd00458d45062d705e5b4f90f60b85fc2ba5c5f6..f8645b236a364a755661a096afa6d1cf4b1360b7 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 c298d940d89bebe3926b963482d5960058989f1a..d020b76baff0890f6e842afc63d0b4687d64851f 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 6a37f2d147dff484b845f0871b1d7b695fbccda2..05226a126e2fd020be58ed5aaa811558899c8e1e 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 d4c904f4e9cf44cc6ee4f568326a4e4f239db9cc..f466d590028f9a6abaa1571cabd74ac7d4a57b10 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 0398326f4343bac00335d51a6d5527d81e8831e9..82447a0a2e1b604d863f1195342b65f7316798a6 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 44b250bc062eadf53a3a3d3cb5ee4409ec7aabf2..85ea35a8f505266edff6393f2fa8c982e01d9a88 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 2e24797a5ed559c5af389706494915f513ba3baf..97c23f48fb732ae513478784343d0f206753c53c 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 e507d2e1c455b75e80fde7d8c9c17901b56fd079..0000000000000000000000000000000000000000
--- 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 c1a24cae910d2f3cde2afed4ebbeec51f57867f0..b783d025c98363afd8cb426348cd400b1ed1c242 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 1d85fbb3e3228e27e0ea271725f1f20caf1c4865..63a783a2c58c7d1717ba960f5223b35f5e92dbd6 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 2405fae4a361c73329208996aa395efec985a138..8e89bb2f3dad0799804b5e7bf87863d884a9b7df 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 cc3733ebe49acb15c093863df0d202c76b02c0ba..418c1507830cf9f9f7320e1bdc2c6293526a2932 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 3f949aafecee17c6257655bad0e4b0f5c0800e58..237b660ee4bf03fa2671c2e8c1200b2d057f443d 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 2f1594af38b1e2e281e6487524e83bbc8f1821c6..759251b5fc1550e190c9b2758b433fdb2ed42d50 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 d6085f34d691442bf053a52297e6cdbb0d78f9d6..09de84a969be3f02296bbac27ae8ac9507a539f0 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 75adfaeda304afaa35aa36d83786ad41c35bc15a..96a01b7dd1b01d5388ab4e67082dc8005f308761 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 486cb6ed072f3137f1bef3c7e277baf01420d6a2..71823f14e1230644128ab377662d218387687884 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 a1eb377ffa7fb2a1a8a944ccec22cbfc1ac7f79b..01c5a556622af40be58e7edceddd67359408d278 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 2b3e68a029e4c14932a4cce65315afd885da812c..255dc59833e050e9795ca67f325e2760d3295afb 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 ee394ef5a2dff40c6e70711db4869f905a51fd9f..759fedc73a682c7e73c9f8fa21fd7b7caba70c49 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 5e1243e64d31ca6cdf24acdbc0a9c9871786ed85..1edfe9a515e8a8138fc18e791e5cc0988dfc2aea 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 5d1055bc2da21c82d0c040133aaa70125cf5aa45..16b84fefb2d3940d13562e6c8e5561229310ab69 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 51e6197bedb69e3af78118b2df3e653a645d1d3b..66f6cf33923970c560c7a86f2807eafc97cd8001 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 f3757ee60ebdb26242927de37925c2df0ec42c3e..bc83dcf7d09798e29b9fd3ec88d19a9ab57d286b 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 d772c906673fb831e1e1f7e32a89182c1fdb15fa..0b01a618de5911a3ce1153fac43cedc14a3571d0 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 c4e409ec0b36922aee703bd2550d2f07ecaba85e..3e4d8c143ccab68d93c8ee586839a1a58696c88b 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 9086b3184276179f78d2b45c5f75724f732480a5..0000000000000000000000000000000000000000
--- 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 617ba89b29e1208c9db340f1e55df04522989c78..bd242bf3e93aaa4c326422575698c9401e7180b7 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 f6f7e6f3f3c8111211d42f339707906b8869eea4..2c30b18394f5adbf5bb6323533078012e753a426 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 1dbd6606154745831f9b182f7f1e61602f92ee88..2e7e64cc9f6dc8b76dda91464d177d40ab00967e 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 56daf99c6c1e987e3697989666f5c94d9b8cf839..cb845305a00fa82cce4735a33d2951f3192334f5 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 1d81160181023e271c9c89e3f4bb8c55c3e4cb39..5c2f5718738fe557f3beee9f5b8b7a0b82c48951 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 19fc2a11ada07212ea29048568738b83f88fb7ba..ab0ecc48bece84ae46af1466b038f059dec90431 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 1537e264e01f3a253ba8e773ebfd872a3e03bdd7..192d5f3dd0b7f85f45128043fab2f89f1e901375 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 b17b849638fea24d005e6a24a4ed61ea2ed4eb7f..0ebadb95b2e9a6024b3ce49364bc8d88b11875bb 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 11f6c59b6e23f74dfcf47f4e3627f8b0bbd71a1c..10bcca358b3ebc0559e958dba816010918702166 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 2f6bccaa2de6b4029eefa44164d0990b66ddae15..76b067ced5d68228a6edc6af1fbf97e1bd979ecb 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 65b5b6723340895d714004c2b2976e6e20a16593..d4e588bdfa14f1905d6f6911a8ccfe9975256d31 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 f59778cdbaaa4aea4ec75c31fa1685b1cc16ec5b..1917c2ec8b4dd55dac1b60207ec6e308a4cb9df7 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 6ae01e2dc46bdc08afb95cea119a0c2643cd1e79..026bd06d16261d8252e9ffcee491aace990ad7e7 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 72d4472b57f0e3406377be324ac9083f2aa0ea84..96252550e59254a27a42354e498d3677ebffea5b 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 b6c5908e15095b09df829b444ce638b8a148d860..f0db649a23a6d427c96a5eb6bca1558128482c53 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 49c68b0803d5c47db8c956cc94f60517c8ae7f0e..292ad9d57bc86d44b8f40785d9f611e161a0d4a6 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 cfcf95913120ae4620243f3168b1558992180a88..72d2e15c8f9156496aa0cb0ec2bc09f5f907517e 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 2d734eaafdf195f8687090ce00f44c0f7eb3435b..73c4647a0a46194e4661b55e3568e00647a0beaf 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 11184880f8474815c77e52e8ebebb6cbd33a9a59..3484387584110f9bff72e5effb82c5addf3f50eb 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 4ecd7cf3707d1c31686630da6f7795d792808578..2d3f228be41c010a0b4a27096ae631ee62143f27 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 98d67c2f4d6b53dde47bdf5811621526a93e2849..750ad2243cf4833621cb8035a04465523c141fb4 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 25d451393fc191f5cf9bf2604c4c9e51dae72a82..d32f5eb6fa4d151305e83fb20abfc2e0b8b8cac5 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 029da1a2ce2b9475c6cce3c442fc806da65e07e0..cee8276b0f4bcfdeb04128e1054ef4874cf3bef2 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 c4f60a9e75c507f71fc4f5588e535310cb3d30a7..1a682ecbd5f8a1a6bc3e4e732273e9c35e4dd555 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 4a894b80cc0cfae35888a271590b21b2c0455937..60673c3bd2434608ebde93ca0db6349546a480e7 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 9d5d407aba02d93e7d958a234aede92fe7858890..0000000000000000000000000000000000000000
--- 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 4e20de102de56afd924a83bcae1af9bcc8a38a77..1973663de9a983bf827f29267e7dfb65411a9503 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 d5ecd9c8ac0fecf44a740ea28e9ff8c88bee146f..5520a0b3256f58644178bbf7d36955d38703a046 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 72445f6d92e0c4492f7bf0bc6a7632430a7bf0f3..84af9e0a941541a7faeae749d157685bfb5481a0 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 6317a13b762de9d7b68285f5a3a85f9b3c22075f..f0c128d5177e955fe2c332a5e4e287253cd0e55b 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 53e81c7c742bdd6993b021801354ad20afe63ead..58c281186190402095d8e5e0cf2795741b734c95 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 deb8bf07a1f741306012cbdb1501b6344021ef98..3cd8184ee4dabbbee5b64f6931aadc41b85a9d6a 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 36134a209964c3c27167f737cfe3812ccd6915ee..660b2a591c8e598c2d7029fcb889645c73c177f4 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 c808a8e7390c7b7bfc54220be969b18e08a5048f..11753ec2e48a542f4e12557decc771e80eb0b17c 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 2c391683347ce43ef4621a10f1cf25fab3acc8a2..2f78305668da397f35b26d97ec21d055d09ab0b3 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 e48c0588940fb40ed2c8f5fb76bd63fd5b953539..4d1cfcddc83c3d8ed36f85df5602524ec85122ce 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 c3ae40a4c56c83a8b938bf5eebfadab06fb7ce09..0b644dcd8baa35d6990dfc03c3190a379458a43b 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 8a384906b3c15587245286f6a37381a3bfbb4e5c..f04e4cecb8a079506ec594abc2d2494df7289d52 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 b61c178cbdb527c10eec4cb03814ac585377746a..40919034674c190900ca10c659a8eec179248942 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 a8efe1abcc290fd2fc240aeb6b1d873aa14b0ea2..5e166093ca39b9174879f42a082159c6a107509f 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 22827fa4e1d865e34368a8e679e9ab8e2a9f944b..5cd65ddca1d2750497d17a88b9984735c8512631 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 5c057fe2ee96998dc4ba35290050c1c70b7ec4ce..d2b2f0746ffb217e9138f71d27fa0ac5eb399665 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 ae6faae95e0ac234bc5eec0e3292310d13f02870..27f444dac50414ebccb571038fbaed3e17bd248c 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 8799da46b42e29e869d7442fdbe88d8f029bf338..0000000000000000000000000000000000000000
--- 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 5c180eb4fadf4371aca08af3ab93f794d6d4ec6b..0000000000000000000000000000000000000000
--- 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 bd51090149b8cbfe7239ef94ef8c7151aaeae640..614882a528802cb44935dfab137fcfb8e4f77a8b 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 b3a776fb77d6c1df9e31cc3839180712850e9334..18d47c0fea1b5bbb10d3811b287a01c233b8dd5d 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 577b795df0f8c4115d4496806f5b767afdeb9b68..89ecdf97dd5e3d80fb967a00cf29a34ba6792d11 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 62d0b9a7ff84461e5391795d526b785474f4fa4a..a4d82304cbcb5125bdf1d917d6d8200c3f133f9d 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 9768563c88ec444ca2e02fadfe92b2020bbe1621..3dd375f31b8564b9604110061f5b550eadd444a0 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 ed0014f95bde79cd7ab5983990a705d689d01e18..9a3bbc2ea32d2218fd88a538cbacb767e6ffbbb8 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 a2cb7e2c7e41de70134852a62465deae561ddeb6..0000000000000000000000000000000000000000
--- 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 be7fda3da0250215e814d13d0bc44c4b806c0edc..09cecfab780cbd113942289996c8000edf070200 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 d81847503cb533f11f3356b563b6b60360c9148a..057430176323cc6ef49a42036e3b94cb46dc1684 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 24d8add5a556e54350f7e2f1231860d5701a1b67..85604e8e9c8f06be3130926dbab5caa0978975e5 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 33d156de53b92525297fa362ea8d0219ba9c9722..4a6456909241d249606b1ec92cf4a5225b9adb1e 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 33ee877eef2a9931c76d6cafac0bb3c0acbde75b..f635585cf30650ebb40ca1be384f2aab97d80a14 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 39e436d8c31a472b2631fa74cc7824c3e70cab81..6737103e7a984a788ecff3351f26bfef9065ea9b 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 5e7478d0605d42d4bd0ceedb34c367dc15e5960d..aa2a4907941a18c9177f8b134d16e1bcb39092c5 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 9356bb2e94f024c3ffef4de8bca92b098e353490..8db461af79f9c6b45d91ebad57ae9e404e71e8e7 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 a4d051fb596ccf1e15b12401d4d949edf094f8b8..c687716ff7c06832318d98f8c11405d9245dfd63 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 f7fc93390646c67f888ec85ee09ee4705559c6e7..73c440670c6668d97ca1054efe97cf58a3c48022 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 7c183b143c230d519ceba1dd15b239924c2cb947..8d21ed02aa0e6c04140e630fb9f808c1bdc04387 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 73b803cb1e51d27d17081b67744de8622af16d2b..9df17ead3ce43eb99bc2cc7f8ad9713f4c991e35 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 5796cd4e96765d9698bc4586370d6f52fcb0beae..61ade109a8a45df6f4d9531525668eae0a0ab3f0 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 7ef97dbf211438247d044d740cade86acf2f608d..d4fb6e6fb153fe3c95f2b0b9426c65e5dc56e7fa 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 36295dfcd85b418f822c3fa4d5487b77625b34ce..ac39df4a5a9b1a671ca900d1121ec2278d737bd8 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 23edaed052ef299dba1e17790d4792049aae6b13..1c068f07dd54d619e8def0866d6890d7eb985b51 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 918b4a7d5c2675ebc582473a22ec85ab87230ef9..ea06d8d3ac6845e767eabef494cd8d57c4ad2ba5 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 d4617c96795eac592c0fd673ac5d897638978142..09f3e679fd28a3755ebd59f67779c9f888b42e1f 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 b18468267a6745327f915d9479967fb56f413599..fb5d225dcdcf95e646f3e7b5d8e9124c755045da 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 d0b4358373424655cc0a6d2de54c8714f44921b9..f0645c9b0b1effa1f35f531d248b5ec1d38efe54 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 cbd9de7d502e44e2879d909b8d1dc42079115d7e..197ed8040715d2f4221012dc6b45bb72cf8227e9 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 7997378d898ee653737df2812582f917b0063194..718dfeeb876ed0139aa361f02b37d74798549756 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 98a89578a9e473b24df49ec4b00680c39c8ebcf7..88d91d06d460d8eee1002fdf2f7409e5d0678ebb 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 758d7a32608d373f976c7fcc1a310d5124f76fd0..97b698fb1b1cb70d278932ecfdb9ebf47eed53e4 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 dd01da4de79610736d630794072f56f861dafb6b..0000000000000000000000000000000000000000
--- 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 38967fe78199ba80e5983d43a91bd8d9b99450ea..1f54bad3cd1335f216e6efa1a0bc28134f06a668 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 a14a2795214f411ab04ca786aa02bbcc66902b5b..2b37c431102b2d49557d3fa2a1e24d2f69c801a9 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 7be7b106c25f910f4dccc2f1e2b692ea0be971d1..a55c4186d7b9b3e7dfb9227a9181ab000833ddd4 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 46c66ded07ebaa28b2ea276d16eb7c64963cc9da..aef731c1b4999289bee9f6e5ece8577bbb9ec0f6 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 59768a2d9f1434bff28c2a661be8367474d30980..2e20a1a4e1035105c76b63e47f724187b198d420 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 466e8c4013dfddf9a8a69ae2ad77cc3e45ec9da2..077a6efc69b2be13e8912a03cf08f2fd43eae949 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 44f6fd2ecbf21b86adb46f9c474885bd941dd194..168e46795384b0fc5ab2a64da825a5566bfff08d 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 49335982f52dfcfe9862bbddbbef44921a9829ad..6a5f4a88cb41407ca6472c61abaecc718db47c3f 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 504ea360c8cc27448ada32a330dbf9a32b1beb92..6bed59f2e32ded09e8bae7b5803b8a1d19e39590 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 16ab5e5feae9207a08ef2c68b7c487e6bb3e48b7..d38db7ca3095d597c33a23ecb6ffa10e1932a5cb 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 70bbf41a5879af7db2ced3cd0549c28bea4c005a..a2d37a6dfe76d5bbc7757bd788aa60c4e2fa960e 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 7a7a65fbce172915d67ef9f5430112687803b170..704be4b1de1a4118f9f0208983a8b827f6f29a97 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 f5e5aab80f96ccbf151f7eedd276d6802cc69462..84d51195bdd515af4c0d6be305559293aa9303e4 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 485b597f109ca03de1f942c749cc172ab58fa43a..0a4269a1c1835091c034f8b31bc9c1db95aa04c3 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 d0ea862b101305cc04cb529ec0db75204b5cae7a..70204b1ff95848ed860fa3d2055372ca1f26870a 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 4a749243e24c6dd67d8c155f95171013a111d9e3..fbac09bc6c81b55d945074a068233ce5895970a4 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 bb06e5092f4d5e5704b9e7d0ca9bae3512e7a334..bd2ebe513c8a8ca95c4b0af5601c71efba7d0468 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 ffd9ec0e00c02e88eef783b1bfc327343e91e576..64f831aca702ea2727d2c8b1128b7766ffa67c37 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 30500ba58ed2d37a963d6b54b28c33f48933218e..43612e725d2c83e11dfc6448d52c46b05edcde7c 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 284f1ce0d160f6b0a864157964d65505646488da..407f3d62c2a290a12032ff5778420a1ba986dc9d 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 49f9421afa125956dc46117b1186e04c4e593f75..714f278ca281e7c310d33b23784664979bafbbc5 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 dd422ae1ff5ea46c36891fc1b0b673fa3475c7e8..4e392531eeff7721e6d77296d34c7fe174cdd5a4 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 e406b2868c2f4d9b39fe396342415f39cbe2acf6..a790a8b7926a387f686c0a4328a76a4c3d7eb3c4 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 baaa137b7df1e8295b22f621b70c50c4fa01d769..0ac4f084e4ec1bd12e031a0ce1bdb4b82dc98698 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 0a0b58e47b15f4924e208dd578ead1cf00574f74..77a0eab01d092b223d818023b924b225b56a583d 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 c2e2cf501f8971ea309b167b034ec6dab177c573..b17d29ced4f51777350131a6dde30b1fc56f3532 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 fbe5fbecf7d732a8c6b149c29781d4b27160906f..30c6100838a83927af5c0853ed20eaa4753cae40 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 63282687cf813c464cfa7eff13f0018cab2b72f5..7d7ca677f04e6e83d4b8d9e573879213aa896f87 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 9879fd39230c43d84de8fdaf6dca98df70b2998d..97a8b157f0d341ea8fe30629447c6ab94ba8516d 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 e8235cf4c0c4515e141140b856d56062e732a4db..a12633ae8ae930534acbcf20e18358adabe7ade1 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 bafa1fb62321028c2dd6571c1971be774caed952..1429bbde029dec0ffd98c1289056e461a70c7c21 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 91302df4ced10443711c524a10f54ce59323aca7..0000000000000000000000000000000000000000
--- 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 14a6ede64d8e2ac50e43e9100637a77f73ea4e0c..0000000000000000000000000000000000000000
--- 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 82dd55dcd4e3bb381afee9f61a0262b8120af981..69af3b29d0dc6bcbaadef3dc503ebcf5a5d96448 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 8c57967449dd6c6ef9b1524b7d72f02e458834d4..18556729220ca63af7a8b4c554652360594f8c5b 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 a04c032d2b8c000ca92e88a6fdde882fe0250c3a..ceb589f174d306b19dc75a88b8a3a1802b74571c 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 ac34e2d1c318d84bcc0924a92e2908e5c2c8c998..dad3e7baf3db882858bc65e2507e11e13c1e041c 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 b5ddb0cee98b1bacc1140f076d90a7fda4791c10..5ec7d7c0cc96aae22889ed5d5d64cd2600077dcb 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 e2737adef4d2f1f0b8a38278754517d37f204dd0..f38dc93af20df73c7b47b87ac5521d2d711b2bcd 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 7a585adb636adade0d2839c52c23e687faa854c9..efcaa9de8f19cfdde760866f793d77b2be30685d 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 84ad5faa803fd0832516d662042b8907bc1b5451..bf34c9ce2ac9956a18011c21f109c47590a8152f 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 3c10a45ad677d75182393ba87e10f87963030fc3..2944d90d2da8ab645b456f3d0f66d23a5c58eb05 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 cca9e330553f9b484822eecd04b697cee30d0bc5..c5a29fc3a2aafe7b2aa200425fb7c4decde65f03 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
@@ -378,6 +357,106 @@ unify_tuple_ty_help arity ty
returnTc arg_tys
\end{code}
+%************************************************************************
+%* *
+\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 fa446a153dcc80a05353f4424179a672de285caf..94c6e7ea4adb28306a74f1d8d84ae743a760ec59 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 3f0520f30734dff266757d5df526913836742447..6845415e8f1af76e15670d1bf184d693d478db9e 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 6d6e8a39d76db2100a1807934fc4656d51f27702..d4fe4a3981cb27441b40aed5f0828f7f95dc7a74 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 051ad922cb90786b21c287c74988ca64b3022d57..3762e632a7a03e91e0d311c0228b8b8b78dd1010 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 370faf57653bfc7d50a39be2b76932a6e233066b..530af857e58d566914da7a73ca87b62100ca9f9d 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 ec3c65c2df16169135a81d7a5a0c88627bc2c800..0000000000000000000000000000000000000000
--- 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 c36f6d83968c83be4e971f68adbdb074a7061e12..0000000000000000000000000000000000000000
--- 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 7c4373b0ebbbc034048c90a2ecd0cdfd4d528b3f..0ca0d1a8f993b2373d77a063f1324a298dd2946e 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 8a2b03588fca89b464a223d640007539fa95fabe..70e81f165c9aaaccde82f09f96c33b9639eefdc3 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 d419223d1c4060402a2e67e2d4957e5e78bad7bb..d84f41a5c9bda32ca86425c5a4b69685efeb2597 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 5ea9e4cb69070fb637438f264c6d4b45a86e804c..0000000000000000000000000000000000000000
--- 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 c9fc6a589b3d8b15aadd134fd38532b353997348..4793b127dc02f13ec8914c66fa45c9e10e26d42a 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 fcb9a9c40b3061a7656718a188bb2104bc8c731b..546ad2fbc34ad81271b1320835a1f9e8814a6543 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 3c69ce29e971a414c405e1db74025910b28cc4e3..15df0baa143237635ec4341f72f0b49e61902226 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 e9624be6d9c2d6d530e4434b18b2863abb5aa774..0d6b055214f05ecdb5574fd60113065865a5562c 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 09e63592e2c6850d76b389b07147be568edb7466..432d4f2cf9db793459e0d81b114dc6b25a522f4b 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 d0fad80e42817d17d3699205c555a6d40f10da77..0000000000000000000000000000000000000000
--- 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 d2737a4b7f87d77f10c6f49013663c5bfcf3fcde..dfa2cd023f67bec16d96c98e6eb73c0768ef77f7 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 6c09616e2934a189874631c7969ee90c00ee6f23..0000000000000000000000000000000000000000
--- 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 37a12e06b9d59f509be1566f1601dd49738c807d..ce92316d6ce7dc14759bee51980d620209b008ca 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 ea1188795763850b6ed04d6c0738025bc2206d0e..861f4b5f09e310b956a5c8a3507650e4ec97cef7 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 54abced398ad03b6fcb27d04d3830612d4b1e90b..41cdb1a5d0ed4d8302a83f75f808c6a1fa7210cf 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 78f00714634e3ae1e5100e1b460b0dc656edcb88..10216452f639dcb9c9825f9f06862a783c3704b9 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 110375056ab4e87c844eb9ebaf1c6b177254c878..ac147dc920d97d7ea613762aa5436d271f669bc4 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 a85c98f5a1a71a2b38215378ad2cf144aebc6d25..0000000000000000000000000000000000000000
--- 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 5c070daf4f0c3235e70832fd9bce7151e1942898..3119a13c4971d7bad49fe1e85fcc3d8c61d6d6cc 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 c66085da1f8e597b78037f5025c5db662f01ad2c..0000000000000000000000000000000000000000
--- 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 dc0b46586a6a9681a260cb872644b6ed17dc239b..0000000000000000000000000000000000000000
--- 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 3ce6713a92e1af8bed6e7c2a34b88b3462f60f56..2fec976bc326580a0287951a093b23d10a8a365a 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 2f53d068bc221353e6b2a867bd28161c58f35390..13b3eae53fa522110ae4fc43f7c23411494102eb 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 97ca5242ffa65d7a4b83d985783fd7c290bdbfe0..34d36ae47205aaa7cdbd9ee830d454fc8d6d8b24 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}
@@ -105,22 +92,6 @@ mapEager f (x:xs) = f x `thenEager` \ y ->
returnEager (y:ys)
\end{code}
-%************************************************************************
-%* *
-\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 67657b5793c7a292b2c61f341e10c94dcbab6f52..b1fae527828d4bdc402f389c69422ce2fae1a40c 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 b4b12d0879dd39bd66436cd62f84b26208b4d82d..35e2fc293f0806a64398cb917cfdf142f349dd2f 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 39fe2542c3bb939ba34011c89bd98f4baf9525c0..807dba22a84a85205fde1a89c5cc7eee9befd2cf 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 b0c3c81dbc4f6d438c90096a5f24c9ecd1017269..a2787815a919f98aa9247fa9ec1476489d0d24d5 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 dc0a835b62f2ea737cc5687ff9222db36bafdba5..1f8614b9aabf7719f197d2c41edcc92517bf6ad9 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 891d45c964bb212874f26ea9ec8d66eabdc8d907..cfe4a83cfc67ef659d47b595d419b39852dfd1c4 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 4ed206b78ada708d00c83fa98132517c5411dc43..7fd2d20aeb096d92cd183c8b5fc5c1226ad23994 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 041214df1d9c38f50f7727d603e9cd238e77151a..434406021e8374fd375cfeb5ee549e951628a135 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 6de7fbf2c8bc3d4c422c94bfbf46896025da2c50..f1205e89fd1a0e47d586bf3034793838021b0723 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 62345929352aeaefab68ef689d6f3cd9277ae381..ef97220450bb745cb935355a6f8e2e453efef78c 100644
--- a/ghc/lib/required/IO.lhs
+++ b/ghc/lib/required/IO.lhs
@@ -106,6 +106,12 @@ instance Eq IOError where
(IOError h1 e1 str1) == (IOError h2 e2 str2) =
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
@@ -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 d48c5bf9ddf43379c64729ba1bb38e8e8a530b22..08952a6dae5c3b3d3d3a2567573d2ee93dd544cf 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