Commit 9dd6e1c2 authored by simonm's avatar simonm

[project @ 1998-01-08 18:03:08 by simonm]

The Great Multi-Parameter Type Classes Merge.

Notes from Simon (abridged):

* Multi-parameter type classes are fully implemented.
* Error messages from the type checker should be noticeably improved
* Warnings for unused bindings (-fwarn-unused-names)
* many other minor bug fixes.

Internally there are the following changes

* Removal of Haskell 1.2 compatibility.
* Dramatic clean-up of the PprStyle stuff.
* The type Type has been substantially changed.
* The dictionary for each class is represented by a new
  data type for that purpose, rather than by a tuple.
parent ff14742c
...@@ -26,49 +26,13 @@ you will screw up the layout where they are used in case expressions! ...@@ -26,49 +26,13 @@ you will screw up the layout where they are used in case expressions!
#define CAT2(a,b)a/**/b #define CAT2(a,b)a/**/b
#endif #endif
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ == 201 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 202
# define REALLY_HASKELL_1_3 # define REALLY_HASKELL_1_3
# define SYN_IE(a) a # define SYN_IE(a) a
# define EXP_MODULE(a) module a # define EXP_MODULE(a) module a
# define IMPORT_DELOOPER(mod) import mod # define IMPORT_DELOOPER(mod) import mod
# define IMPORT_1_3(mod) import mod # define IMPORT_1_3(mod) import mod
# define _tagCmp compare # define _Addr Addr
# 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 _ByteArray GlaExts.ByteArray # define _ByteArray GlaExts.ByteArray
# define _MutableByteArray GlaExts.MutableByteArray # define _MutableByteArray GlaExts.MutableByteArray
# define _MutableArray GlaExts.MutableArray # define _MutableArray GlaExts.MutableArray
...@@ -126,37 +90,19 @@ you will screw up the layout where they are used in case expressions! ...@@ -126,37 +90,19 @@ you will screw up the layout where they are used in case expressions!
# define MkIOError(h,errt,msg) (errt msg) # define MkIOError(h,errt,msg) (errt msg)
#endif #endif
#if __GLASGOW_HASKELL__ >= 26 && __GLASGOW_HASKELL__ < 200 #if defined(__GLASGOW_HASKELL__)
#define trace _trace
#endif
#define TAG_ Int# -- Import the beggars
#define LT_ -1# import GlaExts ( Int(..), Int#, (+#), (-#), (*#),
#define EQ_ 0# quotInt#, negateInt#, (==#), (<#), (<=#), (>=#), (>#)
#define GT_ 1# )
#define GT__ _
#if defined(__GLASGOW_HASKELL__)
#define FAST_INT Int# #define FAST_INT Int#
#define ILIT(x) (x#) #define ILIT(x) (x#)
#define IBOX(x) (I# (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 _ADD_ +#
#define _SUB_ -# #define _SUB_ -#
#define _MUL_ *# #define _MUL_ *#
#define _DIV_ /#
#define _QUOT_ `quotInt#` #define _QUOT_ `quotInt#`
#define _NEG_ negateInt# #define _NEG_ negateInt#
#define _EQ_ ==# #define _EQ_ ==#
...@@ -164,7 +110,6 @@ you will screw up the layout where they are used in case expressions! ...@@ -164,7 +110,6 @@ you will screw up the layout where they are used in case expressions!
#define _LE_ <=# #define _LE_ <=#
#define _GE_ >=# #define _GE_ >=#
#define _GT_ ># #define _GT_ >#
#endif
#define FAST_BOOL Int# #define FAST_BOOL Int#
#define _TRUE_ 1# #define _TRUE_ 1#
...@@ -196,45 +141,29 @@ you will screw up the layout where they are used in case expressions! ...@@ -196,45 +141,29 @@ you will screw up the layout where they are used in case expressions!
#endif {- ! __GLASGOW_HASKELL__ -} #endif {- ! __GLASGOW_HASKELL__ -}
#if __GLASGOW_HASKELL__ >= 23 #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 # define USE_FAST_STRINGS 1
# if __GLASGOW_HASKELL__ < 200 || __GLASGOW_HASKELL__ >= 202 # define FAST_STRING FastString
# define FAST_STRING FastString {-_PackedString -} # define SLIT(x) (mkFastCharString# (x#))
# if __GLASGOW_HASKELL__ < 200 # define _NULL_ nullFastString
# define SLIT(x) (mkFastCharString (A# (x#))) # define _NIL_ (mkFastString "")
# elif __GLASGOW_HASKELL__ < 209 # define _CONS_ consFS
# define SLIT(x) (mkFastCharString (GlaExts.A# (x#))) # define _HEAD_ headFS
# else # define _TAIL_ tailFS
# define SLIT(x) (mkFastCharString (Addr.A# (x#))) # define _LENGTH_ lengthFS
# endif # define _PK_ mkFastString
# define _CMP_STRING_ cmpPString # define _UNPK_ unpackFS
/* cmpPString defined in utils/Util.lhs */ # define _APPEND_ `appendFS`
# define _NULL_ nullFastString {-_nullPS-} # define _CONCAT_ concatFS
# 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
#else #else
# define FAST_STRING String # define FAST_STRING String
# define SLIT(x) (x) # define SLIT(x) (x)
......
...@@ -31,6 +31,13 @@ LIBRARY=libhsp.a ...@@ -31,6 +31,13 @@ LIBRARY=libhsp.a
HS_PROG=hsc HS_PROG=hsc
# -----------------------------------------------------------------------------
# Compilation history for Patrick
# Make the sources first, because that's what the compilation history needs
$(HS_PROG) :: $(HS_SRCS)
# ----------------------------------------------------------------------------- # -----------------------------------------------------------------------------
# Set SRCS, LOOPS, HCS, OBJS # Set SRCS, LOOPS, HCS, OBJS
# #
...@@ -53,7 +60,7 @@ endif ...@@ -53,7 +60,7 @@ endif
HS_SRCS = $(SRCS_UGNHS) \ HS_SRCS = $(SRCS_UGNHS) \
$(foreach dir,$(DIRS),$(wildcard $(dir)/*.lhs)) \ $(foreach dir,$(DIRS),$(wildcard $(dir)/*.lhs)) \
rename/ParseIface.hs rename/ParseType.hs rename/ParseUnfolding.hs rename/ParseIface.hs
ifneq "$(Ghc2_0)" "YES" ifneq "$(Ghc2_0)" "YES"
HS_SRCS += main/LoopHack.hc HS_SRCS += main/LoopHack.hc
...@@ -104,7 +111,7 @@ LIBOBJS = \ ...@@ -104,7 +111,7 @@ LIBOBJS = \
# #
# stuff you get for free in a source distribution # 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/U_tree.c parser/tree.h parser/tree.c \
parser/hsparser.tab.c parser/hsparser.tab.h \ parser/hsparser.tab.c parser/hsparser.tab.h \
parser/hslexer.c parser/hslexer.c
...@@ -148,6 +155,10 @@ SRC_HC_OPTS += $(GhcHcOpts) ...@@ -148,6 +155,10 @@ SRC_HC_OPTS += $(GhcHcOpts)
absCSyn/AbsCSyn_HC_OPTS = -fno-omit-reexported-instances absCSyn/AbsCSyn_HC_OPTS = -fno-omit-reexported-instances
absCSyn/CStrings_HC_OPTS = -monly-3-regs absCSyn/CStrings_HC_OPTS = -monly-3-regs
# Was 6m with 2.10
absCSyn/PprAbsC_HC_OPTS = -H10m
basicTypes/IdInfo_HC_OPTS = -K2m basicTypes/IdInfo_HC_OPTS = -K2m
coreSyn/AnnCoreSyn_HC_OPTS = -fno-omit-reexported-instances coreSyn/AnnCoreSyn_HC_OPTS = -fno-omit-reexported-instances
hsSyn/HsExpr_HC_OPTS = -K2m hsSyn/HsExpr_HC_OPTS = -K2m
...@@ -172,14 +183,13 @@ parser/U_tree_HC_OPTS = -H12m -fvia-C '-\#include"hspincl.h"' ...@@ -172,14 +183,13 @@ parser/U_tree_HC_OPTS = -H12m -fvia-C '-\#include"hspincl.h"'
parser/U_ttype_HC_OPTS = -fvia-C '-\#include"hspincl.h"' parser/U_ttype_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
prelude/PrimOp_HC_OPTS = -H12m -K3m prelude/PrimOp_HC_OPTS = -H12m -K3m
reader/Lex_HC_OPTS = -K2m -H16m -fvia-C reader/Lex_HC_OPTS = -K2m -H16m -fvia-C
reader/ReadPrefix_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
rename/ParseIface_HC_OPTS += -Onot -H16m # Heap was 6m with 2.10
rename/ParseType_HC_OPTS += -Onot -H16m reader/ReadPrefix_HC_OPTS = -fvia-C '-\#include"hspincl.h"' -H10m
rename/ParseUnfolding_HC_OPTS += -Onot -H30m
rename/ParseIface_HC_OPTS += -Onot -H30m
ifeq "$(Ghc2_0)" "YES" ifeq "$(Ghc2_0)" "YES"
rename/ParseIface_HC_OPTS += -fno-warn-incomplete-patterns 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 endif
ifeq "$(TARGETPLATFORM)" "hppa1.1-hp-hpux9" ifeq "$(TARGETPLATFORM)" "hppa1.1-hp-hpux9"
...@@ -192,6 +202,7 @@ endif ...@@ -192,6 +202,7 @@ endif
rename/RnEnv_HC_OPTS = -fvia-C rename/RnEnv_HC_OPTS = -fvia-C
rename/RnSource_HC_OPTS = -H12m rename/RnSource_HC_OPTS = -H12m
rename/RnIfaces_HC_OPTS = -H8m -fvia-C rename/RnIfaces_HC_OPTS = -H8m -fvia-C
rename/RnExpr_HC_OPTS = -H10m
rename/RnNames_HC_OPTS = -H12m rename/RnNames_HC_OPTS = -H12m
rename/RnMonad_HC_OPTS = -fvia-C rename/RnMonad_HC_OPTS = -fvia-C
# Urk! Really big heap for ParseUnfolding # Urk! Really big heap for ParseUnfolding
...@@ -199,8 +210,13 @@ rename/RnMonad_HC_OPTS = -fvia-C ...@@ -199,8 +210,13 @@ rename/RnMonad_HC_OPTS = -fvia-C
specialise/Specialise_HC_OPTS = -Onot -H12m specialise/Specialise_HC_OPTS = -Onot -H12m
stgSyn/StgSyn_HC_OPTS = -fno-omit-reexported-instances stgSyn/StgSyn_HC_OPTS = -fno-omit-reexported-instances
typecheck/TcGenDeriv_HC_OPTS = -H10m 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 typecheck/TcEnv_HC_OPTS = -H10m
ifeq "$(Ghc2_0)" "NO" ifeq "$(Ghc2_0)" "NO"
typecheck/TcMonad_HC_OPTS = -fvia-C typecheck/TcMonad_HC_OPTS = -fvia-C
...@@ -258,16 +274,6 @@ rename/ParseIface.hs : rename/ParseIface.y ...@@ -258,16 +274,6 @@ rename/ParseIface.hs : rename/ParseIface.y
$(HAPPY) $(HAPPY_OPTS) -g rename/ParseIface.y $(HAPPY) $(HAPPY_OPTS) -g rename/ParseIface.y
@chmod 444 rename/ParseIface.hs @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 # Building the stand-alone parser
...@@ -332,7 +338,7 @@ endif ...@@ -332,7 +338,7 @@ endif
# #
# Before doing `make depend', need to build all derived Haskell source files # 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" ifeq "$(GhcWithHscBuiltViaC)" "YES"
......
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}
...@@ -12,8 +12,6 @@ From @AbstractC@, one may convert to real C (for portability) or to ...@@ -12,8 +12,6 @@ From @AbstractC@, one may convert to real C (for portability) or to
raw assembler/machine code. raw assembler/machine code.
\begin{code} \begin{code}
#include "HsVersions.h"
module AbsCSyn {- ( module AbsCSyn {- (
-- export everything -- export everything
AbstractC(..), AbstractC(..),
...@@ -35,15 +33,13 @@ module AbsCSyn {- ( ...@@ -35,15 +33,13 @@ module AbsCSyn {- (
CostRes(Cost) CostRes(Cost)
)-} where )-} where
IMP_Ubiq(){-uitous-} #include "HsVersions.h"
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
IMPORT_DELOOPER(AbsCLoop)
#else
# if ! OMIT_NATIVE_CODEGEN
import {-# SOURCE #-} MachMisc
# endif
import {-# SOURCE #-} ClosureInfo ( ClosureInfo ) import {-# SOURCE #-} ClosureInfo ( ClosureInfo )
import {-# SOURCE #-} CLabel ( CLabel ) import {-# SOURCE #-} CLabel ( CLabel )
#if ! OMIT_NATIVE_CODEGEN
import {-# SOURCE #-} MachMisc
#endif #endif
import Constants ( mAX_Vanilla_REG, mAX_Float_REG, import Constants ( mAX_Vanilla_REG, mAX_Float_REG,
...@@ -51,8 +47,8 @@ import Constants ( mAX_Vanilla_REG, mAX_Float_REG, ...@@ -51,8 +47,8 @@ import Constants ( mAX_Vanilla_REG, mAX_Float_REG,
lIVENESS_R3, lIVENESS_R4, lIVENESS_R5, lIVENESS_R3, lIVENESS_R4, lIVENESS_R5,
lIVENESS_R6, lIVENESS_R7, lIVENESS_R8 lIVENESS_R6, lIVENESS_R7, lIVENESS_R8
) )
import HeapOffs ( SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset), import HeapOffs ( VirtualSpAOffset, VirtualSpBOffset,
SYN_IE(VirtualHeapOffset), HeapOffset VirtualHeapOffset, HeapOffset
) )
import CostCentre ( CostCentre ) import CostCentre ( CostCentre )
import Literal ( mkMachInt, Literal ) import Literal ( mkMachInt, Literal )
......
...@@ -4,8 +4,6 @@ ...@@ -4,8 +4,6 @@
\section[AbsCUtils]{Help functions for Abstract~C datatype} \section[AbsCUtils]{Help functions for Abstract~C datatype}
\begin{code} \begin{code}
#include "HsVersions.h"
module AbsCUtils ( module AbsCUtils (
nonemptyAbsC, nonemptyAbsC,
mkAbstractCs, mkAbsCStmts, mkAbstractCs, mkAbsCStmts,
...@@ -19,24 +17,21 @@ module AbsCUtils ( ...@@ -19,24 +17,21 @@ module AbsCUtils (
-- printing/forcing stuff comes from PprAbsC -- printing/forcing stuff comes from PprAbsC
) where ) where
IMP_Ubiq(){-uitous-} #include "HsVersions.h"
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 200
import AbsCLoop (mkReturnPtLabel, CLabel )
#else
import {-# SOURCE #-} CLabel ( mkReturnPtLabel, CLabel ) import {-# SOURCE #-} CLabel ( mkReturnPtLabel, CLabel )
-- The loop here is (CLabel -> CgRetConv -> AbsCUtils -> CLabel) -- The loop here is (CLabel -> CgRetConv -> AbsCUtils -> CLabel)
#endif
import AbsCSyn import AbsCSyn
import Digraph ( stronglyConnComp, SCC(..) ) import Digraph ( stronglyConnComp, SCC(..) )
import HeapOffs ( possiblyEqualHeapOffset ) import HeapOffs ( possiblyEqualHeapOffset )
import Id ( fIRST_TAG, SYN_IE(ConTag) ) import Id ( fIRST_TAG, ConTag )
import Literal ( literalPrimRep, Literal(..) ) import Literal ( literalPrimRep, Literal(..) )
import PrimRep ( getPrimRepSize, PrimRep(..) ) import PrimRep ( getPrimRepSize, PrimRep(..) )
import Unique ( Unique{-instance Eq-} ) import Unique ( Unique{-instance Eq-} )
import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply ) import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
import Util ( assocDefaultUsing, panic, Ord3(..) ) import Util ( assocDefaultUsing, panic )
infixr 9 `thenFlt` infixr 9 `thenFlt`
\end{code} \end{code}
......
...@@ -4,8 +4,6 @@ ...@@ -4,8 +4,6 @@
\section[CLabel]{@CLabel@: Information to make C Labels} \section[CLabel]{@CLabel@: Information to make C Labels}
\begin{code} \begin{code}
#include "HsVersions.h"
module CLabel ( module CLabel (
CLabel, -- abstract type CLabel, -- abstract type
...@@ -47,15 +45,11 @@ module CLabel ( ...@@ -47,15 +45,11 @@ module CLabel (
#endif #endif
) where ) where
IMP_Ubiq(){-uitous-}
#include "HsVersions.h"
#if ! OMIT_NATIVE_CODEGEN #if ! OMIT_NATIVE_CODEGEN
# if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl )
# else
import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl ) import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
# endif
#endif #endif
import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg ) import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg )
...@@ -64,16 +58,15 @@ import Id ( externallyVisibleId, cmpId_withSpecDataCon, ...@@ -64,16 +58,15 @@ import Id ( externallyVisibleId, cmpId_withSpecDataCon,
isDataCon, isDictFunId, isDataCon, isDictFunId,
isDefaultMethodId_maybe, isDefaultMethodId_maybe,
isSuperDictSelId_maybe, fIRST_TAG, isSuperDictSelId_maybe, fIRST_TAG,
SYN_IE(ConTag), GenId{-instance Outputable-}, ConTag, GenId{-instance Outputable-},
SYN_IE(Id) Id
) )
import Maybes ( maybeToBool ) import Maybes ( maybeToBool )
import Outputable ( Outputable(..), PprStyle(..) )
import PprType ( showTyCon, GenType{-instance Outputable-} ) import PprType ( showTyCon, GenType{-instance Outputable-} )
import TyCon ( TyCon{-instance Eq-} ) import TyCon ( TyCon{-instance Eq-} )
import Unique ( showUnique, pprUnique, Unique{-instance Eq-} ) import Unique ( showUnique, pprUnique, Unique{-instance Eq-} )
import Pretty import Util ( assertPanic{-, pprTraceToDo:rm-} )
import Util ( assertPanic{-, pprTraceToDo:rm-}, Ord3(..) ) import Outputable
\end{code} \end{code}
things we want to find out: things we want to find out:
...@@ -115,19 +108,16 @@ unspecialised constructors are compared. ...@@ -115,19 +108,16 @@ unspecialised constructors are compared.
\begin{code} \begin{code}
data CLabelId = CLabelId Id data CLabelId = CLabelId Id
instance Ord3 CLabelId where
cmp (CLabelId a) (CLabelId b) = cmpId_withSpecDataCon a b
instance Eq CLabelId where instance Eq CLabelId where
CLabelId a == CLabelId b = case (a `cmp` b) of { EQ_ -> True; _ -> False } CLabelId a == CLabelId b = case (a `compare` 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 -> False; _ -> True }
instance Ord CLabelId where 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 `compare` 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 `compare` 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 `compare` b) of { LT -> False; EQ -> True; GT -> True }
CLabelId a > CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } CLabelId a > CLabelId b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
_tagCmp (CLabelId a) (CLabelId b) = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } compare (CLabelId a) (CLabelId b) = a `cmpId_withSpecDataCon` b
\end{code} \end{code}
\begin{code} \begin{code}
...@@ -316,77 +306,82 @@ duplicate declarations in generating C (see @labelSeenTE@ in ...@@ -316,77 +306,82 @@ duplicate declarations in generating C (see @labelSeenTE@ in
\begin{code} \begin{code}
-- specialised for PprAsm: saves lots of arg passing in NCG -- specialised for PprAsm: saves lots of arg passing in NCG
#if ! OMIT_NATIVE_CODEGEN #if ! OMIT_NATIVE_CODEGEN
pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl) pprCLabel_asm = pprCLabel
#endif #endif
pprCLabel :: PprStyle -> CLabel -> Doc pprCLabel :: CLabel -> SDoc
pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u) pprCLabel (AsmTempLabel u)
= text (fmtAsmLbl (showUnique u)) = text (fmtAsmLbl (showUnique u))
pprCLabel (PprForAsm prepend_cSEP _) lbl pprCLabel lbl
= if prepend_cSEP = getPprStyle $ \ sty ->