Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
dcef38ba
Commit
dcef38ba
authored
May 19, 1997
by
sof
Browse files
[project @ 1997-05-19 00:12:10 by sof]
2.04 changes
parent
f1815aa4
Changes
158
Expand all
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/absCSyn/AbsCLoop.hs
0 → 100644
View file @
dcef38ba
module
AbsCLoop
(
module
MachMisc
,
module
CLabel
,
module
ClosureInfo
,
module
CgRetConv
)
where
import
MachMisc
import
CLabel
import
ClosureInfo
import
CgRetConv
ghc/compiler/absCSyn/AbsCSyn.lhs
View file @
dcef38ba
...
...
@@ -36,6 +36,7 @@ module AbsCSyn {- (
)-} where
IMP_Ubiq(){-uitous-}
IMPORT_DELOOPER(AbsCLoop)
import Constants ( mAX_Vanilla_REG, mAX_Float_REG,
mAX_Double_REG, lIVENESS_R1, lIVENESS_R2,
...
...
@@ -43,10 +44,15 @@ import Constants ( mAX_Vanilla_REG, mAX_Float_REG,
lIVENESS_R6, lIVENESS_R7, lIVENESS_R8
)
import HeapOffs ( SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset),
SYN_IE(VirtualHeapOffset)
SYN_IE(VirtualHeapOffset)
, HeapOffset
)
import Literal ( mkMachInt )
import CLabel ( CLabel )
import CostCentre ( CostCentre )
import Literal ( mkMachInt, Literal )
import PrimRep ( isFollowableRep, PrimRep(..) )
import PrimOp ( PrimOp )
import Unique ( Unique )
\end{code}
@AbstractC@ is a list of Abstract~C statements, but the data structure
...
...
ghc/compiler/absCSyn/AbsCUtils.lhs
View file @
dcef38ba
...
...
@@ -23,15 +23,15 @@ IMP_Ubiq(){-uitous-}
import AbsCSyn
import CLabel ( mkReturnPtLabel )
import Digraph ( stronglyConnComp )
import CLabel ( mkReturnPtLabel
, CLabel
)
import Digraph ( stronglyConnComp
, SCC(..)
)
import HeapOffs ( possiblyEqualHeapOffset )
import Id ( fIRST_TAG, SYN_IE(ConTag) )
import Literal ( literalPrimRep, Literal(..) )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import Unique ( Unique{-instance Eq-} )
import UniqSupply ( getUnique, getUniques, splitUniqSupply )
import Util (
panic
)
import UniqSupply ( getUnique, getUniques, splitUniqSupply
, UniqSupply
)
import Util (
assocDefaultUsing, panic, Ord3(..)
)
infixr 9 `thenFlt`
\end{code}
...
...
@@ -628,38 +628,22 @@ sameAmode other1 other2 = False
doSimultaneously1 :: [CVertex] -> FlatM AbstractC
doSimultaneously1 vertices
= let
edges :: [CEdge]
edges = concat (map edges_from vertices)
edges_from :: CVertex -> [CEdge]
edges_from v1 = [(v1,v2) | v2 <- vertices, v1 `should_follow` v2]
should_follow :: CVertex -> CVertex -> Bool
(n1, CAssign dest1 _) `should_follow` (n2, CAssign _ src2)
= dest1 `conflictsWith` src2
(n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, CAssign _ src2)
= or [dest1 `conflictsWith` src2 | dest1 <- dests1]
(n1, CAssign dest1 _)`should_follow` (n2, COpStmt _ _ srcs2 _ _)
= or [dest1 `conflictsWith` src2 | src2 <- srcs2]
(n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, COpStmt _ _ srcs2 _ _)
= or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
-- (_, COpStmt _ _ _ _ _) `should_follow` (_, CCallProfCtrMacro _ _) = False
-- (_, CCallProfCtrMacro _ _) `should_follow` (_, COpStmt _ _ _ _ _) = False
eq_vertex :: CVertex -> CVertex -> Bool
(n1, _) `eq_vertex` (n2, _) = n1 == n2
components = stronglyConnComp eq_vertex edges vertices
edges = [ (vertex, key1, edges_from stmt1)
| vertex@(key1, stmt1) <- vertices
]
edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
stmt1 `should_follow` stmt2
]
components = stronglyConnComp edges
-- do_components deal with one strongly-connected component
do_component :: [CVertex] -> FlatM AbstractC
-- A singleton? Then just do it.
do_component [(n,abs_c)] = returnFlt abs_c
-- Not cyclic, or singleton? Just do it
do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c
do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
-- Two or more? Then go via temporaries.
do_component ((n,first_stmt):rest)
-- Cyclic? Then go via temporaries. Pick one to
-- break the loop and try again with the rest.
do_component (CyclicSCC ((n,first_stmt) : rest))
= doSimultaneously1 rest `thenFlt` \ abs_cs ->
go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
...
...
@@ -681,6 +665,22 @@ doSimultaneously1 vertices
in
mapFlt do_component components `thenFlt` \ abs_cs ->
returnFlt (mkAbstractCs abs_cs)
where
should_follow :: AbstractC -> AbstractC -> Bool
(CAssign dest1 _) `should_follow` (CAssign _ src2)
= dest1 `conflictsWith` src2
(COpStmt dests1 _ _ _ _) `should_follow` (CAssign _ src2)
= or [dest1 `conflictsWith` src2 | dest1 <- dests1]
(CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _ _)
= or [dest1 `conflictsWith` src2 | src2 <- srcs2]
(COpStmt dests1 _ _ _ _) `should_follow` (COpStmt _ _ srcs2 _ _)
= or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
-- (COpStmt _ _ _ _ _) `should_follow` (CCallProfCtrMacro _ _) = False
-- (CCallProfCtrMacro _ _) `should_follow` (COpStmt _ _ _ _ _) = False
\end{code}
...
...
ghc/compiler/absCSyn/CLabel.hi-boot
0 → 100644
View file @
dcef38ba
_interface_ CLabel 1
_exports_
CLabel CLabel;
_declarations_
1 data CLabel;
ghc/compiler/absCSyn/CLabel.lhs
View file @
dcef38ba
...
...
@@ -61,16 +61,20 @@ import Id ( externallyVisibleId, cmpId_withSpecDataCon,
isConstMethodId_maybe,
isDefaultMethodId_maybe,
isSuperDictSelId_maybe, fIRST_TAG,
SYN_IE(ConTag), GenId{-instance Outputable-}
SYN_IE(ConTag), GenId{-instance Outputable-},
SYN_IE(Id)
)
import Maybes ( maybeToBool )
import PprStyle ( PprStyle(..) )
import PprType ( showTyCon, GenType{-instance Outputable-} )
import Pretty ( prettyToUn{-, ppPStr ToDo:rm-} )
import TyCon ( TyCon{-instance Eq-} )
import Unique ( showUnique, pprUnique, Unique{-instance Eq-} )
import Unpretty -- NOTE!! ********************
import Util ( assertPanic{-, pprTraceToDo:rm-} )
import Pretty
import Util ( assertPanic{-, pprTraceToDo:rm-}, Ord3(..) )
#if __GLASGOW_HASKELL__ >= 202
import Outputable ( Outputable(..) )
#endif
\end{code}
things we want to find out:
...
...
@@ -316,92 +320,92 @@ duplicate declarations in generating C (see @labelSeenTE@ in
pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl)
#endif
pprCLabel :: PprStyle -> CLabel ->
Unpretty
pprCLabel :: PprStyle -> CLabel ->
Doc
pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u)
=
uppStr
(fmtAsmLbl (_UNPK_ (showUnique u)))
=
text
(fmtAsmLbl (_UNPK_ (showUnique u)))
pprCLabel (PprForAsm prepend_cSEP _) lbl
= if prepend_cSEP
then
uppBeside
pp_cSEP prLbl
then
(<>)
pp_cSEP prLbl
else prLbl
where
prLbl = pprCLabel PprForC lbl
pprCLabel sty (TyConLabel tc UnvecConUpdCode)
=
uppBesides [uppPStr
SLIT("ret"), pp_cSEP, ppr_tycon sty tc,
pp_cSEP,
uppPStr
SLIT("upd")]
=
hcat [ptext
SLIT("ret"), pp_cSEP, ppr_tycon sty tc,
pp_cSEP,
ptext
SLIT("upd")]
pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
=
uppBesides [uppPStr
SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP,
uppI
nt tag, pp_cSEP,
uppPStr
SLIT("upd")]
=
hcat [ptext
SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP,
i
nt tag, pp_cSEP,
ptext
SLIT("upd")]
pprCLabel sty (TyConLabel tc (StdUpdCode tag))
= case (ctrlReturnConvAlg tc) of
UnvectoredReturn _ ->
uppPStr
SLIT("IndUpdRetDir")
VectoredReturn _ ->
uppBeside (uppPStr
SLIT("IndUpdRetV")) (
uppI
nt (tag - fIRST_TAG))
UnvectoredReturn _ ->
ptext
SLIT("IndUpdRetDir")
VectoredReturn _ ->
(<>) (ptext
SLIT("IndUpdRetV")) (
i
nt (tag - fIRST_TAG))
pprCLabel sty (TyConLabel tc InfoTblVecTbl)
=
uppBesides
[ppr_tycon sty tc, pp_cSEP,
uppPStr
SLIT("itblvtbl")]
=
hcat
[ppr_tycon sty tc, pp_cSEP,
ptext
SLIT("itblvtbl")]
pprCLabel sty (TyConLabel tc StdUpdVecTbl)
=
uppBesides [uppPStr
SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc,
pp_cSEP,
uppPStr
SLIT("upd")]
=
hcat [ptext
SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc,
pp_cSEP,
ptext
SLIT("upd")]
pprCLabel sty (CaseLabel u CaseReturnPt)
=
uppBesides [uppPStr
SLIT("ret"), pp_cSEP, ppr_u u]
=
hcat [ptext
SLIT("ret"), pp_cSEP, ppr_u u]
pprCLabel sty (CaseLabel u CaseVecTbl)
=
uppBesides [uppPStr
SLIT("vtbl"), pp_cSEP, ppr_u u]
=
hcat [ptext
SLIT("vtbl"), pp_cSEP, ppr_u u]
pprCLabel sty (CaseLabel u (CaseAlt tag))
=
uppBesides [uppPStr
SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP,
uppI
nt tag]
=
hcat [ptext
SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP,
i
nt tag]
pprCLabel sty (CaseLabel u CaseDefault)
=
uppBesides [uppPStr
SLIT("djn"), pp_cSEP, ppr_u u]
=
hcat [ptext
SLIT("djn"), pp_cSEP, ppr_u u]
pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) =
uppPStr
SLIT("StdErrorCode")
pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) =
ptext
SLIT("StdErrorCode")
pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) =
uppPStr
SLIT("BH_UPD_info")
pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) =
ptext
SLIT("BH_UPD_info")
pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
=
uppBesides [uppPStr
SLIT("__sel_info_"),
uppStr
(show offset),
uppPStr
(if upd_reqd then SLIT("upd") else SLIT("noupd")),
uppPStr
SLIT("__")]
=
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))
=
uppBesides [uppPStr
SLIT("__sel_entry_"),
uppStr
(show offset),
uppPStr
(if upd_reqd then SLIT("upd") else SLIT("noupd")),
uppPStr
SLIT("__")]
=
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)
=
uppBeside (prettyToUn
(ppr sty id)
)
(ppFlavor flavor)
=
(<>)
(ppr sty id) (ppFlavor flavor)
ppr_u u =
prettyToUn (
pprUnique u
)
ppr_u u = pprUnique u
ppr_tycon sty tc
= let
str = showTyCon sty tc
in
--pprTrace "ppr_tycon:" (
ppStr
str) $
uppStr
str
--pprTrace "ppr_tycon:" (
text
str) $
text
str
ppFlavor :: IdLabelInfo ->
Unpretty
ppFlavor :: IdLabelInfo ->
Doc
ppFlavor x =
uppBeside
pp_cSEP
ppFlavor x =
(<>)
pp_cSEP
(case x of
Closure ->
uppPStr
SLIT("closure")
InfoTbl ->
uppPStr
SLIT("info")
EntryStd ->
uppPStr
SLIT("entry")
Closure ->
ptext
SLIT("closure")
InfoTbl ->
ptext
SLIT("info")
EntryStd ->
ptext
SLIT("entry")
EntryFast arity -> --false:ASSERT (arity > 0)
uppBeside (uppPStr
SLIT("fast")) (
uppI
nt arity)
StaticClosure ->
uppPStr
SLIT("static_closure")
ConEntry ->
uppPStr
SLIT("con_entry")
ConInfoTbl ->
uppPStr
SLIT("con_info")
StaticConEntry ->
uppPStr
SLIT("static_entry")
StaticInfoTbl ->
uppPStr
SLIT("static_info")
PhantomInfoTbl ->
uppPStr
SLIT("inregs_info")
VapInfoTbl True ->
uppPStr
SLIT("vap_info")
VapInfoTbl False ->
uppPStr
SLIT("vap_noupd_info")
VapEntry True ->
uppPStr
SLIT("vap_entry")
VapEntry False ->
uppPStr
SLIT("vap_noupd_entry")
RednCounts ->
uppPStr
SLIT("ct")
(<>) (ptext
SLIT("fast")) (
i
nt arity)
StaticClosure ->
ptext
SLIT("static_closure")
ConEntry ->
ptext
SLIT("con_entry")
ConInfoTbl ->
ptext
SLIT("con_info")
StaticConEntry ->
ptext
SLIT("static_entry")
StaticInfoTbl ->
ptext
SLIT("static_info")
PhantomInfoTbl ->
ptext
SLIT("inregs_info")
VapInfoTbl True ->
ptext
SLIT("vap_info")
VapInfoTbl False ->
ptext
SLIT("vap_noupd_info")
VapEntry True ->
ptext
SLIT("vap_entry")
VapEntry False ->
ptext
SLIT("vap_noupd_entry")
RednCounts ->
ptext
SLIT("ct")
)
\end{code}
ghc/compiler/absCSyn/CStrings.lhs
View file @
dcef38ba
...
...
@@ -17,13 +17,8 @@ module CStrings(
CHK_Ubiq() -- debugging consistency check
import Pretty
import Unpretty( uppChar )
IMPORT_1_3(Char (isAlphanum))
#ifdef REALLY_HASKELL_1_3
ord = fromEnum :: Char -> Int
chr = toEnum :: Int -> Char
#endif
IMPORT_1_3(Char (isAlphanum,ord,chr))
\end{code}
...
...
@@ -42,9 +37,9 @@ Prelude<x> ZP<x>
\begin{code}
cSEP = SLIT("_") -- official C separator
pp_cSEP =
uppC
har '_'
pp_cSEP =
c
har '_'
identToC :: FAST_STRING ->
Pretty
identToC :: FAST_STRING ->
Doc
modnameToC :: FAST_STRING -> FAST_STRING
stringToC :: String -> String
charToC, charToEasyHaskell :: Char -> String
...
...
@@ -105,36 +100,36 @@ identToC ps
= let
str = _UNPK_ ps
in
ppBeside
(<>)
(case str of
's':'t':'d':_ -> -- avoid "stdin", "stdout", and "stderr"...
ppC
har 'Z'
_ ->
ppNil
)
c
har 'Z'
_ ->
empty
)
(if (all isAlphanum str) -- we gamble that this test will succeed...
then p
pPStr
ps
else
ppIntersperse ppNil
(map char_to_c str))
then p
text
ps
else
hcat
(map char_to_c str))
where
char_to_c 'Z' = p
pPStr
SLIT("ZZ")
char_to_c '&' = p
pPStr
SLIT("Za")
char_to_c '|' = p
pPStr
SLIT("Zb")
char_to_c ':' = p
pPStr
SLIT("Zc")
char_to_c '/' = p
pPStr
SLIT("Zd")
char_to_c '=' = p
pPStr
SLIT("Ze")
char_to_c '>' = p
pPStr
SLIT("Zg")
char_to_c '#' = p
pPStr
SLIT("Zh")
char_to_c '<' = p
pPStr
SLIT("Zl")
char_to_c '-' = p
pPStr
SLIT("Zm")
char_to_c '!' = p
pPStr
SLIT("Zn")
char_to_c '.' = p
pPStr
SLIT("_")
char_to_c '+' = p
pPStr
SLIT("Zp")
char_to_c '\'' = p
pPStr
SLIT("Zq")
char_to_c '*' = p
pPStr
SLIT("Zt")
char_to_c '_' = p
pPStr
SLIT("Zu")
char_to_c 'Z' = p
text
SLIT("ZZ")
char_to_c '&' = p
text
SLIT("Za")
char_to_c '|' = p
text
SLIT("Zb")
char_to_c ':' = p
text
SLIT("Zc")
char_to_c '/' = p
text
SLIT("Zd")
char_to_c '=' = p
text
SLIT("Ze")
char_to_c '>' = p
text
SLIT("Zg")
char_to_c '#' = p
text
SLIT("Zh")
char_to_c '<' = p
text
SLIT("Zl")
char_to_c '-' = p
text
SLIT("Zm")
char_to_c '!' = p
text
SLIT("Zn")
char_to_c '.' = p
text
SLIT("_")
char_to_c '+' = p
text
SLIT("Zp")
char_to_c '\'' = p
text
SLIT("Zq")
char_to_c '*' = p
text
SLIT("Zt")
char_to_c '_' = p
text
SLIT("Zu")
char_to_c c = if isAlphanum c
then
ppC
har c
else
ppBeside (ppC
har 'Z') (
ppI
nt (ord c))
then
c
har c
else
(<>) (c
har 'Z') (
i
nt (ord c))
\end{code}
For \tr{modnameToC}, we really only have to worry about \tr{'}s (quote
...
...
ghc/compiler/absCSyn/HeapOffs.lhs
View file @
dcef38ba
...
...
@@ -38,8 +38,9 @@ IMPORT_DELOOPER(AbsCLoop) ( fixedHdrSizeInWords, varHdrSizeInWords )
import Maybes ( catMaybes )
import SMRep
import
Unp
retty -- ********** NOTE **********
import
P
retty -- ********** NOTE **********
import Util ( panic )
import PprStyle ( PprStyle )
\end{code}
%************************************************************************
...
...
@@ -264,19 +265,19 @@ print either a single value, or a parenthesised value. No need for
the caller to parenthesise.
\begin{code}
pprHeapOffset :: PprStyle -> HeapOffset ->
Unpretty
pprHeapOffset :: PprStyle -> HeapOffset ->
Doc
pprHeapOffset sty ZeroHeapOffset =
uppC
har '0'
pprHeapOffset sty ZeroHeapOffset =
c
har '0'
pprHeapOffset sty (MaxHeapOffset off1 off2)
=
uppBeside (uppPStr
SLIT("STG_MAX"))
(
uppP
arens (
uppBesides
[pprHeapOffset sty off1,
uppC
omma, pprHeapOffset sty off2]))
=
(<>) (ptext
SLIT("STG_MAX"))
(
p
arens (
hcat
[pprHeapOffset sty off1,
c
omma, pprHeapOffset sty off2]))
pprHeapOffset sty (AddHeapOffset off1 off2)
=
uppP
arens (
uppBesides
[pprHeapOffset sty off1,
uppC
har '+',
=
p
arens (
hcat
[pprHeapOffset sty off1,
c
har '+',
pprHeapOffset sty off2])
pprHeapOffset sty (SubHeapOffset off1 off2)
=
uppP
arens (
uppBesides
[pprHeapOffset sty off1,
uppC
har '-',
=
p
arens (
hcat
[pprHeapOffset sty off1,
c
har '-',
pprHeapOffset sty off2])
pprHeapOffset sty (MkHeapOffset int_offs fxdhdr_offs varhdr_offs tothdr_offs)
...
...
@@ -289,44 +290,44 @@ pprHeapOffsetPieces :: PprStyle
-> FAST_INT -- Fixed hdrs
-> [SMRep__Int] -- Var hdrs
-> [SMRep__Int] -- Tot hdrs
->
Unpretty
->
Doc
pprHeapOffsetPieces sty n ILIT(0) [] [] =
uppI
nt IBOX(n) -- Deals with zero case too
pprHeapOffsetPieces sty n ILIT(0) [] [] =
i
nt IBOX(n) -- Deals with zero case too
pprHeapOffsetPieces sty int_offs fxdhdr_offs varhdr_offs tothdr_offs
= let pp_int_offs =
if int_offs _EQ_ ILIT(0)
then Nothing
else Just (
uppI
nt IBOX(int_offs))
else Just (
i
nt IBOX(int_offs))
pp_fxdhdr_offs =
if fxdhdr_offs _EQ_ ILIT(0) then
Nothing
else if fxdhdr_offs _EQ_ ILIT(1) then
Just (
uppPStr
SLIT("_FHS"))
Just (
ptext
SLIT("_FHS"))
else
Just (
uppBesides [uppC
har '(',
uppPStr
SLIT("_FHS*"),
uppI
nt IBOX(fxdhdr_offs),
uppC
har ')'])
Just (
hcat [c
har '(',
ptext
SLIT("_FHS*"),
i
nt IBOX(fxdhdr_offs),
c
har ')'])
pp_varhdr_offs = pp_hdrs (
uppPStr
SLIT("_VHS")) varhdr_offs
pp_varhdr_offs = pp_hdrs (
ptext
SLIT("_VHS")) varhdr_offs
pp_tothdr_offs = pp_hdrs (
uppPStr
SLIT("_HS")) tothdr_offs
pp_tothdr_offs = pp_hdrs (
ptext
SLIT("_HS")) tothdr_offs
in
case (catMaybes [pp_tothdr_offs, pp_varhdr_offs, pp_fxdhdr_offs, pp_int_offs]) of
[] ->
uppC
har '0'
[] ->
c
har '0'
[pp] -> pp -- Each blob is parenthesised if necessary
pps ->
uppP
arens (
uppIntersperse (uppC
har '+') pps)
pps ->
p
arens (
cat (punctuate (c
har '+') pps)
)
where
pp_hdrs hdr_pp [] = Nothing
pp_hdrs hdr_pp [SMRI(rep, n)] | n _EQ_ ILIT(1) = Just (
uppBeside (uppStr
(show rep)) hdr_pp)
pp_hdrs hdr_pp hdrs = Just (
uppP
arens (
uppInterleave (uppC
har '+')
(map (pp_hdr hdr_pp) hdrs)))
pp_hdrs hdr_pp [SMRI(rep, n)] | n _EQ_ ILIT(1) = Just (
(<>) (text
(show rep)) hdr_pp)
pp_hdrs hdr_pp hdrs = Just (
p
arens (
sep (punctuate (c
har '+')
(map (pp_hdr hdr_pp) hdrs)))
)
pp_hdr ::
Unpretty
-> SMRep__Int ->
Unpretty
pp_hdr ::
Doc
-> SMRep__Int ->
Doc
pp_hdr pp_str (SMRI(rep, n))
= if n _EQ_ ILIT(1) then
uppBeside (uppStr
(show rep)) pp_str
(<>) (text
(show rep)) pp_str
else
uppBesides [uppI
nt IBOX(n),
uppC
har '*',
uppStr
(show rep), pp_str]
hcat [i
nt IBOX(n),
c
har '*',
text
(show rep), pp_str]
\end{code}
%************************************************************************
...
...
ghc/compiler/absCSyn/PprAbsC.lhs
View file @
dcef38ba
This diff is collapsed.
Click to expand it.
ghc/compiler/basicTypes/Demand.lhs
View file @
dcef38ba
...
...
@@ -10,7 +10,7 @@ module Demand where
import PprStyle ( PprStyle )
import Outputable
import Pretty (
SYN_IE(Pretty), PrettyRep, ppStr
)
import Pretty (
Doc, text
)
import Util ( panic )
\end{code}
...
...
@@ -124,7 +124,7 @@ instance Show Demand where
ch = if wu then "U" else "u"
instance Outputable Demand where
ppr sty si =
ppStr
(showList [si] "")
ppr sty si =
text
(showList [si] "")
\end{code}
...
...
ghc/compiler/basicTypes/FieldLabel.hi-boot
0 → 100644
View file @
dcef38ba
_interface_ FieldLabel 1
_exports_
FieldLabel FieldLabel;
_declarations_
1 data FieldLabel;
ghc/compiler/basicTypes/FieldLabel.lhs
View file @
dcef38ba
...
...
@@ -10,13 +10,16 @@ module FieldLabel where
IMP_Ubiq(){-uitous-}
import Name ( Name{-instance Eq/Outputable-}, nameUnique )
import Name
--
( Name{-instance Eq/Outputable-}, nameUnique )
import Type ( SYN_IE(Type) )
import Outputable
import UniqFM ( SYN_IE(Uniquable) )
\end{code}
\begin{code}
data FieldLabel
= FieldLabel Name
= FieldLabel Name
-- Also used as the Name of the field selector Id
Type
FieldLabelTag
...
...
ghc/compiler/basicTypes/Id.hi-boot
View file @
dcef38ba
_interface_ Id 1
_exports_
Id Id GenId StrictnessMark(MarkedStrict NotMarkedStrict) dataConArgTys idType isNullaryDataCon mkDataCon mkTupleCon nmbrId;
_instances_
instance {Outputable.Outputable Id} = $d1;
_declarations_
1 $d1 _:_ {Outputable.Outputable Id} ;;
1 type Id = Id.GenId Type.Type ;
1 data GenId ty ;
1 data StrictnessMark = MarkedStrict | NotMarkedStrict ;
1 dataConArgTys _:_ Id -> [Type.Type] -> [Type.Type] ;;
1 idType _:_ Id -> Type.Type ;;
1 isNullaryDataCon _:_ Id -> PrelBase.Bool ;;
1 mkDataCon _:_ Name.Name -> [StrictnessMark] -> [FieldLabel.FieldLabel] -> [TyVar.TyVar] -> [(Class.Class,Type.Type)] -> [TyVar.TyVar] -> [(Class.Class,Type.Type)] -> [Type.Type] -> TyCon.TyCon -> Id ;;
1 mkTupleCon _:_ PrelBase.Int -> Name.Name -> Type.Type -> Id ;;
1 nmbrId _:_ Id -> PprEnv.NmbrEnv -> (PprEnv.NmbrEnv, Id) ;;
ghc/compiler/basicTypes/Id.lhs
View file @
dcef38ba
...
...
@@ -19,7 +19,7 @@ module Id (
mkDataCon,
mkDefaultMethodId,
mkDictFunId,
mkIdWithNewUniq,
mkIdWithNewUniq,
mkIdWithNewName,
mkImported,
mkInstId,
mkMethodSelId,
...
...
@@ -41,7 +41,6 @@ module Id (
dataConRepType,
dataConArgTys,
dataConArity,
dataConNumFields,
dataConFieldLabels,
dataConRawArgTys,
...
...
@@ -59,8 +58,8 @@ module Id (
cmpId_withSpecDataCon,
externallyVisibleId,
idHasNoFreeTyVars,
idWantsToBeINLINEd,
idMustBeINLINEd,
idWantsToBeINLINEd,
getInlinePragma,
idMustBeINLINEd,
idMustNotBeINLINEd,
isBottomingId,
isConstMethodId,
isConstMethodId_maybe,
...
...
@@ -111,7 +110,7 @@ module Id (
getIdUpdateInfo,
getPragmaInfo,
replaceIdInfo,
addInlinePragma,
addInlinePragma,
nukeNoInlinePragma, addNoInlinePragma,
-- IdEnvs AND IdSets
SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet),
...
...
@@ -145,25 +144,30 @@ module Id (
) where
IMP_Ubiq()
IMPORT_DELOOPER(IdLoop) -- for paranoia checking
IMPORT_DELOOPER(TyLoop) -- for paranoia checking
import Bag
import Class ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClassOp )
import IdInfo
import Maybes ( maybeToBool )
import Name ( nameUnique, mkLocalName, mkSysLocalName, isLocalName,
import Name
{-
( nameUnique, mkLocalName, mkSysLocalName, isLocalName,
mkCompoundName, mkInstDeclName,
isLocallyDefinedName, occNameString, modAndOcc,
isLocallyDefined, changeUnique, isWiredInName,
nameString, getOccString, setNameVisibility,
isExported, ExportFlag(..), DefnInfo, Provenance,
OccName(..), Name
)
)
-}
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 PprEnv -- ( SYN_IE(NmbrM), NmbrEnv(..) )
import PprType ( getTypeString, specMaybeTysSuffix,
nmbrType, nmbrTyVar,
...
...
@@ -172,15 +176,15 @@ import PprType ( getTypeString, specMaybeTysSuffix,
import PprStyle
import Pretty
import MatchEnv ( MatchEnv )
import SrcLoc ( mkBuiltinSrcLoc )
import SrcLoc
--
( mkBuiltinSrcLoc )
import TysWiredIn ( tupleTyCon )
import TyCon ( TyCon, tyConDataCons )
import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
import TyCon
--
( TyCon, tyConDataCons )
import Type
{-
( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
applyTyCon, instantiateTy, mkForAllTys,
tyVarsOfType, applyTypeEnvToTy, typePrimRep,
GenType, SYN_IE(ThetaType), SYN_IE(TauType), SYN_IE(Type)
)