The Great Multi-Parameter Type Classes Merge.
Notes from Simon (abridged):
* Multi-parameter type classes are fully implemented.
* Error messages from the type checker should be noticeably improved
* Warnings for unused bindings (-fwarn-unused-names)
* many other minor bug fixes.
Internally there are the following changes
* Removal of Haskell 1.2 compatibility.
* Dramatic clean-up of the PprStyle stuff.
* The type Type has been substantially changed.
* The dictionary for each class is represented by a new
data type for that purpose, rather than by a tuple.
#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
# 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_ ==#
#define _LE_ <=#
#define _GE_ >=#
#define _GT_ >#
-#endif
#define FAST_BOOL Int#
#define _TRUE_ 1#
#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)
# -----------------------------------------------------------------------------
+# Compilation history for Patrick
+
+# Make the sources first, because that's what the compilation history needs
+$(HS_PROG) :: $(HS_SRCS)
+
+
+# -----------------------------------------------------------------------------
# Set SRCS, LOOPS, HCS, OBJS
#
# First figure out DIRS, the source sub-directories
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
#
# 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
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
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"
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
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
$(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
#
# 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"
+++ /dev/null
-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}
raw assembler/machine code.
\begin{code}
-#include "HsVersions.h"
-
module AbsCSyn {- (
-- export everything
AbstractC(..),
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,
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 )
\section[AbsCUtils]{Help functions for Abstract~C datatype}
\begin{code}
-#include "HsVersions.h"
-
module AbsCUtils (
nonemptyAbsC,
mkAbstractCs, mkAbsCStmts,
-- 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}
\section[CLabel]{@CLabel@: Information to make C Labels}
\begin{code}
-#include "HsVersions.h"
-
module CLabel (
CLabel, -- abstract type
#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 )
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:
\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}
\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
This module deals with printing (a) C string literals and (b) C labels.
\begin{code}
-#include "HsVersions.h"
-
module CStrings(
cSEP,
) 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}
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
\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 -}
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)
INTERNAL MODULE: should be accessed via @AbsCSyn.hi@.
\begin{code}
-#include "HsVersions.h"
-
module HeapOffs (
HeapOffset,
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}
%************************************************************************
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
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
%************************************************************************
\begin{code}
-#include "HsVersions.h"
-
module PprAbsC (
writeRealC,
dumpRealC
#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
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`
\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))
-- 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.
-- 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
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,
}
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
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
};
-}
-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,
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
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
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
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}
\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)
\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:
-- 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 '}' ]
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 '{',
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++;",
-- 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
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)
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")
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}
\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
@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
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}
@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
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}
%************************************************************************
(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}
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")
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)
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}
\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
_ -> 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)
\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)
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 ->
\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 )
\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}
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}
%************************************************************************
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
\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}
\section[Demand]{@Demand@: the amount of demand on a value}
\begin{code}
-#include "HsVersions.h"
-
module Demand(
Demand(..),
showDemands
) where
+#include "HsVersions.h"
+
import BasicTypes ( NewOrData(..) )
import Outputable
-import Pretty ( Doc, text )
import Util ( panic )
\end{code}
| otherwise -> 'n'
instance Outputable Demand where
- ppr sty si = text (showList [si] "")
+ ppr si = text (showList [si] "")
\end{code}
\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(..) )
(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
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 ;;
-%
+
% (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,
mkImported,
mkMethodSelId,
mkRecordSelId,
- mkSameSpecCon,
mkSuperDictSelId,
mkSysLocal,
mkTemplateLocals,
addInlinePragma, nukeNoInlinePragma, addNoInlinePragma,
-- IdEnvs AND IdSets
- SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet),
+ IdEnv, GenIdSet, IdSet,
addOneToIdEnv,
addOneToIdSet,
combineIdEnvs,
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
[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:
-- 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
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}
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
\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
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}
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
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
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
\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 }
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
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 []
-- 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
-- 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
= 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}
\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}
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
unspecialised counterpart.
\begin{code}
-cmpId_withSpecDataCon :: Id -> Id -> TAG_
+cmpId_withSpecDataCon :: Id -> Id -> Ordering
cmpId_withSpecDataCon id1 id2
| eq_ids && isDataCon id1 && isDataCon 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}
%************************************************************************
\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}
Haskell. [WDP 94/11])
\begin{code}
-#include "HsVersions.h"
-
module IdInfo (
IdInfo, -- Abstract
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}
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
\end{code}
\begin{code}
-noIdInfo = IdInfo UnknownArity UnknownDemand nullSpecEnv NoStrictnessInfo noUnfolding
+noIdInfo = IdInfo UnknownArity UnknownDemand emptySpecEnv NoStrictnessInfo noUnfolding
NoUpdateInfo NoArgUsageInfo NoFBTypeInfo
\end{code}
\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"
\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))
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}
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}
%************************************************************************
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}
%************************************************************************
%* *
%************************************************************************
-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@}
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}
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}
%************************************************************************
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 '-'
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
+++ /dev/null
-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}
\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 )
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
\section[Literal]{@Literal@: Machine literals (unboxed, of course)}
\begin{code}
-#include "HsVersions.h"
-
module Literal (
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}:
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}
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}
\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
Name, -- Abstract
mkLocalName, mkSysLocalName,
- mkCompoundName, mkGlobalName, mkInstDeclName,
+ mkCompoundName, mkGlobalName,
mkWiredInIdName, mkWiredInTyConName,
maybeWiredInIdName, maybeWiredInTyConName,
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(..),
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}
| 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
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
\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
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
\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
| 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
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}
%************************************************************************
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
-- 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
\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
\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}
\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}
\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}
%************************************************************************
\begin{code}
-#include "HsVersions.h"
-
-module SrcLoc {- (
+module SrcLoc (
SrcLoc, -- Abstract
mkSrcLoc,
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}
%************************************************************************
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
isNoSrcLoc NoSrcLoc = True
isNoSrcLoc other = False
+
+incSrcLine :: SrcLoc -> SrcLoc
+incSrcLine (SrcLoc s l) = SrcLoc s (l +# 1#)
+incSrcLine loc = loc
\end{code}
%************************************************************************
\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("\" #-}")]
--}
\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,
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
-- 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}
Haskell).
\begin{code}
-#include "HsVersions.h"
-
---<mkdependHS:friends> UniqSupply
-
module Unique (
Unique, Uniquable(..),
u2i, -- hack: used in UniqFM
, 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}
\begin{code}
data Unique = MkUnique Int#
-
-class Uniquable a where
- uniqueOf :: a -> Unique
\end{code}
\begin{code}
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@}
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
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
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
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
# define RETURN returnStrictlyST
#endif
-iToBase62 :: Int -> Doc
+iToBase62 :: Int -> SDoc
iToBase62 n@(I# n#)
= ASSERT(n >= 0)
_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 ;;
\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,
rebindToAStack, rebindToBStack
) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
import AbsCSyn
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}
| 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}
%************************************************************************
#ifdef DEBUG
bindNewPrimToAmode name amode
- = panic ("bindNew...:"++(show (pprAmode PprDebug amode)))
+ = pprPanic "bindNew...:" (pprAmode amode)
#endif
\end{code}
%********************************************************
\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
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(..)
)
)
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}
-- 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
-- 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
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 ]
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,
-- )
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
@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
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}
-- 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
-- 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
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 ->
-- 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
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)
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)
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
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}
%************************************************************************
-- 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}
-> 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...)
@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
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 )
\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
)
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)"
%********************************************************
\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
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
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
\section[CgHeapery]{Heap management functions}
\begin{code}
-#include "HsVersions.h"
-
module CgHeapery (
heapCheck,
allocHeap, allocDynClosure
, heapCheckOnly, fetchAndReschedule, yield
) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
import AbsCSyn
import CgMonad
slopSize, allocProfilingMsg, closureKind, ClosureInfo
)
import HeapOffs ( isZeroOff, addOff, intOff,
- SYN_IE(VirtualHeapOffset), HeapOffset
+ VirtualHeapOffset, HeapOffset
)
import PrimRep ( PrimRep(..) )
\end{code}
%********************************************************
\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
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}
%************************************************************************
+++ /dev/null
-\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}
+++ /dev/null
-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}
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,
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 )
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`
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}
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}
about return conventions.
\begin{code}
-#include "HsVersions.h"
-
module CgRetConv (
CtrlReturnConvention(..), DataReturnConvention(..),
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,
)
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(..),
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}
%************************************************************************
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...
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
-- 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)
(This is the module that knows all about stack layouts, etc.)
\begin{code}
-#include "HsVersions.h"
-
module CgStackery (
allocAStack, allocBStack, allocAStackTop, allocBStackTop,
allocUpdateFrame,
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(..)
)
%********************************************************
\begin{code}
-#include "HsVersions.h"
-
module CgTailCall (
cgTailCall,
performReturn,
tailCallBusiness
) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
import CgMonad
import AbsCSyn
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}
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}
\section[CgUpdate]{Manipulating update frames}
\begin{code}
-#include "HsVersions.h"
-
module CgUpdate ( pushUpdateFrame ) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
import CgMonad
import AbsCSyn
modify (\tr{set*} functions) the stacks and heap usage information.
\begin{code}
-#include "HsVersions.h"
-
module CgUsages (
initHeapUsage, setVirtHp, getVirtAndRealHp, setRealHp,
setRealAndVirtualSps,
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}
%************************************************************************
the STG paper.
\begin{code}
-#include "HsVersions.h"
-
module ClosureInfo (
ClosureInfo, LambdaFormInfo, SMRep, -- all abstract
StandardFormInfo,
mkVirtHeapOffsets,
nodeMustPointToIt, getEntryConvention,
- SYN_IE(FCode), CgInfoDownwards, CgState,
+ FCode, CgInfoDownwards, CgState,
blackHoleOnEntry,
entryLabelFromCI,
closureLFInfo, closureSMRep, closureUpdReqd,
closureSingleEntry, closureSemiTag, closureType,
- closureReturnsUnboxedType, getStandardFormThunkInfo,
+ closureReturnsUnpointedType, getStandardFormThunkInfo,
GenStgArg,
isToplevClosure,
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
)
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:
-- 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}
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}
-}
= 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)
%************************************************************************
\begin{code}
-#include "HsVersions.h"
-
module CodeGen ( codeGen ) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
import StgSyn
import CgMonad
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}
Other modules should access this info through ClosureInfo.
\begin{code}
-#include "HsVersions.h"
-
module SMRep (
SMRep(..), SMSpecRepKind(..), SMUpdateKind(..),
getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
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}
%************************************************************************
MuTupleRep _ -> "MUTUPLE")
instance Outputable SMRep where
- ppr sty rep = text (show rep)
+ ppr rep = text (show rep)
getSMInfoStr :: SMRep -> String
getSMInfoStr (StaticRep _ _) = "STATIC"
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 )
\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
\section[CoreLift]{Lifts unboxed bindings and any references to them}
\begin{code}
-#include "HsVersions.h"
-
module CoreLift (
liftCoreBindings,
) 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 )
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 ->
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
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
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)
\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}
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 ()
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}
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}
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
\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)
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
= -- 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) ->
-- 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}
%************************************************************************
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
-> 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
| 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}
if isEmptyBag errs then
Nothing
else
- Just ( \ sty ->
- vcat [ msg sty | msg <- bagToList errs ]
- )
+ Just (vcat (bagToList errs))
}
returnL :: a -> LintM a
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
-- 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}
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}
\section[CoreSyn]{A data type for the Haskell compiler midsection}
\begin{code}
-#include "HsVersions.h"
-
module CoreSyn (
GenCoreBinding(..), GenCoreExpr(..),
GenCoreArg(..), GenCoreBinder(..), GenCoreCaseAlts(..),
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,
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}
%************************************************************************
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]
(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}
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 ->
-- 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.
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
{\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
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}
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@
\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}
(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
\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}
%************************************************************************
\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
\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)
\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)
%************************************************************************
\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
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}
%************************************************************************
\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}
%************************************************************************
\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}
%************************************************************************
\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}
find, unsurprisingly, a Core expression.
\begin{code}
-#include "HsVersions.h"
-
module CoreUnfold (
SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types
UfExpr, RdrName, -- For closure (delete in 1.3)
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 )
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}
%************************************************************************
\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'
| 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
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
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
| 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)
size_up expr@(Lam _ _)
= let
- (uvars, tyvars, args, body) = collectBinders expr
+ (tyvars, args, body) = collectBinders expr
in
size_up body `addSizeN` length args
alt_cost :: Int
alt_cost
- = case (maybeAppDataTyConExpandingDicts scrut_ty) of
+ = case (splitAlgTyConApp_maybe scrut_ty) of
Nothing -> 1
Just (tc,_,_) -> tyConFamilySize tc
\section[CoreUtils]{Utility functions on @Core@ syntax}
\begin{code}
-#include "HsVersions.h"
-
module CoreUtils (
coreExprType, coreAltsType, coreExprCc,
, squashableDictishCcExpr
) where
-IMP_Ubiq()
+#include "HsVersions.h"
import CoreSyn
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}
%************************************************************************
-- 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
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}
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}
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
\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
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
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]
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)
\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
\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
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
)
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}
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)
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 ->
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}
Taken quite directly from the Peyton Jones/Lester paper.
\begin{code}
-#include "HsVersions.h"
-
module FreeVars (
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
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}
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.
-- 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)
(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)
\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
(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)
%************************************************************************
\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-} )
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}
@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
-- 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}
%************************************************************************
%************************************************************************
\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}
%************************************************************************
%************************************************************************
\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}
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
-- 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
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 ]
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)
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
= 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)
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}
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}
\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
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,
)
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:
instance Outputable BoxedString where
- ppr sty (BS s) = text s
+ ppr (BS s) = text s
check :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
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)
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 []
\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 )
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}
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}
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}
%************************************************************************
= 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}
\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
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 ->
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 $
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.
\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 )
unitDataCon, stringTy,
realWorldStateTy, stateDataCon
)
-import Util ( pprPanic, pprError, panic )
-
+import Outputable
\end{code}
Desugaring of @ccall@s consists of adding some state manipulation,
-- 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 ->
)
| 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
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}
-- 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 ->
)
| 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
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:
\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
import DsListComp ( dsListComp )
import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtomGivenTy, mkTupleExpr,
mkErrorAppDs, showForErr, EquationInfo,
- MatchResult, SYN_IE(DsCoreArg)
+ MatchResult, DsCoreArg
)
import Match ( matchWrapper )
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
| _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]
= 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))
-- 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))
= 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 ->
= 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 ->
= 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 ->
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
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 ->
\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,
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
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:
\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 ->
\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.
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 ->
\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}
\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
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 )
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}
%************************************************************************
+++ /dev/null
-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}
\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,
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 )
-> 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
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}
| 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}
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,
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}
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
-- 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
= 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
)
%************************************************************************
\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
\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
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}
%************************************************************************
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}
mkTupleExpr [] = Con unitDataCon []
mkTupleExpr [id] = Var id
mkTupleExpr ids = mkCon (tupleCon (length ids))
- [{-usages-}]
(map idType ids)
[ VarArg i | i <- ids ]
\end{code}
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 ->
\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
)
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
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("->")
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}
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)
-- 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
= 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 []
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)
\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 )
import DsMonad
import DsUtils
-import Id ( GenId{-instances-}, SYN_IE(Id) )
+import Id ( GenId{-instances-}, Id )
import Util ( panic, assertPanic )
\end{code}
\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}
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}
\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}
%************************************************************************
\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}
-_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 ;;
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}
%************************************************************************
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
\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}
%************************************************************************
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.
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}
%************************************************************************
\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}
@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 )
-- others:
import Literal ( Literal )
-import Outputable ( Outputable(..) )
-import Pretty
import Util ( panic )
-#if __GLASGOW_HASKELL__ >= 202
import CostCentre
-#endif
+import Outputable
\end{code}
%************************************************************************
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}
%************************************************************************
\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}
@InstDecl@, @DefaultDecl@.
\begin{code}
-#include "HsVersions.h"
-
module HsDecls where
-IMP_Ubiq()
+#include "HsVersions.h"
-- friends:
import HsBinds ( HsBinds, MonoBinds, Sig, nullMonoBinds )
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}
%************************************************************************
\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}
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}
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.
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}
%************************************************************************
\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}
%************************************************************************
%************************************************************************
\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}
%************************************************************************
%************************************************************************
\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
\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;
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}
%************************************************************************
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}
%************************************************************************
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
_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 ;;
\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 )
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}
%************************************************************************
%************************************************************************
\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.
-- 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
-- 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}
\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
%************************************************************************
\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}
%************************************************************************
\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}
%************************************************************************
%************************************************************************
\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}
\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}
%************************************************************************
\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)
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}
%************************************************************************
\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}
+++ /dev/null
-\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}
_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 ;;
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}
%************************************************************************
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:
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}
%************************************************************************
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}
\section[PatSyntax]{Abstract Haskell syntax---patterns}
\begin{code}
-#include "HsVersions.h"
-
module HsPat (
InPat(..),
OutPat(..),
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.
| 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
-- (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
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}
%************************************************************************
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
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
\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
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
@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!
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 ==============
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]
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}
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
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
-- 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,
]
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 "#-}"]
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)
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.
\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
-- 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
\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}
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}
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)
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)
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}
\section[CmdLineOpts]{Things to do with command-line options}
\begin{code}
-#include "HsVersions.h"
-
module CmdLineOpts (
CoreToDo(..),
SimplifierSwitch(..),
opt_IgnoreIfacePragmas,
opt_IrrefutableTuples,
opt_LiberateCaseThreshold,
+ opt_MultiParamClasses,
opt_NoImplicitPrelude,
opt_NumbersStrict,
opt_OmitBlackHoling,
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}
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")
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
*** 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,
-- 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}
\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}
\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}
\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(..) )
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 )
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}
_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) >>
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) ->
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
>>=
\ (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
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
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))
\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
= 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 ()
-- 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
-- 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}
-> 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]
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
-> 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
[]
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)
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
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
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("! ")
-- 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"),
]
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}
%************************************************************************
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}
\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 ()
%
\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
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
%
\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
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
\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
@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 ->
\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 )
import Stix ( StixTree )
import Unique ( mkBuiltinUnique )
import Util ( mapAccumB, panic )
+import GlaExts ( trace )
\end{code}
This is the generic register allocator.
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
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.
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)
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)
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)
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)
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)
-----------------------
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
@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
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
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 ->
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
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 -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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
= 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)
]
]
-}
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
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)
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)
\section[MachMisc]{Description of various machine-specific things}
\begin{code}
-#include "HsVersions.h"
#include "nativeGen/NCG.h"
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 )
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(..) )
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
-- 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.
| 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.
| 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
| 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
data Operand
= OpReg Reg -- register
| OpImm Imm -- immediate value
- | OpAddr Address -- memory reference
+ | OpAddr MachRegsAddr -- memory reference
#endif {- i386_TARGET_ARCH -}
\end{code}
-- 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.
| 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
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,
#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}
% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
= 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
% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\begin{code}
-data Address
+data MachRegsAddr
#if alpha_TARGET_ARCH
= AddrImm Imm
| AddrReg Reg
#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
| AddrRegImm Reg Imm
#endif
-addrOffset :: Address -> Int -> Maybe Address
+addrOffset :: MachRegsAddr -> Int -> Maybe MachRegsAddr
addrOffset addr off
= case addr of
_ -> 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
\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
#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
+#define COMMA ,
+
#ifndef NCG_H
#define NCG_H
#if 0
+++ /dev/null
-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}
@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
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}
%************************************************************************
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
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");
})
#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");
})
#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");
%************************************************************************
\begin{code}
-pprSize :: Size -> Doc
+pprSize :: Size -> SDoc
pprSize x = ptext (case x of
#if alpha_TARGET_ARCH
-- 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")
%************************************************************************
\begin{code}
-pprCond :: Cond -> Doc
+pprCond :: Cond -> SDoc
pprCond c = ptext (case c of {
#if alpha_TARGET_ARCH
%************************************************************************
\begin{code}
-pprImm :: Imm -> Doc
+pprImm :: Imm -> SDoc
pprImm (ImmInt i) = int i
pprImm (ImmInteger i) = integer i
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}
%************************************************************************
\begin{code}
-pprAddr :: Address -> Doc
+pprAddr :: MachRegsAddr -> SDoc
#if alpha_TARGET_ARCH
pprAddr (AddrReg r) = parens (pprReg r)
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)
%************************************************************************
\begin{code}
-pprInstr :: Instr -> Doc
+pprInstr :: Instr -> SDoc
--pprInstr (COMMENT s) = (<>) (ptext SLIT("# ")) (ptext s)
pprInstr (COMMENT s) = empty -- nuke 'em
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)
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)
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 [
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 [
-- 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
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',
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',
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',
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',
pprReg size reg
]
-pprSizeAddr :: FAST_STRING -> Size -> Address -> Doc
+pprSizeAddr :: FAST_STRING -> Size -> MachRegsAddr -> SDoc
pprSizeAddr name size op
= hcat [
char '\t',
pprAddr op
]
-pprSizeAddrReg :: FAST_STRING -> Size -> Address -> Reg -> Doc
+pprSizeAddrReg :: FAST_STRING -> Size -> MachRegsAddr -> Reg -> SDoc
pprSizeAddrReg name size op dst
= hcat [
char '\t',
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',
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,
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]
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',
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',
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',
pprReg reg2
]
-pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Doc
+pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> SDoc
pprRIReg name b ri reg1
= hcat [
char '\t',
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}
The (machine-independent) allocator itself is in @AsmRegAlloc@.
\begin{code}
-#include "HsVersions.h"
#include "nativeGen/NCG.h"
module RegAllocInfo (
regUsage,
FutureLive(..),
- SYN_IE(RegAssignment),
- SYN_IE(RegConflicts),
+ RegAssignment,
+ RegConflicts,
RegFuture(..),
RegHistory(..),
RegInfo(..),
regLiveness,
spillReg,
- SYN_IE(RegSet),
+ RegSet,
elementOfRegSet,
emptyRegSet,
isEmptyRegSet,
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 )
import PrimRep ( PrimRep(..) )
import Stix ( StixTree, CodeSegment )
import UniqSet -- quite a bit of it
+import Outputable
\end{code}
%************************************************************************
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 = []
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...
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)
%
\begin{code}
-#include "HsVersions.h"
-
module Stix (
- CodeSegment(..), StixReg(..), StixTree(..), SYN_IE(StixTreeList),
+ CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
sStLitLbl,
stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg,
getUniqLabelNCG
) where
-IMP_Ubiq(){-uitous-}
-IMPORT_1_3(Ratio(Rational))
+#include "HsVersions.h"
+
+import Ratio ( Rational )
import AbsCSyn ( node, infoptr, MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
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
| 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
%
\begin{code}
-#include "HsVersions.h"
-
module StixInfo ( genCodeInfoTable ) where
-IMP_Ubiq(){-uitious-}
+#include "HsVersions.h"
import AbsCSyn ( AbstractC(..), CAddrMode, ReturnInfo,
RegRelative, MagicId, CStmtMacro
)
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).
%
\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
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}
%
\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
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
%
\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
)
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
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}
%---------------------------------------------------------------------
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
.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
#include "hspincl.h"
%}
%{{
+module U_binding where
+
#include "HsVersions.h"
-module U_binding where
-IMP_Ubiq() -- debugging consistency check
import UgenUtil
import U_constr
gfline : long; >;
abind : < gabindfst : binding;
gabindsnd : binding; >;
- ibind : < gibindc : list;
- gibindid : qid;
- gibindi : ttype;
+ ibind : < gibindi : ttype;
gibindw : binding;
giline : long; >;
dbind : < gdbindts : list;
#include "hspincl.h"
%}
%{{
-#include "HsVersions.h"
module U_constr where
-IMP_Ubiq() -- debugging consistency check
+
+#include "HsVersions.h"
+
import UgenUtil
import U_maybe
#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; > ;
#include "hspincl.h"
%}
%{{
+module U_entidt where
+
#include "HsVersions.h"
-module U_entidt where
-IMP_Ubiq() -- debugging consistency check
import UgenUtil
import U_list
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
%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
%type <uentid> export import
-%type <ulong> commas importkey
+%type <ulong> commas importkey get_line_no
/**********************************************************************
* *
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
| 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); }
;
| 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); }
;
| 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); }
;
* *
**********************************************************************/
-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); }
valdef : vallhs
+
{
tree fn = function($1);
PREVPATT = $1;
#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; }
/* 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);
}
#include "hspincl.h"
%}
%{{
+module U_list where
+
#include "HsVersions.h"
-module U_list where
-IMP_Ubiq() -- debugging consistency check
import UgenUtil
%}}
type list;
#include "hspincl.h"
%}
%{{
+module U_literal where
+
#include "HsVersions.h"
-module U_literal where
-IMP_Ubiq() -- debugging consistency check
import UgenUtil
%}}
type literal;
#include "hspincl.h"
%}
%{{
+module U_maybe where
+
#include "HsVersions.h"
-module U_maybe where
-IMP_Ubiq() -- debugging consistency check
import UgenUtil
%}}
type maybe;
#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
case ibind :
PUTTAG('%');
plineno(giline(b));
- plist(pttype,gibindc(b));
- pqid(gibindid(b));
pttype(gibindi(b));
prbind(gibindw(b));
/* ppragma(gipragma(b)); */
#include "hspincl.h"
%}
%{{
+module U_qid where
+
#include "HsVersions.h"
-module U_qid where
-IMP_Ubiq() -- debugging consistency check
import UgenUtil
%}}
type qid;
#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
ghmodline : long; >;
fixop : < gfixop : qid;
gfixinfx : long;
- gfixprec : long; >;
+ gfixprec : long;
+ gfixline : long; >;
ident : < gident : qid; >;
lit : < glit : literal; >;
#include "hspincl.h"
%}
%{{
+module U_ttype where
+
#include "HsVersions.h"
-module U_ttype where
-IMP_Ubiq() -- debugging consistency check
import UgenUtil
import U_list
#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.
/* 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;
/* 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;
}
}
+
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));
\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,
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
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
\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)
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"))
-- 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
+++ /dev/null
-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}
and gobbled whoever was writing the above :-) -- SOF ]
\begin{code}
-#include "HsVersions.h"
-
module PrelMods
(
gHC__, pRELUDE, pREL_BASE,
cCALL , aDDR
) where
-CHK_Ubiq() -- debugging consistency check
+#include "HsVersions.h"
-import BasicTypes( SYN_IE(Module) )
+import BasicTypes( Module )
\end{code}
\begin{code}
\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
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
#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}
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:
\section[PrimOp]{Primitive operations (machine-level)}
\begin{code}
-#include "HsVersions.h"
-
module PrimOp (
PrimOp(..), allThePrimOps,
tagOf_PrimOp, -- ToDo: rm
pprPrimOp, showPrimOp
) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
import PrimRep -- most of it
import TysPrim
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}
%************************************************************************
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)))
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}
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
= 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}
types.
\begin{code}
-#include "HsVersions.h"
-
module PrimRep (
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"
\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
* 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(..) )
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}
(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
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))
(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]
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}
%* *
%************************************************************************
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 $
\begin{code}
addStandardIdInfo id
- = pprTrace "addStandardIdInfo missing:" (ppr PprDebug id) id
+ = pprTrace "addStandardIdInfo missing:" (ppr id) id
\end{code}
= 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}
_exports_
TysPrim voidTy;
_declarations_
-1 voidTy _:_ Type.Type ;;
+-- Not needed by Type.lhs any more
+-- 1 voidTy _:_ Type.Type ;;
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}
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}
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}
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}
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}
%************************************************************************
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}
%************************************************************************
\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}
%************************************************************************
\begin{code}
stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConKey SLIT("StablePtr#") 1 StablePtrRep
-mkStablePtrPrimTy ty = applyTyCon stablePtrPrimTyCon [ty]
+mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty]
\end{code}
%************************************************************************
could possibly be added?)
\begin{code}
-foreignObjPrimTy = applyTyCon foreignObjPrimTyCon []
+foreignObjPrimTy = mkTyConTy foreignObjPrimTyCon
foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConKey SLIT("ForeignObj#") 0 ForeignObjRep
\end{code}
_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 ;;
+
+
types and operations.''
\begin{code}
-#include "HsVersions.h"
-
module TysWiredIn (
addrDataCon,
addrTy,
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
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
[ {- 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}
%************************************************************************
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
\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}
\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
\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}
%************************************************************************
@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}
%************************************************************************
\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
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
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}
%************************************************************************
\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}
%************************************************************************
\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)
\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}
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
-}
-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}
\section[CostCentre]{The @CostCentre@ data type}
\begin{code}
-#include "HsVersions.h"
-
module CostCentre (
CostCentre, CcKind, IsDupdCC{-ToDo:rm-}, IsCafCC(..),
noCostCentre, subsumedCosts,
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}
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
\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)
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
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 '"']
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 ++ '/':
('/' : 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
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.
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_")
\end{code}
\begin{code}
-uppCostCentreDecl sty is_local cc
+uppCostCentreDecl is_local cc
#ifdef DEBUG
| noCostCentreAttached cc || currentOrSubsumedCosts cc
= panic "uppCostCentreDecl: no cost centre!"
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)
* "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}
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')
\section[Lexical analysis]{Lexical analysis}
\begin{code}
-#include "HsVersions.h"
-
module Lex (
isLexCon, isLexVar, isLexId, isLexSym,
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}
%************************************************************************
-- 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
'-'# ->
-- 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
--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
%************************************************************************
\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
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}
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
Support routines for reading prefix-form from the Lex/Yacc parser.
\begin{code}
-#include "HsVersions.h"
-
module PrefixToHs (
cvValSig,
cvClassOpSig,
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}
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}
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)
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
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,
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
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.
\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}
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}
%************************************************************************
%* *
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
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}
\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.
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}
%************************************************************************
%************************************************************************
\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
returnUgn (
HsLam (foldr PatMatch
(GRHSMatch (GRHSsAndBindsIn
- [OtherwiseGRHS body src_loc]
+ (unguardedRHS body src_loc)
EmptyBinds))
pats)
)
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 ->
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
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)
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}
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))
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))
-- "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))
-- "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))
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}
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
{
-#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
}
QVARSYM { ITqvarsym $$ }
QCONSYM { ITqconsym $$ }
+ STRICT_PART { ITstrict $$ }
TYPE_PART { ITtysig _ _ }
ARITY_PART { ITarity }
- STRICT_PART { ITstrict $$ }
UNFOLD_PART { ITunfold $$ }
BOTTOM { ITbottom }
LAM { ITlam }
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
| 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 }
| { [] }
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 : { [] }
| 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 -} }
: { [] }
| 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 }
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 }
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] }
| 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 }
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 -} }
| 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] }
| 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
+
+}
+++ /dev/null
-{
-#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("->")) }
-
+++ /dev/null
-{
-#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("->")) }
\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 )
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
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}
-- 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
) >>
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 (
) `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 ->
(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"-} []
\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.
-- 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 ->
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
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 ()
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 )
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
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))
= -- 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}
@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
-> 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]
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' ->
(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_`
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
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)
\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
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}
\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 )
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}
%*********************************************************
\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
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
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]
\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
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
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
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 ()
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}
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.
-- 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
-- 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
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
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}
%************************************************************************
%* *
=============== 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_`
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.
lookupNameEnv :: NameEnv -> RdrName -> Maybe Name
lookupNameEnv = lookupFM
-
-delOneFromNameEnv :: NameEnv -> RdrName -> NameEnv
-delOneFromNameEnv env rdr_name = delFromFM env rdr_name
\end{code}
=============== FixityEnv ================
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}
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
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
-- 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 [
\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}
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
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}
-- 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
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}
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,
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_`
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) ->
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)
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)
= 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)
(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
-> (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
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)
%************************************************************************
\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}
\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
%* *
%************************************************************************
-\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}
\section[RnIfaces]{Cacheing and Renaming of Interfaces}
\begin{code}
-#include "HsVersions.h"
-
module RnIfaces (
getInterfaceExports,
getImportedInstDecls,
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
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}
%*********************************************************
\begin{code}
-getRnStats :: [RenamedHsDecl] -> RnMG Doc
+getRnStats :: [RenamedHsDecl] -> RnMG SDoc
getRnStats all_decls
= getIfacesRn `thenRn` \ ifaces ->
let
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,
%*********************************************************
\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
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 ->
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
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}
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 _ _ _ _ _)
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
-- 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?
| 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}
%*********************************************************
\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
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
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
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_`
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 ()
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
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}
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
= -- 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
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
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]
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
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}
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
= 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 ->
%*********************************************************
\begin{code}
-findAndReadIface :: Doc -> Module
+findAndReadIface :: SDoc -> Module
-> IfaceFlavour
-> RnMG (Maybe ParsedIface)
-- Nothing <=> file not found, or unreadable, or illegible
--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
%*********************************************************
\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}
+++ /dev/null
-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}
\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}
%************************************************************************
\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}
\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
-- For getting global names
data GDown = GDown
SearchPath
- (MutVar Ifaces)
+ (SSTRWRef Ifaces)
-- For renaming source code
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.
-- 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:
--
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)
\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
[(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
\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 $
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
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
\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:
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_ #-}
================ 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_`
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_`
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
= 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 ()
= 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
= 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}
================ 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
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}
\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
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}
\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, _) ->
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
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
-- 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])
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}
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
-> 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
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
\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}
= 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.
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
-- 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
| 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
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. -}
(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
%************************************************************************
\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}
_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 ;;
\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
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
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 )
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.
= 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' ->
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))
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}
%*********************************************************
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_`
-- 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
(\_ -> 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}
\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
-- 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)
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)
%*********************************************************
\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.
-- 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
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
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
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
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}
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.
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}
= 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' ->
\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)
%*********************************************************
\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}
\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
(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
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)
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)
-}
%************************************************************************
\begin{code}
-#include "HsVersions.h"
-
module BinderInfo (
BinderInfo(..),
FunOrArg, DuplicationDanger, InsideSCC, -- NB: all abstract (yay!)
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}
\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 ]
(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 )
import SimplMonad
import TysWiredIn ( trueDataCon, falseDataCon )
-#ifdef REALLY_HASKELL_1_3
-import Char(ord,chr)
-#endif
+import Char ( ord, chr )
\end{code}
\begin{code}
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}
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))
``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
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]
(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
= 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
\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?-} )
--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,
| 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')]
-- 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 ->
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"
import Id ( localiseId )
import Maybes
import Outputable
-import Pretty
import Util
\end{code}
\section[MagicUFs]{Magic unfoldings that the simplifier knows about}
\begin{code}
-#include "HsVersions.h"
-
module MagicUFs (
MagicUnfoldingFun, -- absolutely abstract
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-} )
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}
-- 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}
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
-- 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
-- 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') ->
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)"
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"
) 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 )
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 ])
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
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
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
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}
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
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}
%************************************************************************
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))
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
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) ->
-> 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
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(..) )
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-} )
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}
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
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
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
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
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}
\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 )
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 )
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(..) )
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,
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}
-> 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)
-- 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
-- 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 =
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)
-------------------------------------------------
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
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
-- 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)
tidyCoreArg (TyArg ty) = tidyTy ty `thenTM` \ ty' ->
returnTM (TyArg ty')
-tidyCoreArg (UsageArg u) = returnTM (UsageArg u)
\end{code}
\begin{code}
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)
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
-- 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}
\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,
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,
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}
%************************************************************************
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)
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
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}
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
\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}
\section[SimplMonad]{The simplifier Monad}
\begin{code}
-#include "HsVersions.h"
-
module SimplMonad (
- SYN_IE(SmplM),
+ SmplM,
initSmpl, returnSmpl, thenSmpl, thenSmpl_,
mapSmpl, mapAndUnzipSmpl,
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}
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)
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)
\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}
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
])
\section[SimplUtils]{The simplifier utilities}
\begin{code}
-#include "HsVersions.h"
-
module SimplUtils (
floatExposesHNF,
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 )
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,
:: 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
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)
-- 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
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
= 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
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
\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
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}
%************************************************************************
| 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
---------- 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
{-
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
)
\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(..) )
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
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
\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}
\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
\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' ->
| 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'
env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre
| otherwise = env
- (uvars, tyvars, body) = collectUsageAndTyBinders rhs
+ (tyvars, body) = collectTyBinders rhs
\end{code}
| 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_`
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
-- 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}
| 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:
-- 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_`
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
+++ /dev/null
-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}
\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}
-- 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
\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
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}
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
-------------
stg_linter = if False --LATER: opt_DoStgLinting (ToDo)
- then lintStgBindings pprDumpStyle
+ then lintStgBindings
else ( \ whodunnit binds -> 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
\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}
let-no-escapes.
\begin{code}
-#include "HsVersions.h"
-
module StgVarInfo ( setStgVarInfo ) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
import StgSyn
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}
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}
%-----------------------------------------------------------------------------
\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
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}
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}
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
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
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}
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}
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}
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}
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
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}
%-----------------------------------------------------------------------------
_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 ;
\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}
\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
\begin{code}
-#include "HsVersions.h"
-
module SpecUtils (
specialiseCallTys,
- SYN_IE(ConstraintVector),
+ ConstraintVector,
getIdOverloading,
isUnboxedSpecialisation,
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.
\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
tyvar_part_of ((c,ty):theta) = case (getTyVar_maybe ty) of
Nothing -> []
Just tv -> (c, tv) : tyvar_part_of theta
+-}
\end{code}
\begin{code}
\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
-> (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
(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
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
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
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
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!!!
\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
\begin{code}
-#include "HsVersions.h"
-
module Specialise (
specProgram,
initSpecData,
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
)
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 )
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`
\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 _ _ _)
\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 _ _ _ _)
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)
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)),
(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)
= 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
(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])
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}
-- 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) ->
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, []))
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
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) ->
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)
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
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)
-> 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
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
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}
(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
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}
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
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,
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}
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
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
\begin{code}
coreExprToStg env expr@(Lam _ _)
= let
- (_,_, binders, body) = collectBinders expr
+ (_, binders, body) = collectBinders expr
in
coreExprToStg env body `thenUs` \ stg_body ->
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)
)
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 ->
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 ->
\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
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_`
@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 ()
= 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_`
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) ->
-> 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}
if isEmptyBag errs then
Nothing
else
- Just ( \ sty ->
- foldBag ($$) ( \ msg -> msg sty ) empty errs
- )
+ Just (foldBag ($$) (\ msg -> msg) empty errs)
}
returnL :: a -> LintM a
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
-- 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}
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)
| 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
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)
\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}
suited to spineless tagless code generation.
\begin{code}
-#include "HsVersions.h"
-
module StgSyn (
GenStgArg(..),
- SYN_IE(GenStgLiveVars),
+ GenStgLiveVars,
GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
GenStgCaseAlts(..), GenStgCaseDefault(..),
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,
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}
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}
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}
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}
--
-- 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
\section[SaAbsInt]{Abstract interpreter for strictness analysis}
\begin{code}
-#include "HsVersions.h"
-
module SaAbsInt (
findStrictness,
findDemand,
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}
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
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
-- 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")
-- 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
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}
{-
(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
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}
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
\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
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)
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
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
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
else -- A data type!
let
compt_strict_infos
- = [ findRecDemand (tycon:seen)
+ = [ findRecDemand
(\ cmpnt_val ->
str_fn (mkMainlyTopProd prod_len i cmpnt_val)
)
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
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`
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}
%************************************************************************
-- 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}
%-----------
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}
%************************************************************************
-- 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...
| 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
\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 )
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
| 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)
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.
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}
\section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser}
\begin{code}
-#include "HsVersions.h"
-
module WwLib (
WwBinding(..),
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}
%************************************************************************
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
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:
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"
\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"
\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}
%************************************************************************
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
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}
%************************************************************************
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
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]
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
-- 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
\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 ->
\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
\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}
%************************************************************************
%* *
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 ->
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
\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}
| 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
-- 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
\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)
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)
= 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}
\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 )
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}
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))
\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
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
-- 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,
-- 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) ->
-- 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
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
\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
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
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}
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:
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)
-- 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}
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
-- 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_`
\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)"))
-----------------------------------------------
= 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)
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}
-
-
-
-
\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
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 )
\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)
-- 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
in
Just (tcAddImportedIdInfo rec_env dm_id)
in
- returnTc (sel_id, maybe_dm_id)
+ returnTc (local_ty, sel_id, maybe_dm_id)
\end{code}
-> 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)
-- 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))
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
-- 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)
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
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)
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}
\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}
-- 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}
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}
%************************************************************************
-- 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}
-> 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
-- 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)
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}
(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
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
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
-- 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")
-- 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}
%************************************************************************
\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
tycon
where
from_here = isLocallyDefined tycon
- (tycon,_,_) = getAppDataTyCon ty
+ (tycon,_,_) = splitAlgTyConApp ty
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}
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 &&
\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}
\begin{code}
-#include "HsVersions.h"
-
module TcEnv(
+ TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId,
+
TcEnv,
initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes,
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
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
~~~~~~~~~~~~~~~~~~~~~
(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
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}
\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
-- 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
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) ->
= 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
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
= 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
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}
\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
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}
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}
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]
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 -}
-- 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),
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))
`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
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
-- (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) ->
-- 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) ->
-- 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) ->
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
= -- 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)
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
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
-- 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
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) ->
-- 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}
%************************************************************************
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
-- 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) ->
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}
\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}
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}
-> 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}
This is where we do all the grimy bindings' generation.
\begin{code}
-#include "HsVersions.h"
-
module TcGenDeriv (
gen_Bounded_binds,
gen_Enum_binds,
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 )
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}
%************************************************************************
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
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))
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
= 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.
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
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...
= 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)
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
(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
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}
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}
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}
%************************************************************************
%* *
%************************************************************************
+@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
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
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
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, _) ->
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 ->
= 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"
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')
-------------------------------------------------------------------------
\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,
)
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(..) )
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 )
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}
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}
-- 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}
= 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.
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
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' ->
= 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 $
= 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' ->
\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}
\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
-> 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
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}
\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)
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
\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
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
(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
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
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}
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
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
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
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
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.)
--
(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 &&
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
\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
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}
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}
= 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
[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}
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}
\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@
\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}
\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 ())
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
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
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.
-- 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}
+++ /dev/null
-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}
+++ /dev/null
-\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}
\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
-- 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))
-> 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)
\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
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}
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}
\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 )
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
-> 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:
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)
-- 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) ->
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
-- 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 ->
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}
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}
\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,
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,
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
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_`
\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 (
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
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 ->
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 ()
= 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,
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 ()
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
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}
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
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}
= 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
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"
\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}
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}
\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
= 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)
| 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
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}
\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@
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}
\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,
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}
-- 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) ->
-- 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
-- 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
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}
%
\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}
%* *
%************************************************************************
-* 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
\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
\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}
%************************************************************************
%* *
@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;
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}
%************************************************************************
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}
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
@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
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}
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}
\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-} )
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)
-- 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
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))
\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)
= (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
\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}
\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) $
-- 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,
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\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) $
-- Unify tycon kind with (k1->...->kn->Type)
unifyKind tycon_kind
- (foldr mkTcArrowKind mkTcTypeKind tyvar_kinds)
+ (foldr mkArrowKind mkBoxedTypeKind tyvar_kinds)
`thenTc_`
-- Walk the condecls
ctxt
con_ids
derived_classes
+ Nothing -- Not a dictionary
data_or_new
+ is_rec
in
returnTc 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
| 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}
-- 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
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
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
[{- No labelled fields -}]
tyvars
ctxt
- [] [] -- Temporary
+ [] [] -- Temporary; existential chaps
[arg_ty]
tycon
in
field_labels
tyvars
(thinContext arg_tys ctxt)
- [] [] -- Temporary
+ [] [] -- Temporary; existential chaps
arg_tys
tycon
in
[{- No field labels -}]
tyvars
(thinContext arg_tys ctxt)
- [] [] -- Temporary
+ [] [] -- Temporary existential chaps
arg_tys
tycon
in
= 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
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}
\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)
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}
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
= 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}
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
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
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
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)
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
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
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
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}
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}
-> 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
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
-- 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}
%************************************************************************
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
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 ->
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
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
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}
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;
\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
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}
%************************************************************************
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}
%************************************************************************
%* *
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}
\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,
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
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}
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
\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}
%************************************************************************
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}
%************************************************************************
%************************************************************************
\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}
%************************************************************************
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}
%* *
%************************************************************************
-\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}
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}
\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
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)
\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,
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
-- (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
-- -> 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#)
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
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
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
\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"
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}
\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
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@}
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
\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
getName other_tc = moduleNamePair (expectJust "tycon1" (getName other_tc))
getName other = Nothing
-}
-
\end{code}
+++ /dev/null
-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}
+++ /dev/null
-_interface_ TyVar 1
-_exports_
-TyVar TyVar GenTyVar;
-_declarations_
-1 type TyVar = TyVar.GenTyVar Usage.Usage ;
-1 data GenTyVar a;
-
\begin{code}
-#include "HsVersions.h"
-
module TyVar (
- GenTyVar(..), SYN_IE(TyVar),
+ GenTyVar(..), TyVar,
+
mkTyVar, mkSysTyVar,
tyVarKind, -- TyVar -> Kind
cloneTyVar, nameTyVar,
-- 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
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}
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}
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
-- 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
\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
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
_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 ;
+
\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')...
-- 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}
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}
%************************************************************************
%* *
%************************************************************************
-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
= 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'
+++ /dev/null
-%
-% (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}
\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
= 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}
\section[Bags]{@Bag@: an unordered collection with duplicates}
\begin{code}
-#include "HsVersions.h"
-
module Bag (
Bag, -- abstract type
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
\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}
\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,
) where
+# include "HsVersions.h"
+
------------------------------------------------------------------------------
-- A version of the graph algorithms described in:
--
-- Also included is some additional code for printing tree structures ...
------------------------------------------------------------------------------
-#ifdef REALLY_HASKELL_1_3
#define ARR_ELT (COMMA)
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}
| 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
-- 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
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
\begin{code}
graphFromEdges
- :: Ord3 key
+ :: Ord key
=> [(node, key, [key])]
-> (Graph, Vertex -> (node, key, [key]))
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
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}
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}
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
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
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
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
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#
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
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
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.
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# =
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# =
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 ""
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}
\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}
@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
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}
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
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
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
\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}
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 }
= --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
-- if sizeFM result <= 8 then
result
-- else
--- pprTrace ("mkBranch:"++(show which)) (ppr PprDebug result) (
+-- pprTrace ("mkBranch:"++(show which)) (ppr result) (
-- result
-- )
where
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)
#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
+++ /dev/null
-
-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}
\section[ListSetOps]{Set-like operations on lists}
\begin{code}
-#include "HsVersions.h"
-
module ListSetOps (
unionLists,
--UNUSED: intersectLists,
) 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}
+++ /dev/null
-%************************************************************************
-%* *
-\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}
\section[Maybes]{The `Maybe' types and associated utility functions}
\begin{code}
-#include "HsVersions.h"
-
module Maybes (
-- Maybe(..), -- no, it's in 1.3
MaybeErr(..),
catMaybes
) where
-#if __GLASGOW_HASKELL__ >= 204
-import Maybe ( catMaybes, mapMaybe )
-#endif
+#include "HsVersions.h"
+import Maybe( catMaybes, mapMaybe )
\end{code}
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
``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}
\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
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}
%************************************************************************
\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}
\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
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}
``first'' etc.
\begin{code}
-speakNth :: Int -> Doc
+speakNth :: Int -> SDoc
speakNth 1 = ptext SLIT("first")
speakNth 2 = ptext SLIT("second")
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}
\begin{code}
-#include "HsVersions.h"
-
module Pretty (
Doc, -- Abstract
Mode(..), TextDetails(..),
) 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 <>
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
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}
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#
(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)
-}
-- 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#
#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#
-- 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#
\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}
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\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
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
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
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}
+++ /dev/null
-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}
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
(
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
-- 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}
+++ /dev/null
-module Ubiq
- (
- module Unique,
- module UniqFM
-
- ) where
-
-import Unique
-import UniqFM
-
+++ /dev/null
-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}
(A similar thing to @UniqSet@, as opposed to @Set@.)
\begin{code}
-#include "HsVersions.h"
-
module UniqFM (
UniqFM, -- abstract type
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
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,
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
\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)
zipLazy,
mapAndUnzip, mapAndUnzip3,
nOfThem, lengthExceeds, isSingleton,
- startsWith, endsWith,
+ startsWith, endsWith, snocView,
isIn, isn'tIn,
-- association lists
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}
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
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
\end{code}
\begin{code}
-equivClasses :: (a -> a -> TAG_) -- Comparison
+equivClasses :: (a -> a -> Ordering) -- Comparison
-> [a]
-> [[a]]
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
\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
collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
\end{code}
+
%************************************************************************
%* *
\subsection[Utils-sorting]{Sorting}
%************************************************************************
\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]
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}
%************************************************************************
%* *
%************************************************************************
-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}
unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
\end{code}
+
%************************************************************************
%* *
\subsection[Utils-errors]{Error handling}
++ "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}
}
\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'
}
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; }
->
All -- Pseudo class used for universal quantification
+ CCallable
+ CReturnable
Void
-- void CAF is defined in PrelBase
+#
-#
*#
+ /#
quotInt#
remInt#
negateInt#
StablePtr#
makeStablePtr#
deRefStablePtr#
-
reallyUnsafePtrEquality#
;
+
+_declarations_
+
+1 class CCallable a :: ** ;
+1 class CReturnable a :: ** ;
\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
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}
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__
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}
%*********************************************************
ioe_closedHandle :: Handle -> IO a
ioe_closedHandle h = fail (IOError (Just h) IllegalOperation "handle is closed")
-
\end{code}
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 )
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@}
\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
\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.
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"
%*********************************************************
\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}
%*********************************************************
\begin{code}
-class CCallable a
-class CReturnable a
-
instance CCallable Char
instance CCallable Char#
instance CReturnable Char
e1==e2 && str1==str2 && h1==h2
instance Eq Handle where
+ (Handle h1) == (Handle h2) = h1 == h2
+
+{- OLD equality instance. The simpler one above
+ seems more accurate!
+
+instance Eq Handle where
h1 == h2 =
unsafePerformIO (do
h1_ <- readHandle h1
(AppendHandle v1 _ _ , AppendHandle v2 _ _) -> v1 == v2
(ReadWriteHandle v1 _ _ , ReadWriteHandle v2 _ _) -> v1 == v2
_ -> False))
+-}
instance Show Handle where {showsPrec p h = showString "<<Handle>>"}
) where
import Prelude
-import Maybe (listToMaybe)
+import Maybe (listToMaybe)
+import PrelBase ( Int(..) )
+import GHC ( (+#) )
infix 5 \\
\end{code}
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
projects / ghc-hetmet.git / commitdiff