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!
#define CAT2(a,b)a/**/b
#endif
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ == 201
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 202
# define REALLY_HASKELL_1_3
# define SYN_IE(a) a
# define EXP_MODULE(a) module a
# define IMPORT_DELOOPER(mod) import mod
# define IMPORT_1_3(mod) import mod
# define _tagCmp compare
# define _LT LT
# define _EQ EQ
# define _GT GT
# define _Addr GHCbase.Addr
# define _ByteArray GHCbase.ByteArray
# define _MutableByteArray GHCbase.MutableByteArray
# define _MutableArray GHCbase.MutableArray
# define _RealWorld GHCbase.RealWorld
# define _ST GHCbase.ST
# define _ForeignObj GHCbase.ForeignObj
# define _runST STbase.runST
# define failWith fail
# define MkST ST
# define STATE_TOK(x) (S# x)
# define ST_RET(x,y) (x,y)
# define unsafePerformST(x) unsafePerformPrimIO (x)
# define ST_TO_PrimIO(x) x
# define MkIOError(h,errt,msg) (errt msg)
# define Text Show
# define IMP_FASTSTRING()
# define IMP_Ubiq() IMPORT_DELOOPER(Ubiq); import qualified GHCbase
# define CHK_Ubiq() IMPORT_DELOOPER(Ubiq); import qualified GHCbase
# define minInt (minBound::Int)
# define maxInt (maxBound::Int)
#elif defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 202
# define REALLY_HASKELL_1_3
# define SYN_IE(a) a
# define EXP_MODULE(a) module a
# define IMPORT_DELOOPER(mod) import mod
# define IMPORT_1_3(mod) import mod
# define _CMP_TAG Ordering
# define _tagCmp compare
# define _LT LT
# define _EQ EQ
# define _GT GT
# define _Addr GlaExts.Addr
# define _Addr Addr
# define _ByteArray GlaExts.ByteArray
# define _MutableByteArray GlaExts.MutableByteArray
# define _MutableArray GlaExts.MutableArray
......@@ -126,37 +90,19 @@ you will screw up the layout where they are used in case expressions!
# define MkIOError(h,errt,msg) (errt msg)
#endif
#if __GLASGOW_HASKELL__ >= 26 && __GLASGOW_HASKELL__ < 200
#define trace _trace
#endif
#if defined(__GLASGOW_HASKELL__)
#define TAG_ Int#
#define LT_ -1#
#define EQ_ 0#
#define GT_ 1#
#define GT__ _
-- Import the beggars
import GlaExts ( Int(..), Int#, (+#), (-#), (*#),
quotInt#, negateInt#, (==#), (<#), (<=#), (>=#), (>#)
)
#if defined(__GLASGOW_HASKELL__)
#define FAST_INT Int#
#define ILIT(x) (x#)
#define IBOX(x) (I# (x))
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
#define _ADD_ `plusInt#`
#define _SUB_ `minusInt#`
#define _MUL_ `timesInt#`
#define _DIV_ `divInt#`
#define _QUOT_ `quotInt#`
#define _NEG_ negateInt#
#define _EQ_ `eqInt#`
#define _LT_ `ltInt#`
#define _LE_ `leInt#`
#define _GE_ `geInt#`
#define _GT_ `gtInt#`
#else
#define _ADD_ +#
#define _SUB_ -#
#define _MUL_ *#
#define _DIV_ /#
#define _QUOT_ `quotInt#`
#define _NEG_ negateInt#
#define _EQ_ ==#
......@@ -164,7 +110,6 @@ you will screw up the layout where they are used in case expressions!
#define _LE_ <=#
#define _GE_ >=#
#define _GT_ >#
#endif
#define FAST_BOOL Int#
#define _TRUE_ 1#
......@@ -196,45 +141,29 @@ you will screw up the layout where they are used in case expressions!
#endif {- ! __GLASGOW_HASKELL__ -}
#if __GLASGOW_HASKELL__ >= 23
-- This #ifndef lets us switch off the "import FastString"
-- when compiling FastString itself
#ifndef COMPILING_FAST_STRING
--
import FastString ( FastString, mkFastString, mkFastCharString#, nullFastString,
consFS, headFS, tailFS, lengthFS, unpackFS, appendFS, concatFS
)
#endif
# define USE_FAST_STRINGS 1
# if __GLASGOW_HASKELL__ < 200 || __GLASGOW_HASKELL__ >= 202
# define FAST_STRING FastString {-_PackedString -}
# if __GLASGOW_HASKELL__ < 200
# define SLIT(x) (mkFastCharString (A# (x#)))
# elif __GLASGOW_HASKELL__ < 209
# define SLIT(x) (mkFastCharString (GlaExts.A# (x#)))
# else
# define SLIT(x) (mkFastCharString (Addr.A# (x#)))
# endif
# define _CMP_STRING_ cmpPString
/* cmpPString defined in utils/Util.lhs */
# define _NULL_ nullFastString {-_nullPS-}
# define _NIL_ (mkFastString "") {-_nilPS -}
# define _CONS_ consFS {-_consPS-}
# define _HEAD_ headFS {-_headPS-}
# define _TAIL_ tailFS {-_tailPS-}
# define _LENGTH_ lengthFS {-_lengthPS-}
# define _PK_ mkFastString {-_packString-}
# define _UNPK_ unpackFS {-_unpackPS-}
/* # define _SUBSTR_ _substrPS */
# define _APPEND_ `appendFS` {-`_appendPS`-}
# define _CONCAT_ concatFS {-_concatPS-}
# else
# define FAST_STRING GHCbase.PackedString
# define SLIT(x) (packCString (GHCbase.A# x#))
# define _CMP_STRING_ cmpPString
# define _NULL_ nullPS
# define _NIL_ nilPS
# define _CONS_ consPS
# define _HEAD_ headPS
# define _TAIL_ tailPS
# define _LENGTH_ lengthPS
# define _PK_ packString
# define _UNPK_ unpackPS
# define _SUBSTR_ substrPS
# define _APPEND_ `appendPS`
# define _CONCAT_ concatPS
# endif
# define FAST_STRING FastString
# define SLIT(x) (mkFastCharString# (x#))
# define _NULL_ nullFastString
# define _NIL_ (mkFastString "")
# define _CONS_ consFS
# define _HEAD_ headFS
# define _TAIL_ tailFS
# define _LENGTH_ lengthFS
# define _PK_ mkFastString
# define _UNPK_ unpackFS
# define _APPEND_ `appendFS`
# define _CONCAT_ concatFS
#else
# define FAST_STRING String
# define SLIT(x) (x)
......
......@@ -31,6 +31,13 @@ LIBRARY=libhsp.a
HS_PROG=hsc
# -----------------------------------------------------------------------------
# Compilation history for Patrick
# Make the sources first, because that's what the compilation history needs
$(HS_PROG) :: $(HS_SRCS)
# -----------------------------------------------------------------------------
# Set SRCS, LOOPS, HCS, OBJS
#
......@@ -53,7 +60,7 @@ endif
HS_SRCS = $(SRCS_UGNHS) \
$(foreach dir,$(DIRS),$(wildcard $(dir)/*.lhs)) \
rename/ParseIface.hs rename/ParseType.hs rename/ParseUnfolding.hs
rename/ParseIface.hs
ifneq "$(Ghc2_0)" "YES"
HS_SRCS += main/LoopHack.hc
......@@ -104,7 +111,7 @@ LIBOBJS = \
#
# stuff you get for free in a source distribution
#
SRC_DIST_FILES += \
SRC_DIST_FILES += rename/ParseIface.hs \
parser/U_tree.c parser/tree.h parser/tree.c \
parser/hsparser.tab.c parser/hsparser.tab.h \
parser/hslexer.c
......@@ -148,6 +155,10 @@ SRC_HC_OPTS += $(GhcHcOpts)
absCSyn/AbsCSyn_HC_OPTS = -fno-omit-reexported-instances
absCSyn/CStrings_HC_OPTS = -monly-3-regs
# Was 6m with 2.10
absCSyn/PprAbsC_HC_OPTS = -H10m
basicTypes/IdInfo_HC_OPTS = -K2m
coreSyn/AnnCoreSyn_HC_OPTS = -fno-omit-reexported-instances
hsSyn/HsExpr_HC_OPTS = -K2m
......@@ -172,14 +183,13 @@ parser/U_tree_HC_OPTS = -H12m -fvia-C '-\#include"hspincl.h"'
parser/U_ttype_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
prelude/PrimOp_HC_OPTS = -H12m -K3m
reader/Lex_HC_OPTS = -K2m -H16m -fvia-C
reader/ReadPrefix_HC_OPTS = -fvia-C '-\#include"hspincl.h"'
rename/ParseIface_HC_OPTS += -Onot -H16m
rename/ParseType_HC_OPTS += -Onot -H16m
rename/ParseUnfolding_HC_OPTS += -Onot -H30m
# Heap was 6m with 2.10
reader/ReadPrefix_HC_OPTS = -fvia-C '-\#include"hspincl.h"' -H10m
rename/ParseIface_HC_OPTS += -Onot -H30m
ifeq "$(Ghc2_0)" "YES"
rename/ParseIface_HC_OPTS += -fno-warn-incomplete-patterns
rename/ParseType_HC_OPTS += -fno-warn-incomplete-patterns
rename/ParseUnfolding_HC_OPTS += -fno-warn-incomplete-patterns
endif
ifeq "$(TARGETPLATFORM)" "hppa1.1-hp-hpux9"
......@@ -192,6 +202,7 @@ endif
rename/RnEnv_HC_OPTS = -fvia-C
rename/RnSource_HC_OPTS = -H12m
rename/RnIfaces_HC_OPTS = -H8m -fvia-C
rename/RnExpr_HC_OPTS = -H10m
rename/RnNames_HC_OPTS = -H12m
rename/RnMonad_HC_OPTS = -fvia-C
# Urk! Really big heap for ParseUnfolding
......@@ -199,8 +210,13 @@ rename/RnMonad_HC_OPTS = -fvia-C
specialise/Specialise_HC_OPTS = -Onot -H12m
stgSyn/StgSyn_HC_OPTS = -fno-omit-reexported-instances
typecheck/TcGenDeriv_HC_OPTS = -H10m
typecheck/TcHsSyn_HC_OPTS = -H10m
typecheck/TcExpr_HC_OPTS = -H10m
# Was 10m for 2.10
typecheck/TcHsSyn_HC_OPTS = -H15m
# Was 10m for 2.10
typecheck/TcExpr_HC_OPTS = -H15m
typecheck/TcEnv_HC_OPTS = -H10m
ifeq "$(Ghc2_0)" "NO"
typecheck/TcMonad_HC_OPTS = -fvia-C
......@@ -258,16 +274,6 @@ rename/ParseIface.hs : rename/ParseIface.y
$(HAPPY) $(HAPPY_OPTS) -g rename/ParseIface.y
@chmod 444 rename/ParseIface.hs
rename/ParseType.hs : rename/ParseType.y
@$(RM) rename/ParseType.hs rename/ParseType.hinfo
$(HAPPY) $(HAPPY_OPTS) -g rename/ParseType.y
@chmod 444 rename/ParseType.hs
rename/ParseUnfolding.hs : rename/ParseUnfolding.y
@$(RM) rename/ParseUnfolding.hs rename/ParseUnfolding.hinfo
$(HAPPY) $(HAPPY_OPTS) -g rename/ParseUnfolding.y
@chmod 444 rename/ParseUnfolding.hs
#----------------------------------------------------------------------
#
# Building the stand-alone parser
......@@ -332,7 +338,7 @@ endif
#
# Before doing `make depend', need to build all derived Haskell source files
#
depend :: $(LOOPS) $(SRCS_UGNHS) rename/ParseIface.hs rename/ParseUnfolding.hs rename/ParseType.hs
depend :: $(LOOPS) $(SRCS_UGNHS) rename/ParseIface.hs
ifeq "$(GhcWithHscBuiltViaC)" "YES"
......
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
raw assembler/machine code.
\begin{code}
#include "HsVersions.h"
module AbsCSyn {- (
-- export everything
AbstractC(..),
......@@ -35,15 +33,13 @@ module AbsCSyn {- (
CostRes(Cost)
)-} where
IMP_Ubiq(){-uitous-}
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
IMPORT_DELOOPER(AbsCLoop)
#else
# if ! OMIT_NATIVE_CODEGEN
import {-# SOURCE #-} MachMisc
# endif
#include "HsVersions.h"
import {-# SOURCE #-} ClosureInfo ( ClosureInfo )
import {-# SOURCE #-} CLabel ( CLabel )
#if ! OMIT_NATIVE_CODEGEN
import {-# SOURCE #-} MachMisc
#endif
import Constants ( mAX_Vanilla_REG, mAX_Float_REG,
......@@ -51,8 +47,8 @@ import Constants ( mAX_Vanilla_REG, mAX_Float_REG,
lIVENESS_R3, lIVENESS_R4, lIVENESS_R5,
lIVENESS_R6, lIVENESS_R7, lIVENESS_R8
)
import HeapOffs ( SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset),
SYN_IE(VirtualHeapOffset), HeapOffset
import HeapOffs ( VirtualSpAOffset, VirtualSpBOffset,
VirtualHeapOffset, HeapOffset
)
import CostCentre ( CostCentre )
import Literal ( mkMachInt, Literal )
......
......@@ -4,8 +4,6 @@
\section[AbsCUtils]{Help functions for Abstract~C datatype}
\begin{code}
#include "HsVersions.h"
module AbsCUtils (
nonemptyAbsC,
mkAbstractCs, mkAbsCStmts,
......@@ -19,24 +17,21 @@ module AbsCUtils (
-- printing/forcing stuff comes from PprAbsC
) where
IMP_Ubiq(){-uitous-}
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 200
import AbsCLoop (mkReturnPtLabel, CLabel )
#else
#include "HsVersions.h"
import {-# SOURCE #-} CLabel ( mkReturnPtLabel, CLabel )
-- The loop here is (CLabel -> CgRetConv -> AbsCUtils -> CLabel)
#endif
import AbsCSyn
import Digraph ( stronglyConnComp, SCC(..) )
import HeapOffs ( possiblyEqualHeapOffset )
import Id ( fIRST_TAG, SYN_IE(ConTag) )
import Id ( fIRST_TAG, ConTag )
import Literal ( literalPrimRep, Literal(..) )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import Unique ( Unique{-instance Eq-} )
import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
import Util ( assocDefaultUsing, panic, Ord3(..) )
import Util ( assocDefaultUsing, panic )
infixr 9 `thenFlt`
\end{code}
......
......@@ -4,8 +4,6 @@
\section[CLabel]{@CLabel@: Information to make C Labels}
\begin{code}
#include "HsVersions.h"
module CLabel (
CLabel, -- abstract type
......@@ -47,15 +45,11 @@ module CLabel (
#endif
) where
IMP_Ubiq(){-uitous-}
#include "HsVersions.h"
#if ! OMIT_NATIVE_CODEGEN
# if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl )
# else
import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
# endif
#endif
import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg )
......@@ -64,16 +58,15 @@ import Id ( externallyVisibleId, cmpId_withSpecDataCon,
isDataCon, isDictFunId,
isDefaultMethodId_maybe,
isSuperDictSelId_maybe, fIRST_TAG,
SYN_IE(ConTag), GenId{-instance Outputable-},
SYN_IE(Id)
ConTag, GenId{-instance Outputable-},
Id
)
import Maybes ( maybeToBool )
import Outputable ( Outputable(..), PprStyle(..) )
import PprType ( showTyCon, GenType{-instance Outputable-} )
import TyCon ( TyCon{-instance Eq-} )
import Unique ( showUnique, pprUnique, Unique{-instance Eq-} )
import Pretty
import Util ( assertPanic{-, pprTraceToDo:rm-}, Ord3(..) )
import Util ( assertPanic{-, pprTraceToDo:rm-} )
import Outputable
\end{code}
things we want to find out:
......@@ -115,19 +108,16 @@ unspecialised constructors are compared.
\begin{code}
data CLabelId = CLabelId Id
instance Ord3 CLabelId where
cmp (CLabelId a) (CLabelId b) = cmpId_withSpecDataCon a b
instance Eq CLabelId where
CLabelId a == CLabelId b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
CLabelId a /= CLabelId b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
CLabelId a == CLabelId b = case (a `compare` b) of { EQ -> True; _ -> False }
CLabelId a /= CLabelId b = case (a `compare` b) of { EQ -> False; _ -> True }
instance Ord CLabelId where
CLabelId a <= CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
CLabelId a < CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
CLabelId a >= CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
CLabelId a > CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
_tagCmp (CLabelId a) (CLabelId b) = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
CLabelId a <= CLabelId b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
CLabelId a < CLabelId b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
CLabelId a >= CLabelId b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
CLabelId a > CLabelId b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
compare (CLabelId a) (CLabelId b) = a `cmpId_withSpecDataCon` b
\end{code}
\begin{code}
......@@ -316,77 +306,82 @@ duplicate declarations in generating C (see @labelSeenTE@ in
\begin{code}
-- specialised for PprAsm: saves lots of arg passing in NCG
#if ! OMIT_NATIVE_CODEGEN
pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl)
pprCLabel_asm = pprCLabel
#endif
pprCLabel :: PprStyle -> CLabel -> Doc
pprCLabel :: CLabel -> SDoc
pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u)
pprCLabel (AsmTempLabel u)
= text (fmtAsmLbl (showUnique u))
pprCLabel (PprForAsm prepend_cSEP _) lbl
= if prepend_cSEP
then (<>) pp_cSEP prLbl
else prLbl
where
prLbl = pprCLabel PprForC lbl
pprCLabel lbl
= getPprStyle $ \ sty ->
if asmStyle sty && underscorePrefix then
pp_cSEP <> pprCLbl lbl
else
pprCLbl lbl
pprCLabel sty (TyConLabel tc UnvecConUpdCode)
= hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc,
pprCLbl (TyConLabel tc UnvecConUpdCode)
= hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon tc,
pp_cSEP, ptext SLIT("upd")]
pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
= hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP,
pprCLbl (TyConLabel tc (VecConUpdCode tag))
= hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon tc, pp_cSEP,
int tag, pp_cSEP, ptext SLIT("upd")]
pprCLabel sty (TyConLabel tc (StdUpdCode tag))
pprCLbl (TyConLabel tc (StdUpdCode tag))
= case (ctrlReturnConvAlg tc) of
UnvectoredReturn _ -> ptext SLIT("IndUpdRetDir")
VectoredReturn _ -> (<>) (ptext SLIT("IndUpdRetV")) (int (tag - fIRST_TAG))
pprCLabel sty (TyConLabel tc InfoTblVecTbl)
= hcat [ppr_tycon sty tc, pp_cSEP, ptext SLIT("itblvtbl")]
pprCLbl (TyConLabel tc InfoTblVecTbl)
= hcat [ppr_tycon tc, pp_cSEP, ptext SLIT("itblvtbl")]
pprCLabel sty (TyConLabel tc StdUpdVecTbl)
= hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc,
pprCLbl (TyConLabel tc StdUpdVecTbl)
= hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon tc,
pp_cSEP, ptext SLIT("upd")]
pprCLabel sty (CaseLabel u CaseReturnPt)
pprCLbl (CaseLabel u CaseReturnPt)
= hcat [ptext SLIT("ret"), pp_cSEP, ppr_u u]
pprCLabel sty (CaseLabel u CaseVecTbl)
pprCLbl (CaseLabel u CaseVecTbl)
= hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_u u]
pprCLabel sty (CaseLabel u (CaseAlt tag))
pprCLbl (CaseLabel u (CaseAlt tag))
= hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, int tag]
pprCLabel sty (CaseLabel u CaseDefault)
pprCLbl (CaseLabel u CaseDefault)
= hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u]
pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("StdErrorCode")
pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("StdErrorCode")
pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info")
pprCLbl (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info")
pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
= hcat [ptext SLIT("__sel_info_"), text (show offset),
ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
ptext SLIT("__")]
pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset))
pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
= hcat [ptext SLIT("__sel_entry_"), text (show offset),
ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")),
ptext SLIT("__")]
pprCLabel sty (IdLabel (CLabelId id) flavor)
= (<>) (ppr sty id) (ppFlavor flavor)
pprCLbl (IdLabel (CLabelId id) flavor)
= ppr id <> ppFlavor flavor
ppr_u u = pprUnique u
ppr_tycon sty tc
ppr_tycon :: TyCon -> SDoc
ppr_tycon tc = ppr tc
{-
= let
str = showTyCon sty tc
str = showTyCon tc
in
--pprTrace "ppr_tycon:" (text str) $
text str
-}
ppFlavor :: IdLabelInfo -> Doc
ppFlavor :: IdLabelInfo -> SDoc
ppFlavor x = (<>) pp_cSEP
(case x of
......
This module deals with printing (a) C string literals and (b) C labels.
\begin{code}
#include "HsVersions.h"
module CStrings(
cSEP,
......@@ -14,14 +12,10 @@ module CStrings(
) where
IMPORT_1_3(Char (isAlphanum,ord,chr))
CHK_Ubiq() -- debugging consistency check
import Pretty
#if __GLASGOW_HASKELL__ >= 209
import Addr
#endif
#include "HsVersions.h"
import Char ( isAlphanum, ord, chr )
import Outputable
\end{code}
......@@ -42,7 +36,7 @@ Prelude<x> ZP<x>
cSEP = SLIT("_") -- official C separator
pp_cSEP = char '_'
identToC :: FAST_STRING -> Doc
identToC :: FAST_STRING -> SDoc
modnameToC :: FAST_STRING -> FAST_STRING
stringToC :: String -> String
charToC, charToEasyHaskell :: Char -> String
......
......@@ -44,8 +44,6 @@ These are first suggestions for scaling the costs. But, this scaling should be d