--- /dev/null
+module AbsCLoop
+ (
+ module MachMisc,
+ module CLabel,
+ module ClosureInfo,
+ module CgRetConv
+ )where
+
+import MachMisc
+import CLabel
+import ClosureInfo
+import CgRetConv
)-} where
IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(AbsCLoop)
import Constants ( mAX_Vanilla_REG, mAX_Float_REG,
mAX_Double_REG, lIVENESS_R1, lIVENESS_R2,
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
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}
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])
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}
--- /dev/null
+_interface_ CLabel 1
+_exports_
+CLabel CLabel;
+_declarations_
+1 data CLabel;
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:
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,
- uppInt tag, pp_cSEP, uppPStr SLIT("upd")]
+ = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP,
+ int 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")) (uppInt (tag - fIRST_TAG))
+ UnvectoredReturn _ -> ptext SLIT("IndUpdRetDir")
+ VectoredReturn _ -> (<>) (ptext SLIT("IndUpdRetV")) (int (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, uppInt tag]
+ = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, int 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")) (uppInt 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")) (int 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}
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}
\begin{code}
cSEP = SLIT("_") -- official C separator
-pp_cSEP = uppChar '_'
+pp_cSEP = char '_'
-identToC :: FAST_STRING -> Pretty
+identToC :: FAST_STRING -> Doc
modnameToC :: FAST_STRING -> FAST_STRING
stringToC :: String -> String
charToC, charToEasyHaskell :: Char -> String
= let
str = _UNPK_ ps
in
- ppBeside
+ (<>)
(case str of
's':'t':'d':_ -> -- avoid "stdin", "stdout", and "stderr"...
- ppChar 'Z'
- _ -> ppNil)
+ char 'Z'
+ _ -> empty)
(if (all isAlphanum str) -- we gamble that this test will succeed...
- then ppPStr ps
- else ppIntersperse ppNil (map char_to_c str))
+ then ptext ps
+ else hcat (map char_to_c str))
where
- char_to_c 'Z' = ppPStr SLIT("ZZ")
- char_to_c '&' = ppPStr SLIT("Za")
- char_to_c '|' = ppPStr SLIT("Zb")
- char_to_c ':' = ppPStr SLIT("Zc")
- char_to_c '/' = ppPStr SLIT("Zd")
- char_to_c '=' = ppPStr SLIT("Ze")
- char_to_c '>' = ppPStr SLIT("Zg")
- char_to_c '#' = ppPStr SLIT("Zh")
- char_to_c '<' = ppPStr SLIT("Zl")
- char_to_c '-' = ppPStr SLIT("Zm")
- char_to_c '!' = ppPStr SLIT("Zn")
- char_to_c '.' = ppPStr SLIT("_")
- char_to_c '+' = ppPStr SLIT("Zp")
- char_to_c '\'' = ppPStr SLIT("Zq")
- char_to_c '*' = ppPStr SLIT("Zt")
- char_to_c '_' = ppPStr SLIT("Zu")
+ char_to_c 'Z' = ptext SLIT("ZZ")
+ char_to_c '&' = ptext SLIT("Za")
+ char_to_c '|' = ptext SLIT("Zb")
+ char_to_c ':' = ptext SLIT("Zc")
+ char_to_c '/' = ptext SLIT("Zd")
+ char_to_c '=' = ptext SLIT("Ze")
+ char_to_c '>' = ptext SLIT("Zg")
+ char_to_c '#' = ptext SLIT("Zh")
+ char_to_c '<' = ptext SLIT("Zl")
+ char_to_c '-' = ptext SLIT("Zm")
+ char_to_c '!' = ptext SLIT("Zn")
+ char_to_c '.' = ptext SLIT("_")
+ char_to_c '+' = ptext SLIT("Zp")
+ char_to_c '\'' = ptext SLIT("Zq")
+ char_to_c '*' = ptext SLIT("Zt")
+ char_to_c '_' = ptext SLIT("Zu")
char_to_c c = if isAlphanum c
- then ppChar c
- else ppBeside (ppChar 'Z') (ppInt (ord c))
+ then char c
+ else (<>) (char 'Z') (int (ord c))
\end{code}
For \tr{modnameToC}, we really only have to worry about \tr{'}s (quote
import Maybes ( catMaybes )
import SMRep
-import Unpretty -- ********** NOTE **********
+import Pretty -- ********** NOTE **********
import Util ( panic )
+import PprStyle ( PprStyle )
\end{code}
%************************************************************************
the caller to parenthesise.
\begin{code}
-pprHeapOffset :: PprStyle -> HeapOffset -> Unpretty
+pprHeapOffset :: PprStyle -> HeapOffset -> Doc
-pprHeapOffset sty ZeroHeapOffset = uppChar '0'
+pprHeapOffset sty ZeroHeapOffset = char '0'
pprHeapOffset sty (MaxHeapOffset off1 off2)
- = uppBeside (uppPStr SLIT("STG_MAX"))
- (uppParens (uppBesides [pprHeapOffset sty off1, uppComma, pprHeapOffset sty off2]))
+ = (<>) (ptext SLIT("STG_MAX"))
+ (parens (hcat [pprHeapOffset sty off1, comma, pprHeapOffset sty off2]))
pprHeapOffset sty (AddHeapOffset off1 off2)
- = uppParens (uppBesides [pprHeapOffset sty off1, uppChar '+',
+ = parens (hcat [pprHeapOffset sty off1, char '+',
pprHeapOffset sty off2])
pprHeapOffset sty (SubHeapOffset off1 off2)
- = uppParens (uppBesides [pprHeapOffset sty off1, uppChar '-',
+ = parens (hcat [pprHeapOffset sty off1, char '-',
pprHeapOffset sty off2])
pprHeapOffset sty (MkHeapOffset int_offs fxdhdr_offs varhdr_offs tothdr_offs)
-> FAST_INT -- Fixed hdrs
-> [SMRep__Int] -- Var hdrs
-> [SMRep__Int] -- Tot hdrs
- -> Unpretty
+ -> Doc
-pprHeapOffsetPieces sty n ILIT(0) [] [] = uppInt IBOX(n) -- Deals with zero case too
+pprHeapOffsetPieces sty n ILIT(0) [] [] = int 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 (uppInt IBOX(int_offs))
+ else Just (int 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 [uppChar '(', uppPStr SLIT("_FHS*"), uppInt IBOX(fxdhdr_offs), uppChar ')'])
+ Just (hcat [char '(', ptext SLIT("_FHS*"), int IBOX(fxdhdr_offs), char ')'])
- 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
- [] -> uppChar '0'
+ [] -> char '0'
[pp] -> pp -- Each blob is parenthesised if necessary
- pps -> uppParens (uppIntersperse (uppChar '+') pps)
+ pps -> parens (cat (punctuate (char '+') 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 (uppParens (uppInterleave (uppChar '+')
- (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 (parens (sep (punctuate (char '+')
+ (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 [uppInt IBOX(n), uppChar '*', uppStr (show rep), pp_str]
+ hcat [int IBOX(n), char '*', text (show rep), pp_str]
\end{code}
%************************************************************************
IMPORT_DELOOPER(AbsCLoop) -- break its dependence on ClosureInfo
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
import AbsCSyn
import Literal ( showLiteral, Literal(..) )
import Maybes ( maybeToBool, catMaybes )
import PprStyle ( PprStyle(..) )
-import Pretty ( prettyToUn )
+import Pretty
import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
import PrimRep ( isFloatingRep, showPrimRep, PrimRep(..) )
import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
import UniqSet ( emptyUniqSet, elementOfUniqSet,
addOneToUniqSet, SYN_IE(UniqSet)
)
-import Unpretty -- ********** NOTE **********
+import Outputable ( printDoc )
import Util ( nOfThem, panic, assertPanic )
infixr 9 `thenTE`
\begin{code}
writeRealC :: Handle -> AbstractC -> IO ()
-
-writeRealC handle absC
- = uppPutStr handle 80 (
- uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n')
- )
+writeRealC handle absC = printDoc LeftMode handle (pprAbsC PprForC absC (costs absC))
dumpRealC :: AbstractC -> String
-
-dumpRealC absC
- = uppShow 80 (
- uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n')
- )
+dumpRealC absC = show (pprAbsC PprForC 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 -> Unpretty
+emitMacro :: CostRes -> Doc
-- ToDo: Check a compile time flag to decide whether a macro should be emitted
emitMacro (Cost (i,b,l,s,f))
- = uppBesides [ uppPStr SLIT("GRAN_EXEC"), uppChar '(',
- uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma,
- uppInt s, uppComma, uppInt f, pp_paren_semi ]
+ = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
+ int i, comma, int b, comma, int l, comma,
+ int s, comma, int f, pp_paren_semi ]
\end{code}
\begin{code}
-pp_paren_semi = uppStr ");"
+pp_paren_semi = text ");"
-- ---------------------------------------------------------------------------
-- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
-- which must be done before the return i.e. inside absC code) HWL
-- ---------------------------------------------------------------------------
-pprAbsC :: PprStyle -> AbstractC -> CostRes -> Unpretty
+pprAbsC :: PprStyle -> AbstractC -> CostRes -> Doc
-pprAbsC sty AbsCNop _ = uppNil
-pprAbsC sty (AbsCStmts s1 s2) c = uppAbove (pprAbsC sty s1 c) (pprAbsC sty s2 c)
+pprAbsC sty AbsCNop _ = empty
+pprAbsC sty (AbsCStmts s1 s2) c = ($$) (pprAbsC sty s1 c) (pprAbsC sty s2 c)
pprAbsC sty (CClosureUpdInfo info) c
= pprAbsC sty info c
pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeRep dest) dest src
pprAbsC sty (CJump target) c
- = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CJump */"-} ])
- (uppBesides [ uppStr jmp_lit, pprAmode sty target, pp_paren_semi ])
+ = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CJump */"-} ])
+ (hcat [ text jmp_lit, pprAmode sty target, pp_paren_semi ])
pprAbsC sty (CFallThrough target) c
- = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CFallThrough */"-} ])
- (uppBesides [ uppStr jmp_lit, pprAmode sty target, pp_paren_semi ])
+ = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CFallThrough */"-} ])
+ (hcat [ text jmp_lit, pprAmode sty target, pp_paren_semi ])
-- --------------------------------------------------------------------------
-- Spit out GRAN_EXEC macro immediately before the return HWL
pprAbsC sty (CReturn am return_info) c
- = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <---- CReturn */"-} ])
- (uppBesides [uppStr jmp_lit, target, pp_paren_semi ])
+ = ($$) (hcat [emitMacro c {-WDP:, text "/* <---- CReturn */"-} ])
+ (hcat [text jmp_lit, target, pp_paren_semi ])
where
target = case return_info of
- DirectReturn -> uppBesides [uppPStr SLIT("DIRECT"),uppChar '(', pprAmode sty am, uppRparen]
+ DirectReturn -> hcat [ptext SLIT("DIRECT"),char '(', pprAmode sty am, rparen]
DynamicVectoredReturn am' -> mk_vector (pprAmode sty am')
- StaticVectoredReturn n -> mk_vector (uppInt n) -- Always positive
- mk_vector x = uppBesides [uppLparen, pprAmode sty am, uppStr ")[RVREL(", x, uppStr ")]"]
+ StaticVectoredReturn n -> mk_vector (int n) -- Always positive
+ mk_vector x = hcat [parens (pprAmode sty am), brackets (text "RVREL" <> parens x)]
-pprAbsC sty (CSplitMarker) _ = uppPStr SLIT("/* SPLIT */")
+pprAbsC sty (CSplitMarker) _ = ptext SLIT("/* SPLIT */")
-- we optimise various degenerate cases of CSwitches.
| isFloatingRep (getAmodeRep discrim)
= pprAbsC sty (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
| otherwise
- = uppAboves [
- uppBesides [uppStr "switch (", pp_discrim, uppStr ") {"],
- uppNest 2 (uppAboves (map (ppr_alt sty) alts)),
+ = vcat [
+ hcat [text "switch (", pp_discrim, text ") {"],
+ nest 2 (vcat (map (ppr_alt sty) alts)),
(case (nonemptyAbsC deflt) of
- Nothing -> uppNil
+ Nothing -> empty
Just dc ->
- uppNest 2 (uppAboves [uppPStr SLIT("default:"),
+ nest 2 (vcat [ptext SLIT("default:"),
pprAbsC sty dc (c + switch_head_cost
+ costs dc),
- uppPStr SLIT("break;")])),
- uppChar '}' ]
+ ptext SLIT("break;")])),
+ char '}' ]
where
pp_discrim
= pprAmode sty discrim
ppr_alt sty (lit, absC)
- = uppAboves [ uppBesides [uppPStr SLIT("case "), pprBasicLit sty lit, uppChar ':'],
- uppNest 2 (uppAbove (pprAbsC sty absC (c + switch_head_cost + costs absC))
- (uppPStr SLIT("break;"))) ]
+ = vcat [ hcat [ptext SLIT("case "), pprBasicLit sty lit, char ':'],
+ nest 2 (($$) (pprAbsC sty 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))
in
case (ppr_vol_regs sty vol_regs) of { (pp_saves, pp_restores) ->
if primOpNeedsWrapper op then
- uppAboves [ pp_saves,
+ vcat [ pp_saves,
the_op,
pp_restores
]
}
where
ppr_op_call results args
- = uppBesides [ prettyToUn (pprPrimOp sty op), uppLparen,
- uppIntersperse uppComma (map ppr_op_result results),
- if null results || null args then uppNil else uppComma,
- uppIntersperse uppComma (map (pprAmode sty) args),
+ = hcat [ pprPrimOp sty 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)),
pp_paren_semi ]
ppr_op_result r = ppr_amode sty r
-- hence we can toss the provided cast...
pprAbsC sty (CSimultaneous abs_c) c
- = uppBesides [uppPStr SLIT("{{"), pprAbsC sty abs_c c, uppPStr SLIT("}}")]
+ = hcat [ptext SLIT("{{"), pprAbsC sty abs_c c, ptext SLIT("}}")]
pprAbsC sty stmt@(CMacroStmt macro as) _
- = uppBesides [uppStr (show macro), uppLparen,
- uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi] -- no casting
+ = hcat [text (show macro), lparen,
+ hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi] -- no casting
pprAbsC sty stmt@(CCallProfCtrMacro op as) _
- = uppBesides [uppPStr op, uppLparen,
- uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi]
+ = hcat [ptext op, lparen,
+ hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi]
pprAbsC sty stmt@(CCallProfCCMacro op as) _
- = uppBesides [uppPStr op, uppLparen,
- uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi]
+ = hcat [ptext op, lparen,
+ hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi]
pprAbsC sty (CCodeBlock label abs_C) _
= ASSERT( maybeToBool(nonemptyAbsC abs_C) )
case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
- uppAboves [
- uppBesides [uppStr (if (externallyVisibleCLabel label)
+ vcat [
+ hcat [text (if (externallyVisibleCLabel label)
then "FN_(" -- abbreviations to save on output
else "IFN_("),
- pprCLabel sty label, uppStr ") {"],
+ pprCLabel sty label, text ") {"],
case sty of
- PprForC -> uppAbove pp_exts pp_temps
- _ -> uppNil,
- uppNest 8 (uppPStr SLIT("FB_")),
- uppNest 8 (pprAbsC sty abs_C (costs abs_C)),
- uppNest 8 (uppPStr SLIT("FE_")),
- uppChar '}' ]
+ PprForC -> ($$) pp_exts pp_temps
+ _ -> empty,
+ nest 8 (ptext SLIT("FB_")),
+ nest 8 (pprAbsC sty abs_C (costs abs_C)),
+ nest 8 (ptext SLIT("FE_")),
+ char '}' ]
}
pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
- = uppBesides [ pp_init_hdr, uppStr "_HDR(",
- ppr_amode sty (CAddr reg_rel), uppComma,
- pprCLabel sty info_lbl, uppComma,
- if_profiling sty (pprAmode sty cost_centre), uppComma,
- pprHeapOffset sty size, uppComma, uppInt ptr_wds, pp_paren_semi ]
+ = 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 ]
where
info_lbl = infoTableLabelFromCI cl_info
sm_rep = closureSMRep cl_info
size = closureSizeWithoutFixedHdr cl_info
ptr_wds = closurePtrsSize cl_info
- pp_init_hdr = uppStr (if inplace_upd then
+ pp_init_hdr = text (if inplace_upd then
getSMUpdInplaceHdrStr sm_rep
else
getSMInitHdrStr sm_rep)
pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
= case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
- uppAboves [
+ vcat [
case sty of
PprForC -> pp_exts
- _ -> uppNil,
- uppBesides [
- uppPStr SLIT("SET_STATIC_HDR"),uppChar '(',
- pprCLabel sty closure_lbl, uppComma,
- pprCLabel sty info_lbl, uppComma,
- if_profiling sty (pprAmode sty cost_centre), uppComma,
- ppLocalness closure_lbl, uppComma,
+ _ -> empty,
+ 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,
+ ppLocalness closure_lbl, comma,
ppLocalnessMacro False{-for data-} info_lbl,
- uppChar ')'
+ char ')'
],
- uppNest 2 (uppBesides (map (ppr_item sty) amodes)),
- uppNest 2 (uppBesides (map (ppr_item sty) padding_wds)),
- uppPStr SLIT("};") ]
+ nest 2 (hcat (map (ppr_item sty) amodes)),
+ nest 2 (hcat (map (ppr_item sty) padding_wds)),
+ ptext SLIT("};") ]
}
where
info_lbl = infoTableLabelFromCI cl_info
ppr_item sty item
= if getAmodeRep item == VoidRep
- then uppStr ", (W_) 0" -- might not even need this...
- else uppBeside (uppStr ", (W_)") (ppr_amode sty item)
+ then text ", (W_) 0" -- might not even need this...
+ else (<>) (text ", (W_)") (ppr_amode sty item)
padding_wds =
if not (closureUpdReqd cl_info) then
-}
pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
- = uppAboves [
- uppBesides [
+ = vcat [
+ hcat [
pp_info_rep,
- uppPStr SLIT("_ITBL"),uppChar '(',
- pprCLabel sty info_lbl, uppComma,
+ ptext SLIT("_ITBL"),char '(',
+ pprCLabel sty info_lbl, comma,
-- CONST_ITBL needs an extra label for
-- the static version of the object.
if isConstantRep sm_rep
- then uppBeside (pprCLabel sty (closureLabelFromCI cl_info)) uppComma
- else uppNil,
+ then (<>) (pprCLabel sty (closureLabelFromCI cl_info)) comma
+ else empty,
- pprCLabel sty slow_lbl, uppComma,
- pprAmode sty upd, uppComma,
- uppInt liveness, uppComma,
+ pprCLabel sty slow_lbl, comma,
+ pprAmode sty upd, comma,
+ int liveness, comma,
- pp_tag, uppComma,
- pp_size, uppComma,
- pp_ptr_wds, uppComma,
+ pp_tag, comma,
+ pp_size, comma,
+ pp_ptr_wds, comma,
- ppLocalness info_lbl, uppComma,
- ppLocalnessMacro True{-function-} slow_lbl, uppComma,
+ ppLocalness info_lbl, comma,
+ ppLocalnessMacro True{-function-} slow_lbl, comma,
if is_selector
- then uppBeside (uppInt select_word_i) uppComma
- else uppNil,
+ then (<>) (int select_word_i) comma
+ else empty,
- if_profiling sty pp_kind, uppComma,
- if_profiling sty pp_descr, uppComma,
+ if_profiling sty pp_kind, comma,
+ if_profiling sty pp_descr, comma,
if_profiling sty pp_type,
- uppStr ");"
+ text ");"
],
pp_slow,
case maybe_fast of
- Nothing -> uppNil
+ Nothing -> empty
Just fast -> let stuff = CCodeBlock fast_lbl fast in
pprAbsC sty stuff (costs stuff)
]
(slow_lbl, pp_slow)
= case (nonemptyAbsC slow) of
- Nothing -> (mkErrorStdEntryLabel, uppNil)
+ Nothing -> (mkErrorStdEntryLabel, empty)
Just xx -> (entryLabelFromCI cl_info,
let stuff = CCodeBlock slow_lbl xx in
pprAbsC sty stuff (costs stuff))
(Just (_, select_word_i)) = maybe_selector
pp_info_rep -- special stuff if it's a selector; otherwise, just the SMrep
- = uppStr (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
+ = text (if is_selector then "SELECT" else (getSMInfoStr sm_rep))
- pp_tag = uppInt (closureSemiTag cl_info)
+ pp_tag = int (closureSemiTag cl_info)
is_phantom = isPhantomRep sm_rep
pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
- uppInt (closureNonHdrSize cl_info)
+ int (closureNonHdrSize cl_info)
else if is_phantom then -- do not have sizes for these
- uppNil
+ empty
else
pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info)
pp_ptr_wds = if is_phantom then
- uppNil
+ empty
else
- uppInt (closurePtrsSize cl_info)
+ int (closurePtrsSize cl_info)
- pp_kind = uppStr (closureKind cl_info)
- pp_descr = uppBesides [uppChar '"', uppStr (stringToC cl_descr), uppChar '"']
- pp_type = uppBesides [uppChar '"', uppStr (stringToC (closureTypeDescr cl_info)), uppChar '"']
+ pp_kind = text (closureKind cl_info)
+ 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
- = uppAboves [ uppPStr SLIT("{ // CRetVector (lbl????)"),
- uppNest 8 (uppSep (map (ppr_maybe_amode sty) maybes)),
- uppStr "} /*default=*/ {", pprAbsC sty deflt c,
- uppChar '}']
+ = vcat [ ptext SLIT("{ // CRetVector (lbl????)"),
+ nest 8 (sep (map (ppr_maybe_amode sty) maybes)),
+ text "} /*default=*/ {", pprAbsC sty deflt c,
+ char '}']
where
- ppr_maybe_amode sty Nothing = uppPStr SLIT("/*default*/")
+ ppr_maybe_amode sty Nothing = ptext SLIT("/*default*/")
ppr_maybe_amode sty (Just a) = pprAmode sty a
pprAbsC sty stmt@(CRetUnVector label amode) _
- = uppBesides [uppPStr SLIT("UNVECTBL"),uppChar '(', pp_static, uppComma, pprCLabel sty label, uppComma,
- pprAmode sty amode, uppRparen]
+ = hcat [ptext SLIT("UNVECTBL"),char '(', pp_static, comma, pprCLabel sty label, comma,
+ pprAmode sty amode, rparen]
where
- pp_static = if externallyVisibleCLabel label then uppNil else uppPStr SLIT("static")
+ pp_static = if externallyVisibleCLabel label then empty else ptext SLIT("static")
pprAbsC sty stmt@(CFlatRetVector label amodes) _
= case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
- uppAboves [
+ vcat [
case sty of
PprForC -> pp_exts
- _ -> uppNil,
- uppBesides [ppLocalness label, uppPStr SLIT(" W_ "),
- pprCLabel sty label, uppStr "[] = {"],
- uppNest 2 (uppInterleave uppComma (map (ppr_item sty) amodes)),
- uppStr "};" ] }
+ _ -> empty,
+ hcat [ppLocalness label, ptext SLIT(" W_ "),
+ pprCLabel sty label, text "[] = {"],
+ nest 2 (sep (punctuate comma (map (ppr_item sty) amodes))),
+ text "};" ] }
where
- ppr_item sty item = uppBeside (uppStr "(W_) ") (ppr_amode sty item)
+ ppr_item sty item = (<>) (text "(W_) ") (ppr_amode sty item)
pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc
\end{code}
\begin{code}
ppLocalness label
- = uppBeside static const
+ = (<>) static const
where
- static = if (externallyVisibleCLabel label) then uppNil else uppPStr SLIT("static ")
- const = if not (isReadOnly label) then uppNil else uppPStr SLIT("const")
+ static = if (externallyVisibleCLabel label) then empty else ptext SLIT("static ")
+ const = if not (isReadOnly label) then empty else ptext SLIT("const")
ppLocalnessMacro for_fun{-vs data-} clabel
- = uppBesides [ uppChar (if externallyVisibleCLabel clabel then 'E' else 'I'),
+ = hcat [ char (if externallyVisibleCLabel clabel then 'E' else 'I'),
if for_fun then
- uppPStr SLIT("F_")
+ ptext SLIT("F_")
else
- uppBeside (uppPStr SLIT("D_"))
+ (<>) (ptext SLIT("D_"))
(if isReadOnly clabel then
- uppPStr SLIT("RO_")
+ ptext SLIT("RO_")
else
- uppNil)]
+ empty)]
\end{code}
\begin{code}
\end{code}
\begin{code}
-ppr_vol_regs :: PprStyle -> [MagicId] -> (Unpretty, Unpretty)
+ppr_vol_regs :: PprStyle -> [MagicId] -> (Doc, Doc)
-ppr_vol_regs sty [] = (uppNil, uppNil)
+ppr_vol_regs sty [] = (empty, empty)
ppr_vol_regs sty (VoidReg:rs) = ppr_vol_regs sty rs
ppr_vol_regs sty (r:rs)
= let pp_reg = case r of
_ -> pprMagicId sty r
(more_saves, more_restores) = ppr_vol_regs sty rs
in
- (uppAbove (uppBeside (uppPStr SLIT("CALLER_SAVE_")) pp_reg) more_saves,
- uppAbove (uppBeside (uppPStr SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
+ (($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves,
+ ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
-- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and
-- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls,
-- other registers.) Just be *sure* BaseReg is OK before trying to do
-- anything else.
pp_basic_saves
- = uppAboves [
- uppPStr SLIT("CALLER_SAVE_Base"),
- uppPStr SLIT("CALLER_SAVE_SpA"),
- uppPStr SLIT("CALLER_SAVE_SuA"),
- uppPStr SLIT("CALLER_SAVE_SpB"),
- uppPStr SLIT("CALLER_SAVE_SuB"),
- uppPStr SLIT("CALLER_SAVE_Ret"),
--- uppPStr SLIT("CALLER_SAVE_Activity"),
- uppPStr SLIT("CALLER_SAVE_Hp"),
- uppPStr SLIT("CALLER_SAVE_HpLim") ]
+ = vcat [
+ ptext SLIT("CALLER_SAVE_Base"),
+ ptext SLIT("CALLER_SAVE_SpA"),
+ ptext SLIT("CALLER_SAVE_SuA"),
+ ptext SLIT("CALLER_SAVE_SpB"),
+ ptext SLIT("CALLER_SAVE_SuB"),
+ ptext SLIT("CALLER_SAVE_Ret"),
+-- ptext SLIT("CALLER_SAVE_Activity"),
+ ptext SLIT("CALLER_SAVE_Hp"),
+ ptext SLIT("CALLER_SAVE_HpLim") ]
pp_basic_restores
- = uppAboves [
- uppPStr SLIT("CALLER_RESTORE_Base"), -- must be first!
- uppPStr SLIT("CALLER_RESTORE_SpA"),
- uppPStr SLIT("CALLER_RESTORE_SuA"),
- uppPStr SLIT("CALLER_RESTORE_SpB"),
- uppPStr SLIT("CALLER_RESTORE_SuB"),
- uppPStr SLIT("CALLER_RESTORE_Ret"),
--- uppPStr SLIT("CALLER_RESTORE_Activity"),
- uppPStr SLIT("CALLER_RESTORE_Hp"),
- uppPStr SLIT("CALLER_RESTORE_HpLim"),
- uppPStr SLIT("CALLER_RESTORE_StdUpdRetVec"),
- uppPStr SLIT("CALLER_RESTORE_StkStub") ]
+ = vcat [
+ ptext SLIT("CALLER_RESTORE_Base"), -- must be first!
+ ptext SLIT("CALLER_RESTORE_SpA"),
+ ptext SLIT("CALLER_RESTORE_SuA"),
+ ptext SLIT("CALLER_RESTORE_SpB"),
+ ptext SLIT("CALLER_RESTORE_SuB"),
+ ptext SLIT("CALLER_RESTORE_Ret"),
+-- ptext SLIT("CALLER_RESTORE_Activity"),
+ ptext SLIT("CALLER_RESTORE_Hp"),
+ ptext SLIT("CALLER_RESTORE_HpLim"),
+ ptext SLIT("CALLER_RESTORE_StdUpdRetVec"),
+ ptext SLIT("CALLER_RESTORE_StkStub") ]
\end{code}
\begin{code}
= case sty of
PprForC -> if opt_SccProfilingOn
then pretty
- else uppChar '0' -- leave it out!
+ else char '0' -- leave it out!
_ -> {-print it anyway-} pretty
deflt alt_code
(addrModeCosts discrim Rhs) c
other -> let
- cond = uppBesides [ pprAmode sty discrim,
- uppPStr SLIT(" == "),
+ cond = hcat [ pprAmode sty discrim,
+ ptext SLIT(" == "),
pprAmode sty (CLit tag) ]
in
ppr_if_stmt sty cond
(addrModeCosts discrim Rhs) c
ppr_if_stmt sty pp_pred then_part else_part discrim_costs c
- = uppAboves [
- uppBesides [uppStr "if (", pp_pred, uppStr ") {"],
- uppNest 8 (pprAbsC sty then_part (c + discrim_costs +
+ = vcat [
+ hcat [text "if (", pp_pred, text ") {"],
+ nest 8 (pprAbsC sty then_part (c + discrim_costs +
(Cost (0, 2, 0, 0, 0)) +
costs then_part)),
- (case nonemptyAbsC else_part of Nothing -> uppNil; Just _ -> uppStr "} else {"),
- uppNest 8 (pprAbsC sty else_part (c + discrim_costs +
+ (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"),
+ nest 8 (pprAbsC sty else_part (c + discrim_costs +
(Cost (0, 1, 0, 0, 0)) +
costs else_part)),
- uppChar '}' ]
+ char '}' ]
{- Total costs = inherited costs (before if) + costs for accessing discrim
+ costs for cond branch ( = (0, 1, 0, 0, 0) )
+ costs for that alternative
\begin{code}
pprCCall sty 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 ++ "\" " ++ (uppShow 80 (uppCat pp_non_void_args)) ++ "\n")
+ then panic ("Live register in _casm_GC_ \"" ++ casm_str ++ "\" " ++ (show (hsep pp_non_void_args)) ++ "\n")
else
- uppAboves [
- uppChar '{',
+ vcat [
+ char '{',
declare_local_vars, -- local var for *result*
- uppAboves local_arg_decls,
- -- if is_asm then uppNil else declareExtern,
+ vcat local_arg_decls,
+ -- if is_asm then empty else declareExtern,
pp_save_context,
process_casm local_vars pp_non_void_args casm_str,
pp_restore_context,
assign_results,
- uppChar '}'
+ char '}'
]
where
(pp_saves, pp_restores) = ppr_vol_regs sty vol_regs
(pp_save_context, pp_restore_context) =
if may_gc
- then ( uppStr "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
- uppStr "inCCallGC--; RestoreAllStgRegs();")
- else ( pp_basic_saves `uppAbove` pp_saves,
- pp_basic_restores `uppAbove` pp_restores)
+ then ( text "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
+ text "inCCallGC--; RestoreAllStgRegs();")
+ else ( pp_basic_saves $$ pp_saves,
+ pp_basic_restores $$ pp_restores)
non_void_args =
let nvas = tail args
-- Remainder only used for ccall
- ccall_str = uppShow 80
- (uppBesides [
+ ccall_str = show
+ (hcat [
if null non_void_results
- then uppNil
- else uppStr "%r = ",
- uppLparen, uppPStr op_str, uppLparen,
- uppIntersperse uppComma ccall_args,
- uppStr "));"
+ then empty
+ else text "%r = ",
+ lparen, ptext op_str, lparen,
+ hcat (punctuate comma ccall_args),
+ text "));"
])
num_args = length non_void_args
- ccall_args = take num_args [ uppBeside (uppChar '%') (uppInt i) | i <- [0..] ]
+ ccall_args = take num_args [ (<>) (char '%') (int i) | i <- [0..] ]
\end{code}
If the argument is a heap object, we need to reach inside and pull out
passed are @Array@s, @ByteArray@s and @ForeignObj@s.
\begin{code}
-ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Unpretty, Unpretty)
+ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Doc, Doc)
-- (a) decl and assignment, (b) local var to be used later
ppr_casm_arg sty amode a_num
pp_amode = pprAmode sty amode
pp_kind = pprPrimKind sty a_kind
- local_var = uppBeside (uppPStr SLIT("_ccall_arg")) (uppInt a_num)
+ local_var = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
(arg_type, pp_amode2)
= case a_kind of
-- for array arguments, pass a pointer to the body of the array
-- (PTRS_ARR_CTS skips over all the header nonsense)
ArrayRep -> (pp_kind,
- uppBesides [uppPStr SLIT("PTRS_ARR_CTS"),uppChar '(', pp_amode, uppRparen])
+ hcat [ptext SLIT("PTRS_ARR_CTS"),char '(', pp_amode, rparen])
ByteArrayRep -> (pp_kind,
- uppBesides [uppPStr SLIT("BYTE_ARR_CTS"),uppChar '(', pp_amode, uppRparen])
+ hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
-- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
- ForeignObjRep -> (uppPStr SLIT("StgForeignObj"),
- uppBesides [uppPStr SLIT("ForeignObj_CLOSURE_DATA"),uppChar '(',
- pp_amode, uppChar ')'])
+ ForeignObjRep -> (ptext SLIT("StgForeignObj"),
+ hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),char '(',
+ pp_amode, char ')'])
other -> (pp_kind, pp_amode)
declare_local_var
- = uppBesides [ arg_type, uppSP, local_var, uppEquals, pp_amode2, uppSemi ]
+ = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ]
in
(declare_local_var, local_var)
\end{code}
ppr_casm_results ::
PprStyle -- style
-> [CAddrMode] -- list of results (length <= 1)
- -> Unpretty -- liveness mask
+ -> Doc -- liveness mask
->
- ( Unpretty, -- declaration of any local vars
- [Unpretty], -- list of result vars (same length as results)
- Unpretty ) -- assignment (if any) of results in local var to registers
+ ( 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
ppr_casm_results sty [] liveness
- = (uppNil, [], uppNil) -- no results
+ = (empty, [], empty) -- no results
ppr_casm_results sty [r] liveness
= let
result_reg = ppr_amode sty r
r_kind = getAmodeRep r
- local_var = uppPStr SLIT("_ccall_result")
+ local_var = ptext SLIT("_ccall_result")
(result_type, assign_result)
= case r_kind of
with makeForeignObj#.
ForeignObjRep ->
- (uppPStr SLIT("StgForeignObj"),
- uppBesides [ uppPStr SLIT("constructForeignObj"),uppChar '(',
- liveness, uppComma,
- result_reg, uppComma,
+ (ptext SLIT("StgForeignObj"),
+ hcat [ ptext SLIT("constructForeignObj"),char '(',
+ liveness, comma,
+ result_reg, comma,
local_var,
pp_paren_semi ])
-}
_ ->
(pprPrimKind sty r_kind,
- uppBesides [ result_reg, uppEquals, local_var, uppSemi ])
+ hcat [ result_reg, equals, local_var, semi ])
- declare_local_var = uppBesides [ result_type, uppSP, local_var, uppSemi ]
+ declare_local_var = hcat [ result_type, space, local_var, semi ]
in
(declare_local_var, [local_var], assign_result)
\begin{code}
process_casm ::
- [Unpretty] -- results (length <= 1)
- -> [Unpretty] -- arguments
+ [Doc] -- results (length <= 1)
+ -> [Doc] -- arguments
-> String -- format string (with embedded %'s)
->
- Unpretty -- code being generated
+ Doc -- code being generated
process_casm results args string = process results args string
where
- process [] _ "" = uppNil
+ process [] _ "" = empty
process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n")
process ress args ('%':cs)
error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
('%':css) ->
- uppBeside (uppChar '%') (process ress args css)
+ (<>) (char '%') (process ress args css)
('r':css) ->
case ress of
[] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
- [r] -> uppBeside r (process [] args css)
+ [r] -> (<>) r (process [] args css)
_ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
other ->
case (read_int other) of
[(num,css)] ->
if 0 <= num && num < length args
- then uppBeside (uppParens (args !! num))
+ then (<>) (parens (args !! num))
(process ress args css)
else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
_ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
process ress args (other_c:cs)
- = uppBeside (uppChar other_c) (process ress args cs)
+ = (<>) (char other_c) (process ress args cs)
\end{code}
%************************************************************************
@VoidRep@, then don't generate any code at all.
\begin{code}
-pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Unpretty
+pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Doc
-pprAssign sty VoidRep dest src = uppNil
+pprAssign sty 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
- = uppBesides [ uppPStr SLIT("ASSIGN_FLT"),uppChar '(', ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ]
+ = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode sty (CAddr reg_rel), comma, pprAmode sty src, pp_paren_semi ]
pprAssign sty DoubleRep dest@(CVal reg_rel _) src
- = uppBesides [ uppPStr SLIT("ASSIGN_DBL"),uppChar '(', ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ]
+ = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode sty (CAddr reg_rel), comma, pprAmode sty src, pp_paren_semi ]
\end{code}
Lastly, the question is: will the C compiler think the types of the
\begin{code}
pprAssign sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
- = uppBesides [ pprVanillaReg dest, uppEquals,
- pprVanillaReg src, uppSemi ]
+ = hcat [ pprVanillaReg dest, equals,
+ pprVanillaReg src, semi ]
pprAssign sty kind dest src
| mixedTypeLocn dest
-- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
- = uppBesides [ ppr_amode sty dest, uppEquals,
- uppStr "(W_)(", -- Here is the cast
+ = hcat [ ppr_amode sty dest, equals,
+ text "(W_)(", -- Here is the cast
ppr_amode sty src, pp_paren_semi ]
pprAssign sty kind dest src
| mixedPtrLocn dest && getAmodeRep src /= PtrRep
-- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
- = uppBesides [ ppr_amode sty dest, uppEquals,
- uppStr "(P_)(", -- Here is the cast
+ = hcat [ ppr_amode sty dest, equals,
+ text "(P_)(", -- Here is the cast
ppr_amode sty src, pp_paren_semi ]
pprAssign sty ByteArrayRep dest src
| mixedPtrLocn src
-- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
- = uppBesides [ ppr_amode sty dest, uppEquals,
- uppStr "(B_)(", -- Here is the cast
+ = hcat [ ppr_amode sty dest, equals,
+ text "(B_)(", -- Here is the cast
ppr_amode sty src, pp_paren_semi ]
pprAssign sty kind other_dest src
- = uppBesides [ ppr_amode sty other_dest, uppEquals,
- pprAmode sty src, uppSemi ]
+ = hcat [ ppr_amode sty other_dest, equals,
+ pprAmode sty src, semi ]
\end{code}
@pprAmode@.
\begin{code}
-pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Unpretty
+pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Doc
\end{code}
For reasons discussed above under assignments, @CVal@ modes need
\begin{code}
pprAmode sty (CVal reg_rel FloatRep)
- = uppBesides [ uppStr "PK_FLT(", ppr_amode sty (CAddr reg_rel), uppRparen ]
+ = hcat [ text "PK_FLT(", ppr_amode sty (CAddr reg_rel), rparen ]
pprAmode sty (CVal reg_rel DoubleRep)
- = uppBesides [ uppStr "PK_DBL(", ppr_amode sty (CAddr reg_rel), uppRparen ]
+ = hcat [ text "PK_DBL(", ppr_amode sty (CAddr reg_rel), rparen ]
\end{code}
Next comes the case where there is some other cast need, and the
\begin{code}
pprAmode sty amode
| mixedTypeLocn amode
- = uppParens (uppBesides [ pprPrimKind sty (getAmodeRep amode), uppPStr SLIT(")("),
+ = parens (hcat [ pprPrimKind sty (getAmodeRep amode), ptext SLIT(")("),
ppr_amode sty amode ])
| otherwise -- No cast needed
= ppr_amode sty amode
\begin{code}
ppr_amode sty (CVal reg_rel _)
= case (pprRegRelative sty False{-no sign wanted-} reg_rel) of
- (pp_reg, Nothing) -> uppBeside (uppChar '*') pp_reg
- (pp_reg, Just offset) -> uppBesides [ pp_reg, uppBracket offset ]
+ (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
(pp_reg, Nothing) -> pp_reg
- (pp_reg, Just offset) -> uppBeside pp_reg offset
+ (pp_reg, Just offset) -> (<>) pp_reg offset
ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id
-ppr_amode sty (CTemp uniq kind) = prettyToUn (pprUnique uniq)
+ppr_amode sty (CTemp uniq kind) = pprUnique uniq
ppr_amode sty (CLbl label kind) = pprCLabel sty label
ppr_amode sty (CUnVecLbl direct vectored)
- = uppBesides [uppChar '(',uppPStr SLIT("StgRetAddr"),uppChar ')', uppPStr SLIT("UNVEC"),uppChar '(', pprCLabel sty direct, uppComma,
- pprCLabel sty vectored, uppRparen]
+ = hcat [char '(',ptext SLIT("StgRetAddr"),char ')', ptext SLIT("UNVEC"),char '(', pprCLabel sty direct, comma,
+ pprCLabel sty vectored, rparen]
-ppr_amode sty (CCharLike char)
- = uppBesides [uppPStr SLIT("CHARLIKE_CLOSURE"),uppChar '(', pprAmode sty char, uppRparen ]
+ppr_amode sty (CCharLike ch)
+ = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode sty ch, rparen ]
ppr_amode sty (CIntLike int)
- = uppBesides [uppPStr SLIT("INTLIKE_CLOSURE"),uppChar '(', pprAmode sty int, uppRparen ]
+ = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode sty int, rparen ]
-ppr_amode sty (CString str) = uppBesides [uppChar '"', uppStr (stringToC (_UNPK_ str)), uppChar '"']
+ppr_amode sty (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 sty (CLitLit str _) = uppPStr str
+ppr_amode sty (CLitLit str _) = ptext str
ppr_amode sty (COffset off) = pprHeapOffset sty off
ppr_amode sty (CCode abs_C)
- = uppAboves [ uppPStr SLIT("{ -- CCode"), uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ]
+ = vcat [ ptext SLIT("{ -- CCode"), nest 8 (pprAbsC sty abs_C (costs abs_C)), char '}' ]
ppr_amode sty (CLabelledCode label abs_C)
- = uppAboves [ uppBesides [pprCLabel sty label, uppPStr SLIT(" = { -- CLabelledCode")],
- uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ]
+ = vcat [ hcat [pprCLabel sty label, ptext SLIT(" = { -- CLabelledCode")],
+ nest 8 (pprAbsC sty abs_C (costs abs_C)), char '}' ]
ppr_amode sty (CJoinPoint _ _)
= panic "ppr_amode: CJoinPoint"
ppr_amode sty (CTableEntry base index kind)
- = uppBesides [uppStr "((", pprPrimKind sty kind, uppStr " *)(",
- ppr_amode sty base, uppStr "))[(I_)(", ppr_amode sty index,
- uppPStr SLIT(")]")]
+ = hcat [text "((", pprPrimKind sty kind, text " *)(",
+ ppr_amode sty base, text "))[(I_)(", ppr_amode sty index,
+ ptext SLIT(")]")]
ppr_amode sty (CMacroExpr pk macro as)
- = uppBesides [uppLparen, pprPrimKind sty pk, uppStr ")(", uppStr (show macro), uppLparen,
- uppIntersperse uppComma (map (pprAmode sty) as), uppStr "))"]
+ = hcat [lparen, pprPrimKind sty pk, text ")(", text (show macro), lparen,
+ hcat (punctuate comma (map (pprAmode sty) as)), text "))"]
ppr_amode sty (CCostCentre cc print_as_string)
= uppCostCentre sty print_as_string cc
%* *
%************************************************************************
-@pprRegRelative@ returns a pair of the @Unpretty@ for the register
-(some casting may be required), and a @Maybe Unpretty@ for the offset
+@pprRegRelative@ returns a pair of the @Doc@ for the register
+(some casting may be required), and a @Maybe Doc@ for the offset
(zero offset gives a @Nothing@).
\begin{code}
-addPlusSign :: Bool -> Unpretty -> Unpretty
+addPlusSign :: Bool -> Doc -> Doc
addPlusSign False p = p
-addPlusSign True p = uppBeside (uppChar '+') p
+addPlusSign True p = (<>) (char '+') p
-pprSignedInt :: Bool -> Int -> Maybe Unpretty -- Nothing => 0
+pprSignedInt :: Bool -> Int -> Maybe Doc -- Nothing => 0
pprSignedInt sign_wanted n
= if n == 0 then Nothing else
- if n > 0 then Just (addPlusSign sign_wanted (uppInt n))
- else Just (uppInt n)
+ if n > 0 then Just (addPlusSign sign_wanted (int n))
+ else Just (int n)
pprRegRelative :: PprStyle
-> Bool -- True <=> Print leading plus sign (if +ve)
-> RegRelative
- -> (Unpretty, Maybe Unpretty)
+ -> (Doc, Maybe Doc)
pprRegRelative sty sign_wanted (SpARel spA off)
= (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt spA off))
if isZeroOff to_print then
(pp_Hp, Nothing)
else
- (pp_Hp, Just (uppBeside (uppChar '-') (pprHeapOffset sty to_print)))
+ (pp_Hp, Just ((<>) (char '-') (pprHeapOffset sty to_print)))
-- No parens needed because pprHeapOffset
-- does them when necessary
to select the union tag.
\begin{code}
-pprMagicId :: PprStyle -> MagicId -> Unpretty
+pprMagicId :: PprStyle -> MagicId -> Doc
-pprMagicId sty BaseReg = uppPStr SLIT("BaseReg")
-pprMagicId sty StkOReg = uppPStr SLIT("StkOReg")
+pprMagicId sty BaseReg = ptext SLIT("BaseReg")
+pprMagicId sty StkOReg = ptext SLIT("StkOReg")
pprMagicId sty (VanillaReg pk n)
- = uppBesides [ pprVanillaReg n, uppChar '.',
+ = hcat [ pprVanillaReg n, char '.',
pprUnionTag pk ]
-pprMagicId sty (FloatReg n) = uppBeside (uppPStr SLIT("FltReg")) (uppInt IBOX(n))
-pprMagicId sty (DoubleReg n) = uppBeside (uppPStr SLIT("DblReg")) (uppInt IBOX(n))
-pprMagicId sty TagReg = uppPStr SLIT("TagReg")
-pprMagicId sty RetReg = uppPStr SLIT("RetReg")
-pprMagicId sty SpA = uppPStr SLIT("SpA")
-pprMagicId sty SuA = uppPStr SLIT("SuA")
-pprMagicId sty SpB = uppPStr SLIT("SpB")
-pprMagicId sty SuB = uppPStr SLIT("SuB")
-pprMagicId sty Hp = uppPStr SLIT("Hp")
-pprMagicId sty HpLim = uppPStr SLIT("HpLim")
-pprMagicId sty LivenessReg = uppPStr SLIT("LivenessReg")
-pprMagicId sty StdUpdRetVecReg = uppPStr SLIT("StdUpdRetVecReg")
-pprMagicId sty StkStubReg = uppPStr SLIT("StkStubReg")
-pprMagicId sty CurCostCentre = uppPStr SLIT("CCC")
+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 -> Unpretty
+pprVanillaReg :: FAST_INT -> Doc
-pprVanillaReg n = uppBeside (uppChar 'R') (uppInt IBOX(n))
+pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
-pprUnionTag :: PrimRep -> Unpretty
+pprUnionTag :: PrimRep -> Doc
-pprUnionTag PtrRep = uppChar 'p'
-pprUnionTag CodePtrRep = uppPStr SLIT("fp")
-pprUnionTag DataPtrRep = uppChar 'd'
-pprUnionTag RetRep = uppChar 'r'
+pprUnionTag PtrRep = char 'p'
+pprUnionTag CodePtrRep = ptext SLIT("fp")
+pprUnionTag DataPtrRep = char 'd'
+pprUnionTag RetRep = char 'r'
pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?"
-pprUnionTag CharRep = uppChar 'c'
-pprUnionTag IntRep = uppChar 'i'
-pprUnionTag WordRep = uppChar 'w'
-pprUnionTag AddrRep = uppChar 'v'
-pprUnionTag FloatRep = uppChar 'f'
+pprUnionTag CharRep = char 'c'
+pprUnionTag IntRep = char 'i'
+pprUnionTag WordRep = char 'w'
+pprUnionTag AddrRep = char 'v'
+pprUnionTag FloatRep = char 'f'
pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
-pprUnionTag StablePtrRep = uppChar 'i'
-pprUnionTag ForeignObjRep = uppChar 'p'
+pprUnionTag StablePtrRep = char 'i'
+pprUnionTag ForeignObjRep = char 'p'
-pprUnionTag ArrayRep = uppChar 'p'
-pprUnionTag ByteArrayRep = uppChar 'b'
+pprUnionTag ArrayRep = char 'p'
+pprUnionTag ByteArrayRep = char 'b'
pprUnionTag _ = panic "pprUnionTag:Odd kind"
\end{code}
Find and print local and external declarations for a list of
Abstract~C statements.
\begin{code}
-pprTempAndExternDecls :: AbstractC -> (Unpretty{-temps-}, Unpretty{-externs-})
-pprTempAndExternDecls AbsCNop = (uppNil, uppNil)
+pprTempAndExternDecls :: AbstractC -> (Doc{-temps-}, Doc{-externs-})
+pprTempAndExternDecls AbsCNop = (empty, empty)
pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
= initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) ->
ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) ->
case (catMaybes [t_p1, t_p2]) of { real_temps ->
case (catMaybes [e_p1, e_p2]) of { real_exts ->
- returnTE (uppAboves real_temps, uppAboves real_exts) }}
+ returnTE (vcat real_temps, vcat real_exts) }}
)
pprTempAndExternDecls other_stmt
= initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) ->
returnTE (
case maybe_t of
- Nothing -> uppNil
+ Nothing -> empty
Just pp -> pp,
case maybe_e of
- Nothing -> uppNil
+ Nothing -> empty
Just pp -> pp )
)
-pprBasicLit :: PprStyle -> Literal -> Unpretty
-pprPrimKind :: PprStyle -> PrimRep -> Unpretty
+pprBasicLit :: PprStyle -> Literal -> Doc
+pprPrimKind :: PprStyle -> PrimRep -> Doc
-pprBasicLit sty lit = uppStr (showLiteral sty lit)
-pprPrimKind sty k = uppStr (showPrimRep k)
+pprBasicLit sty lit = text (showLiteral sty lit)
+pprPrimKind sty k = text (showPrimRep k)
\end{code}
\end{code}
\begin{code}
-pprTempDecl :: Unique -> PrimRep -> Unpretty
+pprTempDecl :: Unique -> PrimRep -> Doc
pprTempDecl uniq kind
- = uppBesides [ pprPrimKind PprDebug kind, uppSP, prettyToUn (pprUnique uniq), uppSemi ]
+ = hcat [ pprPrimKind PprDebug kind, space, pprUnique uniq, semi ]
-pprExternDecl :: CLabel -> PrimRep -> Unpretty
+pprExternDecl :: CLabel -> PrimRep -> Doc
pprExternDecl clabel kind
= if not (needsCDecl clabel) then
- uppNil -- do not print anything for "known external" things (e.g., < PreludeCore)
+ empty -- do not print anything for "known external" things (e.g., < PreludeCore)
else
case (
case kind of
_ -> ppLocalnessMacro False{-data-} clabel
) of { pp_macro_str ->
- uppBesides [ pp_macro_str, uppLparen, pprCLabel PprForC clabel, pp_paren_semi ]
+ hcat [ pp_macro_str, lparen, pprCLabel PprForC clabel, pp_paren_semi ]
}
\end{code}
\begin{code}
-ppr_decls_AbsC :: AbstractC -> TeM (Maybe Unpretty{-temps-}, Maybe Unpretty{-externs-})
+ppr_decls_AbsC :: AbstractC -> TeM (Maybe Doc{-temps-}, Maybe Doc{-externs-})
ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing)
ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2)
= ppr_decls_AbsC stmts_1 `thenTE` \ p1 ->
ppr_decls_AbsC stmts_2 `thenTE` \ p2 ->
- returnTE (maybe_uppAboves [p1, p2])
+ returnTE (maybe_vcat [p1, p2])
ppr_decls_AbsC (CClosureUpdInfo info)
= ppr_decls_AbsC info
ppr_decls_AbsC (CAssign dest source)
= ppr_decls_Amode dest `thenTE` \ p1 ->
ppr_decls_Amode source `thenTE` \ p2 ->
- returnTE (maybe_uppAboves [p1, p2])
+ returnTE (maybe_vcat [p1, p2])
ppr_decls_AbsC (CJump target) = ppr_decls_Amode target
= ppr_decls_Amode discrim `thenTE` \ pdisc ->
mapTE ppr_alt_stuff alts `thenTE` \ palts ->
ppr_decls_AbsC deflt `thenTE` \ pdeflt ->
- returnTE (maybe_uppAboves (pdisc:pdeflt:palts))
+ returnTE (maybe_vcat (pdisc:pdeflt:palts))
where
ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
(case maybe_fast of
Nothing -> returnTE (Nothing, Nothing)
Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 ->
- returnTE (maybe_uppAboves [p1, p2, p3])
+ returnTE (maybe_vcat [p1, p2, p3])
where
entry_lbl = CLbl slow_lbl CodePtrRep
slow_lbl = case (nonemptyAbsC slow) of
ppr_decls_AbsC (CRetVector label maybe_amodes absC)
= ppr_decls_Amodes (catMaybes maybe_amodes) `thenTE` \ p1 ->
ppr_decls_AbsC absC `thenTE` \ p2 ->
- returnTE (maybe_uppAboves [p1, p2])
+ returnTE (maybe_vcat [p1, p2])
ppr_decls_AbsC (CRetUnVector _ amode) = ppr_decls_Amode amode
ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
\end{code}
\begin{code}
-ppr_decls_Amode :: CAddrMode -> TeM (Maybe Unpretty, Maybe Unpretty)
+ppr_decls_Amode :: CAddrMode -> TeM (Maybe Doc, Maybe Doc)
ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing)
ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing)
ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing)
= labelSeenTE direct `thenTE` \ dlbl_seen ->
labelSeenTE vectored `thenTE` \ vlbl_seen ->
let
- ddcl = if dlbl_seen then uppNil else pprExternDecl direct CodePtrRep
- vdcl = if vlbl_seen then uppNil else pprExternDecl vectored DataPtrRep
+ ddcl = if dlbl_seen then empty else pprExternDecl direct CodePtrRep
+ vdcl = if vlbl_seen then empty else pprExternDecl vectored DataPtrRep
in
returnTE (Nothing,
if (dlbl_seen || not (needsCDecl direct)) &&
(vlbl_seen || not (needsCDecl vectored)) then Nothing
- else Just (uppBesides [uppPStr SLIT("UNVEC"),uppChar '(', ddcl, uppComma, vdcl, uppRparen]))
+ else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
-}
ppr_decls_Amode (CUnVecLbl direct vectored)
--labelSeenTE direct `thenTE` \ dlbl_seen ->
--labelSeenTE vectored `thenTE` \ vlbl_seen ->
let
- ddcl = {-if dlbl_seen then uppNil else-} pprExternDecl direct CodePtrRep
- vdcl = {-if vlbl_seen then uppNil else-} pprExternDecl vectored DataPtrRep
+ ddcl = {-if dlbl_seen then empty else-} pprExternDecl direct CodePtrRep
+ vdcl = {-if vlbl_seen then empty else-} pprExternDecl vectored DataPtrRep
in
returnTE (Nothing,
if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing
- else Just (uppBesides [uppPStr SLIT("UNVEC"),uppChar '(', ddcl, uppComma, vdcl, uppRparen]))
+ else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen]))
ppr_decls_Amode (CTableEntry base index _)
= ppr_decls_Amode base `thenTE` \ p1 ->
ppr_decls_Amode index `thenTE` \ p2 ->
- returnTE (maybe_uppAboves [p1, p2])
+ returnTE (maybe_vcat [p1, p2])
ppr_decls_Amode (CMacroExpr _ _ amodes)
= ppr_decls_Amodes amodes
ppr_decls_Amode other = returnTE (Nothing, Nothing)
-maybe_uppAboves :: [(Maybe Unpretty, Maybe Unpretty)] -> (Maybe Unpretty, Maybe Unpretty)
-maybe_uppAboves ps
+maybe_vcat :: [(Maybe Doc, Maybe Doc)] -> (Maybe Doc, Maybe Doc)
+maybe_vcat ps
= case (unzip ps) of { (ts, es) ->
case (catMaybes ts) of { real_ts ->
case (catMaybes es) of { real_es ->
- (if (null real_ts) then Nothing else Just (uppAboves real_ts),
- if (null real_es) then Nothing else Just (uppAboves real_es))
+ (if (null real_ts) then Nothing else Just (vcat real_ts),
+ if (null real_es) then Nothing else Just (vcat real_es))
} } }
\end{code}
\begin{code}
-ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Unpretty, Maybe Unpretty)
+ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Doc, Maybe Doc)
ppr_decls_Amodes amodes
= mapTE ppr_decls_Amode amodes `thenTE` \ ps ->
- returnTE ( maybe_uppAboves ps )
+ returnTE ( maybe_vcat ps )
\end{code}
import PprStyle ( PprStyle )
import Outputable
-import Pretty ( SYN_IE(Pretty), PrettyRep, ppStr )
+import Pretty ( Doc, text )
import Util ( panic )
\end{code}
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}
--- /dev/null
+_interface_ FieldLabel 1
+_exports_
+FieldLabel FieldLabel;
+_declarations_
+1 data FieldLabel;
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
_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) ;;
mkDataCon,
mkDefaultMethodId,
mkDictFunId,
- mkIdWithNewUniq,
+ mkIdWithNewUniq, mkIdWithNewName,
mkImported,
mkInstId,
mkMethodSelId,
dataConRepType,
dataConArgTys,
- dataConArity,
dataConNumFields,
dataConFieldLabels,
dataConRawArgTys,
cmpId_withSpecDataCon,
externallyVisibleId,
idHasNoFreeTyVars,
- idWantsToBeINLINEd,
- idMustBeINLINEd,
+ idWantsToBeINLINEd, getInlinePragma,
+ idMustBeINLINEd, idMustNotBeINLINEd,
isBottomingId,
isConstMethodId,
isConstMethodId_maybe,
getIdUpdateInfo,
getPragmaInfo,
replaceIdInfo,
- addInlinePragma,
+ addInlinePragma, nukeNoInlinePragma, addNoInlinePragma,
-- IdEnvs AND IdSets
SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet),
) 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,
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)
- )
-import TyVar ( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) )
+ ) -}
+import TyVar --( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) )
import Usage ( SYN_IE(UVar) )
import UniqFM
import UniqSet -- practically all of it
incrUnique,
Unique{-instance Ord3-}
)
-import Util ( mapAccumL, nOfThem, zipEqual, assoc,
+import Outputable ( ifPprDebug, Outputable(..) )
+import Util {- ( mapAccumL, nOfThem, zipEqual, assoc,
panic, panic#, pprPanic, assertPanic
- )
+ ) -}
\end{code}
Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
| DataConId ConTag
[StrictnessMark] -- Strict args; length = arity
- [FieldLabel] -- Field labels for this constructor
+ [FieldLabel] -- Field labels for this constructor;
+ --length = 0 (not a record) or arity
- [TyVar] [(Class,Type)] [Type] TyCon
+ [TyVar] [(Class,Type)] -- Type vars and context for the data type decl
+ [TyVar] [(Class,Type)] -- Ditto for the context of the constructor,
+ -- the existentially quantified stuff
+ [Type] TyCon -- Args and result tycon
-- the type is:
- -- forall tyvars . theta_ty =>
+ -- forall tyvars1 ++ tyvars2. theta1 ++ theta2 =>
-- unitype_1 -> ... -> unitype_n -> tycon tyvars
| TupleConId Int -- Its arity
%************************************************************************
\begin{code}
-isDataCon (Id _ _ _ (DataConId _ _ _ _ _ _ _) _ _) = True
-isDataCon (Id _ _ _ (TupleConId _) _ _) = True
-isDataCon (Id _ _ _ (SpecId unspec _ _) _ _) = isDataCon unspec
-isDataCon other = False
+isDataCon (Id _ _ _ (DataConId _ __ _ _ _ _ _ _) _ _) = True
+isDataCon (Id _ _ _ (TupleConId _) _ _) = True
+isDataCon (Id _ _ _ (SpecId unspec _ _) _ _) = isDataCon unspec
+isDataCon other = False
isTupleCon (Id _ _ _ (TupleConId _) _ _) = True
isTupleCon (Id _ _ _ (SpecId unspec _ _) _ _) = isTupleCon unspec
toplevelishId (Id _ _ _ details _ _)
= chk details
where
- chk (DataConId _ _ _ _ _ _ _) = True
+ chk (DataConId _ __ _ _ _ _ _ _) = True
chk (TupleConId _) = True
chk (RecordSelId _) = True
chk ImportedId = True
idHasNoFreeTyVars (Id _ _ _ details _ info)
= chk details
where
- chk (DataConId _ _ _ _ _ _ _) = True
+ chk (DataConId _ _ _ _ _ _ _ _ _) = True
chk (TupleConId _) = True
chk (RecordSelId _) = True
chk ImportedId = True
-- remember that all type and class decls appear in the interface file.
-- The dfun id must *not* be omitted, because it carries version info for
-- the instance decl
- (DataConId _ _ _ _ _ _ _) -> True
+ (DataConId _ _ _ _ _ _ _ _ _) -> True
(TupleConId _) -> True
(RecordSelId _) -> True
(SuperDictSelId _ _) -> True
name_fn wkr_str = SLIT("$w") _APPEND_ wkr_str
mkInstId u ty name
- = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
+ = Id u name ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
{-LATER:
getConstMethodId clas op ty
in
case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
Just xx -> xx
- Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
- ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
+ Nothing -> pprError "ERROR: getConstMethodId:" (vcat [
+ hsep [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
ppr PprDebug sel_id],
- ppStr "(This can arise if an interface pragma refers to an instance",
- ppStr "but there is no imported interface which *defines* that instance.",
- ppStr "The info above, however ugly, should indicate what else you need to import."
+ text "(This can arise if an interface pragma refers to an instance",
+ text "but there is no imported interface which *defines* that instance.",
+ text "The info above, however ugly, should indicate what else you need to import."
])
-}
mkPrimitiveId n ty primop
= addStandardIdInfo $
- Id (nameUnique n) n ty (PrimitiveId primop) NoPragmaInfo noIdInfo
-
+ Id (nameUnique n) n ty (PrimitiveId primop) IMustBeINLINEd noIdInfo
+ -- The pragma @IMustBeINLINEd@ says that this Id absolutely must be inlined.
+ -- It's only true for primitives, because we don't want to make a closure for each of them.
\end{code}
\begin{code}
mkIdWithNewUniq :: Id -> Unique -> Id
mkIdWithNewUniq (Id _ n ty details prag info) u
= Id u (changeUnique n u) ty details prag info
+
+mkIdWithNewName :: Id -> Name -> Id
+mkIdWithNewName (Id _ _ ty details prag info) new_name
+ = Id (uniqueOf new_name) new_name ty details prag info
\end{code}
Make some local @Ids@ for a template @CoreExpr@. These have bogus
= --ASSERT( not (isDataCon id))
arityInfo id_info
-dataConArity, dataConNumFields :: DataCon -> Int
-
-dataConArity id@(Id _ _ _ _ _ id_info)
- = ASSERT(isDataCon id)
- case arityInfo id_info of
- ArityExactly a -> a
- other -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
-
-dataConNumFields id
- = ASSERT(isDataCon id)
- case (dataConSig id) of { (_, _, arg_tys, _) ->
- length arg_tys }
-
-isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience
-
addIdArity :: Id -> ArityInfo -> Id
addIdArity (Id u n ty details pinfo info) arity
= Id u n ty details pinfo (info `addArityInfo` arity)
\begin{code}
mkDataCon :: Name
-> [StrictnessMark] -> [FieldLabel]
- -> [TyVar] -> ThetaType -> [TauType] -> TyCon
+ -> [TyVar] -> ThetaType
+ -> [TyVar] -> ThetaType
+ -> [TauType] -> TyCon
-> Id
-- can get the tag and all the pieces of the type from the Type
-mkDataCon n stricts fields tvs ctxt args_tys tycon
+mkDataCon n stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon
= ASSERT(length stricts == length args_tys)
addStandardIdInfo data_con
where
= Id (nameUnique n)
n
data_con_ty
- (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon)
+ (DataConId data_con_tag stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon)
IWantToBeINLINEd -- Always inline constructors if possible
noIdInfo
data_con_family = tyConDataCons tycon
data_con_ty
- = mkSigmaTy tvs ctxt
+ = mkSigmaTy (tvs++con_tvs) (ctxt++con_ctxt)
(mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
fIRST_TAG = 1 -- Tags allocated from here for real constructors
\end{code}
+dataConNumFields gives the number of actual fields in the
+{\em representation} of the data constructor. This may be more than appear
+in the source code; the extra ones are the existentially quantified
+dictionaries
+
+\begin{code}
+dataConNumFields id
+ = ASSERT(isDataCon id)
+ case (dataConSig id) of { (_, _, _, con_theta, arg_tys, _) ->
+ length con_theta + length arg_tys }
+
+isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience
+\end{code}
+
+
\begin{code}
dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
-dataConTag (Id _ _ _ (DataConId tag _ _ _ _ _ _) _ _) = tag
+dataConTag (Id _ _ _ (DataConId tag _ _ _ _ _ _ _ _) _ _) = tag
dataConTag (Id _ _ _ (TupleConId _) _ _) = fIRST_TAG
dataConTag (Id _ _ _ (SpecId unspec _ _) _ _) = dataConTag unspec
dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
-dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
+dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ _ _ tycon) _ _) = tycon
dataConTyCon (Id _ _ _ (TupleConId a) _ _) = tupleTyCon a
-dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
+dataConSig :: DataCon -> ([TyVar], ThetaType, [TyVar], ThetaType, [TauType], TyCon)
-- will panic if not a DataCon
-dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
- = (tyvars, theta_ty, arg_tys, tycon)
+dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta con_tyvars con_theta arg_tys tycon) _ _)
+ = (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon)
dataConSig (Id _ _ _ (TupleConId arity) _ _)
- = (tyvars, [], tyvar_tys, tupleTyCon arity)
+ = (tyvars, [], [], [], tyvar_tys, tupleTyCon arity)
where
tyvars = take arity alphaTyVars
tyvar_tys = mkTyVarTys tyvars
(tyvars, theta, tau) = splitSigmaTy (idType con)
dataConFieldLabels :: DataCon -> [FieldLabel]
-dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _) _ _) = fields
+dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _ _ _) _ _) = fields
dataConFieldLabels (Id _ _ _ (TupleConId _) _ _) = []
dataConStrictMarks :: DataCon -> [StrictnessMark]
-dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts
+dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _ _ _) _ _) = stricts
dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _)
= nOfThem arity NotMarkedStrict
dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
-dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys }
+dataConRawArgTys con = case (dataConSig con) of { (_,_, _, _, arg_tys,_) -> arg_tys }
dataConArgTys :: DataCon
-> [Type] -- Instantiated at these types
dataConArgTys con_id inst_tys
= map (instantiateTy tenv) arg_tys
where
- (tyvars, _, arg_tys, _) = dataConSig con_id
- tenv = zipEqual "dataConArgTys" tyvars inst_tys
+ (tyvars, _, _, _, arg_tys, _) = dataConSig con_id
+ tenv = zipEqual "dataConArgTys" tyvars inst_tys
\end{code}
\begin{code}
OK not to if optimisation is switched off.
\begin{code}
+getInlinePragma :: Id -> PragmaInfo
+getInlinePragma (Id _ _ _ _ prag _) = prag
+
idWantsToBeINLINEd :: Id -> Bool
idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True
+idWantsToBeINLINEd (Id _ _ _ _ IMustBeINLINEd _) = True
idWantsToBeINLINEd _ = False
+idMustNotBeINLINEd (Id _ _ _ _ IMustNotBeINLINEd _) = True
+idMustNotBeINLINEd _ = False
+
+idMustBeINLINEd (Id _ _ _ _ IMustBeINLINEd _) = True
+idMustBeINLINEd _ = False
+
addInlinePragma :: Id -> Id
addInlinePragma (Id u sn ty details _ info)
= Id u sn ty details IWantToBeINLINEd info
-\end{code}
-
-The predicate @idMustBeINLINEd@ says that this Id absolutely must be inlined.
-It's only true for primitives, because we don't want to make a closure for each of them.
+nukeNoInlinePragma :: Id -> Id
+nukeNoInlinePragma id@(Id u sn ty details IMustNotBeINLINEd info)
+ = Id u sn ty details NoPragmaInfo info
+nukeNoInlinePragma id@(Id u sn ty details _ info) = id -- Otherwise no-op
-\begin{code}
-idMustBeINLINEd (Id _ _ _ (PrimitiveId primop) _ _) = True
-idMustBeINLINEd other = False
+addNoInlinePragma :: Id -> Id
+addNoInlinePragma id@(Id u sn ty details _ info)
+ = Id u sn ty details IMustNotBeINLINEd info
\end{code}
+
%************************************************************************
%* *
\subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
ppr sty id = pprId sty id
showId :: PprStyle -> Id -> String
-showId sty id = ppShow 80 (pprId sty id)
+showId sty id = show (pprId sty id)
\end{code}
Default printing code (not used for interfaces):
\begin{code}
-pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
+pprId :: Outputable ty => PprStyle -> GenId ty -> Doc
+
+pprId sty (Id u n _ _ prags _)
+ = hcat [ppr sty n, pp_prags]
+ where
+ pp_prags = ifPprDebug sty (case prags of
+ IMustNotBeINLINEd -> text "{n}"
+ IWantToBeINLINEd -> text "{i}"
+ IMustBeINLINEd -> text "{I}"
+ other -> empty)
-pprId sty (Id u n _ _ _ _) = ppr sty n
-- WDP 96/05/06: We can re-elaborate this as we go along...
\end{code}
nmbrDataCon id@(Id _ _ _ (TupleConId _) _ _) nenv
= (nenv, id) -- nothing to do for tuples
-nmbrDataCon id@(Id u n ty (DataConId tag marks fields tvs theta arg_tys tc) prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
+nmbrDataCon id@(Id u n ty (DataConId tag marks fields tvs theta con_tvs con_theta arg_tys tc) prag info)
+ nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
= case (lookupUFM_Directly idenv u) of
Just xx -> trace "nmbrDataCon: in env???\n" (nenv, xx)
Nothing ->
(nenv2, new_fields) = (mapNmbr nmbrField fields) nenv
(nenv3, new_arg_tys) = (mapNmbr nmbrType arg_tys) nenv2
- new_det = DataConId tag marks new_fields (bottom "tvs") (bottom "theta") new_arg_tys tc
+ new_det = DataConId tag marks new_fields (bottom "tvs") (bottom "theta") (bottom "tvs") (bottom "theta") new_arg_tys tc
new_id = Id u n (bottom "ty") new_det prag info
in
(nenv3, new_id)
------------
nmbr_details :: IdDetails -> NmbrM IdDetails
-nmbr_details (DataConId tag marks fields tvs theta arg_tys tc)
+nmbr_details (DataConId tag marks fields tvs theta con_tvs con_theta arg_tys tc)
= mapNmbr nmbrTyVar tvs `thenNmbr` \ new_tvs ->
+ mapNmbr nmbrTyVar con_tvs `thenNmbr` \ new_con_tvs ->
mapNmbr nmbrField fields `thenNmbr` \ new_fields ->
mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
+ mapNmbr nmbr_theta con_theta `thenNmbr` \ new_con_theta ->
mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys ->
- returnNmbr (DataConId tag marks new_fields new_tvs new_theta new_arg_tys tc)
+ returnNmbr (DataConId tag marks new_fields new_tvs new_theta new_con_tvs new_con_theta new_arg_tys tc)
where
nmbr_theta (c,t)
= --nmbrClass c `thenNmbr` \ new_c ->
ppIdInfo :: PprStyle
-> Bool -- True <=> print specialisations, please
-> IdInfo
- -> Pretty
+ -> Doc
ppIdInfo sty specs_please
(IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype)
- = ppCat [
+ = hsep [
-- order is important!:
ppArityInfo sty arity,
ppUpdateInfo sty update,
ppStrictnessInfo sty strictness,
if specs_please
- then ppNil -- ToDo -- sty (not (isDataCon for_this_id))
+ then empty -- ToDo -- sty (not (isDataCon for_this_id))
-- better_id_fn inline_env (mEnvToList specenv)
- else ppNil,
+ else empty,
-- DemandInfo needn't be printed since it has no effect on interfaces
ppDemandInfo sty demand,
arityInfo (IdInfo arity _ _ _ _ _ _ _ _) = arity
-addArityInfo id_info UnknownArity = id_info
addArityInfo (IdInfo _ a c d e f g h i) arity = IdInfo arity a c d e f g h i
-ppArityInfo sty UnknownArity = ppNil
-ppArityInfo sty (ArityExactly arity) = ppCat [ppPStr SLIT("_A_"), ppInt arity]
-ppArityInfo sty (ArityAtLeast arity) = ppCat [ppPStr SLIT("_A>_"), ppInt arity]
+ppArityInfo sty UnknownArity = empty
+ppArityInfo sty (ArityExactly arity) = hsep [ptext SLIT("_A_"), int arity]
+ppArityInfo sty (ArityAtLeast arity) = hsep [ptext SLIT("_A>_"), int arity]
\end{code}
%************************************************************************
addDemandInfo (IdInfo a _ c d e f g h i) demand = IdInfo a demand c d e f g h i
-ppDemandInfo PprInterface _ = ppNil
-ppDemandInfo sty UnknownDemand = ppStr "{-# L #-}"
-ppDemandInfo sty (DemandedAsPer info) = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"]
+ppDemandInfo PprInterface _ = empty
+ppDemandInfo sty UnknownDemand = text "{-# L #-}"
+ppDemandInfo sty (DemandedAsPer info) = hsep [text "{-#", text (showList [info] ""), text "#-}"]
\end{code}
%************************************************************************
addStrictnessInfo id_info NoStrictnessInfo = id_info
addStrictnessInfo (IdInfo a b d _ e f g h i) strict = IdInfo a b d strict e f g h i
-ppStrictnessInfo sty NoStrictnessInfo = ppNil
-ppStrictnessInfo sty BottomGuaranteed = ppPStr SLIT("_bot_")
+ppStrictnessInfo sty NoStrictnessInfo = empty
+ppStrictnessInfo sty BottomGuaranteed = ptext SLIT("_bot_")
ppStrictnessInfo sty (StrictnessInfo wrapper_args wrkr_maybe)
- = ppCat [ppPStr SLIT("_S_"), ppStr (showList wrapper_args ""), pp_wrkr]
+ = hsep [ptext SLIT("_S_"), text (showList wrapper_args ""), pp_wrkr]
where
pp_wrkr = case wrkr_maybe of
- Nothing -> ppNil
+ Nothing -> empty
Just wrkr -> ppr sty wrkr
\end{code}
addUpdateInfo id_info NoUpdateInfo = id_info
addUpdateInfo (IdInfo a b d e f _ g h i) upd_info = IdInfo a b d e f upd_info g h i
-ppUpdateInfo sty NoUpdateInfo = ppNil
-ppUpdateInfo sty (SomeUpdateInfo []) = ppNil
-ppUpdateInfo sty (SomeUpdateInfo spec) = ppBeside (ppPStr SLIT("_U_ ")) (ppBesides (map ppInt spec))
+ppUpdateInfo sty NoUpdateInfo = empty
+ppUpdateInfo sty (SomeUpdateInfo []) = empty
+ppUpdateInfo sty (SomeUpdateInfo spec) = (<>) (ptext SLIT("_U_ ")) (hcat (map int spec))
\end{code}
%************************************************************************
addDeforestInfo id_info Don'tDeforest = id_info
addDeforestInfo (IdInfo a b d e f g _ h i) deforest = IdInfo a b d e f g deforest h i
-ppDeforestInfo sty Don'tDeforest = ppNil
-ppDeforestInfo sty DoDeforest = ppPStr SLIT("_DEFOREST_")
+ppDeforestInfo sty Don'tDeforest = empty
+ppDeforestInfo sty DoDeforest = ptext SLIT("_DEFOREST_")
\end{code}
%************************************************************************
addArgUsageInfo id_info NoArgUsageInfo = id_info
addArgUsageInfo (IdInfo a b d e f g h _ i) au_info = IdInfo a b d e f g h au_info i
-ppArgUsageInfo sty NoArgUsageInfo = ppNil
-ppArgUsageInfo sty (SomeArgUsageInfo aut) = ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut)
+ppArgUsageInfo sty NoArgUsageInfo = empty
+ppArgUsageInfo sty (SomeArgUsageInfo aut) = (<>) (ptext SLIT("_L_ ")) (ppArgUsageType aut)
-ppArgUsage (ArgUsage n) = ppInt n
-ppArgUsage (UnknownArgUsage) = ppChar '-'
+ppArgUsage (ArgUsage n) = int n
+ppArgUsage (UnknownArgUsage) = char '-'
-ppArgUsageType aut = ppBesides
- [ ppChar '"' ,
- ppIntersperse ppComma (map ppArgUsage aut),
- ppChar '"' ]
+ppArgUsageType aut = hcat
+ [ char '"' ,
+ hcat (punctuate comma (map ppArgUsage aut)),
+ char '"' ]
\end{code}
%************************************************************************
addFBTypeInfo id_info NoFBTypeInfo = id_info
addFBTypeInfo (IdInfo a b d e f g h i _) fb_info = IdInfo a b d e f g h i fb_info
-ppFBTypeInfo sty NoFBTypeInfo = ppNil
+ppFBTypeInfo sty NoFBTypeInfo = empty
ppFBTypeInfo sty (SomeFBTypeInfo (FBType cons prod))
- = ppBeside (ppPStr SLIT("_F_ ")) (ppFBType cons prod)
+ = (<>) (ptext SLIT("_F_ ")) (ppFBType cons prod)
-ppFBType cons prod = ppBesides
- ([ ppChar '"' ] ++ map ppCons cons ++ [ ppChar '-', ppProd prod, ppChar '"' ])
+ppFBType cons prod = hcat
+ ([ char '"' ] ++ map ppCons cons ++ [ char '-', ppProd prod, char '"' ])
where
- ppCons FBGoodConsum = ppChar 'G'
- ppCons FBBadConsum = ppChar 'B'
- ppProd FBGoodProd = ppChar 'G'
- ppProd FBBadProd = ppChar 'B'
+ ppCons FBGoodConsum = char 'G'
+ ppCons FBBadConsum = char 'B'
+ ppProd FBGoodProd = char 'G'
+ ppProd FBBadProd = char 'B'
\end{code}
--- /dev/null
+module IdLoop
+
+ (
+ module CostCentre,
+ module SpecEnv,
+ module CoreUnfold,
+ module StdIdInfo,
+ module Id
+ ) where
+
+import CostCentre
+import Id
+import SpecEnv
+import CoreUnfold
+import StdIdInfo
+
import BinderInfo ( BinderInfo )
import CoreSyn ( CoreExpr(..), GenCoreExpr, GenCoreArg )
-import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
+import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), mkUnfolding,
SimpleUnfolding(..), FormSummary(..), noUnfolding )
import CoreUtils ( unTagBinders )
import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId,
preludeDictsCostCentre, mkAllCafsCC,
mkAllDictsCC, mkUserCC
)
-import IdInfo ( IdInfo )
+import IdInfo ( IdInfo, DemandInfo )
import SpecEnv ( SpecEnv, nullSpecEnv, isNullSpecEnv )
import Literal ( Literal )
import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun )
import PprEnv ( NmbrEnv )
import PprStyle ( PprStyle )
import PprType ( pprParendGenType )
-import Pretty ( PrettyRep )
+import PragmaInfo ( PragmaInfo )
+import Pretty ( Doc )
import Type ( GenType )
import TyVar ( GenTyVar )
import UniqFM ( UniqFM )
externallyVisibleId :: Id -> Bool
isDataCon :: GenId ty -> Bool
isWorkerId :: GenId ty -> Bool
-isWrapperId :: Id -> Bool
-unfoldingUnfriendlyId :: Id -> Bool
-getIdInfo :: Id -> IdInfo
-nullIdEnv :: UniqFM a
-lookupIdEnv :: UniqFM b -> GenId a -> Maybe b
-mAX_WORKER_ARGS :: Int
nmbrId :: Id -> NmbrEnv -> (NmbrEnv, Id)
-pprParendGenType :: (Eq a, Outputable a, Eq b, Outputable b) => PprStyle -> GenType a b -> Int -> Bool -> PrettyRep
mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun
+
type IdEnv a = UniqFM a
type CoreExpr = GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique))
(GenId (GenType (GenTyVar (GenUsage Unique)) Unique))
instance (Outputable a) => Outputable (GenId a)
instance (Eq a, Outputable a, Eq b, Outputable b) => Outputable (GenType a b)
+data DemandInfo
data SpecEnv
data NmbrEnv
data 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)
import Id ( mkPrimitiveId, mkTemplateLocals )
import IdInfo -- quite a few things
import StdIdInfo
-import Name ( mkWiredInIdName )
+import Name ( mkWiredInIdName, Name )
import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str,
- PrimOpInfo(..), PrimOpResultInfo(..) )
+ PrimOpInfo(..), PrimOpResultInfo(..), PrimOp )
import PrelMods ( gHC__ )
import Type ( mkForAllTys, mkFunTy, mkFunTys, mkTyVarTy, applyTyCon )
import TysWiredIn ( boolTy )
--- /dev/null
+_interface_ Literal 1
+_exports_
+Literal Literal;
+_declarations_
+1 data Literal;
import TysWiredIn ( stringTy )
import Pretty -- pretty-printing stuff
import PprStyle ( PprStyle(..), codeStyle, ifaceStyle )
-import Util ( thenCmp, panic, pprPanic )
+import Util --( thenCmp, panic, pprPanic )
+#if __GLASGOW_HASKELL__ >= 202
+import Type
+import Outputable
+#endif
\end{code}
So-called @Literals@ are {\em either}:
The boring old output stuff:
\begin{code}
-ppCast :: PprStyle -> FAST_STRING -> Pretty
-ppCast PprForC cast = ppPStr cast
-ppCast _ _ = ppNil
+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
PprInterface -> charToEasyHaskell ch
_ -> [ch]
in
- ppBesides [ppCast sty SLIT("(C_)"), ppChar '\'', ppStr char_encoding, ppChar '\'']
+ hcat [ppCast sty SLIT("(C_)"), char '\'', text char_encoding, char '\'']
ppr sty (MachStr s)
- | codeStyle sty = ppBesides [ppChar '"', ppStr (stringToC (_UNPK_ s)), ppChar '"']
- | otherwise = ppBesides [ppChar '"', ppPStr s, ppChar '"']
+ | 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 = ppBesides [ppPStr SLIT("_string_"), ppChar '"', ppPStr s,ppChar '"']
+ | 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 = ppInteger i
+ | otherwise = integer i
where
range_min = if signed then minInt else 0
out_of_range = not (i >= toInteger range_min && i <= toInteger range_max)
ppr sty (MachFloat f)
- | codeStyle sty = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f]
- | otherwise = ppBesides [ppPStr SLIT("_float_"), ppRational f]
+ | codeStyle sty = hcat [ppCast sty SLIT("(StgFloat)"), rational f]
+ | otherwise = hcat [ptext SLIT("_float_ "), rational f]
- ppr sty (MachDouble d) = ppRational d
+ ppr sty (MachDouble d) = rational d
ppr sty (MachAddr p)
- | codeStyle sty = ppBesides [ppCast sty SLIT("(void*)"), ppInteger p]
- | otherwise = ppBesides [ppPStr SLIT("_addr_"), ppInteger 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 = ppCat [ppPStr SLIT("_integer_"), ppInteger i]
+ | otherwise = hsep [ptext SLIT("_integer_ "), integer i]
ppr sty lit@(NoRepRational r _)
| codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit)
- | otherwise = ppCat [ppPStr SLIT("_rational_"), ppInteger (numerator r), ppInteger (denominator r)]
+ | otherwise = hsep [ptext SLIT("_rational_ "), integer (numerator r), integer (denominator r)]
ppr sty (MachLitLit s k)
- | codeStyle sty = ppPStr s
- | otherwise = ppBesides [ppPStr SLIT("_litlit_ "), ppPrimRep k, ppStr " \"", ppPStr s, ppChar '"']
+ | codeStyle sty = ptext s
+ | otherwise = hcat [ptext SLIT("_litlit_ "), ppPrimRep k, char ' ', text (show (_UNPK_ s))]
showLiteral :: PprStyle -> Literal -> String
-showLiteral sty lit = ppShow 80 (ppr sty lit)
+showLiteral sty lit = show (ppr sty lit)
\end{code}
--- /dev/null
+_interface_ Name 1
+_usages_
+FastString 1 :: FastString 1;
+_exports_
+Name Name Module;
+_declarations_
+1 data Name;
+1 type Module = FastString.FastString;
-- The OccName type
OccName(..),
- pprOccName, pprSymOcc, pprNonSymOcc, occNameString, occNameFlavour,
+ pprOccName, occNameString, occNameFlavour,
isTvOcc, isTCOcc, isVarOcc, prefixOccName,
quoteInText, parenInCode,
maybeWiredInIdName, maybeWiredInTyConName,
isWiredInName,
- nameUnique, changeUnique, setNameProvenance, setNameVisibility,
- nameOccName, nameString,
+ nameUnique, changeUnique, setNameProvenance, getNameProvenance,
+ setNameVisibility,
+ nameOccName, nameString, nameModule,
+
isExportedName, nameSrcLoc,
isLocallyDefinedName,
pprNameProvenance,
-- Sets of Names
- NameSet(..),
+ SYN_IE(NameSet),
emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets,
minusNameSet, elemNameSet, nameSetToList, addListToNameSet, isEmptyNameSet,
-- Class NamedThing and overloaded friends
NamedThing(..),
modAndOcc, isExported,
- getSrcLoc, isLocallyDefined, getOccString,
-
- pprSym, pprNonSym
+ getSrcLoc, isLocallyDefined, getOccString
) where
IMP_Ubiq()
-import TyLoop ( GenId, Id(..), TyCon ) -- Used inside Names
+import TyLoop --( GenId, Id(..), TyCon ) -- Used inside Names
import CStrings ( identToC, modnameToC, cSEP )
import CmdLineOpts ( opt_OmitInterfacePragmas, opt_EnsureSplittableC )
import Pretty
import Lex ( isLexSym, isLexConId )
import SrcLoc ( noSrcLoc, SrcLoc )
+import Usage ( SYN_IE(UVar), SYN_IE(Usage) )
import Unique ( pprUnique, showUnique, Unique )
import UniqSet ( UniqSet(..), emptyUniqSet, unitUniqSet, unionUniqSets, uniqSetToList, isEmptyUniqSet,
unionManyUniqSets, minusUniqSet, mkUniqSet, elementOfUniqSet, addListToUniqSet )
-import UniqFM ( UniqFM )
-import Util ( cmpPString, panic, assertPanic {-, pprTrace ToDo:rm-} )
+import UniqFM ( UniqFM, SYN_IE(Uniquable) )
+import Util --( cmpPString, panic, assertPanic {-, pprTrace ToDo:rm-} )
+
\end{code}
moduleString :: Module -> String
moduleString mod = _UNPK_ mod
-pprModule :: PprStyle -> Module -> Pretty
-pprModule sty m = ppPStr m
+pprModule :: PprStyle -> Module -> Doc
+pprModule sty m = ptext m
-pprOccName :: PprStyle -> OccName -> Pretty
-pprOccName PprDebug n = ppCat [ppPStr (occNameString n), ppBracket (ppStr (occNameFlavour n))]
+pprOccName :: PprStyle -> OccName -> Doc
pprOccName sty n = if codeStyle sty
then identToC (occNameString n)
- else ppPStr (occNameString n)
+ else ptext (occNameString n)
occNameString :: OccName -> FAST_STRING
occNameString (VarOcc s) = s
parenInCode occ = isLexSym (occNameString occ)
quoteInText occ = not (isLexSym (occNameString occ))
-
--- print `vars`, (op) correctly
-pprSymOcc, pprNonSymOcc :: PprStyle -> OccName -> Pretty
-
-pprSymOcc sty var
- = if quoteInText var
- then ppQuote (pprOccName sty var)
- else pprOccName sty var
-
-pprNonSymOcc sty var
- = if parenInCode var
- then ppParens (pprOccName sty var)
- else pprOccName sty var
\end{code}
%************************************************************************
setNameProvenance (Global uniq mod occ def Implicit) prov = Global uniq mod occ def prov
setNameProvenance other_name prov = other_name
+getNameProvenance :: Name -> Provenance
+getNameProvenance (Global uniq mod occ def prov) = prov
+getNameProvenance (Local uniq occ locn) = LocalDef NotExported locn
+
-- When we renumber/rename things, we need to be
-- able to change a Name's Unique to match the cached
-- one in the thing it's the name of. If you know what I mean.
nameUnique :: Name -> Unique
nameModAndOcc :: Name -> (Module, OccName) -- Globals only
nameOccName :: Name -> OccName
+nameModule :: Name -> Module
nameString :: Name -> FAST_STRING -- A.b form
nameSrcLoc :: Name -> SrcLoc
isLocallyDefinedName :: Name -> Bool
nameOccName (Local _ occ _) = occ
nameOccName (Global _ _ occ _ _) = occ
+nameModule (Global _ mod occ _ _) = mod
+
nameModAndOcc (Global _ mod occ _ _) = (mod,occ)
nameString (Local _ occ _) = occNameString occ
\begin{code}
instance Outputable Name where
+ ppr PprQuote name@(Local _ _ _) = quotes (ppr PprForUser name)
+ ppr PprForUser (Local _ n _) = ptext (occNameString n)
+
ppr sty (Local u n _) | codeStyle sty ||
ifaceStyle sty = pprUnique u
- ppr PprForUser (Local _ n _) = ppPStr (occNameString n)
- ppr other_sty (Local u n _) = ppBesides [ppPStr (occNameString n), ppPStr SLIT("_"), pprUnique u]
-
- ppr sty name@(Global u m n _ _) = ppBesides [pp_name, pp_debug sty name]
- where
- pp_name | codeStyle sty = identToC qual_name
- | otherwise = ppBesides[ ppPStr m, ppChar '.', ppPStr pk_n]
- pk_n = occNameString n
- qual_name = m _APPEND_ SLIT(".") _APPEND_ pk_n
-
-pp_debug PprDebug (Global uniq m n _ prov) = ppBesides [ppStr "{-", pprUnique uniq, ppChar ',',
- pp_prov prov, ppStr "-}"]
+
+ ppr sty (Local u n _) = hcat [ptext (occNameString n), ptext SLIT("_"), pprUnique u]
+
+ ppr PprQuote name@(Global _ _ _ _ _) = quotes (ppr PprForUser 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, ptext (occNameString n), pp_debug sty name]
+ where
+ pp_mod = case prov of --- Omit home module qualifier
+ LocalDef _ _ -> empty
+ other -> pprModule PprForUser m <> char '.'
+
+
+pp_debug PprDebug (Global uniq m n _ prov) = hcat [text "{-", pprUnique uniq, char ',',
+ pp_prov prov, text "-}"]
where
- pp_prov (LocalDef Exported _) = ppChar 'x'
- pp_prov (LocalDef NotExported _) = ppChar 'l'
- pp_prov (Imported _ _) = ppChar 'i'
- pp_prov Implicit = ppChar 'p'
-pp_debug other name = ppNil
+ pp_prov (LocalDef Exported _) = char 'x'
+ pp_prov (LocalDef NotExported _) = char 'l'
+ pp_prov (Imported _ _) = char 'i'
+ pp_prov Implicit = char 'p'
+pp_debug other name = empty
-- pprNameProvenance is used in error messages to say where a name came from
-pprNameProvenance :: PprStyle -> Name -> Pretty
+pprNameProvenance :: PprStyle -> Name -> Doc
pprNameProvenance sty (Local _ _ loc) = pprProvenance sty (LocalDef NotExported loc)
pprNameProvenance sty (Global _ _ _ _ prov) = pprProvenance sty prov
-pprProvenance :: PprStyle -> Provenance -> Pretty
+pprProvenance :: PprStyle -> Provenance -> Doc
pprProvenance sty (Imported mod loc)
- = ppSep [ppPStr SLIT("Imported from"), pprModule sty mod, ppPStr SLIT("at"), ppr sty loc]
+ = sep [ptext SLIT("Imported from"), pprModule sty mod, ptext SLIT("at"), ppr sty loc]
pprProvenance sty (LocalDef _ loc)
- = ppSep [ppPStr SLIT("Defined at"), ppr sty loc]
+ = sep [ptext SLIT("Defined at"), ppr sty loc]
pprProvenance sty Implicit
= panic "pprNameProvenance: Implicit"
\end{code}
\begin{code}
modAndOcc :: NamedThing a => a -> (Module, OccName)
+getModule :: NamedThing a => a -> Module
getSrcLoc :: NamedThing a => a -> SrcLoc
isLocallyDefined :: NamedThing a => a -> Bool
isExported :: NamedThing a => a -> Bool
getOccString :: NamedThing a => a -> String
modAndOcc = nameModAndOcc . getName
+getModule = nameModule . getName
isExported = isExportedName . getName
getSrcLoc = nameSrcLoc . getName
isLocallyDefined = isLocallyDefinedName . getName
-pprSym sty = pprSymOcc sty . getOccName
-pprNonSym sty = pprNonSymOcc sty . getOccName
getOccString x = _UNPK_ (occNameString (getOccName x))
\end{code}
IMP_Ubiq(){-uitous-}
-import Pretty ( SYN_IE(Pretty) )
-import Unique ( initRenumberingUniques )
-import UniqFM ( emptyUFM )
+import Pretty ( Doc )
+import Outputable
+import Unique ( initRenumberingUniques, Unique )
+import UniqFM ( emptyUFM, UniqFM )
import Util ( panic )
+#if __GLASGOW_HASKELL__ >= 202
+IMPORT_DELOOPER(TyLoop)
+import PprStyle ( 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
data PprEnv tyvar uvar bndr occ
= PE PprStyle -- stored for safe keeping
- (Literal -> Pretty) -- Doing these this way saves
- (Id -> Pretty) -- carrying around a PprStyle
- (PrimOp -> Pretty)
- (CostCentre -> Pretty)
+ (Literal -> Doc) -- Doing these this way saves
+ (Id -> Doc) -- carrying around a PprStyle
+ (PrimOp -> Doc)
+ (CostCentre -> Doc)
- (tyvar -> Pretty) -- to print tyvar binders
- (tyvar -> Pretty) -- to print tyvar occurrences
+ (tyvar -> Doc) -- to print tyvar binders
+ (tyvar -> Doc) -- to print tyvar occurrences
- (uvar -> Pretty) -- to print usage vars
+ (uvar -> Doc) -- to print usage vars
- (bndr -> Pretty) -- to print "major" val_bdrs
- (bndr -> Pretty) -- to print "minor" val_bdrs
- (occ -> Pretty) -- to print bindees
+ (bndr -> Doc) -- to print "major" val_bdrs
+ (bndr -> Doc) -- to print "minor" val_bdrs
+ (occ -> Doc) -- to print bindees
- (GenType tyvar uvar -> Pretty)
- (GenUsage uvar -> Pretty)
+ (GenType tyvar uvar -> Doc)
+ (GenUsage uvar -> Doc)
\end{code}
\begin{code}
initPprEnv
:: PprStyle
- -> Maybe (Literal -> Pretty)
- -> Maybe (Id -> Pretty)
- -> Maybe (PrimOp -> Pretty)
- -> Maybe (CostCentre -> Pretty)
- -> Maybe (tyvar -> Pretty)
- -> Maybe (tyvar -> Pretty)
- -> Maybe (uvar -> Pretty)
- -> Maybe (bndr -> Pretty)
- -> Maybe (bndr -> Pretty)
- -> Maybe (occ -> Pretty)
- -> Maybe (GenType tyvar uvar -> Pretty)
- -> Maybe (GenUsage uvar -> Pretty)
+ -> 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
-- you can specify all the printers individually; if
= PE (ppr sty) -- for a Literal
(ppr sty) -- for a DataCon
(ppr sty) -- for a PrimOp
- (\ cc -> ppStr (showCostCentre sty True cc)) -- CostCentre
+ (\ cc -> text (showCostCentre sty True cc)) -- CostCentre
(ppr sty) -- for a tyvar
(ppr sty) -- for a usage var
\begin{code}
data PragmaInfo
= NoPragmaInfo
+
| IWantToBeINLINEd
+
+ | IMustNotBeINLINEd -- Used by the simplifier to prevent looping
+ -- on recursive definitions
+
+ | IMustBeINLINEd -- Absolutely must inline; used for PrimOps only
\end{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
+ ) -} where
IMP_Ubiq()
-import PprStyle ( PprStyle(..) )
+import Outputable
+import PprStyle ( PprStyle(..), userStyle )
import Pretty
+
\end{code}
%************************************************************************
\begin{code}
instance Outputable SrcLoc where
- ppr PprForUser (SrcLoc src_file src_line)
- = ppBesides [ ppPStr src_file, ppChar ':', ppStr (show IBOX(src_line)) ]
-
ppr sty (SrcLoc src_file src_line)
- = ppBesides [ppStr "{-# LINE ", ppStr (show IBOX(src_line)), ppSP,
- ppChar '\"', ppPStr src_file, ppStr " #-}"]
- ppr sty (UnhelpfulSrcLoc s) = ppPStr s
+ | 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 = ppStr "<NoSrcLoc>"
+ ppr sty NoSrcLoc = text "<NoSrcLoc>"
\end{code}
{-
- = ppBesides [ppPStr SLIT("{-# LINE "), ppStr (show IBOX(src_line)), ppSP,
- ppChar '"', ppPStr src_file, ppPStr SLIT(" #-}")]
- --ppPStr SLIT("\" #-}")]
+ = hcat [ptext SLIT("{-# LINE "), text (show IBOX(src_line)), space,
+ char '"', ptext src_file, ptext SLIT(" #-}")]
+ --ptext SLIT("\" #-}")]
-}
import Unique
import Util
-import PreludeGlaST
-#if __GLASGOW_HASKELL__ >= 200
+#if __GLASGOW_HASKELL__ == 201
+import PreludeGlaST
# define WHASH GHCbase.W#
+#elif __GLASGOW_HASKELL__ >= 202
+import GlaExts
+import STBase
+# define WHASH GlaExts.W#
#else
+import PreludeGlaST
# define WHASH W#
#endif
-- this is the single-most-hammered bit of code
-- in the compiler....
-- Too bad it's not 1.3-portable...
- unsafe_interleave m s
- = let
- (r, new_s) = m s
- in
- (r, s)
+ unsafe_interleave m =
+ MkST ( \ s ->
+ let
+ (MkST m') = m
+ (r, new_s) = m' s
+ in
+ (r, s))
--
mk_unique = _ccall_ genSymZh `thenPrimIO` \ (WHASH u#) ->
where
get_from 0# _ = []
get_from n (MkSplitUniqSupply (I# u) _ s2)
- = mkUniqueGrimily u : get_from (n `minusInt#` 1#) s2
+ = mkUniqueGrimily u : get_from (n -# 1#) s2
\end{code}
%************************************************************************
--- /dev/null
+_interface_ Unique 1
+_exports_
+Unique Unique mkUniqueGrimily;
+_declarations_
+1 data Unique;
+1 mkUniqueGrimily _:_ GHC.Int# -> Unique.Unique ;;
, parGlobalIdKey
, parLocalIdKey
, unboundKey
+ , byteArrayTyConKey
+ , mutableByteArrayTyConKey
+ , allClassKey
) where
+#if __GLASGOW_HASKELL__ <= 201
import PreludeGlaST
+#else
+import GlaExts
+import ST
+#endif
IMP_Ubiq(){-uitous-}
+#if __GLASGOW_HASKELL__ >= 202
+import {-# SOURCE #-} UniqFM ( Uniquable(..) )
+#endif
+
+import Outputable
import Pretty
import Util
\end{code}
We do sometimes make strings with @Uniques@ in them:
\begin{code}
-pprUnique, pprUnique10 :: Unique -> Pretty
+pprUnique, pprUnique10 :: Unique -> Doc
pprUnique uniq
= case unpkUnique uniq of
pprUnique10 uniq -- in base-10, dudes
= case unpkUnique uniq of
- (tag, u) -> finish_ppr tag u (ppInt u)
+ (tag, u) -> finish_ppr tag u (int u)
finish_ppr tag u pp_u
= if tag /= 't' -- this is just to make v common tyvars, t1, t2, ...
-- come out as a, b, ... (shorter, easier to read)
then pp_all
else case u of
- 1 -> ppChar 'a'
- 2 -> ppChar 'b'
- 3 -> ppChar 'c'
- 4 -> ppChar 'd'
- 5 -> ppChar 'e'
+ 1 -> char 'a'
+ 2 -> char 'b'
+ 3 -> char 'c'
+ 4 -> char 'd'
+ 5 -> char 'e'
_ -> pp_all
where
- pp_all = ppBeside (ppChar tag) pp_u
+ pp_all = (<>) (char tag) pp_u
showUnique :: Unique -> FAST_STRING
-showUnique uniq = _PK_ (ppShow 80 (pprUnique uniq))
+showUnique uniq = _PK_ (show (pprUnique uniq))
instance Outputable Unique where
ppr sty u = pprUnique u
The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints.
Code stolen from Lennart.
\begin{code}
-#if __GLASGOW_HASKELL__ >= 200
+#if __GLASGOW_HASKELL__ == 201
# define BYTE_ARRAY GHCbase.ByteArray
# define RUN_ST GHCbase.runST
# define AND_THEN >>=
# define AND_THEN_ >>
# define RETURN return
+#elif __GLASGOW_HASKELL__ >= 202
+# define BYTE_ARRAY GlaExts.ByteArray
+# define RUN_ST ST.runST
+# define AND_THEN >>=
+# define AND_THEN_ >>
+# define RETURN return
#else
# define BYTE_ARRAY _ByteArray
# define RUN_ST _runST
# define RETURN returnStrictlyST
#endif
-iToBase62 :: Int -> Pretty
+iToBase62 :: Int -> Doc
iToBase62 n@(I# n#)
= ASSERT(n >= 0)
in
if n# <# 62# then
case (indexCharArray# bytes n#) of { c ->
- ppChar (C# c) }
+ char (C# c) }
else
case (quotRem n 62) of { (q, I# r#) ->
case (indexCharArray# bytes r#) of { c ->
- ppBeside (iToBase62 q) (ppChar (C# c)) }}
+ (<>) (iToBase62 q) (char (C# c)) }}
-- keep this at top level! (bug on 94/10/24 WDP)
chars62 :: BYTE_ARRAY Int
cReturnableClassKey = mkPreludeClassUnique 20
ixClassKey = mkPreludeClassUnique 21
+allClassKey = mkPreludeClassUnique 22 -- Pseudo class used for universal quantification
\end{code}
%************************************************************************
stateAndWordPrimTyConKey = mkPreludeTyConUnique 46
statePrimTyConKey = mkPreludeTyConUnique 47
stateTyConKey = mkPreludeTyConUnique 48
- -- 49 is spare
+mutableByteArrayTyConKey = mkPreludeTyConUnique 49
stTyConKey = mkPreludeTyConUnique 50
primIoTyConKey = mkPreludeTyConUnique 51
- -- 52 is spare
+byteArrayTyConKey = mkPreludeTyConUnique 52
wordPrimTyConKey = mkPreludeTyConUnique 53
wordTyConKey = mkPreludeTyConUnique 54
voidTyConKey = mkPreludeTyConUnique 55
--- /dev/null
+module IdLoop () where
--- /dev/null
+_interface_ CgBindery 1
+_exports_
+CgBindery CgBindings CgIdInfo(MkCgIdInfo) VolatileLoc StableLoc LambdaFormInfo nukeVolatileBinds maybeAStkLoc maybeBStkLoc;
+_declarations_
+1 type CgBindings = Id.IdEnv CgIdInfo;
+1 data CgIdInfo = MkCgIdInfo Id.Id CgBindery.VolatileLoc CgBindery.StableLoc CgBindery.LambdaFormInfo;
+1 data VolatileLoc;
+1 data StableLoc;
+1 data LambdaFormInfo;
+1 nukeVolatileBinds _:_ CgBindery.CgBindings -> CgBindery.CgBindings ;;
+1 maybeAStkLoc _:_ CgBindery.StableLoc -> PrelBase.Maybe HeapOffs.VirtualSpAOffset ;;
+1 maybeBStkLoc _:_ CgBindery.StableLoc -> PrelBase.Maybe HeapOffs.VirtualSpBOffset ;;
) where
IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(CgLoop1) -- here for paranoia-checking
+--IMPORT_DELOOPER(CgLoop1) -- here for paranoia-checking
import AbsCSyn
import CgMonad
import Id ( idPrimRep, toplevelishId, isDataCon,
mkIdEnv, rngIdEnv, SYN_IE(IdEnv),
idSetToList,
- GenId{-instance NamedThing-}
+ GenId{-instance NamedThing-}, SYN_IE(Id)
)
+import Literal ( Literal )
import Maybes ( catMaybes )
-import Name ( isLocallyDefined, isWiredInName, Name{-instance NamedThing-} )
+import Name ( isLocallyDefined, isWiredInName,
+ Name{-instance NamedThing-}, NamedThing(..) )
#ifdef DEBUG
import PprAbsC ( pprAmode )
#endif
import PprStyle ( PprStyle(..) )
+import Pretty ( Doc )
+import PrimRep ( PrimRep )
import StgSyn ( SYN_IE(StgArg), SYN_IE(StgLiveVars), GenStgArg(..) )
-import Unpretty ( uppShow )
+import Unique ( Unique )
+import UniqFM ( Uniquable(..) )
import Util ( zipWithEqual, panic )
\end{code}
getCAddrModeAndInfo id
| not (isLocallyDefined name) || isWiredInName name
{- Why the "isWiredInName"?
- Imagine you are compiling GHCbase.hs (a module that
+ Imagine you are compiling PrelBase.hs (a module that
supplies some of the wired-in values). What can
happen is that the compiler will inject calls to
(e.g.) GHCbase.unpackPS, where-ever it likes -- it
#ifdef DEBUG
bindNewPrimToAmode name amode
- = panic ("bindNew...:"++(uppShow 80 (pprAmode PprDebug amode)))
+ = panic ("bindNew...:"++(show (pprAmode PprDebug amode)))
#endif
\end{code}
)
import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon )
import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
-import CostCentre ( useCurrentCostCentre )
+import CostCentre ( useCurrentCostCentre, CostCentre )
import HeapOffs ( SYN_IE(VirtualSpBOffset), SYN_IE(VirtualHeapOffset) )
import Id ( idPrimRep, toplevelishId,
dataConTag, fIRST_TAG, SYN_IE(ConTag),
isDataCon, SYN_IE(DataCon),
- idSetToList, GenId{-instance Uniquable,Eq-}
+ idSetToList, GenId{-instance Uniquable,Eq-}, SYN_IE(Id)
)
+import Literal ( Literal )
import Maybes ( catMaybes )
+import Outputable ( Outputable(..) )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} )
+import Pretty ( Doc )
import PrimOp ( primOpCanTriggerGC, PrimOp(..),
primOpStackRequired, StackRequirement(..)
)
import TyCon ( isEnumerationTyCon )
import Type ( typePrimRep,
getAppSpecDataTyConExpandingDicts,
- maybeAppSpecDataTyConExpandingDicts
+ maybeAppSpecDataTyConExpandingDicts,
+ SYN_IE(Type)
)
+import Unique ( Unique )
+import UniqFM ( Uniquable(..) )
import Util ( sortLt, isIn, isn'tIn, zipEqual,
pprError, panic, assertPanic
)
+
\end{code}
\begin{code}
import CmdLineOpts ( opt_ForConcurrent, opt_GranMacros )
import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts,
noCostCentreAttached, costsAreSubsumed,
- isCafCC, isDictCC, overheadCostCentre, showCostCentre
+ isCafCC, isDictCC, overheadCostCentre, showCostCentre,
+ CostCentre
)
import HeapOffs ( SYN_IE(VirtualHeapOffset) )
import Id ( idType, idPrimRep,
showId, getIdStrictness, dataConTag,
emptyIdSet,
- GenId{-instance Outputable-}
+ GenId{-instance Outputable-}, SYN_IE(Id)
)
import ListSetOps ( minusList )
import Maybes ( maybeToBool )
import Outputable ( Outputable(..){-instances-} ) -- ToDo:rm
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} )
-import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr, ppCat, ppStr )
+import Pretty ( Doc, hcat, char, ptext, hsep, text )
import PrimRep ( isFollowableRep, PrimRep(..) )
import TyCon ( isPrimTyCon, tyConDataCons )
import Type ( showTypeCategory )
-import Unpretty ( uppShow )
import Util ( isIn, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
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:" (ppCat [ppr PprDebug (is_thunk == IsFunction){-, ppr PprDebug closure_info-}, ppStr (showCostCentre PprDebug False cc)])) $
+ (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)])) $
costCentresC SLIT("ENTER_CC_FSUB") []
else if currentOrSubsumedCosts cc then
-- CgConTbls.lhs with a description generated from the data constructor
closureDescription mod_name name args body
- = uppShow 0 (prettyToUn (
- ppBesides [ppChar '<',
- ppPStr mod_name,
- ppChar '.',
+ = show (
+ hcat [char '<',
+ ptext mod_name,
+ char '.',
ppr PprDebug name,
- ppChar '>']))
+ char '>'])
\end{code}
\begin{code}
layOutStaticClosure
)
import CostCentre ( currentOrSubsumedCosts, useCurrentCostCentre,
- dontCareCostCentre
+ dontCareCostCentre, CostCentre
)
import Id ( idPrimRep, dataConTag, dataConTyCon,
isDataCon, SYN_IE(DataCon),
- emptyIdSet
+ emptyIdSet, SYN_IE(Id)
)
import Literal ( Literal(..) )
import Maybes ( maybeToBool )
import ClosureInfo ( layOutStaticClosure, layOutDynCon,
layOutPhantomClosure, closurePtrsSize,
fitsMinUpdSize, mkConLFInfo,
- infoTableLabelFromCI, dataConLiveness
+ infoTableLabelFromCI, dataConLiveness,
+ ClosureInfo
)
-import CostCentre ( dontCareCostCentre )
+import CostCentre ( dontCareCostCentre, CostCentre )
import FiniteMap ( fmToList, FiniteMap )
import HeapOffs ( zeroOff, SYN_IE(VirtualHeapOffset) )
import Id ( dataConTag, dataConRawArgTys,
dataConNumFields, fIRST_TAG,
emptyIdSet,
- GenId{-instance NamedThing-}
+ GenId{-instance NamedThing-}, SYN_IE(Id)
)
import Name ( getOccString )
import PrelInfo ( maybeIntLikeTyCon )
import PrimRep ( getPrimRepSize, PrimRep(..) )
-import TyCon ( tyConDataCons, mkSpecTyCon )
-import Type ( typePrimRep )
+import TyCon ( tyConDataCons, mkSpecTyCon, TyCon )
+import Type ( typePrimRep, SYN_IE(Type) )
import Util ( panic )
mkSameSpecCon = panic "CgConTbls.mkSameSpecCon (ToDo)"
--- /dev/null
+_interface_ CgExpr 1
+_exports_
+CgExpr cgExpr getPrimOpArgAmodes;
+_declarations_
+1 cgExpr _:_ StgSyn.StgExpr -> CgMonad.Code ;;
+1 getPrimOpArgAmodes _:_ PrimOp.PrimOp -> [StgSyn.StgArg] -> CgMonad.FCode [AbsCSyn.CAddrMode] ;;
mkDynamicAlgReturnCode, mkPrimReturnCode
)
import CLabel ( mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
-import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo, mkVapLFInfo, lfArity_maybe,
+import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo, mkVapLFInfo,
layOutDynCon )
import CostCentre ( sccAbleCostCentre, isDictCC, isSccCountCostCentre )
import HeapOffs ( SYN_IE(VirtualSpBOffset), intOffsetIntoGoods )
import Id ( dataConTyCon, idPrimRep, getIdArity,
- mkIdSet, unionIdSets, GenId{-instance Outputable-}
+ mkIdSet, unionIdSets, GenId{-instance Outputable-},
+ SYN_IE(Id)
)
import IdInfo ( ArityInfo(..) )
import Name ( isLocallyDefined )
import PprStyle ( PprStyle(..) )
+import Pretty ( Doc )
import PrimOp ( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..),
getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
)
import TyCon ( tyConDataCons, maybeTyConSingleCon )
import Maybes ( assocMaybe, maybeToBool )
import Util ( panic, isIn, pprPanic, assertPanic )
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable ( Outputable(..) )
+#endif
\end{code}
This module provides the support code for @StgToAbstractC@ to deal
zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
cgRhs name (StgRhsClosure cc bi fvs upd_flag args body)
- = mkRhsLFInfo fvs upd_flag args body `thenFC` \ lf_info ->
- cgRhsClosure name cc bi fvs args body lf_info
+ = cgRhsClosure name cc bi fvs args body lf_info
+ where
+ lf_info = mkRhsLFInfo fvs upd_flag args body
+
\end{code}
mkRhsLFInfo looks for two special forms of the right-hand side:
If neither happens, it just calls mkClosureLFInfo. You might think
that mkClosureLFInfo should do all this, but
+
(a) it seems wrong for the latter to look at the structure
of an expression
+
+ [March 97: item (b) is no longer true, but I've left mkRhsLFInfo here
+ anyway because of (a).]
+
(b) mkRhsLFInfo has to be in the monad since it looks up in
the environment, and it's very tiresome for mkClosureLFInfo to
be. Apart from anything else it would make a loop between
&& maybeToBool offset_into_int_maybe
&& offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
= -- ASSERT(is_single_constructor) -- Should be true, but causes error for SpecTyCon
- returnFC (mkSelectorLFInfo scrutinee con offset_into_int)
+ mkSelectorLFInfo scrutinee con offset_into_int
where
(_, params_w_offsets) = layOutDynCon con idPrimRep params
maybe_offset = assocMaybe params_w_offsets selectee
[] -- No args; a thunk
(StgApp (StgVarArg fun_id) args _)
| isLocallyDefined fun_id -- Must be defined in this module
- = -- Get the arity of the fun_id. We could find out from the
- -- looking in the Id, but it's more certain just to look in the code
- -- generator's environment.
-
-----------------------------------------------
--- Sadly, looking in the environment, as suggested above,
--- causes a black hole (because cgRhsClosure depends on the LFInfo
--- returned here to determine its control flow.
--- So I wimped out and went back to looking at the arity inside the Id.
--- That means beefing up Core2Stg to propagate it. Sigh.
--- getCAddrModeAndInfo fun_id `thenFC` \ (_, fun_lf_info) ->
--- let arity_maybe = lfArity_maybe fun_lf_info
-----------------------------------------------
-
+ = -- Get the arity of the fun_id. It's guaranteed to be correct (by setStgVarInfo).
let
arity_maybe = case getIdArity fun_id of
ArityExactly n -> Just n
other -> Nothing
in
- returnFC (case arity_maybe of
+ case arity_maybe of
Just arity
| arity > 0 && -- It'd better be a function!
arity == length args -- Saturated application
mkVapLFInfo fvs upd_flag fun_id args store_fun_in_vap
other -> mkClosureLFInfo False{-not top level-} fvs upd_flag []
- )
-
where
-- If the function is a free variable then it must be stored
-- in the thunk too; if it isn't a free variable it must be
~~~~~~~~~~~~~~~~
\begin{code}
mkRhsLFInfo fvs upd_flag args body
- = returnFC (mkClosureLFInfo False{-not top level-} fvs upd_flag args)
+ = mkClosureLFInfo False{-not top level-} fvs upd_flag args
\end{code}
initHeapUsage
)
import ClosureInfo ( closureSize, closureHdrSize, closureGoodStuffSize,
- slopSize, allocProfilingMsg, closureKind
+ slopSize, allocProfilingMsg, closureKind, ClosureInfo
)
import HeapOffs ( isZeroOff, addOff, intOff,
- SYN_IE(VirtualHeapOffset)
+ SYN_IE(VirtualHeapOffset), HeapOffset
)
import PrimRep ( PrimRep(..) )
\end{code}
import CgUsages ( setRealAndVirtualSps, getVirtSps )
import CLabel ( mkStdEntryLabel )
import ClosureInfo ( mkLFLetNoEscape )
+import CostCentre ( CostCentre )
import HeapOffs ( SYN_IE(VirtualSpBOffset) )
-import Id ( idPrimRep )
+import Id ( idPrimRep, SYN_IE(Id) )
\end{code}
%************************************************************************
--- /dev/null
+module CgLoop1
+
+ (
+ module CgBindery,
+ module CgUsages
+ ) where
+
+import CgBindery
+import CgUsages
--- /dev/null
+module CgLoop2
+
+ (
+ module CgExpr
+ ) where
+
+import CgExpr
opt_OmitBlackHoling
)
import HeapOffs ( maxOff,
- SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset)
+ SYN_IE(VirtualSpAOffset), SYN_IE(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(ConTag), GenId{-instance Outputable-},
+ SYN_IE(Id)
)
import Maybes ( maybeToBool )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} )
-import Pretty ( ppAboves, ppCat, ppPStr )
+import Pretty ( Doc, vcat, hsep, ptext )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import StgSyn ( SYN_IE(StgLiveVars) )
import Type ( typePrimRep )
import UniqSet ( elementOfUniqSet )
import Util ( sortLt, panic, pprPanic )
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable ( Outputable(..) )
+#endif
infixr 9 `thenC` -- Right-associative!
infixr 9 `thenFC`
Just this -> this
Nothing
-> pprPanic "lookupBindC:no info!\n"
- (ppAboves [
- ppCat [ppPStr SLIT("for:"), ppr PprShowAll name],
- ppPStr SLIT("(probably: data dependencies broken by an optimisation pass)"),
- ppPStr SLIT("static binds for:"),
- ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
- ppPStr SLIT("local binds for:"),
- ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
+ (vcat [
+ hsep [ptext SLIT("for:"), ppr PprShowAll 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 ],
+ ptext SLIT("local binds for:"),
+ vcat [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
])
\end{code}
--- /dev/null
+_interface_ CgRetConv 1
+_exports_
+CgRetConv CtrlReturnConvention(VectoredReturn UnvectoredReturn) ctrlReturnConvAlg;
+_declarations_
+1 data CtrlReturnConvention = VectoredReturn PrelBase.Int | UnvectoredReturn PrelBase.Int;
+1 ctrlReturnConvAlg _:_ TyCon.TyCon -> CgRetConv.CtrlReturnConvention ;;
+
)
import CmdLineOpts ( opt_ReturnInRegsThreshold )
import Id ( isDataCon, dataConRawArgTys,
- SYN_IE(DataCon), GenId{-instance Eq-}
+ SYN_IE(DataCon), GenId{-instance Eq-},
+ SYN_IE(Id)
)
import Maybes ( catMaybes )
import PprStyle ( PprStyle(..) )
import PrimRep ( isFloatingRep, PrimRep(..) )
import TyCon ( tyConDataCons, tyConFamilySize )
import Type ( typePrimRep )
+import Pretty ( Doc )
import Util ( zipWithEqual, mapAccumL, isn'tIn,
pprError, pprTrace, panic, assertPanic
)
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable ( Outputable(..) )
+#endif
\end{code}
%************************************************************************
)
import CgStackery ( adjustRealSps, mkStkAmodes )
import CgUsages ( getSpARelOffset )
-import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
+import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel, CLabel )
import ClosureInfo ( nodeMustPointToIt,
getEntryConvention, EntryConvention(..),
LambdaFormInfo
import CmdLineOpts ( opt_DoSemiTagging )
import HeapOffs ( zeroOff, SYN_IE(VirtualSpAOffset) )
import Id ( idType, dataConTyCon, dataConTag,
- fIRST_TAG
+ fIRST_TAG, SYN_IE(Id)
)
import Literal ( mkMachInt )
import Maybes ( assocMaybe )
import PrimRep ( PrimRep(..) )
import StgSyn ( SYN_IE(StgArg), GenStgArg(..), SYN_IE(StgLiveVars) )
import Type ( isPrimType )
+import TyCon ( TyCon )
import Util ( zipWithEqual, panic, assertPanic )
\end{code}
--- /dev/null
+_interface_ CgUsages 1
+_exports_
+CgUsages getSpBRelOffset;
+_declarations_
+1 getSpBRelOffset _:_ HeapOffs.VirtualSpBOffset -> CgMonad.FCode AbsCSyn.RegRelative ;;
--- /dev/null
+_interface_ ClosureInfo 1
+_exports_
+ClosureInfo ClosureInfo closureKind closureLabelFromCI closureNonHdrSize closurePtrsSize closureSMRep closureSemiTag closureSizeWithoutFixedHdr closureTypeDescr closureUpdReqd entryLabelFromCI fastLabelFromCI infoTableLabelFromCI maybeSelectorInfo;
+_declarations_
+1 data ClosureInfo;
+1 closureKind _:_ ClosureInfo -> PrelBase.String ;;
+1 closureLabelFromCI _:_ ClosureInfo -> CLabel.CLabel ;;
+1 closureNonHdrSize _:_ ClosureInfo -> PrelBase.Int ;;
+1 closurePtrsSize _:_ ClosureInfo -> PrelBase.Int ;;
+1 closureSMRep _:_ ClosureInfo -> SMRep.SMRep ;;
+1 closureSemiTag _:_ ClosureInfo -> PrelBase.Int ;;
+1 closureSizeWithoutFixedHdr _:_ ClosureInfo -> HeapOffs.HeapOffset ;;
+1 closureTypeDescr _:_ ClosureInfo -> PrelBase.String ;;
+1 closureUpdReqd _:_ ClosureInfo -> PrelBase.Bool ;;
+1 entryLabelFromCI _:_ ClosureInfo -> CLabel.CLabel ;;
+1 fastLabelFromCI _:_ ClosureInfo -> CLabel.CLabel ;;
+1 infoTableLabelFromCI _:_ ClosureInfo -> CLabel.CLabel ;;
+1 maybeSelectorInfo _:_ ClosureInfo -> PrelBase.Maybe (Id.Id, PrelBase.Int) ;;
mkVirtHeapOffsets,
nodeMustPointToIt, getEntryConvention,
- blackHoleOnEntry, lfArity_maybe,
+ blackHoleOnEntry,
staticClosureRequired,
slowFunEntryCodeRequired, funInfoTableRequired,
)
import CmdLineOpts ( opt_SccProfilingOn, opt_ForConcurrent )
import HeapOffs ( intOff, addOff, totHdrSize, varHdrSize,
- SYN_IE(VirtualHeapOffset)
+ SYN_IE(VirtualHeapOffset), HeapOffset
)
import Id ( idType, getIdArity,
externallyVisibleId,
dataConTag, fIRST_TAG,
- isDataCon, isNullaryDataCon, dataConTyCon, dataConArity,
+ isDataCon, isNullaryDataCon, dataConTyCon,
isTupleCon, SYN_IE(DataCon),
- GenId{-instance Eq-}
+ GenId{-instance Eq-}, SYN_IE(Id)
)
import IdInfo ( ArityInfo(..) )
import Maybes ( maybeToBool )
import PprType ( getTyDescription, GenType{-instance Outputable-} )
import Pretty --ToDo:rm
import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon )
-import PrimRep ( getPrimRepSize, separateByPtrFollowness )
+import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep )
import SMRep -- all of it
import TyCon ( TyCon{-instance NamedThing-} )
import Type ( isPrimType, splitForAllTy, splitFunTyExpandingDictsAndPeeking,
- mkFunTys, maybeAppSpecDataTyConExpandingDicts
+ mkFunTys, maybeAppSpecDataTyConExpandingDicts,
+ SYN_IE(Type)
)
import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic )
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable ( Outputable(..) )
+#endif
\end{code}
The ``wrapper'' data type for closure information:
@lfArity@ extracts the arity of a function from its LFInfo
\begin{code}
+{- Not needed any more
+
lfArity_maybe (LFReEntrant _ arity _) = Just arity
-lfArity_maybe (LFCon con _) = Just (dataConArity con)
-lfArity_maybe (LFTuple con _) = Just (dataConArity con)
+
+-- Removed SLPJ March 97. I don't believe these two;
+-- LFCon is used for construcor *applications*, not constructors!
+--
+-- lfArity_maybe (LFCon con _) = Just (dataConArity con)
+-- lfArity_maybe (LFTuple con _) = Just (dataConArity con)
+
lfArity_maybe other = Nothing
+-}
\end{code}
%************************************************************************
(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:" (ppCat [ppInt arity, ppr PprShowAll id, ppr PprDebug (idType id)])) $
+ (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
\end{code}
\begin{code}
fastLabelFromCI :: ClosureInfo -> CLabel
fastLabelFromCI (MkClosureInfo id lf_info _)
+{- [SLPJ Changed March 97]
+ (was ok, but is the only call to lfArity,
+ and the id should guarantee to have the correct arity in it.
+
= case lfArity_maybe lf_info of
- Just arity -> mkFastEntryLabel id arity
- other -> pprPanic "fastLabelFromCI" (ppr PprDebug id)
+ Just arity ->
+-}
+ = case getIdArity id of
+ ArityExactly arity -> mkFastEntryLabel id arity
+ other -> pprPanic "fastLabelFromCI" (ppr PprDebug id)
infoTableLabelFromCI :: ClosureInfo -> CLabel
infoTableLabelFromCI (MkClosureInfo id lf_info rep)
import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingGhcInternals,
opt_EnsureSplittableC, opt_SccGroup
)
+import CostCentre ( CostCentre )
import CStrings ( modnameToC )
import FiniteMap ( FiniteMap )
+import Id ( SYN_IE(Id) )
import Maybes ( maybeToBool )
+import Name ( SYN_IE(Module) )
import PrimRep ( getPrimRepSize, PrimRep(..) )
+import Type ( SYN_IE(Type) )
+import TyCon ( TyCon )
import Util ( panic, assertPanic )
\end{code}
IMP_Ubiq(){-uitous-}
-import Pretty ( ppStr )
+import Pretty ( text )
import Util ( panic )
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable
+#endif
\end{code}
%************************************************************************
MuTupleRep _ -> "MUTUPLE")
instance Outputable SMRep where
- ppr sty rep = ppStr (show rep)
+ ppr sty rep = text (show rep)
getSMInfoStr :: SMRep -> String
getSMInfoStr (StaticRep _ _) = "STATIC"
IMP_Ubiq(){-uitous-}
import CoreSyn
+
+import Id ( SYN_IE(Id) )
+import Literal ( Literal )
+import PrimOp ( PrimOp )
+import CostCentre ( CostCentre )
+import Type ( GenType )
+
\end{code}
\begin{code}
import CoreUtils ( coreExprType )
import Id ( idType, mkSysLocal,
nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv),
- GenId{-instances-}
+ GenId{-instances-}, SYN_IE(Id)
)
import Name ( isLocallyDefined, getSrcLoc, getOccString )
import TyCon ( isBoxedTyCon, TyCon{-instance-} )
import Type ( maybeAppDataTyConExpandingDicts, eqTy )
import TysPrim ( statePrimTyCon )
import TysWiredIn ( liftDataCon, mkLiftTy )
+import Unique ( Unique )
import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
import Util ( zipEqual, zipWithEqual, assertPanic, panic )
import CoreSyn
import Bag
-import Kind ( hasMoreBoxityInfo, Kind{-instance-} )
+import Kind ( hasMoreBoxityInfo, Kind{-instance-},
+ isTypeKind, isBoxedTypeKind {- TEMP --SOF -} )
import Literal ( literalType, Literal{-instance-} )
import Id ( idType, isBottomingId, dataConRepType,
dataConArgTys, GenId{-instances-},
emptyIdSet, mkIdSet, intersectIdSets,
- unionIdSets, elementOfIdSet, SYN_IE(IdSet)
+ unionIdSets, elementOfIdSet, SYN_IE(IdSet),
+ SYN_IE(Id)
)
import Maybes ( catMaybes )
-import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-} )
+import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-},
+ NamedThing(..) )
import Outputable ( Outputable(..){-instance * []-} )
import PprCore
import PprStyle ( PprStyle(..) )
getForAllTyExpandingDicts_maybe,
isPrimType,typeKind,instantiateTy,splitSigmaTy,
mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
- maybeAppDataTyConExpandingDicts, eqTy
+ maybeAppDataTyConExpandingDicts, eqTy, SYN_IE(Type)
-- ,expandTy -- ToDo:rm
)
import TyCon ( isPrimTyCon )
= case (initL (lint_binds binds) spec_done) of
Nothing -> binds
Just msg ->
- pprPanic "" (ppAboves [
- ppStr ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"),
+ pprPanic "" (vcat [
+ text ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"),
msg sty,
- ppPStr SLIT("*** Offending Program ***"),
- ppAboves (map (pprCoreBinding sty) binds),
- ppPStr SLIT("*** End of Offense ***")
+ ptext SLIT("*** Offending Program ***"),
+ vcat (map (pprCoreBinding sty) binds),
+ ptext SLIT("*** End of Offense ***")
])
where
lint_binds [] = returnL ()
Nothing -> Just expr
Just msg ->
pprTrace "WARNING: Discarded bad unfolding from interface:\n"
- (ppAboves [msg PprForUser,
- ppPStr SLIT("*** Bad unfolding ***"),
+ (vcat [msg PprForUser,
+ ptext SLIT("*** Bad unfolding ***"),
ppr PprDebug expr,
- ppPStr SLIT("*** End unfolding ***")])
+ ptext SLIT("*** End unfolding ***")])
Nothing
\end{code}
tyvar_kind = tyVarKind tyvar
argty_kind = typeKind arg_ty
in
- if argty_kind `hasMoreBoxityInfo` tyvar_kind
+ if argty_kind `hasMoreBoxityInfo` tyvar_kind || -- Should the args be swapped here?
+ (isTypeKind argty_kind && isBoxedTypeKind tyvar_kind) -- (hackily) added SOF
-- Arg type might be boxed for a function with an uncommitted
-- tyvar; notably this is used so that we can give
-- error :: forall a:*. String -> a
then
returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
else
- pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $
+ 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)
-> Bag ErrMsg -- Error messages so far
-> (a, Bag ErrMsg) -- Result and error messages (if any)
-type ErrMsg = PprStyle -> Pretty
+type ErrMsg = PprStyle -> Doc
data LintLocInfo
= RhsOf Id -- The variable bound
instance Outputable LintLocInfo where
ppr sty (RhsOf v)
- = ppBesides [ppr sty (getSrcLoc v), ppPStr SLIT(": [RHS of "), pp_binders sty [v], ppChar ']']
+ = hcat [ppr sty (getSrcLoc v), ptext SLIT(": [RHS of "), pp_binders sty [v], char ']']
ppr sty (LambdaBodyOf b)
- = ppBesides [ppr sty (getSrcLoc b),
- ppPStr SLIT(": [in body of lambda with binder "), pp_binder sty b, ppChar ']']
+ = hcat [ppr sty (getSrcLoc b),
+ ptext SLIT(": [in body of lambda with binder "), pp_binder sty b, char ']']
ppr sty (BodyOfLetRec bs)
- = ppBesides [ppr sty (getSrcLoc (head bs)),
- ppPStr SLIT(": [in body of letrec with binders "), pp_binders sty bs, ppChar ']']
+ = hcat [ppr sty (getSrcLoc (head bs)),
+ ptext SLIT(": [in body of letrec with binders "), pp_binders sty bs, char ']']
ppr sty (ImportedUnfolding locn)
- = ppBeside (ppr sty locn) (ppPStr SLIT(": [in an imported unfolding]"))
+ = (<>) (ppr sty locn) (ptext SLIT(": [in an imported unfolding]"))
-pp_binders :: PprStyle -> [Id] -> Pretty
-pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs)
+pp_binders :: PprStyle -> [Id] -> Doc
+pp_binders sty bs = sep (punctuate comma (map (pp_binder sty) bs))
-pp_binder :: PprStyle -> Id -> Pretty
-pp_binder sty b = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
+pp_binder :: PprStyle -> Id -> Doc
+pp_binder sty b = hsep [ppr sty b, text "::", ppr sty (idType b)]
\end{code}
\begin{code}
Nothing
else
Just ( \ sty ->
- ppAboves [ msg sty | msg <- bagToList errs ]
+ vcat [ msg sty | msg <- bagToList errs ]
)
}
addErr errs_so_far msg locs
= ASSERT (not (null locs))
errs_so_far `snocBag` ( \ sty ->
- ppHang (ppr sty (head locs)) 4 (msg sty)
+ hang (ppr sty (head locs)) 4 (msg sty)
)
addLoc :: LintLocInfo -> LintM a -> LintM a
id_name = getName id
in
if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then
- ((),addErr errs (\sty -> ppCat [ppr sty id, ppPStr SLIT("is out of scope")]) loc)
+ ((),addErr errs (\sty -> hsep [ppr sty id, ptext SLIT("is out of scope")]) loc)
else
((),errs)
\begin{code}
mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
mkCaseAltMsg alts sty
- = ppAbove (ppPStr SLIT("Type of case alternatives not the same:"))
+ = ($$) (ptext SLIT("Type of case alternatives not the same:"))
(ppr sty alts)
mkCaseDataConMsg :: CoreExpr -> ErrMsg
mkCaseDataConMsg expr sty
- = ppAbove (ppPStr SLIT("A case scrutinee not of data constructor type:"))
+ = ($$) (ptext SLIT("A case scrutinee not of data constructor type:"))
(pp_expr sty expr)
mkCaseNotPrimMsg :: TyCon -> ErrMsg
mkCaseNotPrimMsg tycon sty
- = ppAbove (ppPStr SLIT("A primitive case on a non-primitive type:"))
+ = ($$) (ptext SLIT("A primitive case on a non-primitive type:"))
(ppr sty tycon)
mkCasePrimMsg :: TyCon -> ErrMsg
mkCasePrimMsg tycon sty
- = ppAbove (ppPStr SLIT("An algebraic case on a primitive type:"))
+ = ($$) (ptext SLIT("An algebraic case on a primitive type:"))
(ppr sty tycon)
mkCaseAbstractMsg :: TyCon -> ErrMsg
mkCaseAbstractMsg tycon sty
- = ppAbove (ppPStr SLIT("An algebraic case on some weird type:"))
+ = ($$) (ptext SLIT("An algebraic case on some weird type:"))
(ppr sty tycon)
mkDefltMsg :: CoreCaseDefault -> ErrMsg
mkDefltMsg deflt sty
- = ppAbove (ppPStr SLIT("Binder in case default doesn't match type of scrutinee:"))
+ = ($$) (ptext SLIT("Binder in case default doesn't match type of scrutinee:"))
(ppr sty deflt)
mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
mkAppMsg fun arg expr sty
- = ppAboves [ppPStr SLIT("Argument value doesn't match argument type:"),
- ppHang (ppPStr SLIT("Fun type:")) 4 (ppr sty fun),
- ppHang (ppPStr SLIT("Arg type:")) 4 (ppr sty arg),
- ppHang (ppPStr SLIT("Expression:")) 4 (pp_expr sty 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)]
mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg
mkTyAppMsg msg ty arg expr sty
- = ppAboves [ppCat [ppPStr msg, ppPStr SLIT("type application:")],
- ppHang (ppPStr SLIT("Exp type:")) 4 (ppr sty ty),
- ppHang (ppPStr SLIT("Arg type:")) 4 (ppr sty arg),
- ppHang (ppPStr SLIT("Expression:")) 4 (pp_expr sty 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
- = ppAboves [ppPStr SLIT("Illegal usage application:"),
- ppHang (ppPStr SLIT("Exp type:")) 4 (ppr sty ty),
- ppHang (ppPStr SLIT("Usage exp:")) 4 (ppr sty u),
- ppHang (ppPStr SLIT("Expression:")) 4 (pp_expr sty expr)]
+ = 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)]
mkAlgAltMsg1 :: Type -> ErrMsg
mkAlgAltMsg1 ty sty
- = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
+ = ($$) (text "In some case statement, type of scrutinee is not a data type:")
(ppr sty ty)
--- (ppAbove (ppr sty ty) (ppr sty (expandTy ty))) -- ToDo: rm
+-- (($$) (ppr sty ty) (ppr sty (expandTy ty))) -- ToDo: rm
mkAlgAltMsg2 :: Type -> Id -> ErrMsg
mkAlgAltMsg2 ty con sty
- = ppAboves [
- ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
+ = vcat [
+ text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
ppr sty ty,
ppr sty con
]
mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
mkAlgAltMsg3 con alts sty
- = ppAboves [
- ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
+ = vcat [
+ text "In some algebraic case alternative, number of arguments doesn't match constructor:",
ppr sty con,
ppr sty alts
]
mkAlgAltMsg4 :: Type -> Id -> ErrMsg
mkAlgAltMsg4 ty arg sty
- = ppAboves [
- ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
+ = vcat [
+ text "In some algebraic case alternative, type of argument doesn't match data constructor:",
ppr sty ty,
ppr sty arg
]
mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
mkPrimAltMsg alt sty
- = ppAbove
- (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
+ = ($$)
+ (text "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
(ppr sty alt)
mkRhsMsg :: Id -> Type -> ErrMsg
mkRhsMsg binder ty sty
- = ppAboves
- [ppCat [ppPStr SLIT("The type of this binder doesn't match the type of its RHS:"),
+ = vcat
+ [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
ppr sty binder],
- ppCat [ppPStr SLIT("Binder's type:"), ppr sty (idType binder)],
- ppCat [ppPStr SLIT("Rhs type:"), ppr sty ty]]
+ hsep [ptext SLIT("Binder's type:"), ppr sty (idType binder)],
+ hsep [ptext SLIT("Rhs type:"), ppr sty ty]]
mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
mkRhsPrimMsg binder rhs sty
- = ppAboves [ppCat [ppPStr SLIT("The type of this binder is primitive:"),
+ = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
ppr sty binder],
- ppCat [ppPStr SLIT("Binder's type:"), ppr sty (idType binder)]
+ hsep [ptext SLIT("Binder's type:"), ppr sty (idType binder)]
]
mkSpecTyAppMsg :: CoreArg -> ErrMsg
mkSpecTyAppMsg arg sty
- = ppAbove
- (ppPStr SLIT("Unboxed types in a type application (after specialisation):"))
+ = ($$)
+ (ptext SLIT("Unboxed types in a type application (after specialisation):"))
(ppr sty arg)
-pp_expr :: PprStyle -> CoreExpr -> Pretty
+pp_expr :: PprStyle -> CoreExpr -> Doc
pp_expr sty expr
= pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr
\end{code}
IMP_Ubiq(){-uitous-}
import CostCentre ( showCostCentre, CostCentre )
-import Id ( idType, GenId{-instance Eq-} )
-import Type ( isUnboxedType )
-import Usage ( SYN_IE(UVar) )
+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 Util ( panic, assertPanic {-pprTrace:ToDo:rm-} )
+#if __GLASGOW_HASKELL__ >= 202
+import Literal ( Literal )
+import BinderInfo ( BinderInfo )
+import PrimOp ( PrimOp )
+#endif
\end{code}
%************************************************************************
--- /dev/null
+_interface_ CoreUnfold 1
+_exports_
+CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding;
+_declarations_
+1 data Unfolding;
+1 data UnfoldingGuidance;
+1 mkUnfolding _:_ PragmaInfo.PragmaInfo -> CoreSyn.CoreExpr -> CoreUnfold.Unfolding ;;
+1 noUnfolding _:_ CoreUnfold.Unfolding ;;
SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types
UfExpr, RdrName, -- For closure (delete in 1.3)
- FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup,
+ FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup, exprIsTrivial,
noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate,
smallEnoughToInline, couldBeSmallEnoughToInline, certainlySmallEnoughToInline,
okToInline,
- calcUnfoldingGuidance
+ calcUnfoldingGuidance,
+
+ PragmaInfo(..) -- Re-export
) where
IMP_Ubiq()
IMPORT_DELOOPER(IdLoop) -- for paranoia checking;
-- and also to get mkMagicUnfoldingFun
IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
+IMPORT_DELOOPER(SmplLoop)
import Bag ( emptyBag, unitBag, unionBags, Bag )
uNFOLDING_NOREP_LIT_COST
)
import BinderInfo ( BinderInfo(..), FunOrArg, DuplicationDanger, InsideSCC, isDupDanger )
+import PragmaInfo ( PragmaInfo(..) )
import CoreSyn
import CoreUtils ( unTagBinders )
import HsCore ( UfExpr )
import RdrHsSyn ( RdrName )
import OccurAnal ( occurAnalyseGlobalExpr )
import CoreUtils ( coreExprType )
-import CostCentre ( ccMentionsId )
+--import CostCentre ( ccMentionsId )
import Id ( idType, getIdArity, isBottomingId, isDataCon, isPrimitiveId_maybe,
SYN_IE(IdSet), GenId{-instances-} )
import PrimOp ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) )
import Pretty
import TyCon ( tyConFamilySize )
import Type ( maybeAppDataTyConExpandingDicts )
+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}
%************************************************************************
noUnfolding = NoUnfolding
-mkUnfolding inline_me expr
+mkUnfolding inline_prag expr
= let
-- strictness mangling (depends on there being no CSE)
- ufg = calcUnfoldingGuidance inline_me opt_UnfoldingCreationThreshold expr
+ ufg = calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold expr
occ = occurAnalyseGlobalExpr expr
cuf = CoreUnfolding (SimpleUnfolding (mkFormSummary expr) ufg occ)
| UnfoldIfGoodArgs Int -- if "m" type args
Int -- and "n" value args
+
[Int] -- Discount if the argument is evaluated.
-- (i.e., a simplification will definitely
-- be possible). One elt of the list per *value* arg.
+
Int -- The "size" of the unfolding; to be elaborated
-- later. ToDo
+
+ Int -- Scrutinee discount: the discount to substract if the thing is in
+ -- a context (case (thing args) of ...),
+ -- (where there are the right number of arguments.)
\end{code}
\begin{code}
instance Outputable UnfoldingGuidance where
- ppr sty UnfoldAlways = ppPStr SLIT("_ALWAYS_")
--- ppr sty EssentialUnfolding = ppPStr SLIT("_ESSENTIAL_") -- shouldn't appear in an iface
- ppr sty (UnfoldIfGoodArgs t v cs size)
- = ppCat [ppPStr SLIT("_IF_ARGS_"), ppInt t, ppInt v,
+ ppr sty UnfoldAlways = ptext SLIT("_ALWAYS_")
+ ppr sty (UnfoldIfGoodArgs t v cs size discount)
+ = hsep [ptext SLIT("_IF_ARGS_"), int t, int v,
if null cs -- always print *something*
- then ppChar 'X'
- else ppBesides (map (ppStr . show) cs),
- ppInt size ]
+ then char 'X'
+ else hcat (map (text . show) cs),
+ int size,
+ int discount ]
\end{code}
| OtherForm -- Anything else
instance Outputable FormSummary where
- ppr sty VarForm = ppPStr SLIT("Var")
- ppr sty ValueForm = ppPStr SLIT("Value")
- ppr sty BottomForm = ppPStr SLIT("Bot")
- ppr sty OtherForm = ppPStr SLIT("Other")
+ ppr sty VarForm = ptext SLIT("Var")
+ ppr sty ValueForm = ptext SLIT("Value")
+ ppr sty BottomForm = ptext SLIT("Bot")
+ ppr sty OtherForm = ptext SLIT("Other")
mkFormSummary ::GenCoreExpr bndr Id tyvar uvar -> FormSummary
go n (Prim _ _) = OtherForm
go n (SCC _ e) = go n e
go n (Coerce _ _ e) = go n e
+
+ go n (Let (NonRec b r) e) | exprIsTrivial r = go n e -- let f = f' alpha in (f,g)
+ -- should be treated as a value
go n (Let _ e) = OtherForm
go n (Case _ _) = OtherForm
OtherForm -> False
\end{code}
+@exprIsTrivial@ is true of expressions we are unconditionally happy to duplicate;
+simple variables and constants, and type applications.
+
+\begin{code}
+exprIsTrivial (Var v) = True
+exprIsTrivial (Lit lit) = not (isNoRepLit lit)
+exprIsTrivial (App e (TyArg _)) = exprIsTrivial e
+exprIsTrivial other = False
+\end{code}
\begin{code}
exprSmallEnoughToDup (Con _ _) = True -- Could check # of args
exprSmallEnoughToDup expr
= case (collectArgs expr) of { (fun, _, _, vargs) ->
case fun of
- Var v | length vargs == 0 -> True
+ Var v | length vargs <= 4 -> True
_ -> False
}
-{- LATER:
-WAS: MORE CLEVER:
-exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
- = case (collectArgs expr) of { (fun, _, _, vargs) ->
- case fun of
- Var v -> v /= buildId
- && v /= augmentId
- && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish.
- _ -> False
- }
--}
\end{code}
-Question (ADR): What is the above used for? Is a _ccall_ really small
-enough?
+
%************************************************************************
%* *
\begin{code}
calcUnfoldingGuidance
- :: Bool -- True <=> there's an INLINE pragma on this thing
+ :: PragmaInfo -- INLINE pragma stuff
-> Int -- bomb out if size gets bigger than this
-> CoreExpr -- expression to look at
-> UnfoldingGuidance
-calcUnfoldingGuidance True bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so
+calcUnfoldingGuidance IMustBeINLINEd bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so
+calcUnfoldingGuidance IWantToBeINLINEd bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so
+calcUnfoldingGuidance IMustNotBeINLINEd bOMB_OUT_SIZE expr = UnfoldNever -- ...and vice versa...
-calcUnfoldingGuidance False bOMB_OUT_SIZE expr
+calcUnfoldingGuidance NoPragmaInfo bOMB_OUT_SIZE expr
= case collectBinders expr of { (use_binders, ty_binders, val_binders, body) ->
case (sizeExpr bOMB_OUT_SIZE val_binders body) of
- Nothing -> UnfoldNever
+ TooBig -> UnfoldNever
- Just (size, cased_args)
+ SizeIs size cased_args scrut_discount
-> UnfoldIfGoodArgs
(length ty_binders)
(length val_binders)
(map discount_for val_binders)
- size
+ (I# size)
+ (I# scrut_discount)
where
discount_for b
| is_data && b `is_elem` cased_args = tyConFamilySize tycon
-> [Id] -- Arguments; we're interested in which of these
-- get case'd
-> CoreExpr
- -> Maybe (Int, -- Size
- [Id] -- Subset of args which are cased
- )
+ -> ExprSize
-sizeExpr bOMB_OUT_SIZE args expr
-
- | data_or_prim fun
--- We are very keen to inline literals, constructors, or primitives
--- including their slightly-disguised forms as applications (the latter
--- can show up in the bodies of things imported from interfaces).
- = Just (0, [])
-
- | otherwise
+sizeExpr (I# bOMB_OUT_SIZE) args expr
= size_up expr
where
- (fun, _) = splitCoreApps expr
- data_or_prim (Var v) = maybeToBool (isPrimitiveId_maybe v) ||
- isDataCon v
- data_or_prim (Con _ _) = True
- data_or_prim (Prim _ _) = True
- data_or_prim (Lit _) = True
- data_or_prim other = False
-
- size_up (Var v) = sizeZero
- size_up (App fun arg) = size_up fun `addSize` size_up_arg arg `addSizeN` 1
- -- 1 for application node
-
- size_up (Lit lit) = if isNoRepLit lit
- then sizeN uNFOLDING_NOREP_LIT_COST
- else sizeZero
-
--- I don't understand this hack so I'm removing it! SLPJ Nov 96
--- size_up (SCC _ (Con _ _)) = Nothing -- **** HACK *****
+ size_up (Var v) = sizeZero
+ size_up (Lit lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
+ | otherwise = sizeZero
size_up (SCC lbl body) = size_up body -- SCCs cost nothing
size_up (Coerce _ _ body) = size_up body -- Coercions cost nothing
- size_up (Con con args) = sizeN (numValArgs args)
+ size_up (App fun arg) = size_up fun `addSize` size_up_arg arg
+ -- NB Zero cost for for type applications;
+ -- others cost 1 or more
+
+ size_up (Con con args) = conSizeN (numValArgs args)
-- We don't count 1 for the constructor because we're
-- quite keen to get constructors into the open
size_up body `addSizeN` length args
size_up (Let (NonRec binder rhs) body)
- = size_up rhs
+ = nukeScrutDiscount (size_up rhs)
`addSize`
size_up body
- `addSizeN`
- 1
size_up (Let (Rec pairs) body)
- = foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs]
+ = nukeScrutDiscount (foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs])
`addSize`
size_up body
- `addSizeN`
- length pairs
size_up (Case scrut alts)
- = size_up_scrut scrut
+ = nukeScrutDiscount (size_up scrut)
+ `addSize`
+ arg_discount scrut
`addSize`
size_up_alts (coreExprType scrut) alts
-- We charge for the "case" itself in "size_up_alts"
------------
+ -- In an application we charge 0 for type application
+ -- 1 for most anything else
+ -- N for norep_lits
size_up_arg (LitArg lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
- size_up_arg other = sizeZero
+ size_up_arg (TyArg _) = sizeZero
+ size_up_arg other = sizeOne
------------
size_up_alts scrut_ty (AlgAlts alts deflt)
- = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts
+ = (foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts)
`addSizeN`
alt_cost
where
alt_cost :: Int
alt_cost
- = --trace "CoreUnfold.getAppDataTyConExpandingDicts:2" $
- case (maybeAppDataTyConExpandingDicts scrut_ty) of
+ = case (maybeAppDataTyConExpandingDicts scrut_ty) of
Nothing -> 1
Just (tc,_,_) -> tyConFamilySize tc
size_prim_alt (lit,rhs) = size_up rhs
------------
- size_up_deflt NoDefault = sizeZero
+ size_up_deflt NoDefault = sizeZero
size_up_deflt (BindDefault binder rhs) = size_up rhs
------------
- -- Scrutinees. There are two things going on here.
- -- First, we want to record if we're case'ing an argument
- -- Second, we want to charge nothing for the srutinee if it's just
- -- a variable. That way wrapper-like things look cheap.
- size_up_scrut (Var v) | v `is_elem` args = Just (0, [v])
- | otherwise = Just (0, [])
- size_up_scrut other = size_up other
+ -- We want to record if we're case'ing an argument
+ arg_discount (Var v) | v `is_elem` args = scrutArg v
+ arg_discount other = sizeZero
is_elem :: Id -> [Id] -> Bool
is_elem = isIn "size_up_scrut"
------------
- sizeZero = Just (0, [])
- sizeOne = Just (1, [])
- sizeN n = Just (n, [])
-
- addSizeN Nothing _ = Nothing
- addSizeN (Just (n, xs)) m
- | tot < bOMB_OUT_SIZE = Just (tot, xs)
- | otherwise = Nothing
- where
- tot = n+m
+ -- These addSize things have to be here because
+ -- I don't want to give them bOMB_OUT_SIZE as an argument
- addSize Nothing _ = Nothing
- addSize _ Nothing = Nothing
- addSize (Just (n, xs)) (Just (m, ys))
- | tot < bOMB_OUT_SIZE = Just (tot, xys)
- | otherwise = Nothing
+ addSizeN TooBig _ = TooBig
+ addSizeN (SizeIs n xs d) (I# m)
+ | n_tot -# d <# bOMB_OUT_SIZE = SizeIs n_tot xs d
+ | otherwise = TooBig
+ where
+ n_tot = n +# m
+
+ addSize TooBig _ = TooBig
+ addSize _ TooBig = TooBig
+ addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
+ | (n_tot -# d_tot) <# bOMB_OUT_SIZE = SizeIs n_tot xys d_tot
+ | otherwise = TooBig
where
- tot = n+m
- xys = xs ++ ys
+ n_tot = n1 +# n2
+ d_tot = d1 +# d2
+ xys = xs ++ ys
+
-splitCoreApps e
- = go e []
- where
- go (App fun arg) args = go fun (arg:args)
- go fun args = (fun,args)
+\end{code}
+
+Code for manipulating sizes
+
+\begin{code}
+
+data ExprSize = TooBig
+ | SizeIs Int# -- Size found
+ [Id] -- Arguments cased herein
+ Int# -- Size to subtract if result is scrutinised
+ -- by a case expression
+
+sizeZero = SizeIs 0# [] 0#
+sizeOne = SizeIs 1# [] 0#
+sizeN (I# n) = SizeIs n [] 0#
+conSizeN (I# n) = SizeIs n [] n
+scrutArg v = SizeIs 0# [v] 0#
+
+nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
+nukeScrutDiscount TooBig = TooBig
\end{code}
%************************************************************************
a single integer. (3)~An ``argument info'' vector. For this, what we
have at the moment is a Boolean per argument position that says, ``I
will look with great favour on an explicit constructor in this
-position.''
+position.'' (4)~The ``discount'' to subtract if the expression
+is being scrutinised.
Assuming we have enough type- and value arguments (if not, we give up
immediately), then we see if the ``discounted size'' is below some
hands, we get a (again, semi-arbitrary) discount [proportion to the
number of constructors in the type being scrutinized].
+If we're in the context of a scrutinee ( \tr{(case <expr > of A .. -> ...;.. )})
+and the expression in question will evaluate to a constructor, we use
+the computed discount size *for the result only* rather than
+computing the argument discounts. Since we know the result of
+the expression is going to be taken apart, discounting its size
+is more accurate (see @sizeExpr@ above for how this discount size
+is computed).
+
\begin{code}
smallEnoughToInline :: [Bool] -- Evaluated-ness of value arguments
+ -> Bool -- Result is scrutinised
-> UnfoldingGuidance
-> Bool -- True => unfold it
-smallEnoughToInline _ UnfoldAlways = True
-smallEnoughToInline _ UnfoldNever = False
-smallEnoughToInline arg_is_evald_s
- (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size)
+smallEnoughToInline _ _ UnfoldAlways = True
+smallEnoughToInline _ _ UnfoldNever = False
+smallEnoughToInline arg_is_evald_s result_is_scruted
+ (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount)
= enough_args n_vals_wanted arg_is_evald_s &&
discounted_size <= opt_UnfoldingUseThreshold
where
+
+ enough_args n [] | n > 0 = False -- A function with no value args => don't unfold
+ enough_args _ _ = True -- Otherwise it's ok to try
+
+{- OLD: require saturated args
enough_args 0 evals = True
enough_args n [] = False
enough_args n (e:es) = enough_args (n-1) es
-- NB: don't take the length of arg_is_evald_s because when
-- called from couldBeSmallEnoughToInline it is infinite!
+-}
+
+ discounted_size = size - args_discount - result_discount
- discounted_size = size - sum (zipWith arg_discount discount_vec arg_is_evald_s)
+ args_discount = sum (zipWith arg_discount discount_vec arg_is_evald_s)
+ result_discount | result_is_scruted = scrut_discount
+ | otherwise = 0
arg_discount no_of_constrs is_evald
| is_evald = 1 + no_of_constrs * opt_UnfoldingConDiscount
Just the same as smallEnoughToInline, except that it has no actual arguments.
\begin{code}
+--UNUSED?
couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool
-couldBeSmallEnoughToInline guidance = smallEnoughToInline (repeat True) guidance
+couldBeSmallEnoughToInline guidance = smallEnoughToInline (repeat True) True guidance
certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool
-certainlySmallEnoughToInline guidance = smallEnoughToInline (repeat False) guidance
+certainlySmallEnoughToInline guidance = smallEnoughToInline (repeat False) False guidance
\end{code}
Predicates
import PprCore
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instances-} )
-import Pretty ( ppAboves, ppStr )
-import PrelVals ( augmentId, buildId )
+import Pretty ( vcat, text )
import PrimOp ( primOpType, PrimOp(..) )
import SrcLoc ( noSrcLoc )
import TyVar ( cloneTyVar,
- isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
+ isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv),
+ SYN_IE(TyVar)
)
import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
getFunTyExpandingDicts_maybe, applyTy, isPrimType,
- splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
+ splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy,
+ SYN_IE(Type)
)
import TysWiredIn ( trueDataCon, falseDataCon )
import UniqSupply ( initUs, returnUs, thenUs,
-- a Prim is <ditto> of a PrimOp
coreExprType (Con con args) =
--- pprTrace "appTyArgs" (ppCat [ppr PprDebug con, ppSemi,
--- ppr PprDebug con_ty, ppSemi,
+-- pprTrace "appTyArgs" (hsep [ppr PprDebug con, semi,
+-- ppr PprDebug con_ty, semi,
-- ppr PprDebug args]) $
applyTypeToArgs con_ty args
where
coreExprType (App expr (TyArg ty))
=
--- pprTrace "appTy1" (ppCat [ppr PprDebug fun_ty, ppSP, ppr PprDebug ty]) $
+-- pprTrace "appTy1" (hsep [ppr PprDebug fun_ty, space, ppr PprDebug ty]) $
applyTy fun_ty ty
where
fun_ty = coreExprType expr
Just (_, result_ty) -> result_ty
#ifdef DEBUG
Nothing -> pprPanic "coreExprType:\n"
- (ppAboves [ppr PprDebug fun_ty,
+ (vcat [ppr PprDebug fun_ty,
ppr PprShowAll (App expr val_arg)])
#endif
\end{code}
-- *pretend* that the result ty won't be
-- primitive -- somebody later must
-- ensure this.
- -> Maybe (GenCoreExpr a Id TyVar UVar)
+ -> Maybe (GenCoreExpr b Id TyVar UVar)
maybeErrorApp expr result_ty_maybe
= case (collectArgs expr) of
import Id ( idType, getIdArity, isBottomingId,
emptyIdSet, unitIdSet, mkIdSet,
elementOfIdSet, minusIdSet, unionManyIdSets,
- SYN_IE(IdSet)
+ SYN_IE(IdSet), SYN_IE(Id)
)
import IdInfo ( ArityInfo(..) )
import PrimOp ( PrimOp(..) )
-import Type ( tyVarsOfType )
+import Type ( tyVarsOfType, SYN_IE(Type) )
import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet,
intersectTyVarSets,
- SYN_IE(TyVarSet)
+ SYN_IE(TyVarSet), SYN_IE(TyVar)
)
import UniqSet ( unionUniqSets )
import Usage ( SYN_IE(UVar) )
import CoreSyn
import CostCentre ( showCostCentre )
import Id ( idType, getIdInfo, getIdStrictness, isTupleCon,
- nullIdEnv, SYN_IE(DataCon), GenId{-instances-}
- )
+ nullIdEnv, SYN_IE(DataCon), GenId{-instances-},
+ SYN_IE(Id)
+ )
import IdInfo ( ppIdInfo, StrictnessInfo(..) )
import Literal ( Literal{-instances-} )
import Name ( OccName, parenInCode )
usually be called through some intermediary.
The binder/occ printers take the default ``homogenized'' (see
-@PprEnv@...) @Pretty@ and the binder/occ. They can either use the
+@PprEnv@...) @Doc@ and the binder/occ. They can either use the
homogenized one, or they can ignore it completely. In other words,
the things passed in act as ``hooks'', getting the last word on how to
print something.
@pprParendCoreExpr@ puts parens around non-atomic Core expressions.
\begin{code}
-pprCoreBinding :: PprStyle -> CoreBinding -> Pretty
+pprCoreBinding :: PprStyle -> CoreBinding -> Doc
pprGenCoreBinding
:: (Eq tyvar, Outputable tyvar,
Outputable bndr,
Outputable occ)
=> PprStyle
- -> (bndr -> Pretty) -- to print "major" val_bdrs
- -> (bndr -> Pretty) -- to print "minor" val_bdrs
- -> (occ -> Pretty) -- to print bindees
+ -> (bndr -> Doc) -- to print "major" val_bdrs
+ -> (bndr -> Doc) -- to print "minor" val_bdrs
+ -> (occ -> Doc) -- to print bindees
-> GenCoreBinding bndr occ tyvar uvar
- -> Pretty
+ -> Doc
pprGenCoreBinding sty pbdr1 pbdr2 pocc bind
= ppr_bind (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) bind
(Just (ppr sty)) -- literals
(Just ppr_con) -- data cons
(Just ppr_prim) -- primops
- (Just (\ cc -> ppStr (showCostCentre sty True cc)))
+ (Just (\ cc -> text (showCostCentre sty True cc)))
(Just tvbndr) -- tyvar binders
(Just (ppr sty)) -- tyvar occs
(Just (ppr sty)) -- usage vars
-- to distinguish them from ordinary applications. But not when
-- printing for interfaces, where they are treated as ordinary applications
ppr_con con | ifaceStyle sty = ppr sty con
- | otherwise = ppr sty con `ppBeside` ppChar '!'
+ | otherwise = ppr sty con <> char '!'
-}
-- 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 `ppBeside` ppChar '!'
+ | otherwise = ppr sty prim <> char '!'
--------------
pprCoreBinding sty (NonRec binder expr)
- = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
+ = hang (hsep [pprBigCoreBinder sty binder, equals])
4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
pprCoreBinding sty (Rec binds)
- = ppAboves [ifPprDebug sty (ppPStr SLIT("{- plain Rec -}")),
- ppAboves (map ppr_bind binds),
- ifPprDebug sty (ppPStr SLIT("{- end plain Rec -}"))]
+ = vcat [ptext SLIT("Rec {"),
+ vcat (map ppr_bind binds),
+ ptext SLIT("end Rec }")]
where
ppr_bind (binder, expr)
- = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
+ = hang (hsep [pprBigCoreBinder sty binder, equals])
4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
\end{code}
\begin{code}
pprCoreExpr
:: PprStyle
- -> (Id -> Pretty) -- to print "major" val_bdrs
- -> (Id -> Pretty) -- to print "minor" val_bdrs
- -> (Id -> Pretty) -- to print bindees
+ -> (Id -> Doc) -- to print "major" val_bdrs
+ -> (Id -> Doc) -- to print "minor" val_bdrs
+ -> (Id -> Doc) -- to print bindees
-> CoreExpr
- -> Pretty
+ -> Doc
pprCoreExpr = pprGenCoreExpr
pprGenCoreExpr, pprParendCoreExpr
Outputable bndr,
Outputable occ)
=> PprStyle
- -> (bndr -> Pretty) -- to print "major" val_bdrs
- -> (bndr -> Pretty) -- to print "minor" val_bdrs
- -> (occ -> Pretty) -- to print bindees
+ -> (bndr -> Doc) -- to print "major" val_bdrs
+ -> (bndr -> Doc) -- to print "minor" val_bdrs
+ -> (occ -> Doc) -- to print bindees
-> GenCoreExpr bndr occ tyvar uvar
- -> Pretty
+ -> Doc
pprGenCoreExpr sty pbdr1 pbdr2 pocc expr
= ppr_expr (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) expr
= case expr of
Var _ -> id -- leave unchanged
Lit _ -> id
- _ -> ppParens -- wraps in parens
+ _ -> parens -- wraps in parens
in
parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr)
-- Printer for unfoldings in interfaces
-pprIfaceUnfolding :: CoreExpr -> Pretty
+pprIfaceUnfolding :: CoreExpr -> Doc
pprIfaceUnfolding = ppr_expr env
where
env = init_ppr_env PprInterface (pprTyVarBndr PprInterface)
Eq uvar, Outputable uvar)
=>
Outputable (GenCoreBinding bndr occ tyvar uvar) where
- ppr sty bind = pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
+ 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 = pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
+ 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 = ppr_core_arg sty (ppr sty) arg
+ 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 = ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts
+ 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 = ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
+ ppr sty deflt = pprQuote sty $ \sty ->
+ ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
\end{code}
%************************************************************************
\begin{code}
ppr_bind pe (NonRec val_bdr expr)
- = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
+ = hang (hsep [pMajBndr pe val_bdr, equals])
4 (ppr_expr pe expr)
ppr_bind pe (Rec binds)
- = ppAboves (map ppr_pair binds)
+ = vcat (map ppr_pair binds)
where
ppr_pair (val_bdr, expr)
- = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
- 4 (ppr_expr pe expr `ppBeside` ppSemi)
+ = hang (hsep [pMajBndr pe val_bdr, equals])
+ 4 (ppr_expr pe expr <> semi)
\end{code}
\begin{code}
= case expr of
Var _ -> id -- leave unchanged
Lit _ -> id
- _ -> ppParens -- wraps in parens
+ _ -> parens -- wraps in parens
in
parenify (ppr_expr pe expr)
\end{code}
ppr_expr pe (Lit lit) = pLit pe lit
ppr_expr pe (Con con args)
- = ppHang (pCon pe con)
- 4 (ppCurlies $ ppSep (map (ppr_arg pe) args))
+ = hang (pCon pe con)
+ 4 (braces $ sep (map (ppr_arg pe) args))
ppr_expr pe (Prim prim args)
- = ppHang (pPrim pe prim)
- 4 (ppSep (map (ppr_arg pe) args))
+ = hang (pPrim pe prim)
+ 4 (sep (map (ppr_arg pe) args))
ppr_expr pe expr@(Lam _ _)
= let
(uvars, tyvars, vars, body) = collectBinders expr
in
- ppHang (ppCat [pp_vars SLIT("/u\\") (pUVar pe) uvars,
+ hang (hsep [pp_vars SLIT("/u\\") (pUVar pe) uvars,
pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars,
pp_vars SLIT("\\") (pMajBndr pe) vars])
4 (ppr_expr pe body)
where
- pp_vars lam pp [] = ppNil
+ pp_vars lam pp [] = empty
pp_vars lam pp vs
- = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppPStr SLIT("->")]
+ = hsep [ptext lam, hsep (map pp vs), ptext SLIT("->")]
ppr_expr pe expr@(App fun arg)
= let
go (App fun arg) args_so_far = go fun (arg:args_so_far)
go fun args_so_far = (fun, args_so_far)
in
- ppHang (ppr_parend_expr pe final_fun) 4 (ppSep (map (ppr_arg pe) final_args))
+ hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
ppr_expr pe (Case expr alts)
| only_one_alt alts
-- and no indent; all sane persons agree with him.
= let
- ppr_alt (AlgAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) ppr_arrow
- ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) ppr_arrow
- ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l) ppr_arrow
+ ppr_alt (AlgAlts [] (BindDefault n _)) = (<>) (pMinBndr pe n) ppr_arrow
+ ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (pMinBndr pe n) ppr_arrow
+ ppr_alt (PrimAlts ((l, _):[]) NoDefault)= (<>) (pLit pe l) ppr_arrow
ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
- = ppCat [pCon pe con,
- ppInterleave ppSP (map (pMinBndr pe) params),
+ = hsep [pCon pe con,
+ hsep (map (pMinBndr pe) params),
ppr_arrow]
ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
- ppr_arrow = ppPStr SLIT(" ->")
+ ppr_arrow = ptext SLIT(" ->")
in
- ppSep
- [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppStr "of {", ppr_alt alts],
- ppBeside (ppr_rhs alts) (ppStr ";}")]
+ sep
+ [sep [pp_keyword, nest 4 (ppr_expr pe expr), text "of {", ppr_alt alts],
+ (<>) (ppr_rhs alts) (text ";}")]
| otherwise -- default "case" printing
- = ppSep
- [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppPStr SLIT("of {")],
- ppNest 2 (ppr_alts pe alts),
- ppStr "}"]
+ = sep
+ [sep [pp_keyword, nest 4 (ppr_expr pe expr), ptext SLIT("of {")],
+ nest 2 (ppr_alts pe alts),
+ text "}"]
where
pp_keyword = case alts of
- AlgAlts _ _ -> ppPStr SLIT("case")
- PrimAlts _ _ -> ppPStr SLIT("case#")
+ AlgAlts _ _ -> ptext SLIT("case")
+ PrimAlts _ _ -> ptext SLIT("case#")
-- special cases: let ... in let ...
-- ("disgusting" SLPJ)
ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
- = ppAboves [
- ppCat [ppPStr SLIT("let {"), pMajBndr pe val_bdr, ppEquals],
- ppNest 2 (ppr_expr pe rhs),
- ppPStr SLIT("} in"),
+ = vcat [
+ hsep [ptext SLIT("let {"), pMajBndr pe 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 _ _))
- = ppAbove
- (ppHang (ppPStr SLIT("let {"))
- 2 (ppCat [ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
+ = ($$)
+ (hang (ptext SLIT("let {"))
+ 2 (hsep [hang (hsep [pMajBndr pe val_bdr, equals])
4 (ppr_expr pe rhs),
- ppPStr SLIT("} in")]))
+ ptext SLIT("} in")]))
(ppr_expr pe expr)
-- general case (recursive case, too)
ppr_expr pe (Let bind expr)
- = ppSep [ppHang (ppPStr keyword) 2 (ppr_bind pe bind),
- ppHang (ppPStr SLIT("} in ")) 2 (ppr_expr pe expr)]
+ = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
+ hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
where
keyword = case bind of
- Rec _ -> SLIT("letrec {")
+ Rec _ -> SLIT("_letrec_ {")
NonRec _ _ -> SLIT("let {")
ppr_expr pe (SCC cc expr)
- = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc],
+ = sep [hsep [ptext SLIT("_scc_"), pSCC pe cc],
ppr_parend_expr pe expr ]
ppr_expr pe (Coerce c ty expr)
- = ppSep [pp_coerce c, pTy pe ty, ppr_expr pe expr]
+ = sep [pp_coerce c, pTy pe ty, ppr_expr pe expr]
where
- pp_coerce (CoerceIn v) = ppBeside (ppPStr SLIT("_coerce_in_ ")) (ppr (pStyle pe) v)
- pp_coerce (CoerceOut v) = ppBeside (ppPStr SLIT("_coerce_out_ ")) (ppr (pStyle pe) v)
+ pp_coerce (CoerceIn v) = (<>) (ptext SLIT("_coerce_in_ ")) (ppr (pStyle pe) v)
+ pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_coerce_out_ ")) (ppr (pStyle pe) v)
only_one_alt (AlgAlts [] (BindDefault _ _)) = True
only_one_alt (AlgAlts (_:[]) NoDefault) = True
\begin{code}
ppr_alts pe (AlgAlts alts deflt)
- = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
+ = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
where
- ppr_arrow = ppPStr SLIT("->")
+ ppr_arrow = ptext SLIT("->")
ppr_alt (con, params, expr)
- = ppHang (if isTupleCon con then
- ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)),
- ppr_arrow]
+ = hang (if isTupleCon con then
+ hsep [parens (hsep (punctuate comma (map (pMinBndr pe) params))),
+ ppr_arrow]
else
- ppCat [pCon pe con,
- ppInterleave ppSP (map (pMinBndr pe) params),
+ hsep [pCon pe con,
+ hsep (map (pMinBndr pe) params),
ppr_arrow]
)
- 4 (ppr_expr pe expr `ppBeside` ppSemi)
+ 4 (ppr_expr pe expr <> semi)
ppr_alts pe (PrimAlts alts deflt)
- = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
+ = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
where
ppr_alt (lit, expr)
- = ppHang (ppCat [pLit pe lit, ppPStr SLIT("->")])
- 4 (ppr_expr pe expr `ppBeside` ppSemi)
+ = hang (hsep [pLit pe lit, ptext SLIT("->")])
+ 4 (ppr_expr pe expr <> semi)
\end{code}
\begin{code}
-ppr_default pe NoDefault = ppNil
+ppr_default pe NoDefault = empty
ppr_default pe (BindDefault val_bdr expr)
- = ppHang (ppCat [pMinBndr pe val_bdr, ppPStr SLIT("->")])
- 4 (ppr_expr pe expr `ppBeside` ppSemi)
+ = hang (hsep [pMinBndr pe val_bdr, ptext SLIT("->")])
+ 4 (ppr_expr pe expr <> semi)
\end{code}
\begin{code}
ppr_arg pe (LitArg lit) = pLit pe lit
ppr_arg pe (VarArg v) = pOcc pe v
-ppr_arg pe (TyArg ty) = ppPStr SLIT("_@_ ") `ppBeside` pTy pe ty
+ppr_arg pe (TyArg ty) = ptext SLIT("_@_ ") <> pTy pe ty
ppr_arg pe (UsageArg use) = pUse pe use
\end{code}
\begin{code}
pprBigCoreBinder sty binder
- = ppAboves [sig, pragmas, ppr sty binder]
+ = vcat [sig, pragmas, ppr sty binder]
where
sig = ifnotPprShowAll sty (
- ppHang (ppCat [ppr sty binder, ppDcolon])
+ hang (hsep [ppr sty binder, ppDcolon])
4 (ppr sty (idType binder)))
pragmas =
ifnotPprForUser sty
(ppIdInfo sty False{-no specs, thanks-} (getIdInfo binder))
pprBabyCoreBinder sty binder
- = ppCat [ppr sty binder, pp_strictness]
+ = hsep [ppr sty binder, pp_strictness]
where
pp_strictness
= case (getIdStrictness binder) of
- NoStrictnessInfo -> ppNil
- BottomGuaranteed -> ppPStr SLIT("{- _!_ -}")
+ NoStrictnessInfo -> empty
+ BottomGuaranteed -> ptext SLIT("{- _!_ -}")
StrictnessInfo xx _ ->
panic "PprCore:pp_strictness:StrictnessInfo:ToDo"
- -- ppStr ("{- " ++ (showList xx "") ++ " -}")
+ -- text ("{- " ++ (showList xx "") ++ " -}")
pprTypedCoreBinder sty binder
- = ppBesides [ppr sty binder, ppDcolon, pprParendGenType sty (idType binder)]
+ = hcat [ppr sty binder, ppDcolon, pprParendGenType sty (idType binder)]
-ppDcolon = ppPStr SLIT(" :: ")
+ppDcolon = ptext SLIT(" :: ")
-- The space before the :: is important; it helps the lexer
-- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
\end{code}
\begin{code}
#include "HsVersions.h"
-module Desugar ( deSugar, DsMatchContext, pprDsWarnings,
- DsWarnFlavour -- removed when compiling with 1.4
+module Desugar ( deSugar, pprDsWarnings
+#if __GLASGOW_HASKELL__ < 200
+ , DsMatchContext
+ , DsWarnFlavour -- fluff needed for closure,
+ -- removed when compiling with 1.4
+#endif
) where
IMP_Ubiq(){-uitous-}
-import HsSyn ( HsBinds, HsExpr )
-import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) )
+import HsSyn ( HsBinds, HsExpr, MonoBinds,
+ SYN_IE(RecFlag), nonRecursive
+ )
+import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr)
+ )
import CoreSyn
import Name ( isExported )
import DsMonad
-import DsBinds ( dsBinds, dsInstBinds )
+import DsBinds ( dsBinds, dsMonoBinds )
import DsUtils
import Bag ( unionBags )
import CostCentre ( IsCafCC(..), mkAutoCC )
import CoreLift ( liftCoreBindings )
import CoreLint ( lintCoreBindings )
-import Id ( nullIdEnv, mkIdEnv, idType, SYN_IE(DictVar), GenId )
+import Id ( nullIdEnv, mkIdEnv, idType,
+ SYN_IE(DictVar), GenId, SYN_IE(Id) )
import PprStyle ( PprStyle(..) )
-import UniqSupply ( splitUniqSupply )
+import UniqSupply ( splitUniqSupply, UniqSupply )
\end{code}
The only trick here is to get the @DsMonad@ stuff off to a good
TypecheckedHsBinds, -- bindings; see "tcModule" (which produces
TypecheckedHsBinds, -- them)
TypecheckedHsBinds,
- [(Id, TypecheckedHsExpr)])
+ TypecheckedHsBinds)
-- ToDo: handling of const_inst thingies is certainly WRONG ***************************
-> ([CoreBinding], -- output
DsWarnings) -- Shadowing complaints
-deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst_pairs)
+deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst_binds)
= let
(us0, us0a) = splitUniqSupply us
(us1, us1a) = splitUniqSupply us0a
Just xx -> _PK_ xx
Nothing -> mod_name -- default: module name
- ((core_const_prs, consts_pairs), shadows1)
- = initDs us0 nullIdEnv mod_name (dsInstBinds [] const_inst_pairs)
-
- consts_env = mkIdEnv consts_pairs
+ (core_const_binds, shadows1)
+ = initDs us0 nullIdEnv mod_name (dsBinds const_inst_binds)
+ core_const_prs = pairsFromCoreBinds core_const_binds
(core_clas_binds, shadows2)
- = initDs us1 consts_env mod_name (dsBinds clas_binds)
+ = initDs us1 nullIdEnv mod_name (dsBinds clas_binds)
core_clas_prs = pairsFromCoreBinds core_clas_binds
(core_inst_binds, shadows3)
- = initDs us2 consts_env mod_name (dsBinds inst_binds)
+ = initDs us2 nullIdEnv mod_name (dsBinds inst_binds)
core_inst_prs = pairsFromCoreBinds core_inst_binds
(core_val_binds, shadows4)
- = initDs us3 consts_env mod_name (dsBinds val_binds)
+ = initDs us3 nullIdEnv mod_name (dsBinds val_binds)
core_val_pairs = map (addAutoScc module_and_group) (pairsFromCoreBinds core_val_binds)
(core_recsel_binds, shadows5)
- = initDs us4 consts_env mod_name (dsBinds recsel_binds)
+ = initDs us4 nullIdEnv mod_name (dsBinds recsel_binds)
core_recsel_prs = pairsFromCoreBinds core_recsel_binds
final_binds
--- /dev/null
+_interface_ DsBinds 1
+_exports_
+DsBinds dsBinds;
+_declarations_
+1 dsBinds _:_ TcHsSyn.TypecheckedHsBinds -> DsMonad.DsM [CoreSyn.CoreBinding] ;;
\begin{code}
#include "HsVersions.h"
-module DsBinds ( dsBinds, dsInstBinds ) where
+module DsBinds ( dsBinds, dsMonoBinds ) where
IMP_Ubiq()
IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop
import HsSyn -- lots of things
- hiding ( collectBinders{-also in CoreSyn-} )
import CoreSyn -- lots of things
+import CoreUtils ( coreExprType )
import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
- SYN_IE(TypecheckedBind), SYN_IE(TypecheckedMonoBinds),
+ SYN_IE(TypecheckedMonoBinds),
SYN_IE(TypecheckedPat)
)
-import DsHsSyn ( collectTypedBinders, collectTypedPatBinders )
-
import DsMonad
import DsGRHSs ( dsGuarded )
import DsUtils
import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs,
opt_AutoSccsOnExportedToplevs, opt_CompilingGhcInternals )
import CostCentre ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre )
-import Id ( idType, SYN_IE(DictVar), GenId )
+import Id ( idType, SYN_IE(DictVar), GenId, SYN_IE(Id) )
import ListSetOps ( minusList, intersectLists )
import Name ( isExported )
import PprType ( GenType )
import PprStyle ( PprStyle(..) )
-import Pretty ( ppShow )
-import Type ( mkTyVarTys, mkForAllTys, splitSigmaTy,
- tyVarsOfType, tyVarsOfTypes, isDictTy
+import Type ( mkTyVarTy, isDictTy, instantiateTy
)
import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
+import TysPrim ( voidTy )
import Util ( isIn, panic{-, pprTrace ToDo:rm-} )
---import PprCore--ToDo:rm
---import PprType ( GenTyVar ) --ToDo:rm
---import Usage--ToDo:rm
---import Unique--ToDo:rm
\end{code}
%************************************************************************
\begin{code}
dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
-\end{code}
-
-All ``real'' bindings are expressed in terms of the
-@AbsBinds@ construct, which is a massively-complicated ``shorthand'',
-and its desugaring is the subject of section~9.1 in the static
-semantics paper.
-
-(ToDo) For:
-\begin{verbatim}
-AbsBinds [a1, ... ,aj] -- type variables
- [d1, ... ,dk] -- dict variables
- [(l1,g1), ..., (lm,gm)] -- overloaded equivs [Id pairs] (later...)
- [db1=..., ..., dbn=...] -- dict binds
- [vb1=..., ..., vbm=...] -- val binds; note: vb_i = l_i
-\end{verbatim}
-we want to make, in the general case (non-Fozzie translation):
-\begin{verbatim}
- -- tupler-upper:
- tup a1...aj d1...dk =
- let <dict-binds> in
- let(rec) <val-binds> in (vb1,...,vbm) -- NB: == ... in (l1,...,lm)
-
- -- a bunch of selectors:
- g1 a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> x1
- ...
- gm a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> xm
-\end{verbatim}
-But there are lots of special cases.
-
-
-%==============================================
-\subsubsection{Structure cases}
-%==============================================
-
-\begin{code}
-dsBinds (BindWith _ _) = panic "dsBinds:BindWith"
-dsBinds EmptyBinds = returnDs []
-dsBinds (SingleBind bind) = dsBind [] [] id [] bind
-
-dsBinds (ThenBinds binds_1 binds_2)
- = andDs (++) (dsBinds binds_1) (dsBinds binds_2)
-\end{code}
-
-
-%==============================================
-\subsubsection{AbsBind case: no overloading}
-%==============================================
-
-Special case: no overloading.
-\begin{verbatim}
- x1 = e1
- x2 = e2
-\end{verbatim}
-We abstract each wrt the type variables, giving
-\begin{verbatim}
- x1' = /\tyvars -> e1[x1' tyvars/x1, x2' tyvars/x2]
- x2' = /\tyvars -> e2[x1' tyvars/x1, x2' tyvars/x2]
-\end{verbatim}
-There are some complications.
-
-(i) The @val_binds@ might mention variable not in @local_global_prs@.
-In this case we need to make up new polymorphic versions of them.
-
-(ii) Exactly the same applies to any @inst_binds@ which may be
-present. However, here we expect that mostly they will be simple constant
-definitions, which don't mention the type variables at all, so making them
-polymorphic is really overkill. @dsInstBinds@ deals with this case.
-
-\begin{code}
-dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
- = mapDs mk_poly_private_binder private_binders
- `thenDs` \ poly_private_binders ->
- let
- full_local_global_prs = (private_binders `zip` poly_private_binders)
- ++ local_global_prs
- in
- listDs [ mkSatTyApp global tyvar_tys `thenDs` \ app ->
- returnDs (local, app)
- | (local,global) <- full_local_global_prs
- ] `thenDs` \ env ->
--- pprTrace "AbsBinds1:" (ppr PprDebug env) $
+dsBinds EmptyBinds = returnDs []
+dsBinds (ThenBinds binds_1 binds_2) = andDs (++) (dsBinds binds_1) (dsBinds binds_2)
- extendEnvDs env (
-
- dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
- extendEnvDs inst_env (
-
- dsBind tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds
- ))
- where
- -- "private_binders" is the list of binders in val_binds
- -- which don't appear in the local_global_prs list
- -- These only really show up in stuff produced from compiling
- -- class and instance declarations.
- -- We need to add suitable polymorphic versions of them to the
- -- local_global_prs.
- private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
- binders = collectTypedBinders val_binds
- mk_poly_private_binder id = newSysLocalDs (mkForAllTys tyvars (idType id))
-
- tyvar_tys = mkTyVarTys tyvars
-\end{code}
-
-
-%==============================================
-\subsubsection{AbsBind case: overloading}
-%==============================================
-
-If there is overloading we go for the general case.
-
-We want the global identifiers to be abstracted wrt all types and
-dictionaries; and the local identifiers wrt the non-overloaded types.
-That is, we try to avoid global scoping of type abstraction. Example
-
- f :: Eq a => a -> [(a,b)] -> b
- f = ...f...
-
-Here, f is fully polymorphic in b. So we generate
-
- f ab d = let ...dict defns...
- in
- letrec f' b = ...(f' b)...
- in f' b
-
-*Notice* that we don't clone type variables, and *do* make use of
-shadowing. It is possible to do cloning, but it makes the code quite
-a bit more complicated, and the simplifier will clone it all anyway.
-
-Why bother with this gloss? Because it makes it more likely that
-the defn of f' can get floated out, notably if f gets specialised
-to a particular type for a.
-
-\begin{code}
-dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
- = -- If there is any non-overloaded polymorphism, make new locals with
- -- appropriate polymorphism
- (if null non_overloaded_tyvars
- then
- -- No non-overloaded polymorphism, so stay with current envt
- returnDs (id, [], [])
- else
- -- Some local, non-overloaded polymorphism
- cloneTyVarsDs non_overloaded_tyvars `thenDs` \ local_tyvars ->
-
- mapDs mk_binder binders `thenDs` \ new_binders ->
- let
- old_new_pairs = binders `zip` new_binders
- in
-
- listDs [ mkSatTyApp new non_ov_tyvar_tys `thenDs` \ app ->
- returnDs (old, app)
- | (old,new) <- old_new_pairs
- ] `thenDs` \ extra_env ->
- let
- local_binds = [NonRec old app | (old,app) <- extra_env, old `is_elem` locals]
- is_elem = isIn "dsBinds"
- in
- returnDs (lookupId old_new_pairs, extra_env, local_binds)
+dsBinds (MonoBind binds sigs is_rec)
+ = dsMonoBinds is_rec binds `thenDs` \ prs ->
+ returnDs (if is_rec then
+ [Rec prs]
+ else
+ [NonRec binder rhs | (binder,rhs) <- prs]
)
- `thenDs` \ (binder_subst_fn, local_env, local_binds) ->
-
--- pprTrace "AbsBinds:all:" (ppAbove (ppr PprDebug local_binds) (ppr PprDebug local_env)) $
-
- extendEnvDs local_env (
-
- dsInstBinds non_overloaded_tyvars dict_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
-
- extendEnvDs inst_env (
-
- dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
- )) `thenDs` \ core_binds ->
-
- let
- tuple_rhs = mkCoLetsAny core_binds (
- mkCoLetsAny local_binds (
- mkTupleExpr locals ))
- in
- mkTupleBind all_tyvars dicts local_global_prs tuple_rhs `thenDs` \ core_bind_prs ->
-
- returnDs (mk_result_bind core_bind_prs)
- where
- locals = [local | (local,global) <- local_global_prs]
- non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars
-
- overloaded_tyvars = tyVarsOfTypes (map idType dicts)
- non_overloaded_tyvars = all_tyvars `minusList` (tyVarSetToList{-????-} overloaded_tyvars)
-
- binders = collectTypedBinders val_binds
- mk_binder id = newSysLocalDs (mkForAllTys non_overloaded_tyvars (idType id))
-
- is_rec_bind = case val_binds of
- RecBind _ -> True
- NonRecBind _ -> False
-
- -- Recursion can still be needed if there are type signatures
- mk_result_bind prs | is_rec_bind = [Rec prs]
- | otherwise = [NonRec binder rhs | (binder,rhs) <- prs]
-\end{code}
-
-@mkSatTyApp id tys@ constructs an expression whose value is (id tys).
-However, sometimes id takes more type args than are in tys, and the
-specialiser hates that, so we have to eta expand, to
-@(/\ a b -> id tys a b)@.
-
-\begin{code}
-mkSatTyApp :: Id -- Id to apply to the types
- -> [Type] -- Types to apply it to
- -> DsM CoreExpr
-
-mkSatTyApp id [] = returnDs (Var id)
-
-mkSatTyApp id tys
- | null tvs
- = returnDs ty_app -- Common case
- | otherwise
- = newTyVarsDs (drop (length tys) tvs) `thenDs` \ tyvars ->
- returnDs (mkTyLam tyvars (mkTyApp ty_app (mkTyVarTys tyvars)))
- where
- (tvs, theta, tau_ty) = splitSigmaTy (idType id)
- ty_app = mkTyApp (Var id) tys
-\end{code}
-
-There are several places where we encounter ``inst binds,''
-@(Id, TypecheckedHsExpr)@ pairs. Many of these are ``trivial'' binds
-(a var to a var or literal), which we want to substitute away; so we
-return both some desugared bindings {\em and} a substitution
-environment for the subbed-away ones.
-
-These dictionary bindings are non-recursive, and ordered, so that
-later ones may mention earlier ones, but not vice versa.
-
-\begin{code}
-dsInstBinds :: [TyVar] -- Abstract wrt these
- -> [(Id, TypecheckedHsExpr)] -- From AbsBinds
- -> DsM ([(Id,CoreExpr)], -- Non-trivial bindings
- [(Id,CoreExpr)]) -- Trivial ones to be substituted away
-
-do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
-prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
-
-dsInstBinds tyvars [] = returnDs do_nothing
-
-dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs)
- = dsExpr expr `thenDs` \ rhs ->
- let -- Need to apply dsExpr to the variable in case it
- -- has a substitution in the current environment
- subst_item = (inst, rhs)
- in
- extendEnvDs [subst_item] (
- dsInstBinds tyvars bs
- ) `thenDs` \ (binds, subst_env) ->
- returnDs (binds, subst_item : subst_env)
-
-dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs)
- = dsExpr expr `thenDs` \ core_lit ->
- let
- subst_item = (inst, core_lit)
- in
- extendEnvDs [subst_item] (
- dsInstBinds tyvars bs
- ) `thenDs` \ (binds, subst_env) ->
- returnDs (binds, subst_item : subst_env)
-
-dsInstBinds tyvars ((inst, expr) : bs)
- | null abs_tyvars
- = dsExpr expr `thenDs` \ core_expr ->
- ds_dict_cc core_expr `thenDs` \ dict_expr ->
- dsInstBinds tyvars bs `thenDs` \ (core_rest, subst_env) ->
- returnDs ((inst, dict_expr) : core_rest, subst_env)
-
- | otherwise
- = -- Obscure case.
- -- The inst mentions the type vars wrt which we are abstracting,
- -- so we have to invent a new polymorphic version, and substitute
- -- appropriately.
- -- This can occur in, for example:
- -- leftPoll :: [FeedBack a] -> FeedBack a
- -- leftPoll xs = take poll xs
- -- Here there is an instance of take at the type of elts of xs,
- -- as well as the type of poll.
-
- dsExpr expr `thenDs` \ core_expr ->
- ds_dict_cc core_expr `thenDs` \ dict_expr ->
- newSysLocalDs poly_inst_ty `thenDs` \ poly_inst_id ->
- let
- subst_item = (inst, mkTyApp (Var poly_inst_id) abs_tys)
- in
- extendEnvDs [subst_item] (
- dsInstBinds tyvars bs
- ) `thenDs` \ (core_rest, subst_env) ->
- returnDs ((poly_inst_id, mkTyLam abs_tyvars dict_expr) : core_rest,
- subst_item : subst_env)
- where
- inst_ty = idType inst
- abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars
- abs_tys = mkTyVarTys abs_tyvars
- poly_inst_ty = mkForAllTys abs_tyvars inst_ty
-
- ------------------------
- -- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
- -- appropriate. Uses "inst"'s type.
-
- -- if profiling, wrap the dict in "_scc_ DICT <dict>":
- ds_dict_cc expr
- | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs)
- -- the latter is so that -unprof-auto-scc-all adds dict sccs
- || not (isDictTy inst_ty)
- = returnDs expr -- that's easy: do nothing
-
- | opt_CompilingGhcInternals
- = returnDs (SCC prel_dicts_cc expr)
-
- | otherwise
- = getModuleAndGroupDs `thenDs` \ (mod, grp) ->
-
- -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
-
- returnDs (SCC (mkAllDictsCC mod grp False) expr)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[dsBind]{Desugaring a @Bind@}
-%* *
-%************************************************************************
-
-Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be that
-some of the binders are of unboxed type.
-
-For an explanation of the first three args, see @dsMonoBinds@.
-
-\begin{code}
-dsBind :: [TyVar] -> [DictVar] -- Abstract wrt these
- -> (Id -> Id) -- Binder substitution
- -> [(Id,CoreExpr)] -- Inst bindings already dealt with
- -> TypecheckedBind
- -> DsM [CoreBinding]
-
-dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind
- = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
-
-dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
- = dsMonoBinds False tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs ->
- returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs]
-
-dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
- = dsMonoBinds True tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs ->
- returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)]
\end{code}
%* *
%************************************************************************
-@dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @CoreBinds@.
-In addition to desugaring pattern matching, @dsMonoBinds@ takes
-a list of type variables and dicts, and adds abstractions for these
-to the front of every binding. That requires that the
-binders be altered too (their type has changed,
-so @dsMonoBinds@ also takes a function which maps binders into binders.
-This mapping gives the binder the correct new type.
-
-Remember, there's also a substitution in the monad which maps occurrences
-of these binders into applications of the new binder to suitable type variables
-and dictionaries.
-
\begin{code}
-dsMonoBinds :: Bool -- True <=> recursive binding group
- -> [TyVar] -> [DictVar] -- Abstract wrt these
- -> (Id -> Id) -- Binder substitution
- -> TypecheckedMonoBinds
- -> DsM [(Id,CoreExpr)]
-\end{code}
+dsMonoBinds :: RecFlag -> TypecheckedMonoBinds -> DsM [(Id,CoreExpr)]
+dsMonoBinds is_rec EmptyMonoBinds = returnDs []
+dsMonoBinds is_rec (AndMonoBinds binds_1 binds_2)
+ = andDs (++) (dsMonoBinds is_rec binds_1) (dsMonoBinds is_rec binds_2)
-%==============================================
-\subsubsection{Structure cases}
-%==============================================
+dsMonoBinds is_rec (CoreMonoBind var core_expr)
+ = returnDs [(var, core_expr)]
-\begin{code}
-dsMonoBinds is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs []
-
-dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2)
- = andDs (++) (dsMonoBinds is_rec tyvars dicts binder_subst binds_1)
- (dsMonoBinds is_rec tyvars dicts binder_subst binds_2)
-\end{code}
-
-
-%==============================================
-\subsubsection{Simple base cases: function and variable bindings}
-%==============================================
+dsMonoBinds is_rec (VarMonoBind var expr)
+ = dsExpr expr `thenDs` \ core_expr ->
-\begin{code}
-dsMonoBinds is_rec tyvars dicts binder_subst (CoreMonoBind var core_expr)
- = returnDs [(binder_subst var, mkLam tyvars dicts core_expr)]
+ -- Dictionary bindings are always VarMonoBinds, so
+ -- we only need do this here
+ addDictScc var core_expr `thenDs` \ core_expr' ->
-dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
- = dsExpr expr `thenDs` \ core_expr ->
- returnDs [(binder_subst var, mkLam tyvars dicts core_expr)]
+ returnDs [(var, core_expr')]
-dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn)
+dsMonoBinds is_rec (FunMonoBind fun _ matches locn)
= putSrcLocDs locn $
- let
- new_fun = binder_subst fun
- error_string = "function " ++ showForErr fun
- in
matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) ->
- returnDs [(new_fun,
- mkLam tyvars (dicts ++ args) body)]
+ returnDs [(fun, mkValLam args body)]
+ where
+ error_string = "function " ++ showForErr fun
-dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
- = putSrcLocDs locn $
- dsGuarded grhss_and_binds `thenDs` \ body_expr ->
- returnDs [(binder_subst v, mkLam tyvars dicts body_expr)]
+dsMonoBinds is_rec (PatMonoBind pat grhss_and_binds locn)
+ = putSrcLocDs locn $
+ dsGuarded grhss_and_binds `thenDs` \ body_expr ->
+ mkSelectorBinds pat body_expr
+
+dsMonoBinds is_rec (AbsBinds [] [] exports binds) -- Common special case
+ = dsMonoBinds is_rec binds `thenDs` \ prs ->
+ returnDs (prs ++ [(global, Var local) | (_, global, local) <- exports])
+
+dsMonoBinds is_rec (AbsBinds all_tyvars dicts exports binds)
+ = dsMonoBinds is_rec binds `thenDs` \ core_prs ->
+ let
+ core_binds | is_rec = [Rec core_prs]
+ | otherwise = [NonRec b e | (b,e) <- core_prs]
+
+ tup_expr = mkLam all_tyvars dicts $
+ mkCoLetsAny core_binds $
+ mkTupleExpr locals
+ locals = [local | (_, _, local) <- exports]
+ local_tys = map idType locals
+ in
+ newSysLocalDs (coreExprType tup_expr) `thenDs` \ tup_id ->
+ let
+ dict_args = map VarArg dicts
+
+ mk_bind (tyvars, global, local) n -- locals !! n == local
+ = -- Need to make fresh locals to bind in the selector, because
+ -- some of the tyvars will be bound to voidTy
+ newSysLocalsDs (map (instantiateTy env) local_tys) `thenDs` \ locals' ->
+ returnDs (global, mkLam tyvars dicts $
+ mkTupleSelector locals' (locals' !! n) $
+ mkValApp (mkTyApp (Var tup_id) ty_args) dict_args)
+ where
+ 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
+ in
+ zipWithDs mk_bind exports [0..] `thenDs` \ export_binds ->
+ returnDs ((tup_id, tup_expr) : export_binds)
\end{code}
-%==============================================
-\subsubsection{The general base case}
-%==============================================
-
-Now the general case of a pattern binding. The monomorphism restriction
-should ensure that if there is a non-simple pattern binding in the
-group, then there is no overloading involved, so the dictionaries should
-be empty. (Simple pattern bindings were handled above.)
-First, the paranoia check.
+If profiling and dealing with a dict binding, wrap the dict in "_scc_ DICT <dict>":
\begin{code}
-dsMonoBinds is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn)
- = panic "Non-empty dict list in for pattern binding"
-\end{code}
-
-We handle three cases for the binding
- pat = rhs
-
-\begin{description}
-\item[pat has no binders.]
-Then all this is dead code and we return an empty binding.
-
-\item[pat has exactly one binder, v.]
-Then we can transform to:
-\begin{verbatim}
- v' = /\ tyvars -> case rhs of { pat -> v }
-\end{verbatim}
-where \tr{v'} is gotten by looking up \tr{v} in the \tr{binder_subst}.
-
-\item[pat has more than one binder.]
-Then we transform to:
-\begin{verbatim}
- t = /\ tyvars -> case rhs of { pat -> (v1, ..., vn) }
+addDictScc var rhs
+ | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs)
+ -- the latter is so that -unprof-auto-scc-all adds dict sccs
+ || not (isDictTy (idType var))
+ = returnDs rhs -- That's easy: do nothing
- vi = /\ tyvars -> case (t tyvars) of { (v1, ..., vn) -> vi }
-\end{verbatim}
-\end{description}
+ | opt_CompilingGhcInternals
+ = returnDs (SCC prel_dicts_cc rhs)
-\begin{code}
-dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
- = putSrcLocDs locn $
+ | otherwise
+ = getModuleAndGroupDs `thenDs` \ (mod, grp) ->
- dsGuarded grhss_and_binds `thenDs` \ body_expr ->
+ -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
+ returnDs (SCC (mkAllDictsCC mod grp False) rhs)
-{- KILLED by Sansom. 95/05
- -- make *sure* there are no primitive types in the pattern
- if any_con_w_prim_arg pat then
- error ( "ERROR: Pattern-bindings cannot involve unboxed/primitive types!\n\t"
- ++ (ppShow 80 (ppr PprForUser pat)) ++ "\n"
- ++ "(We apologise for not reporting this more `cleanly')\n" )
-
- -- Check whether the pattern already is a simple tuple; if so,
- -- we can just use the rhs directly
- else
--}
--- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $
-
- mkSelectorBinds tyvars pat
- [(binder, binder_subst binder) | binder <- pat_binders]
- body_expr
- where
- pat_binders = collectTypedPatBinders pat
- -- NB For a simple tuple pattern, these binders
- -- will appear in the right order!
+prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
\end{code}
-
-Wild-card patterns could be made acceptable here, but it involves some
-extra work to benefit only rather unusual constructs like
-\begin{verbatim}
- let (_,a,b) = ... in ...
-\end{verbatim}
-Better to extend the whole thing for any irrefutable constructor, at least.
import PrelVals ( packStringForCId )
import PrimOp ( PrimOp(..) )
import Type ( isPrimType, maybeAppDataTyConExpandingDicts, maybeAppTyCon,
- eqTy, maybeBoxedPrimType )
+ eqTy, maybeBoxedPrimType, SYN_IE(Type) )
import TysPrim ( byteArrayPrimTy, realWorldTy, realWorldStatePrimTy,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
import TysWiredIn ( getStatePairingConInfo,
stringTy
)
import Util ( pprPanic, pprError, panic )
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable ( Outputable(..) )
+#endif
+
\end{code}
Desugaring of @ccall@s consists of adding some state manipulation,
can't_see_datacons_error thing ty
= pprError "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ "
- (ppBesides [ppStr thing, ppStr "; type: ", ppr PprForUser ty])
+ (hcat [text thing, text "; type: ", ppr PprForUser ty])
\end{code}
--- /dev/null
+_interface_ DsExpr 1
+_exports_
+DsExpr dsExpr;
+_declarations_
+1 dsExpr _:_ TcHsSyn.TypecheckedHsExpr -> DsMonad.DsM CoreSyn.CoreExpr ;;
import DsCCall ( dsCCall )
import DsHsSyn ( outPatType )
import DsListComp ( dsListComp )
-import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom,
+import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom, mkTupleExpr,
mkErrorAppDs, showForErr, EquationInfo,
MatchResult, SYN_IE(DsCoreArg)
)
import FieldLabel ( fieldLabelType, FieldLabel )
import Id ( idType, nullIdEnv, addOneToIdEnv,
dataConArgTys, dataConFieldLabels,
- recordSelectorFieldLabel
+ recordSelectorFieldLabel, SYN_IE(Id)
)
import Literal ( mkMachInt, Literal(..) )
import Name ( Name{--O only-} )
import PprStyle ( PprStyle(..) )
import PprType ( GenType )
import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, voidId )
-import Pretty ( ppShow, ppBesides, ppPStr, ppStr )
+import Pretty ( Doc, hcat, ptext, text )
import TyCon ( isDataTyCon, isNewTyCon )
import Type ( splitSigmaTy, splitFunTy, typePrimRep,
getAppDataTyConExpandingDicts, maybeAppTyCon, getAppTyCon, applyTy,
- maybeBoxedPrimType, splitAppTy
+ maybeBoxedPrimType, splitAppTy, SYN_IE(Type)
)
import TysPrim ( voidTy )
import TysWiredIn ( mkTupleTy, tupleCon, nilDataCon, consDataCon, listTyCon,
import Maybes ( maybeToBool )
import Util ( zipEqual, pprError, panic, assertPanic )
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable
+#endif
+
mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility...
\end{code}
-> (boxing_data_con, typePrimRep prim_ty)
Nothing
-> pprError "ERROR: ``literal-literal'' not a single-constructor type: "
- (ppBesides [ppPStr s, ppStr "; type: ", ppr PprDebug ty])
+ (hcat [ptext s, text "; type: ", ppr PprDebug ty])
dsExpr (HsLitOut (HsInt i) ty)
= returnDs (Lit (NoRepInteger i ty))
returnDs ( mkCoLetsAny core_binds core_expr )
dsExpr (HsDoOut do_or_lc stmts return_id then_id zero_id result_ty src_loc)
- | maybeToBool maybe_list_comp -- Special case for list comprehensions
- = putSrcLocDs src_loc $
+ | maybeToBool maybe_list_comp
+ = -- Special case for list comprehensions
+ putSrcLocDs src_loc $
dsListComp stmts elt_ty
| otherwise
= putSrcLocDs src_loc $
dsDo do_or_lc stmts return_id then_id zero_id result_ty
where
- maybe_list_comp = case maybeAppTyCon result_ty of
- Just (tycon, [elt_ty]) | tycon == listTyCon
- -> Just elt_ty
- other -> Nothing
+ maybe_list_comp
+ = case (do_or_lc, maybeAppTyCon result_ty) of
+ (ListComp, Just (tycon, [elt_ty]))
+ | tycon == listTyCon
+ -> Just elt_ty
+ other -> Nothing
+ -- We need the ListComp form to use deListComp (rather than the "do" form)
+ -- because the "return" in a do block is a call to "PrelBase.return", and
+ -- not a ReturnStmt. Only the ListComp form has ReturnStmts
+
Just elt_ty = maybe_list_comp
dsExpr (HsIf guard_expr then_expr else_expr src_loc)
dictionaries.
\begin{code}
-dsExpr (RecordUpdOut record_expr dicts rbinds)
+dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds)
= dsExpr record_expr `thenDs` \ record_expr' ->
-- Desugar the rbinds, and generate let-bindings if
-- necessary so that we don't lose sharing
dsRbinds rbinds $ \ rbinds' ->
let
- record_ty = coreExprType record_expr'
- (tycon, inst_tys, cons) = --trace "DsExpr.getAppDataTyConExpandingDicts" $
- getAppDataTyConExpandingDicts record_ty
- cons_to_upd = filter has_all_fields cons
+ record_in_ty = coreExprType record_expr'
+ (tycon, in_inst_tys, cons) = getAppDataTyConExpandingDicts record_in_ty
+ (_, out_inst_tys, _) = getAppDataTyConExpandingDicts record_out_ty
+ cons_to_upd = filter has_all_fields cons
-- initial_args are passed to every constructor
- initial_args = map TyArg inst_tys ++ map VarArg dicts
+ initial_args = map TyArg out_inst_tys ++ map VarArg dicts
mk_val_arg (field, arg_id)
= case [arg | (f, arg) <- rbinds',
[] -> VarArg arg_id
mk_alt con
- = newSysLocalsDs (dataConArgTys con inst_tys) `thenDs` \ arg_ids ->
+ = newSysLocalsDs (dataConArgTys con in_inst_tys) `thenDs` \ arg_ids ->
let
val_args = map mk_val_arg (zipEqual "dsExpr:RecordUpd" (dataConFieldLabels con) arg_ids)
in
| length cons_to_upd == length cons
= returnDs NoDefault
| otherwise
- = newSysLocalDs record_ty `thenDs` \ deflt_id ->
- mkErrorAppDs rEC_UPD_ERROR_ID record_ty "" `thenDs` \ err ->
+ = newSysLocalDs record_in_ty `thenDs` \ deflt_id ->
+ mkErrorAppDs rEC_UPD_ERROR_ID record_out_ty "" `thenDs` \ err ->
returnDs (BindDefault deflt_id err)
in
mapDs mk_alt cons_to_upd `thenDs` \ alts ->
\end{verbatim}
\begin{code}
dsExpr (SingleDict dict) -- just a local
- = lookupEnvWithDefaultDs dict (Var dict)
-
-dsExpr (Dictionary dicts methods)
- = -- hey, these things may have been substituted away...
- zipWithDs lookupEnvWithDefaultDs
- dicts_and_methods dicts_and_methods_exprs
- `thenDs` \ core_d_and_ms ->
-
- (case num_of_d_and_ms of
- 0 -> returnDs (Var voidId)
+ = lookupEnvDs dict `thenDs` \ dict' ->
+ returnDs (Var dict')
- 1 -> returnDs (head core_d_and_ms) -- just a single Id
+dsExpr (Dictionary [] []) -- Empty dictionary represented by void,
+ = returnDs (Var voidId) -- (not, as would happen if we took the next case, by ())
- _ -> -- tuple 'em up
- mkConDs (tupleCon num_of_d_and_ms)
- (map (TyArg . coreExprType) core_d_and_ms ++ map VarArg core_d_and_ms)
- )
- where
- dicts_and_methods = dicts ++ methods
- dicts_and_methods_exprs = map Var dicts_and_methods
- num_of_d_and_ms = length dicts_and_methods
+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 ->
dsApp op (VarArg core_e1 : VarArg core_e2 : args)
dsApp (DictApp expr dicts) args
- = -- now, those dicts may have been substituted away...
- zipWithDs lookupEnvWithDefaultDs dicts (map Var dicts)
- `thenDs` \ core_dicts ->
- dsApp expr (map VarArg core_dicts ++ args)
+ = mapDs lookupEnvDs dicts `thenDs` \ core_dicts ->
+ dsApp expr (map (VarArg . Var) core_dicts ++ args)
dsApp (TyApp expr tys) args
= dsApp expr (map TyArg tys ++ args)
mkAppDs core_expr args
dsId v
- = lookupEnvDs v `thenDs` \ maybe_expr ->
- returnDs (case maybe_expr of { Nothing -> Var v; Just expr -> expr })
+ = lookupEnvDs v `thenDs` \ v' ->
+ returnDs (Var v')
\end{code}
\begin{code}
IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop
import HsSyn ( GRHSsAndBinds(..), GRHS(..),
- HsExpr, HsBinds
+ 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) )
-import CoreSyn ( SYN_IE(CoreBinding), SYN_IE(CoreExpr), mkCoLetsAny )
+ SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedStmt)
+ )
+import CoreSyn ( SYN_IE(CoreBinding), GenCoreBinding(..), SYN_IE(CoreExpr), mkCoLetsAny )
import DsMonad
import DsUtils
-import CoreUtils ( mkCoreIfThenElse )
+#if __GLASGOW_HASKELL__ < 200
+import Id ( GenId )
+#endif
+import CoreUtils ( coreExprType, mkCoreIfThenElse )
import PrelVals ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
import PprStyle ( PprStyle(..) )
-import Pretty ( ppShow )
import SrcLoc ( SrcLoc{-instance-} )
+import Type ( SYN_IE(Type) )
+import Unique ( Unique, otherwiseIdKey )
+import UniqFM ( Uniquable(..) )
import Util ( panic )
\end{code}
dsGRHS ty kind pats (GRHS guard expr locn)
= putSrcLocDs locn $
- dsExpr guard `thenDs` \ core_guard ->
- dsExpr expr `thenDs` \ core_expr ->
+ dsExpr expr `thenDs` \ core_expr ->
let
- expr_fn = \ fail -> mkCoreIfThenElse core_guard core_expr fail
+ expr_fn = \ ignore -> core_expr
in
- returnDs (MatchResult CanFail ty expr_fn (DsMatchContext kind pats locn))
+ matchGuard guard (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
\end{code}
+
+%************************************************************************
+%* *
+%* matchGuard : make a MatchResult from a guarded RHS *
+%* *
+%************************************************************************
+
+\begin{code}
+matchGuard :: [TypecheckedStmt] -- Guard
+ -> MatchResult -- What to do if the guard succeeds
+ -> DsM MatchResult
+
+matchGuard [] body_result = returnDs body_result
+
+ -- Turn an "otherwise" guard is a no-op
+matchGuard (GuardStmt (HsVar v) _ : stmts) body_result
+ | uniqueOf v == otherwiseIdKey
+ = matchGuard stmts body_result
+
+matchGuard (GuardStmt expr _ : stmts) body_result
+ = matchGuard stmts body_result `thenDs` \ (MatchResult _ ty body_fn cxt) ->
+ dsExpr expr `thenDs` \ core_expr ->
+ let
+ expr_fn = \ fail -> mkCoreIfThenElse core_expr (body_fn fail) fail
+ in
+ returnDs (MatchResult CanFail ty expr_fn cxt)
+
+matchGuard (LetStmt binds : stmts) body_result
+ = matchGuard stmts body_result `thenDs` \ match_result ->
+ dsBinds binds `thenDs` \ core_binds ->
+ returnDs (mkCoLetsMatchResult core_binds match_result)
+
+matchGuard (BindStmt pat rhs _ : stmts) body_result
+ = matchGuard stmts body_result `thenDs` \ match_result ->
+ dsExpr rhs `thenDs` \ core_rhs ->
+ newSysLocalDs (coreExprType core_rhs) `thenDs` \ scrut_var ->
+ match [scrut_var] [EqnInfo [pat] match_result] [] `thenDs` \ match_result' ->
+ returnDs (mkCoLetsMatchResult [NonRec scrut_var core_rhs] match_result')
+\end{code}
IMP_Ubiq()
-import HsSyn ( OutPat(..), HsBinds(..), Bind(..), MonoBinds(..),
+import HsSyn ( OutPat(..), HsBinds(..), MonoBinds(..),
Sig, HsExpr, GRHSsAndBinds, Match, HsLit )
-import TcHsSyn ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedBind),
+import TcHsSyn ( SYN_IE(TypecheckedPat),
SYN_IE(TypecheckedMonoBinds) )
-import Id ( idType )
+import Id ( idType, SYN_IE(Id) )
+import Type ( SYN_IE(Type) )
import TysWiredIn ( mkListTy, mkTupleTy, unitTy )
import Util ( panic )
\end{code}
collectTypedBinders and collectedTypedPatBinders are the exportees.
\begin{code}
-collectTypedBinders :: TypecheckedBind -> [Id]
-collectTypedBinders EmptyBind = []
-collectTypedBinders (NonRecBind bs) = collectTypedMonoBinders bs
-collectTypedBinders (RecBind bs) = collectTypedMonoBinders bs
-
collectTypedMonoBinders :: TypecheckedMonoBinds -> [Id]
collectTypedMonoBinders EmptyMonoBinds = []
collectTypedMonoBinders (PatMonoBind pat _ _) = collectTypedPatBinders pat
collectTypedMonoBinders (CoreMonoBind v _) = [v]
collectTypedMonoBinders (AndMonoBinds bs1 bs2)
= collectTypedMonoBinders bs1 ++ collectTypedMonoBinders bs2
+collectTypedMonoBinders (AbsBinds _ _ exports _)
+ = [global | (_, global, local) <- exports]
collectTypedPatBinders :: TypecheckedPat -> [Id]
collectTypedPatBinders (VarPat var) = [var]
import CmdLineOpts ( opt_FoldrBuildOn )
import CoreUtils ( coreExprType, mkCoreIfThenElse )
+import Id ( SYN_IE(Id) )
import PrelVals ( mkBuild, foldrId )
-import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy )
+import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy, SYN_IE(Type) )
import TysPrim ( alphaTy )
import TysWiredIn ( nilDataCon, consDataCon, listTyCon )
import TyVar ( alphaTyVar )
--- /dev/null
+module DsLoop
+ (
+ module Match,
+ module DsExpr,
+ module DsBinds
+ ) where
+
+import Match
+import DsExpr
+import DsBinds
+
+
newFailLocalDs,
getSrcLocDs, putSrcLocDs,
getModuleAndGroupDs,
- extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs,
+ extendEnvDs, lookupEnvDs,
SYN_IE(DsIdEnv),
- lookupId,
dsShadowWarn, dsIncompleteWarn,
- DsWarnings(..),
+ SYN_IE(DsWarnings),
DsMatchContext(..), DsMatchKind(..), pprDsWarnings,
DsWarnFlavour -- Nuke with 1.4
IMP_Ubiq()
-import Bag ( emptyBag, snocBag, bagToList )
+import Bag ( emptyBag, snocBag, bagToList, Bag )
import CmdLineOpts ( opt_SccGroup )
import CoreSyn ( SYN_IE(CoreExpr) )
import CoreUtils ( substCoreExpr )
import HsSyn ( OutPat )
import Id ( mkSysLocal, mkIdWithNewUniq,
- lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv)
+ lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv),
+ SYN_IE(Id)
)
import PprType ( GenType, GenTyVar )
import PprStyle ( PprStyle(..) )
+import Outputable ( pprQuote, Outputable(..) )
import Pretty
import SrcLoc ( noSrcLoc, SrcLoc )
import TcHsSyn ( SYN_IE(TypecheckedPat) )
-import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} )
+import Type ( SYN_IE(Type) )
+import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
import Unique ( Unique{-instances-} )
import UniqSupply ( splitUniqSupply, getUnique, getUniques,
- mapUs, thenUs, returnUs, SYN_IE(UniqSM) )
+ mapUs, thenUs, returnUs, SYN_IE(UniqSM),
+ UniqSupply )
import Util ( assoc, mapAccumL, zipWithEqual, panic )
infixr 9 `thenDs`
zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
-zipWithDs f [] [] = returnDs []
+zipWithDs f [] ys = returnDs []
zipWithDs f (x:xs) (y:ys)
= f x y `thenDs` \ r ->
zipWithDs f xs ys `thenDs` \ rs ->
returnDs (r:rs)
--- Note: crashes if lists not equal length (like zipWithEqual)
\end{code}
And all this mysterious stuff is so we can occasionally reach out and
grab one or more names. @newLocalDs@ isn't exported---exported
functions are defined with it. The difference in name-strings makes
it easier to read debugging output.
+
\begin{code}
newLocalDs :: FAST_STRING -> Type -> DsM Id
newLocalDs nm ty us loc mod_and_grp env warns
\end{code}
\begin{code}
-type DsIdEnv = IdEnv CoreExpr
+type DsIdEnv = IdEnv Id
-extendEnvDs :: [(Id, CoreExpr)] -> DsM a -> DsM a
+extendEnvDs :: [(Id, Id)] -> DsM a -> DsM a
extendEnvDs pairs then_do us loc mod_and_grp old_env warns
- = case splitUniqSupply us of { (s1, s2) ->
- let
- revised_pairs = subst_all pairs s1
- in
- then_do s2 loc mod_and_grp (growIdEnvList old_env revised_pairs) warns
- }
- where
- subst_all pairs = mapUs subst pairs
-
- subst (v, expr)
- = substCoreExpr old_env nullTyVarEnv expr `thenUs` \ new_expr ->
- returnUs (v, new_expr)
+ = then_do us loc mod_and_grp (growIdEnvList old_env pairs) warns
-lookupEnvDs :: Id -> DsM (Maybe CoreExpr)
+lookupEnvDs :: Id -> DsM Id
lookupEnvDs id us loc mod_and_grp env warns
- = (lookupIdEnv env id, warns)
- -- Note: we don't assert anything about the Id
- -- being looked up. There's not really anything
- -- much to say about it. (WDP 94/06)
-
-lookupEnvWithDefaultDs :: Id -> CoreExpr -> DsM CoreExpr
-lookupEnvWithDefaultDs id deflt us loc mod_and_grp env warns
= (case (lookupIdEnv env id) of
- Nothing -> deflt
+ Nothing -> id
Just xx -> xx,
warns)
-
-lookupId :: [(Id, a)] -> Id -> a
-lookupId env id
- = assoc "lookupId" env id
\end{code}
%************************************************************************
| DoBindMatch
deriving ()
-pprDsWarnings :: PprStyle -> DsWarnings -> Pretty
+pprDsWarnings :: PprStyle -> DsWarnings -> Doc
pprDsWarnings sty warns
- = ppAboves (map pp_warn (bagToList warns))
+ = vcat (map pp_warn (bagToList warns))
where
- pp_warn (flavour, NoMatchContext) = ppSep [ppPStr SLIT("Warning: Some match is"),
+ pp_warn (flavour, NoMatchContext) = sep [ptext SLIT("Warning: Some match is"),
case flavour of
- Shadowed -> ppPStr SLIT("shadowed")
- Incomplete -> ppPStr SLIT("possibly incomplete")]
+ Shadowed -> ptext SLIT("shadowed")
+ Incomplete -> ptext SLIT("possibly incomplete")]
pp_warn (flavour, DsMatchContext kind pats loc)
- = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")])
- 4 (ppHang msg
+ = hang (hcat [ppr PprForUser loc, ptext SLIT(": ")])
+ 4 (hang msg
4 (pp_match kind pats))
where
msg = case flavour of
- Shadowed -> ppPStr SLIT("Warning: Pattern match(es) completely overlapped")
- Incomplete -> ppPStr SLIT("Warning: Possibly incomplete patterns")
+ Shadowed -> ptext SLIT("Warning: Pattern match(es) completely overlapped")
+ Incomplete -> ptext SLIT("Warning: Possibly incomplete patterns")
pp_match (FunMatch fun) pats
- = ppCat [ppPStr SLIT("in the definition of function"), ppQuote (ppr sty fun)]
+ = hsep [ptext SLIT("in the definition of function"), ppr sty fun]
pp_match CaseMatch pats
- = ppHang (ppPStr SLIT("in a group of case alternatives beginning:"))
- 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
+ = hang (ptext SLIT("in a group of case alternatives beginning:"))
+ 4 (ppr_pats pats)
pp_match PatBindMatch pats
- = ppHang (ppPStr SLIT("in a pattern binding:"))
- 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
+ = hang (ptext SLIT("in a pattern binding:"))
+ 4 (ppr_pats pats)
pp_match LambdaMatch pats
- = ppHang (ppPStr SLIT("in a lambda abstraction:"))
- 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
+ = hang (ptext SLIT("in a lambda abstraction:"))
+ 4 (ppr_pats pats)
pp_match DoBindMatch pats
- = ppHang (ppPStr SLIT("in a `do' pattern binding:"))
- 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
+ = hang (ptext SLIT("in a `do' pattern binding:"))
+ 4 (ppr_pats pats)
- pp_arrow_dotdotdot = ppPStr SLIT("-> ...")
+ ppr_pats pats = pprQuote sty $ \ sty ->
+ sep [sep (map (ppr sty) pats), ptext SLIT("-> ...")]
\end{code}
mkSelectorBinds,
mkTupleBind,
mkTupleExpr,
+ mkTupleSelector,
selectMatchVars,
showForErr
) where
import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), Fixity,
Match, HsBinds, Stmt, DoOrListComp, HsType, ArithSeqInfo )
import TcHsSyn ( SYN_IE(TypecheckedPat) )
-import DsHsSyn ( outPatType )
+import DsHsSyn ( outPatType, collectTypedPatBinders )
import CoreSyn
import DsMonad
import CoreUtils ( coreExprType, mkCoreIfThenElse )
import PprStyle ( PprStyle(..) )
import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId )
-import Pretty ( ppShow, ppBesides, ppStr )
+import Pretty ( Doc, hcat, text )
import Id ( idType, dataConArgTys,
-- pprId{-ToDo:rm-},
SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(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 -}
+ GenType {- instances -}, SYN_IE(Type)
)
-import TyVar ( GenTyVar {- instances -} )
+import TyVar ( GenTyVar {- instances -}, SYN_IE(TyVar) )
import TysPrim ( voidTy )
import TysWiredIn ( tupleTyCon, unitDataCon, tupleCon )
import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) )
import Unique ( Unique )
import Usage ( SYN_IE(UVar) )
import SrcLoc ( SrcLoc {- instance Outputable -} )
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable
+#endif
+
+\end{code}
+
+
+%************************************************************************
+%* *
+%* Selecting match variables
+%* *
+%************************************************************************
+
+We're about to match against some patterns. We want to make some
+@Ids@ to use as match variables. If a pattern has an @Id@ readily at
+hand, which should indeed be bound to the pattern as a whole, then use it;
+otherwise, make one up.
+
+\begin{code}
+selectMatchVars :: [TypecheckedPat] -> DsM [Id]
+selectMatchVars pats
+ = mapDs var_from_pat_maybe pats
+ where
+ var_from_pat_maybe (VarPat var) = returnDs var
+ var_from_pat_maybe (AsPat var pat) = returnDs var
+ var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat
+ var_from_pat_maybe other_pat
+ = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
\end{code}
+
%************************************************************************
%* *
%* type synonym EquationInfo and access functions for its pieces *
\begin{code}
showForErr :: Outputable a => a -> String -- Boring but useful
-showForErr thing = ppShow 80 (ppr PprForUser thing)
+showForErr thing = show (ppr PprQuote 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 = ppShow 80 (ppBesides [ppr PprForUser src_loc, ppStr "|", ppStr msg])
+ full_msg = show (hcat [ppr PprForUser src_loc, text "|", text msg])
msg_lit = NoRepStr (_PK_ full_msg)
in
returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])
expressions.
\begin{code}
-mkSelectorBinds :: [TyVar] -- Variables wrt which the pattern is polymorphic
- -> TypecheckedPat -- The pattern
- -> [(Id,Id)] -- Monomorphic and polymorphic binders for
- -- the pattern
- -> CoreExpr -- Expression to which the pattern is bound
+mkSelectorBinds :: TypecheckedPat -- The pattern
+ -> CoreExpr -- Expression to which the pattern is bound
-> DsM [(Id,CoreExpr)]
-mkSelectorBinds tyvars pat locals_and_globals val_expr
- = if is_simple_tuple_pat pat then
- mkTupleBind tyvars [] locals_and_globals val_expr
- else
- mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty pat_string `thenDs` \ error_msg ->
- matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
- mkTupleBind tyvars [] locals_and_globals tuple_expr
+mkSelectorBinds (VarPat v) val_expr
+ = returnDs [(v, val_expr)]
+
+mkSelectorBinds pat val_expr
+ | is_simple_tuple_pat pat
+ = mkTupleBind binders val_expr
+
+ | otherwise
+ = mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty pat_string `thenDs` \ error_msg ->
+ matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
+ mkTupleBind binders tuple_expr
+
where
- locals = [local | (local, _) <- locals_and_globals]
- local_tuple = mkTupleExpr locals
+ binders = collectTypedPatBinders pat
+ local_tuple = mkTupleExpr binders
res_ty = coreExprType local_tuple
is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
is_var_pat (VarPat v) = True
is_var_pat other = False -- Even wild-card patterns aren't acceptable
- pat_string = ppShow 80 (ppr PprForUser pat)
+ pat_string = show (ppr PprForUser pat)
\end{code}
-We're about to match against some patterns. We want to make some
-@Ids@ to use as match variables. If a pattern has an @Id@ readily at
-hand, which should indeed be bound to the pattern as a whole, then use it;
-otherwise, make one up.
-\begin{code}
-selectMatchVars :: [TypecheckedPat] -> DsM [Id]
-selectMatchVars pats
- = mapDs var_from_pat_maybe pats
- where
- var_from_pat_maybe (VarPat var) = returnDs var
- var_from_pat_maybe (AsPat var pat) = returnDs var
- var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat
- var_from_pat_maybe other_pat
- = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
-\end{code}
\begin{code}
-mkTupleBind :: [TyVar] -- Abstract wrt these...
- -> [DictVar] -- ... and these
-
- -> [(Id, Id)] -- Local, global pairs, equal in number
- -- to the size of the tuple. The types
- -- of the globals is the generalisation of
- -- the corresp local, wrt the tyvars and dicts
+mkTupleBind :: [Id] -- Names of tuple components
+ -> CoreExpr -- Expr whose value is a tuple of correct type
+ -> DsM [(Id, CoreExpr)] -- Bindings for the globals
- -> CoreExpr -- Expr whose value is a tuple; the expression
- -- may mention the tyvars and dicts
-
- -> DsM [(Id, CoreExpr)] -- Bindings for the globals
-\end{code}
-The general call is
-\begin{verbatim}
- mkTupleBind tyvars dicts [(l1,g1), ..., (ln,gn)] tup_expr
-\end{verbatim}
-If $n=1$, the result is:
-\begin{verbatim}
- g1 = /\ tyvars -> \ dicts -> rhs
-\end{verbatim}
-Otherwise, the result is:
-\begin{verbatim}
- tup = /\ tyvars -> \ dicts -> tup_expr
- g1 = /\ tyvars -> \ dicts -> case (tup tyvars dicts) of
- (l1, ..., ln) -> l1
- ...etc...
-\end{verbatim}
+mkTupleBind [local] tuple_expr
+ = returnDs [(local, tuple_expr)]
-\begin{code}
-mkTupleBind tyvars dicts [(local,global)] tuple_expr
- = returnDs [(global, mkLam tyvars dicts tuple_expr)]
+mkTupleBind locals tuple_expr
+ = newSysLocalDs (coreExprType tuple_expr) `thenDs` \ tuple_var ->
+ let
+ mk_bind local = (local, mkTupleSelector locals local (Var tuple_var))
+ in
+ returnDs ( (tuple_var, tuple_expr) :
+ map mk_bind locals )
\end{code}
-The general case:
-
-\begin{code}
-mkTupleBind tyvars dicts local_global_prs tuple_expr
- = --pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $
-
- newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
-
- zipWithDs (mk_selector (Var tuple_var))
- local_global_prs
- [(0::Int) .. (length local_global_prs - 1)]
- `thenDs` \ tup_selectors ->
- returnDs (
- (tuple_var, mkLam tyvars dicts tuple_expr)
- : tup_selectors
- )
- where
- locals, globals :: [Id]
- locals = [local | (local,global) <- local_global_prs]
- globals = [global | (local,global) <- local_global_prs]
-
- no_of_binders = length local_global_prs
- tyvar_tys = mkTyVarTys tyvars
-
- tuple_var_ty :: Type
- tuple_var_ty
- = mkForAllTys tyvars $
- mkRhoTy theta $
- applyTyCon (tupleTyCon no_of_binders)
- (map idType locals)
- where
- theta = mkTheta (map idType dicts)
-
- mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr)
-
- mk_selector tuple_var_expr (local, global) which_local
- = mapDs duplicateLocalDs locals{-the whole bunch-} `thenDs` \ binders ->
- let
- selected = binders !! which_local
- in
- returnDs (
- global,
- mkLam tyvars dicts (
- mkTupleSelector
- (mkValApp (mkTyApp tuple_var_expr tyvar_tys)
- (map VarArg dicts))
- binders
- selected)
- )
-\end{code}
@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
has only one element, it is the identity function.
just the identity.
\begin{code}
-mkTupleSelector :: CoreExpr -- Scrutinee
- -> [Id] -- The tuple args
+mkTupleSelector :: [Id] -- The tuple args
-> Id -- The selected one
+ -> CoreExpr -- Scrutinee
-> CoreExpr
-mkTupleSelector expr [] the_var = panic "mkTupleSelector"
+mkTupleSelector [] the_var scrut = panic "mkTupleSelector"
-mkTupleSelector expr [var] should_be_the_same_var
+mkTupleSelector [var] should_be_the_same_var scrut
= ASSERT(var == should_be_the_same_var)
- expr
+ scrut
-mkTupleSelector expr vars the_var
- = Case expr (AlgAlts [(tupleCon arity, vars, Var the_var)]
+mkTupleSelector vars the_var scrut
+ = Case scrut (AlgAlts [(tupleCon arity, vars, Var the_var)]
NoDefault)
where
arity = length vars
--- /dev/null
+_interface_ Match 1
+_exports_
+Match match matchSimply;
+_declarations_
+1 match _:_ [Id.Id] -> [DsUtils.EquationInfo] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;;
+1 matchSimply _:_ CoreSyn.CoreExpr -> TcHsSyn.TypecheckedPat -> Type.Type -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;;
IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons
-- and to break dsExpr/dsBinds-ish loop
-import HsSyn hiding ( collectBinders{-also from CoreSyn-} )
+import CmdLineOpts ( opt_WarnIncompletePatterns )
+import HsSyn
import TcHsSyn ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedMatch),
SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) )
import DsHsSyn ( outPatType, collectTypedPatBinders )
import FieldLabel ( FieldLabel {- Eq instance -} )
import Id ( idType, dataConFieldLabels,
dataConArgTys, recordSelectorFieldLabel,
- GenId{-instance-}
+ GenId{-instance-}, SYN_IE(Id)
)
import Name ( Name {--O only-} )
import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance-}, GenTyVar{-ditto-} )
+import PprType ( GenType{-instance-}, GenTyVar{-ditto-} )
+import Pretty ( Doc )
import PrelVals ( pAT_ERROR_ID )
import Type ( isPrimType, eqTy, getAppDataTyConExpandingDicts,
- instantiateTauTy
+ instantiateTauTy, SYN_IE(Type)
)
-import TyVar ( GenTyVar{-instance Eq-} )
+import TyVar ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
addrPrimTy, wordPrimTy
)
)
import Unique ( Unique{-instance Eq-} )
import Util ( panic, pprPanic, assertPanic )
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable ( Outputable(..) )
+#endif
+
\end{code}
The function @match@ is basically the same as in the Wadler chapter,
-}
tidy1 v (LazyPat pat) match_result
- = mkSelectorBinds [] pat l_to_l (Var v) `thenDs` \ sel_binds ->
+ = mkSelectorBinds pat (Var v) `thenDs` \ sel_binds ->
returnDs (WildPat (idType v),
mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result)
- where
- l_to_l = binders `zip` binders -- Boring
- binders = collectTypedPatBinders pat
-- re-express <con-something> as (ConPat ...) [directly]
-- Check for incomplete pattern match
(case match_result of
- MatchResult CanFail result_ty match_fn cxt -> dsIncompleteWarn cxt
- other -> returnDs ()
+ MatchResult CanFail result_ty match_fn cxt
+ | opt_WarnIncompletePatterns
+ -> dsIncompleteWarn cxt
+ other -> returnDs ()
) `thenDs` \ _ ->
extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
pats = reverse pats_so_far -- They've accumulated in reverse order
\end{code}
+
import DsMonad
import DsUtils
-import Id ( isDataCon, GenId{-instances-} )
+import Id ( isDataCon, GenId{-instances-}, SYN_IE(Id) )
import Util ( panic, assertPanic )
\end{code}
SYN_IE(TypecheckedPat)
)
import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding), GenCoreExpr(..), GenCoreBinding(..) )
-import Id ( GenId {- instance Eq -} )
+import Id ( GenId {- instance Eq -}, SYN_IE(Id) )
import DsMonad
import DsUtils
import Literal ( mkMachInt, Literal(..) )
import Maybes ( catMaybes )
-import Type ( isPrimType )
+import Type ( isPrimType, SYN_IE(Type) )
import Util ( panic, assertPanic )
\end{code}
> loop ls (Var (Label e e1))
> =
> d2c e `thenUs` \core_e ->
->-- trace ("loop:\n" ++ ppShow 80 (ppr PprDebug core_e)) $
+>-- trace ("loop:\n" ++ show (ppr PprDebug core_e)) $
> mapUs (\(f,e',val_args,ty_args) ->
> renameExprs e' e `thenUs` \r ->
> if f `elem` ls' then
> d2c e' `thenUs` \core_e' ->
> trace ("In Forward Loop " ++
-> ppShow 80 (ppr PprDebug f) ++ "\n" ++
-> ppShow 80 (ppr PprDebug core_e')) $
+> show (ppr PprDebug f) ++ "\n" ++
+> show (ppr PprDebug core_e')) $
> if f `notElem` (freeVars (head back_loops)) then
> returnUs (ls', bs, bls, head back_loops)
> else
> if not (null back_loops) then
> d2c e' `thenUs` \core_e ->
> trace ("Floating back loop:\n"
-> ++ ppShow 80 (ppr PprDebug core_e))
+> ++ show (ppr PprDebug core_e))
> returnUs (ls', bs, back_loops ++ bls, e')
> else
> returnUs res
> t = foldl App (Var (DefArgVar new_id))
> (map mkVar fvs)
> in
-> trace ("adding " ++ show (length fvs) ++ " args to " ++ ppShow 80 (ppr PprDebug id)) $
+> trace ("adding " ++ show (length fvs) ++ " args to " ++ show (ppr PprDebug id)) $
> ((new_id, mkValLam fvs e), [(id,t)])
> where
> fvs = case e of
> defPanic :: String -> String -> DefExpr -> UniqSM a
> defPanic modl fun expr =
> d2c expr `thenUs` \expr ->
-> panic (modl ++ "(" ++ fun ++ "): " ++ ppShow 80 (ppr PprDebug expr))
+> panic (modl ++ "(" ++ fun ++ "): " ++ show (ppr PprDebug expr))
> {- panic
> ("DefExpr(tran): Deforestable id `"
-> ++ ppShow 80 (ppr PprDebug id)
+> ++ show (ppr PprDebug id)
> ++ "' doesn't have an unfolding.") -}
-----------------------------------------------------------------------------
> ++ showIds evs
> ++ "\n{ input:\n" ++ (concat (map showBind (zip vs' es'))) ++ "}\n"
> ++ "{ result:\n" ++ (concat (map showBind (zip evs ees))) ++ "}\n") res
-> where showBind (v,e) = ppShow 80 (ppr PprDebug v) ++ "=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n"
+> where showBind (v,e) = show (ppr PprDebug v) ++ "=\n" ++ show (ppr PprDebug e) ++ "\n"
> tranRecBind sw p t (id,e) =
> tran sw p t e [] `thenUs` \e ->
> returnUs (applyTypeEnvToId t id,e)
> showIds :: [Id] -> String
-> showIds ids = "(" ++ concat (map ((' ' :) . ppShow 80 . ppr PprDebug) ids)
+> showIds ids = "(" ++ concat (map ((' ' :) . show . ppr PprDebug) ids)
> ++ " )"
-----------------------------------------------------------------------------
> d2c (strip u) `thenUs` \u ->
> d2c (strip u') `thenUs` \u' ->
> trace ("failed consistency check:\n" ++
-> ppShow 80 (ppr PprDebug u) ++ "\n" ++
-> ppShow 80 (ppr PprDebug u'))
+> show (ppr PprDebug u) ++ "\n" ++
+> show (ppr PprDebug u'))
> (returnUs (InconsistentRenaming r))
> else
> trace "Renaming!" (returnUs (IsRenaming r))
>
> defProg sw p (NonRec v e : bs) =
> trace ("Processing: `" ++
-> ppShow 80 (ppr PprDebug v) ++ "'\n") (
+> show (ppr PprDebug v) ++ "'\n") (
> tran sw p nullTyVarEnv e [] `thenUs` \e ->
> mkLoops e `thenUs` \(extracted,e) ->
> let e' = mkDefLetrec extracted e in
>
> defRecBind sw p (v,e) =
> trace ("Processing: `" ++
-> ppShow 80 (ppr PprDebug v) ++ "'\n") (
+> show (ppr PprDebug v) ++ "'\n") (
> tran sw p nullTyVarEnv e [] `thenUs` \e' ->
> mkLoops e' `thenUs` \(bs,e') ->
> let e'' = mkDefLetrec bs e' in
>
> d2c e'' `thenUs` \core_e ->
-> let showBind (v,e) = ppShow 80 (ppr PprDebug v) ++
-> "=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n"
+> let showBind (v,e) = show (ppr PprDebug v) ++
+> "=\n" ++ show (ppr PprDebug e) ++ "\n"
> in
> trace ("Extracting from `" ++
-> ppShow 80 (ppr PprDebug v) ++ "'\n"
+> show (ppr PprDebug v) ++ "'\n"
> ++ "{ result:\n" ++ showBind (v,core_e) ++ "}\n") $
>
> if deforestable v
IMPORT_1_3(Ratio(Rational))
import Pretty
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable
+#endif
\end{code}
%************************************************************************
\begin{code}
instance Outputable HsLit where
- ppr sty (HsChar c) = ppStr (show c)
- ppr sty (HsCharPrim c) = ppBeside (ppStr (show c)) (ppChar '#')
- ppr sty (HsString s) = ppStr (show s)
- ppr sty (HsStringPrim s) = ppBeside (ppStr (show s)) (ppChar '#')
- ppr sty (HsInt i) = ppInteger i
- ppr sty (HsFrac f) = ppRational f
- ppr sty (HsFloatPrim f) = ppBeside (ppRational f) (ppChar '#')
- ppr sty (HsDoublePrim d) = ppBeside (ppRational d) (ppStr "##")
- ppr sty (HsIntPrim i) = ppBeside (ppInteger i) (ppChar '#')
- ppr sty (HsLitLit s) = ppBesides [ppStr "``", ppPStr s, ppStr "''"]
+ 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 "''"]
\end{code}
%************************************************************************
deriving(Eq)
instance Outputable Fixity where
- ppr sty (Fixity prec dir) = ppBesides [ppr sty dir, ppSP, ppInt prec]
+ ppr sty (Fixity prec dir) = hcat [ppr sty dir, space, int prec]
instance Outputable FixityDirection where
- ppr sty InfixL = ppPStr SLIT("infixl")
- ppr sty InfixR = ppPStr SLIT("infixr")
- ppr sty InfixN = ppPStr SLIT("infix")
+ ppr sty InfixL = ptext SLIT("infixl")
+ ppr sty InfixR = ptext SLIT("infixr")
+ ppr sty 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
--- /dev/null
+_interface_ HsBinds 1
+_exports_
+HsBinds HsBinds nullBinds;
+_instances_
+instance _forall_ [a b c d] => {Outputable.Outputable (HsBinds.HsBinds a b c d)} = $d1;
+_declarations_
+1 $d1 _:_ _forall_ [a b c d] => {Outputable.Outputable (HsBinds.HsBinds a b c d)} ;;
+1 data HsBinds a b c d ;
+1 nullBinds _:_ _forall_ [a b c d] => HsBinds.HsBinds a b c d -> PrelBase.Bool ;;
+
--others:
import Id ( SYN_IE(DictVar), SYN_IE(Id), GenId )
-import Name ( pprNonSym, getOccName, OccName )
+import Name ( getOccName, OccName, NamedThing(..) )
import Outputable ( interpp'SP, ifnotPprForUser,
Outputable(..){-instance * (,)-}
)
-import PprCore ( GenCoreExpr {- instance Outputable -} )
+import PprCore --( GenCoreExpr {- instance Outputable -} )
import PprType ( GenTyVar {- instance Outputable -} )
import Pretty
import Bag
| ThenBinds (HsBinds tyvar uvar id pat)
(HsBinds tyvar uvar id pat)
- | SingleBind (Bind tyvar uvar id pat)
+ | MonoBind (MonoBinds tyvar uvar id pat)
+ [Sig id] -- Empty on typechecker output
+ RecFlag
- | BindWith -- Bind with a type signature.
- -- These appear only on typechecker input
- -- (HsType [in Sigs] can't appear on output)
- (Bind tyvar uvar id pat)
- [Sig id]
+type RecFlag = Bool
+recursive = True
+nonRecursive = False
+\end{code}
+
+\begin{code}
+nullBinds :: HsBinds tyvar uvar id pat -> Bool
+
+nullBinds EmptyBinds = True
+nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
+nullBinds (MonoBind b _ _) = nullMonoBinds b
+\end{code}
+
+\begin{code}
+instance (Outputable pat, NamedThing id, Outputable id,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+ Outputable (HsBinds tyvar uvar id pat) where
+
+ ppr sty EmptyBinds = empty
+ ppr sty (ThenBinds binds1 binds2)
+ = ($$) (ppr sty binds1) (ppr sty binds2)
+ ppr 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
+ ]
+ where
+ rec_str | is_rec = SLIT("{- rec -}")
+ | otherwise = SLIT("{- nonrec -}")
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Bindings: @MonoBinds@}
+%* *
+%************************************************************************
+
+Global bindings (where clauses)
+
+\begin{code}
+data MonoBinds tyvar uvar id pat
+ = EmptyMonoBinds
+
+ | AndMonoBinds (MonoBinds tyvar uvar id pat)
+ (MonoBinds tyvar uvar id pat)
+
+ | PatMonoBind pat
+ (GRHSsAndBinds tyvar uvar id pat)
+ SrcLoc
+
+ | FunMonoBind id
+ Bool -- True => infix declaration
+ [Match tyvar uvar id pat] -- must have at least one Match
+ SrcLoc
+
+ | VarMonoBind id -- TRANSLATION
+ (HsExpr tyvar uvar id pat)
+
+ | CoreMonoBind id -- TRANSLATION
+ CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
| AbsBinds -- Binds abstraction; TRANSLATION
- [tyvar]
- [id] -- Dicts
- [(id, id)] -- (momonmorphic, polymorphic) pairs
- [(id, HsExpr tyvar uvar id pat)] -- local dictionaries
- (Bind tyvar uvar id pat) -- "the business end"
+ [tyvar] -- Type variables
+ [id] -- Dicts
+ [([tyvar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
+ (MonoBinds tyvar uvar id pat) -- The "business end"
-- Creates bindings for *new* (polymorphic, overloaded) locals
-- in terms of *old* (monomorphic, non-overloaded) ones.
What AbsBinds means
~~~~~~~~~~~~~~~~~~~
- AbsBinds [a,b]
+ AbsBinds tvs
[d1,d2]
- [(fm,fp), (gm,gp)]
- [d3 = d1,
- d4 = df d2]
+ [(tvs1, f1p, f1m),
+ (tvs2, f2p, f2m)]
BIND
means
- fp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
+ f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
in fm
gp = ...same again, with gm instead of fm
in (fm,gm)
\begin{code}
-nullBinds :: HsBinds tyvar uvar id pat -> Bool
+nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
-nullBinds EmptyBinds = True
-nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
-nullBinds (SingleBind b) = nullBind b
-nullBinds (BindWith b _) = nullBind b
-nullBinds (AbsBinds _ _ _ ds b) = null ds && nullBind b
+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 binds = foldr AndMonoBinds EmptyMonoBinds binds
\end{code}
\begin{code}
-instance (Outputable pat, NamedThing id, Outputable id,
+instance (NamedThing id, Outputable id, Outputable pat,
Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
- Outputable (HsBinds tyvar uvar id pat) where
+ Outputable (MonoBinds tyvar uvar id pat) where
+ ppr sty EmptyMonoBinds = empty
+ ppr sty (AndMonoBinds binds1 binds2)
+ = ($$) (ppr sty binds1) (ppr sty binds2)
- ppr sty EmptyBinds = ppNil
- ppr sty (ThenBinds binds1 binds2)
- = ppAbove (ppr sty binds1) (ppr sty binds2)
- ppr sty (SingleBind bind) = ppr sty bind
- ppr sty (BindWith bind sigs)
- = ppAbove (if null sigs
- then ppNil
- else ppAboves (map (ppr sty) sigs))
- (ppr sty bind)
- ppr sty (AbsBinds tyvars dictvars local_pairs dict_binds val_binds)
- = ppAbove (ppSep [ppPStr SLIT("AbsBinds"),
- ppBesides[ppLbrack, interpp'SP sty tyvars, ppRbrack],
- ppBesides[ppLbrack, interpp'SP sty dictvars, ppRbrack],
- ppBesides[ppLbrack, interpp'SP sty local_pairs, ppRbrack]])
- (ppNest 4 (ppAbove (ppAboves (map (ppr sty) dict_binds)) (ppr sty val_binds)))
+ ppr sty (PatMonoBind pat grhss_n_binds locn)
+ = hang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
+
+ ppr sty (FunMonoBind fun inf matches locn)
+ = pprMatches sty (False, ppr sty fun) matches
+ -- ToDo: print infix if appropriate
+
+ ppr sty (VarMonoBind name expr)
+ = hang (hsep [ppr sty name, equals]) 4 (ppr sty expr)
+
+ ppr sty (CoreMonoBind name expr)
+ = hang (hsep [ppr sty name, equals]) 4 (ppr sty expr)
+
+ ppr sty (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))
\end{code}
%************************************************************************
\begin{code}
instance (NamedThing name, Outputable name) => Outputable (Sig name) where
ppr sty (Sig var ty _)
- = ppHang (ppCat [ppr sty var, ppPStr SLIT("::")])
+ = hang (hsep [ppr sty var, ptext SLIT("::")])
4 (ppr sty ty)
ppr sty (ClassOpSig var _ ty _)
- = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")])
+ = hang (hsep [ppr sty (getOccName var), ptext SLIT("::")])
4 (ppr sty ty)
ppr sty (DeforestSig var _)
- = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonSym sty var])
- 4 (ppStr "#-")
+ = hang (hsep [text "{-# DEFOREST", ppr sty var])
+ 4 (text "#-")
ppr sty (SpecSig var ty using _)
- = ppHang (ppCat [ppStr "{-# SPECIALIZE", pprNonSym sty var, ppPStr SLIT("::")])
- 4 (ppCat [ppr sty ty, pp_using using, ppStr "#-}"])
+ = hang (hsep [text "{-# SPECIALIZE", ppr sty var, ptext SLIT("::")])
+ 4 (hsep [ppr sty ty, pp_using using, text "#-}"])
where
- pp_using Nothing = ppNil
- pp_using (Just me) = ppCat [ppChar '=', ppr sty me]
+ pp_using Nothing = empty
+ pp_using (Just me) = hsep [char '=', ppr sty me]
ppr sty (InlineSig var _)
- = ppCat [ppStr "{-# INLINE", pprNonSym sty var, ppStr "#-}"]
+ = hsep [text "{-# INLINE", ppr sty var, text "#-}"]
ppr sty (MagicUnfoldingSig var str _)
- = ppCat [ppStr "{-# MAGIC_UNFOLDING", pprNonSym sty var, ppPStr str, ppStr "#-}"]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Binding: @Bind@}
-%* *
-%************************************************************************
-
-\begin{code}
-data Bind tyvar uvar id pat -- binders and bindees
- = EmptyBind -- because it's convenient when parsing signatures
- | NonRecBind (MonoBinds tyvar uvar id pat)
- | RecBind (MonoBinds tyvar uvar id pat)
-\end{code}
-
-\begin{code}
-nullBind :: Bind tyvar uvar id pat -> Bool
-
-nullBind EmptyBind = True
-nullBind (NonRecBind bs) = nullMonoBinds bs
-nullBind (RecBind bs) = nullMonoBinds bs
-\end{code}
-
-\begin{code}
-bindIsRecursive :: Bind tyvar uvar id pat -> Bool
-
-bindIsRecursive EmptyBind = False
-bindIsRecursive (NonRecBind _) = False
-bindIsRecursive (RecBind _) = True
-\end{code}
-
-\begin{code}
-instance (NamedThing id, Outputable id, Outputable pat,
- Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
- Outputable (Bind tyvar uvar id pat) where
- ppr sty EmptyBind = ppNil
- ppr sty (NonRecBind binds)
- = ppAbove (ifnotPprForUser sty (ppPStr SLIT("{- nonrec -}")))
- (ppr sty binds)
- ppr sty (RecBind binds)
- = ppAbove (ifnotPprForUser sty (ppPStr SLIT("{- rec -}")))
- (ppr sty binds)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Bindings: @MonoBinds@}
-%* *
-%************************************************************************
-
-Global bindings (where clauses)
-
-\begin{code}
-data MonoBinds tyvar uvar id pat
- = EmptyMonoBinds
- | AndMonoBinds (MonoBinds tyvar uvar id pat)
- (MonoBinds tyvar uvar id pat)
- | PatMonoBind pat
- (GRHSsAndBinds tyvar uvar id pat)
- SrcLoc
- | FunMonoBind id
- Bool -- True => infix declaration
- [Match tyvar uvar id pat] -- must have at least one Match
- SrcLoc
-
- | VarMonoBind id -- TRANSLATION
- (HsExpr tyvar uvar id pat)
-
- | CoreMonoBind id -- TRANSLATION
- CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
-\end{code}
-
-\begin{code}
-nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
-
-nullMonoBinds EmptyMonoBinds = True
-nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
-nullMonoBinds other_monobind = False
-\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 EmptyMonoBinds = ppNil
- ppr sty (AndMonoBinds binds1 binds2)
- = ppAbove (ppr sty binds1) (ppr sty binds2)
-
- ppr sty (PatMonoBind pat grhss_n_binds locn)
- = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
-
- ppr sty (FunMonoBind fun inf matches locn)
- = pprMatches sty (False, ppr sty fun) matches
- -- ToDo: print infix if appropriate
-
- ppr sty (VarMonoBind name expr)
- = ppHang (ppCat [ppr sty name, ppEquals]) 4 (ppr sty expr)
-
- ppr sty (CoreMonoBind name expr)
- = ppHang (ppCat [ppr sty name, ppEquals]) 4 (ppr sty expr)
+ = hsep [text "{-# MAGIC_UNFOLDING", ppr sty var, ptext str, text "#-}"]
\end{code}
%************************************************************************
\begin{code}
collectTopBinders :: HsBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
collectTopBinders EmptyBinds = emptyBag
-collectTopBinders (SingleBind b) = collectBinders b
-collectTopBinders (BindWith b _) = collectBinders b
+collectTopBinders (MonoBind b _ _) = collectMonoBinders b
collectTopBinders (ThenBinds b1 b2)
= collectTopBinders b1 `unionBags` collectTopBinders b2
-collectBinders :: Bind tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
-collectBinders EmptyBind = emptyBag
-collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds
-collectBinders (RecBind monobinds) = collectMonoBinders monobinds
-
collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
collectMonoBinders EmptyMonoBinds = emptyBag
collectMonoBinders (PatMonoBind pat grhss_w_binds loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat))
import Outputable ( Outputable(..) )
import Pretty
import Util ( panic )
+#if __GLASGOW_HASKELL__ >= 202
+import CostCentre
+#endif
\end{code}
%************************************************************************
ppr sty (UfLit l) = ppr sty l
ppr sty (UfCon c as)
- = ppCat [ppStr "UfCon", ppr sty c, ppr sty as, ppChar ')']
+ = hsep [text "UfCon", ppr sty c, ppr sty as, char ')']
ppr sty (UfPrim o as)
- = ppCat [ppStr "UfPrim", ppr sty o, ppr sty as, ppChar ')']
+ = hsep [text "UfPrim", ppr sty o, ppr sty as, char ')']
ppr sty (UfLam b body)
- = ppCat [ppChar '\\', ppr sty b, ppPStr SLIT("->"), ppr sty body]
+ = hsep [char '\\', ppr sty b, ptext SLIT("->"), ppr sty body]
ppr sty (UfApp fun (UfTyArg ty))
- = ppCat [ppr sty fun, ppChar '@', pprParendHsType sty ty]
+ = hsep [ppr sty fun, char '@', pprParendHsType sty ty]
ppr sty (UfApp fun (UfLitArg lit))
- = ppCat [ppr sty fun, ppr sty lit]
+ = hsep [ppr sty fun, ppr sty lit]
ppr sty (UfApp fun (UfVarArg var))
- = ppCat [ppr sty fun, ppr sty var]
+ = hsep [ppr sty fun, ppr sty var]
ppr sty (UfCase scrut alts)
- = ppCat [ppPStr SLIT("case"), ppr sty scrut, ppPStr SLIT("of {"), pp_alts alts, ppChar '}']
+ = hsep [ptext SLIT("case"), ppr sty scrut, ptext SLIT("of {"), pp_alts alts, char '}']
where
pp_alts (UfAlgAlts alts deflt)
- = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
+ = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
where
- pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppr_arrow, ppr sty rhs]
+ pp_alt (c,bs,rhs) = hsep [ppr sty c, ppr sty bs, ppr_arrow, ppr sty rhs]
pp_alts (UfPrimAlts alts deflt)
- = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
+ = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
where
- pp_alt (l,rhs) = ppCat [ppr sty l, ppr_arrow, ppr sty rhs]
+ pp_alt (l,rhs) = hsep [ppr sty l, ppr_arrow, ppr sty rhs]
- pp_deflt UfNoDefault = ppNil
- pp_deflt (UfBindDefault b rhs) = ppCat [ppr sty b, ppr_arrow, ppr sty rhs]
+ pp_deflt UfNoDefault = empty
+ pp_deflt (UfBindDefault b rhs) = hsep [ppr sty b, ppr_arrow, ppr sty rhs]
- ppr_arrow = ppPStr SLIT("->")
+ ppr_arrow = ptext SLIT("->")
ppr sty (UfLet (UfNonRec b rhs) body)
- = ppCat [ppPStr SLIT("let"), ppr sty b, ppEquals, ppr sty rhs, ppPStr SLIT("in"), ppr sty body]
+ = hsep [ptext SLIT("let"), ppr sty b, equals, ppr sty rhs, ptext SLIT("in"), ppr sty body]
ppr sty (UfLet (UfRec pairs) body)
- = ppCat [ppPStr SLIT("letrec {"), ppInterleave ppSemi (map pp_pair pairs), ppPStr SLIT("} in"), ppr sty body]
+ = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr sty body]
where
- pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs]
+ pp_pair (b,rhs) = hsep [ppr sty b, equals, ppr sty rhs]
ppr sty (UfSCC uf_cc body)
- = ppCat [ppPStr SLIT("_scc_ <cost-centre[ToDo]>"), ppr sty body]
+ = hsep [ptext SLIT("_scc_ <cost-centre[ToDo]>"), ppr sty body]
instance Outputable name => Outputable (UfPrimOp name) where
ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
= let
- before = ppPStr (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
- after = if is_casm then ppStr "'' " else ppSP
+ before = ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
+ after = if is_casm then text "'' " else space
in
- ppBesides [before, ppPStr str, after,
- ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
+ hcat [before, ptext str, after,
+ brackets (ppr sty arg_tys), space, ppr sty result_ty]
ppr sty (UfOtherOp op)
= ppr sty op
ppr sty (UfUsageArg name) = ppr sty name
instance Outputable name => Outputable (UfBinder name) where
- ppr sty (UfValBinder name ty) = ppCat [ppr sty name, ppPStr SLIT("::"), ppr sty ty]
- ppr sty (UfTyBinder name kind) = ppCat [ppr sty name, ppPStr SLIT("::"), ppr sty kind]
+ 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
\end{code}
import SpecEnv ( SpecEnv )
import HsCore ( UfExpr )
import HsBasic ( Fixity )
+import TyCon ( NewOrData(..) ) -- Just a boolean flag really
-- others:
-import Name ( pprSym, pprNonSym, getOccName, OccName )
+import Name --( getOccName, OccName )
import Outputable ( interppSP, interpp'SP,
Outputable(..){-instance * []-}
)
import Pretty
import SrcLoc ( SrcLoc )
-import PprStyle ( PprStyle(..), ifaceStyle )
+import PprStyle ( PprStyle(..) )
+import Util
\end{code}
\end{code}
\begin{code}
-hsDeclName (TyD (TyData _ name _ _ _ _ _)) = name
-hsDeclName (TyD (TyNew _ name _ _ _ _ _)) = name
-hsDeclName (TyD (TySynonym name _ _ _)) = name
-hsDeclName (ClD (ClassDecl _ name _ _ _ _ _)) = name
-hsDeclName (SigD (IfaceSig name _ _ _)) = name
+#ifdef DEBUG
+hsDeclName :: (NamedThing name, Outputable name, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => HsDecl tyvar uvar name pat -> name
+#endif
+hsDeclName (TyD (TyData _ _ name _ _ _ _ _)) = name
+hsDeclName (TyD (TySynonym 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)
+#endif
\end{code}
\begin{code}
ppr sty (DefD def) = ppr sty def
ppr sty (InstD inst) = ppr sty inst
--- In interfaces, top-level binders are printed without their "Module." prefix
-ppr_top_binder sty bndr | ifaceStyle sty = ppr sty (getOccName bndr)
- | otherwise = ppr sty bndr
+#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
+#else
+instance (Ord3 name) => Ord3 (HsDecl tyvar uvar name pat) where
+#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) = ppSep [ppr sty fixity, ppr sty name]
+ ppr sty (FixityDecl name fixity loc) = sep [ppr sty fixity, ppr sty name]
\end{code}
\begin{code}
data TyDecl name
- = TyData (Context name) -- context
+ = TyData NewOrData
+ (Context name) -- context
name -- type constructor
[HsTyVar name] -- type variables
[ConDecl name] -- data constructors (empty if abstract)
(DataPragmas name)
SrcLoc
- | TyNew (Context name) -- context
- name -- type constructor
- [HsTyVar name] -- type variables
- (ConDecl name) -- data constructor
- (Maybe [name]) -- derivings; as above
- (DataPragmas name)
- SrcLoc
-
| TySynonym name -- type constructor
[HsTyVar name] -- type variables
(HsType name) -- synonym expansion
=> Outputable (TyDecl name) where
ppr sty (TySynonym tycon tyvars mono_ty src_loc)
- = ppHang (pp_decl_head sty SLIT("type") ppNil tycon tyvars)
+ = hang (pp_decl_head sty SLIT("type") empty tycon tyvars)
4 (ppr sty mono_ty)
- ppr sty (TyData context tycon tyvars condecls derivings pragmas src_loc)
+ ppr sty (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
= pp_tydecl sty
- (pp_decl_head sty SLIT("data") (pp_context_and_arrow sty context) tycon tyvars)
+ (pp_decl_head sty keyword (pp_context_and_arrow sty context) tycon tyvars)
(pp_condecls sty condecls)
derivings
-
- ppr sty (TyNew context tycon tyvars condecl derivings pragmas src_loc)
- = pp_tydecl sty
- (pp_decl_head sty SLIT("newtype") (pp_context_and_arrow sty context) tycon tyvars)
- (ppr sty condecl)
- derivings
+ where
+ keyword = case new_or_data of
+ NewType -> SLIT("newtype")
+ DataType -> SLIT("data")
pp_decl_head sty str pp_context tycon tyvars
- = ppCat [ppPStr str, pp_context, ppr_top_binder sty tycon,
- interppSP sty tyvars, ppPStr SLIT("=")]
+ = hsep [ptext str, pp_context, ppr sty tycon,
+ interppSP sty tyvars, ptext SLIT("=")]
-pp_condecls sty [] = ppNil -- Curious!
+pp_condecls sty [] = empty -- Curious!
pp_condecls sty (c:cs)
- = ppSep (ppr sty c : map (\ c -> ppBeside (ppPStr SLIT("| ")) (ppr sty c)) cs)
+ = sep (ppr sty c : map (\ c -> (<>) (ptext SLIT("| ")) (ppr sty c)) cs)
pp_tydecl sty pp_head pp_decl_rhs derivings
- = ppHang pp_head 4 (ppSep [
+ = hang pp_head 4 (sep [
pp_decl_rhs,
case (derivings, sty) of
- (Nothing,_) -> ppNil
- (_,PprInterface) -> ppNil -- No derivings in interfaces
- (Just ds,_) -> ppCat [ppPStr SLIT("deriving"), ppParens (interpp'SP sty ds)]
+ (Nothing,_) -> empty
+ (_,PprInterface) -> empty -- No derivings in interfaces
+ (Just ds,_) -> hsep [ptext SLIT("deriving"), parens (interpp'SP sty ds)]
])
-pp_context_and_arrow :: Outputable name => PprStyle -> Context name -> Pretty
-pp_context_and_arrow sty [] = ppNil
-pp_context_and_arrow sty theta = ppCat [pprContext sty theta, ppPStr SLIT("=>")]
+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("=>")]
\end{code}
A type for recording what types a datatype should be specialised to.
=> Outputable (SpecDataSig name) where
ppr sty (SpecDataSig tycon ty _)
- = ppCat [ppStr "{-# SPECIALIZE data", ppr sty ty, ppStr "#-}"]
+ = hsep [text "{-# SPECIALIZE data", ppr sty ty, text "#-}"]
\end{code}
%************************************************************************
\begin{code}
data ConDecl name
- = ConDecl name -- prefix-style con decl
- [BangType name]
+ = ConDecl name -- Constructor name
+ (Context name) -- Existential context for this constructor
+ (ConDetails name)
SrcLoc
- | ConOpDecl (BangType name) -- infix-style con decl
- name
+data ConDetails name
+ = VanillaCon -- prefix-style con decl
+ [BangType name]
+
+ | InfixCon -- infix-style con decl
+ (BangType name)
(BangType name)
- SrcLoc
- | RecConDecl name
+ | RecCon -- record-style con decl
[([name], BangType name)] -- list of "fields"
- SrcLoc
- | NewConDecl name -- newtype con decl
+ | NewCon -- newtype con decl
(HsType name)
- SrcLoc
data BangType name
= Banged (HsType name) -- HsType: to allow Haskell extensions
\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 sty (ConDecl con tys _)
- = ppCat [ppr_top_binder sty con, ppInterleave ppNil (map (ppr_bang sty) tys)]
+ppr_con_details sty con (InfixCon ty1 ty2)
+ = hsep [ppr_bang sty ty1, ppr sty con, ppr_bang sty ty2]
- -- We print ConOpDecls in prefix form in interface files
- ppr sty (ConOpDecl ty1 op ty2 _)
- | ifaceStyle sty
- = ppCat [ppr_top_binder sty op, ppr_bang sty ty1, ppr_bang sty ty2]
- | otherwise
- = ppCat [ppr_bang sty ty1, ppr_top_binder sty op, ppr_bang sty ty2]
-
- ppr sty (NewConDecl con ty _)
- = ppCat [ppr_top_binder sty con, pprParendHsType sty ty]
- ppr sty (RecConDecl con fields _)
- = ppCat [ppr_top_binder sty con,
- ppCurlies (ppInterleave pp'SP (map pp_field fields))
- ]
- where
- pp_field (ns, ty) = ppCat [ppCat (map (ppr_top_binder sty) ns),
- ppPStr SLIT("::"), ppr_bang sty ty]
+ppr_con_details sty con (VanillaCon tys)
+ = ppr sty con <+> hsep (map (ppr_bang sty) tys)
+
+ppr_con_details sty con (NewCon ty)
+ = ppr sty con <+> pprParendHsType sty ty
-ppr_bang sty (Banged ty) = ppBeside (ppPStr SLIT("! ")) (pprParendHsType sty ty)
- -- The extra space helps the lexical analyser that lexes
- -- interface files; it doesn't make the rigid operator/identifier
- -- distinction, so "!a" is a valid identifier so far as it is concerned
+ppr_con_details sty con (RecCon fields)
+ = ppr sty con <+> braces (hsep (punctuate comma (map ppr_field fields)))
+ where
+ ppr_field (ns, ty) = hsep (map (ppr sty) ns) <+>
+ ptext SLIT("::") <+>
+ ppr_bang sty ty
+
+ppr_bang sty (Banged ty) = ptext SLIT("!") <> pprParendHsType sty ty
ppr_bang sty (Unbanged ty) = pprParendHsType sty ty
\end{code}
| null sigs -- No "where" part
= top_matter
- | iface_style -- All on one line (for now at least)
- = ppCat [top_matter, ppPStr SLIT("where"),
- ppCurlies (ppInterleave (ppPStr SLIT("; ")) pp_sigs)]
-
| otherwise -- Laid out
- = ppSep [ppCat [top_matter, ppPStr SLIT("where {")],
- ppNest 4 ((ppIntersperse ppSemi pp_sigs `ppAbove` pp_methods)
- `ppBeside` ppChar '}')]
+ = sep [hsep [top_matter, ptext SLIT("where {")],
+ nest 4 (vcat [sep (map ppr_sig sigs),
+ ppr sty methods,
+ char '}'])]
where
- top_matter = ppCat [ppPStr SLIT("class"), pp_context_and_arrow sty context,
- ppr_top_binder sty clas, ppr sty tyvar]
- pp_sigs = map (ppr sty) sigs
- pp_methods = ppr sty methods
- iface_style = case sty of {PprInterface -> True; other -> False}
+ 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
\end{code}
%************************************************************************
ppr sty (InstDecl inst_ty binds uprags dfun_name src_loc)
| case sty of { PprInterface -> True; other -> False} ||
nullMonoBinds binds && null uprags
- = ppCat [ppPStr SLIT("instance"), ppr sty inst_ty]
+ = hsep [ptext SLIT("instance"), ppr sty inst_ty]
| otherwise
- = ppAboves [ppCat [ppPStr SLIT("instance"), ppr sty inst_ty, ppPStr SLIT("where")],
- ppNest 4 (ppr sty uprags),
- ppNest 4 (ppr sty binds) ]
+ = vcat [hsep [ptext SLIT("instance"), ppr sty inst_ty, ptext SLIT("where")],
+ nest 4 (ppr sty uprags),
+ nest 4 (ppr sty binds) ]
\end{code}
A type for recording what instances the user wants to specialise;
=> Outputable (SpecInstSig name) where
ppr sty (SpecInstSig clas ty _)
- = ppCat [ppStr "{-# SPECIALIZE instance", ppr sty clas, ppr sty ty, ppStr "#-}"]
+ = hsep [text "{-# SPECIALIZE instance", ppr sty clas, ppr sty ty, text "#-}"]
\end{code}
%************************************************************************
=> Outputable (DefaultDecl name) where
ppr sty (DefaultDecl tys src_loc)
- = ppBeside (ppPStr SLIT("default ")) (ppParens (interpp'SP sty tys))
+ = (<>) (ptext SLIT("default ")) (parens (interpp'SP sty tys))
\end{code}
%************************************************************************
instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where
ppr sty (IfaceSig var ty _ _)
- = ppHang (ppCat [ppr_top_binder sty var, ppPStr SLIT("::")])
+ = hang (hsep [ppr sty var, ptext SLIT("::")])
4 (ppr sty ty)
data HsIdInfo name
--- /dev/null
+_interface_ HsExpr 1
+_exports_
+HsExpr HsExpr Stmt;
+_instances_
+instance _forall_ [a b c d] => {Outputable.Outputable (HsExpr a b c d)} = $d1;
+instance _forall_ [a b c d] => {Outputable.Outputable (Stmt a b c d)} = $d2;
+_declarations_
+1 $d1 _:_ _forall_ [a b c d] => {Outputable.Outputable (HsExpr a b c d)} ;;
+1 $d2 _:_ _forall_ [a b c d] => {Outputable.Outputable (Stmt a b c d)} ;;
+1 data HsExpr a b c d;
+1 data Stmt a b c d;
-- others:
import Id ( SYN_IE(DictVar), GenId, SYN_IE(Id) )
-import Name ( pprNonSym, pprSym )
-import Outputable ( interppSP, interpp'SP, ifnotPprForUser )
+import Outputable --( interppSP, interpp'SP, ifnotPprForUser )
import PprType ( pprGenType, pprParendGenType, GenType{-instance-} )
import Pretty
-import PprStyle ( PprStyle(..) )
+import PprStyle ( PprStyle(..), userStyle )
import SrcLoc ( SrcLoc )
import Usage ( GenUsage{-instance-} )
--import Util ( panic{-ToDo:rm eventually-} )
+#if __GLASGOW_HASKELL__ >= 202
+import Name
+#endif
\end{code}
%************************************************************************
(HsRecordBinds tyvar uvar id pat)
| RecordUpdOut (HsExpr tyvar uvar id pat) -- TRANSLATION
+ (GenType tyvar uvar) -- Type of *result* record (may differ from
+ -- type of input record)
[id] -- Dicts needed for construction
(HsRecordBinds tyvar uvar id pat)
instance (NamedThing id, Outputable id, Outputable pat,
Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
Outputable (HsExpr tyvar uvar id pat) where
- ppr = pprExpr
+ ppr sty expr = pprQuote sty $ \ sty -> pprExpr sty expr
\end{code}
\begin{code}
pprExpr sty (HsLitOut lit _) = ppr sty lit
pprExpr sty (HsLam match)
- = ppCat [ppChar '\\', ppNest 2 (pprMatch sty True match)]
+ = hsep [char '\\', nest 2 (pprMatch sty True match)]
pprExpr sty expr@(HsApp e1 e2)
= let (fun, args) = collect_args expr [] in
- ppHang (pprExpr sty fun) 4 (ppSep (map (pprExpr sty) args))
+ hang (pprExpr sty fun) 4 (sep (map (pprExpr sty) args))
where
collect_args (HsApp fun arg) args = collect_args fun (arg:args)
collect_args fun args = (fun, args)
pp_e2 = pprParendExpr sty e2
pp_prefixly
- = ppHang (pprExpr sty op) 4 (ppSep [pp_e1, pp_e2])
+ = hang (pprExpr sty op) 4 (sep [pp_e1, pp_e2])
pp_infixly v
- = ppSep [pp_e1, ppCat [ppr sty v, pp_e2]]
+ = sep [pp_e1, hsep [ppr sty v, pp_e2]]
pprExpr sty (NegApp e _)
- = ppBeside (ppChar '-') (pprParendExpr sty e)
+ = (<>) (char '-') (pprParendExpr sty e)
pprExpr sty (HsPar e)
- = ppParens (pprExpr sty e)
+ = parens (pprExpr sty e)
pprExpr sty (SectionL expr op)
= case op of
where
pp_expr = pprParendExpr sty expr
- pp_prefixly = ppHang (ppCat [ppStr " \\ x_ ->", ppr sty op])
- 4 (ppCat [pp_expr, ppPStr SLIT("x_ )")])
- pp_infixly v
- = ppSep [ ppBeside ppLparen pp_expr,
- ppBeside (ppr sty v) ppRparen ]
+ pp_prefixly = hang (hsep [text " \\ x_ ->", ppr sty op])
+ 4 (hsep [pp_expr, ptext SLIT("x_ )")])
+ pp_infixly v = parens (sep [pp_expr, ppr sty v])
pprExpr sty (SectionR op expr)
= case op of
where
pp_expr = pprParendExpr sty expr
- pp_prefixly = ppHang (ppCat [ppStr "( \\ x_ ->", ppr sty op, ppPStr SLIT("x_")])
- 4 (ppBeside pp_expr ppRparen)
+ pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr sty op, ptext SLIT("x_")])
+ 4 ((<>) pp_expr rparen)
pp_infixly v
- = ppSep [ ppBeside ppLparen (ppr sty v),
- ppBeside pp_expr ppRparen ]
+ = parens (sep [ppr sty v, pp_expr])
pprExpr sty (HsCase expr matches _)
- = ppSep [ ppSep [ppPStr SLIT("case"), ppNest 4 (pprExpr sty expr), ppPStr SLIT("of")],
- ppNest 2 (pprMatches sty (True, ppNil) matches) ]
+ = sep [ sep [ptext SLIT("case"), nest 4 (pprExpr sty expr), ptext SLIT("of")],
+ nest 2 (pprMatches sty (True, empty) matches) ]
pprExpr sty (HsIf e1 e2 e3 _)
- = ppSep [ppCat [ppPStr SLIT("if"), ppNest 2 (pprExpr sty e1), ppPStr SLIT("then")],
- ppNest 4 (pprExpr sty e2),
- ppPStr SLIT("else"),
- ppNest 4 (pprExpr sty e3)]
+ = sep [hsep [ptext SLIT("if"), nest 2 (pprExpr sty e1), ptext SLIT("then")],
+ nest 4 (pprExpr sty e2),
+ ptext SLIT("else"),
+ nest 4 (pprExpr sty e3)]
-- special case: let ... in let ...
pprExpr sty (HsLet binds expr@(HsLet _ _))
- = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppCat [ppr sty binds, ppPStr SLIT("in")]),
+ = sep [hang (ptext SLIT("let")) 2 (hsep [ppr sty binds, ptext SLIT("in")]),
ppr sty expr]
pprExpr sty (HsLet binds expr)
- = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppr sty binds),
- ppHang (ppPStr SLIT("in")) 2 (ppr sty 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)
- = ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs))
+ = brackets (fsep (punctuate comma (map (pprExpr sty) exprs)))
pprExpr sty (ExplicitListOut ty exprs)
- = ppBesides [ ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs)),
- ifnotPprForUser sty (ppBeside ppSP (ppParens (pprGenType sty ty))) ]
+ = hcat [ brackets (fsep (punctuate comma (map (pprExpr sty) exprs))),
+ ifnotPprForUser sty ((<>) space (parens (pprGenType sty ty))) ]
pprExpr sty (ExplicitTuple exprs)
- = ppParens (ppInterleave ppComma (map (pprExpr sty) exprs))
+ = parens (sep (punctuate comma (map (pprExpr sty) exprs)))
pprExpr sty (RecordCon con rbinds)
= pp_rbinds sty (ppr sty con) rbinds
pprExpr sty (RecordUpd aexp rbinds)
= pp_rbinds sty (pprParendExpr sty aexp) rbinds
-pprExpr sty (RecordUpdOut aexp _ rbinds)
+pprExpr sty (RecordUpdOut aexp _ _ rbinds)
= pp_rbinds sty (pprParendExpr sty aexp) rbinds
pprExpr sty (ExprWithTySig expr sig)
- = ppHang (ppBeside (ppNest 2 (pprExpr sty expr)) (ppPStr SLIT(" ::")))
+ = hang ((<>) (nest 2 (pprExpr sty expr)) (ptext SLIT(" ::")))
4 (ppr sty sig)
pprExpr sty (ArithSeqIn info)
- = ppBracket (ppr sty info)
+ = brackets (ppr sty info)
pprExpr sty (ArithSeqOut expr info)
- = case sty of
- PprForUser ->
- ppBracket (ppr sty info)
- _ ->
- ppBesides [ppLbrack, ppParens (ppr sty expr), ppSP, ppr sty info, ppRbrack]
+ | 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)
- = ppHang (if is_asm
- then ppBesides [ppPStr SLIT("_casm_ ``"), ppPStr fun, ppPStr SLIT("''")]
- else ppBeside (ppPStr SLIT("_ccall_ ")) (ppPStr fun))
- 4 (ppSep (map (pprParendExpr sty) args))
+ = 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))
pprExpr sty (HsSCC label expr)
- = ppSep [ ppBeside (ppPStr SLIT("_scc_ ")) (ppBesides [ppChar '"', ppPStr label, ppChar '"']),
+ = sep [ (<>) (ptext SLIT("_scc_ ")) (hcat [char '"', ptext label, char '"']),
pprParendExpr sty expr ]
pprExpr sty (TyLam tyvars expr)
- = ppHang (ppCat [ppPStr SLIT("/\\"), interppSP sty tyvars, ppPStr SLIT("->")])
+ = hang (hsep [ptext SLIT("/\\"), interppSP sty tyvars, ptext SLIT("->")])
4 (pprExpr sty expr)
pprExpr sty (TyApp expr [ty])
- = ppHang (pprExpr sty expr) 4 (pprParendGenType sty ty)
+ = hang (pprExpr sty expr) 4 (pprParendGenType sty ty)
pprExpr sty (TyApp expr tys)
- = ppHang (pprExpr sty expr)
- 4 (ppBracket (interpp'SP sty tys))
+ = hang (pprExpr sty expr)
+ 4 (brackets (interpp'SP sty tys))
pprExpr sty (DictLam dictvars expr)
- = ppHang (ppCat [ppPStr SLIT("\\{-dict-}"), interppSP sty dictvars, ppPStr SLIT("->")])
+ = hang (hsep [ptext SLIT("\\{-dict-}"), interppSP sty dictvars, ptext SLIT("->")])
4 (pprExpr sty expr)
pprExpr sty (DictApp expr [dname])
- = ppHang (pprExpr sty expr) 4 (ppr sty dname)
+ = hang (pprExpr sty expr) 4 (ppr sty dname)
pprExpr sty (DictApp expr dnames)
- = ppHang (pprExpr sty expr)
- 4 (ppBracket (interpp'SP sty dnames))
+ = hang (pprExpr sty expr)
+ 4 (brackets (interpp'SP sty dnames))
pprExpr sty (ClassDictLam dicts methods expr)
- = ppHang (ppCat [ppPStr SLIT("\\{-classdict-}"),
- ppBracket (interppSP sty dicts),
- ppBracket (interppSP sty methods),
- ppPStr SLIT("->")])
+ = hang (hsep [ptext SLIT("\\{-classdict-}"),
+ brackets (interppSP sty dicts),
+ brackets (interppSP sty methods),
+ ptext SLIT("->")])
4 (pprExpr sty expr)
pprExpr sty (Dictionary dicts methods)
- = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")],
- ppBracket (interpp'SP sty dicts),
- ppBesides [ppBracket (interpp'SP sty methods), ppRparen]]
+ = parens (sep [ptext SLIT("{-dict-}"),
+ brackets (interpp'SP sty dicts),
+ brackets (interpp'SP sty methods)])
pprExpr sty (SingleDict dname)
- = ppCat [ppPStr SLIT("{-singleDict-}"), ppr sty dname]
+ = hsep [ptext SLIT("{-singleDict-}"), ppr sty dname]
\end{code}
\begin{code}
pprParendExpr :: (NamedThing id, Outputable id, Outputable pat,
Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
- => PprStyle -> HsExpr tyvar uvar id pat -> Pretty
+ => PprStyle -> HsExpr tyvar uvar id pat -> Doc
pprParendExpr sty expr
= let
ExplicitTuple _ -> pp_as_was
HsPar _ -> pp_as_was
- _ -> ppParens pp_as_was
+ _ -> parens pp_as_was
\end{code}
%************************************************************************
\begin{code}
pp_rbinds :: (NamedThing id, Outputable id, Outputable pat,
Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
- => PprStyle -> Pretty
- -> HsRecordBinds tyvar uvar id pat -> Pretty
+ => PprStyle -> Doc
+ -> HsRecordBinds tyvar uvar id pat -> Doc
pp_rbinds sty thing rbinds
- = ppHang thing
- 4 (ppCurlies (ppIntersperse pp'SP (map (pp_rbind sty) rbinds)))
+ = hang thing
+ 4 (braces (hsep (punctuate comma (map (pp_rbind sty) rbinds))))
where
- pp_rbind PprForUser (v, _, True) = ppr PprForUser v
- pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppChar '=', ppr sty e]
+ pp_rbind sty (v, _, True) | userStyle sty = ppr sty v
+ pp_rbind sty (v, e, _) = hsep [ppr sty v, char '=', ppr sty e]
\end{code}
%************************************************************************
data DoOrListComp = DoStmt | ListComp
pprDo DoStmt sty stmts
- = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts))
+ = hang (ptext SLIT("do")) 2 (vcat (map (ppr sty) stmts))
pprDo ListComp sty stmts
- = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|'])
- 4 (ppSep [interpp'SP sty quals, ppRbrack])
+ = hang (hsep [lbrack, pprExpr sty expr, char '|'])
+ 4 (sep [interpp'SP sty quals, rbrack])
where
ReturnStmt expr = last stmts -- Last stmt should be a ReturnStmt for list comps
quals = init stmts
instance (NamedThing id, Outputable id, Outputable pat,
Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
Outputable (Stmt tyvar uvar id pat) where
- ppr sty (BindStmt pat expr _)
- = ppCat [ppr sty pat, ppPStr SLIT("<-"), ppr sty expr]
- ppr sty (LetStmt binds)
- = ppCat [ppPStr SLIT("let"), ppr sty binds]
- ppr sty (ExprStmt expr _)
- = ppr sty expr
- ppr sty (GuardStmt expr _)
- = ppr sty expr
- ppr sty (ReturnStmt expr)
- = ppCat [ppPStr SLIT("return"), ppr sty expr]
+ 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]
\end{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) = ppBesides [ppr sty e1, pp_dotdot]
- ppr sty (FromThen e1 e2) = ppBesides [ppr sty e1, pp'SP, ppr sty e2, pp_dotdot]
- ppr sty (FromTo e1 e3) = ppBesides [ppr sty e1, pp_dotdot, ppr sty e3]
+ 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)
- = ppBesides [ppr sty e1, pp'SP, ppr sty e2, pp_dotdot, ppr sty e3]
+ = hcat [ppr sty e1, comma, space, ppr sty e2, pp_dotdot, ppr sty e3]
-pp_dotdot = ppPStr SLIT(" .. ")
+pp_dotdot = ptext SLIT(" .. ")
\end{code}
IMP_Ubiq()
-import Name ( pprNonSym )
import Outputable
import PprStyle ( PprStyle(..) )
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 spec _)
- = ppHang (ppCat [ppPStr SLIT("import"), pp_qual qual, ppPStr mod, pp_as as])
+ = hang (hsep [ptext SLIT("import"), pp_qual qual, ptext mod, pp_as as])
4 (pp_spec spec)
where
- pp_qual False = ppNil
- pp_qual True = ppPStr SLIT("qualified")
+ pp_qual False = empty
+ pp_qual True = ptext SLIT("qualified")
- pp_as Nothing = ppNil
- pp_as (Just a) = ppBeside (ppPStr SLIT("as ")) (ppPStr a)
+ pp_as Nothing = empty
+ pp_as (Just a) = (<>) (ptext SLIT("as ")) (ptext a)
- pp_spec Nothing = ppNil
+ pp_spec Nothing = empty
pp_spec (Just (False, spec))
- = ppParens (interpp'SP sty spec)
+ = parens (interpp'SP sty spec)
pp_spec (Just (True, spec))
- = ppBeside (ppPStr SLIT("hiding ")) (ppParens (interpp'SP sty spec))
+ = (<>) (ptext SLIT("hiding ")) (parens (interpp'SP sty spec))
\end{code}
%************************************************************************
\begin{code}
instance (NamedThing name, Outputable name) => Outputable (IE name) where
- ppr sty (IEVar var) = pprNonSym sty var
+ ppr sty (IEVar var) = ppr sty var
ppr sty (IEThingAbs thing) = ppr sty thing
ppr sty (IEThingAll thing)
- = ppBesides [ppr sty thing, ppStr "(..)"]
+ = hcat [ppr sty thing, text "(..)"]
ppr sty (IEThingWith thing withs)
- = ppBeside (ppr sty thing)
- (ppParens (ppInterleave ppComma (map (pprNonSym sty) withs)))
+ = (<>) (ppr sty thing)
+ (parens (fsep (punctuate comma (map (ppr sty) withs))))
ppr sty (IEModuleContents mod)
- = ppBeside (ppPStr SLIT("module ")) (ppPStr mod)
+ = (<>) (ptext SLIT("module ")) (ptext mod)
\end{code}
--- /dev/null
+module HsLoop
+
+ (
+ module HsExpr,
+ module HsBinds
+ ) where
+
+import HsExpr
+import HsBinds
interface HsLoop where
-import HsExpr ( HsExpr )
-import HsBinds ( Bind, HsBinds, MonoBinds, Sig, nullBinds, nullMonoBinds )
+import HsExpr ( HsExpr, Stmt )
+import HsBinds ( HsBinds, MonoBinds, Sig, nullBinds, nullMonoBinds )
import HsDecls ( ConDecl )
import Name ( NamedThing )
import Outputable ( Outputable )
-- HsExpr outputs
data HsExpr tyvar uvar id pat
+data Stmt tyvar uvar id pat
instance (NamedThing id, Outputable id, Outputable pat,
Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
=> Outputable (HsExpr tyvar uvar id pat)
+instance (NamedThing id, Outputable id, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => Outputable (Stmt tyvar uvar id pat)
+
-- HsBinds outputs
data Sig id
instance (NamedThing name, Outputable name) => Outputable (Sig name)
-data Bind tyvar uvar id pat
-
data HsBinds tyvar uvar id pat
instance (Outputable pat, NamedThing id, Outputable id,
IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(HsLoop) ( HsExpr, nullBinds, HsBinds )
-import Outputable ( ifPprShowAll )
+IMPORT_DELOOPER(HsLoop) ( HsExpr, Stmt, nullBinds, HsBinds )
+import Outputable --( ifPprShowAll )
import PprType ( GenType{-instance Outputable-} )
import Pretty
import SrcLoc ( SrcLoc{-instances-} )
import Util ( panic )
+#if __GLASGOW_HASKELL__ >= 202
+import Name
+import PprStyle
+#endif
+
\end{code}
%************************************************************************
(GenType tyvar uvar)
data GRHS tyvar uvar id pat
- = GRHS (HsExpr tyvar uvar id pat) -- guard(ed)...
+ = GRHS [Stmt tyvar uvar id pat] -- guard(ed)...
(HsExpr tyvar uvar id pat) -- ... right-hand side
SrcLoc
\begin{code}
pprMatches :: (NamedThing id, Outputable id, Outputable pat,
Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
- PprStyle -> (Bool, Pretty) -> [Match tyvar uvar id pat] -> Pretty
+ PprStyle -> (Bool, Doc) -> [Match tyvar uvar id pat] -> Doc
pprMatches sty print_info@(is_case, name) [match]
= if is_case then
pprMatch sty is_case match
else
- ppHang name 4 (pprMatch sty is_case match)
+ hang name 4 (pprMatch sty is_case match)
pprMatches sty print_info (match1 : rest)
- = ppAbove (pprMatches sty print_info [match1])
+ = ($$) (pprMatches sty print_info [match1])
(pprMatches sty 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 -> Pretty
+ PprStyle -> Bool -> Match tyvar uvar id pat -> Doc
pprMatch sty is_case first_match
- = ppHang (ppSep (map (ppr sty) row_of_pats))
+ = hang (sep (map (ppr sty) row_of_pats))
8 grhss_etc_stuff
where
(row_of_pats, grhss_etc_stuff) = ppr_match sty is_case first_match
= ([], pprGRHSsAndBinds sty is_case grhss_n_binds)
ppr_match sty is_case (SimpleMatch expr)
- = ([], ppHang (ppStr (if is_case then "->" else "="))
+ = ([], hang (text (if is_case then "->" else "="))
4 (ppr sty expr))
----------------------------------------------------------
pprGRHSsAndBinds sty is_case (GRHSsAndBindsIn grhss binds)
- = ppAbove (ppAboves (map (pprGRHS sty is_case) grhss))
+ = ($$) (vcat (map (pprGRHS sty is_case) grhss))
(if (nullBinds binds)
- then ppNil
- else ppAboves [ ppStr "where", ppNest 4 (ppr sty binds) ])
+ then empty
+ else vcat [ text "where", nest 4 (ppr sty binds) ])
pprGRHSsAndBinds sty is_case (GRHSsAndBindsOut grhss binds ty)
- = ppAbove (ppAboves (map (pprGRHS sty is_case) grhss))
+ = ($$) (vcat (map (pprGRHS sty is_case) grhss))
(if (nullBinds binds)
- then ppNil
- else ppAboves [ ifPprShowAll sty
- (ppCat [ppStr "{- ty:", ppr sty ty, ppStr "-}"]),
- ppStr "where", ppNest 4 (ppr sty binds) ])
+ then empty
+ else vcat [ ifPprShowAll sty
+ (hsep [text "{- ty:", ppr sty ty, text "-}"]),
+ text "where", nest 4 (ppr sty binds) ])
---------------------------------------------
pprGRHS :: (NamedThing id, Outputable id, Outputable pat,
Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
- => PprStyle -> Bool -> GRHS tyvar uvar id pat -> Pretty
+ => PprStyle -> Bool -> GRHS tyvar uvar id pat -> Doc
+
+pprGRHS sty is_case (GRHS [] expr locn)
+ = hang (text (if is_case then "->" else "="))
+ 4 (ppr sty expr)
pprGRHS sty is_case (GRHS guard expr locn)
- = ppHang (ppCat [ppChar '|', ppr sty guard, ppStr (if is_case then "->" else "=")])
+ = hang (hsep [char '|', ppr sty guard, text (if is_case then "->" else "=")])
4 (ppr sty expr)
pprGRHS sty is_case (OtherwiseGRHS expr locn)
- = ppHang (ppStr (if is_case then "->" else "="))
+ = hang (text (if is_case then "->" else "="))
4 (ppr sty expr)
\end{code}
-- friends:
import HsBasic ( HsLit, Fixity )
+IMPORT_DELOOPER(IdLoop)
IMPORT_DELOOPER(HsLoop) ( HsExpr )
+
-- others:
-import Id ( dataConTyCon, GenId )
+import Id --( dataConTyCon, GenId )
import Maybes ( maybeToBool )
-import Name ( pprSym, pprNonSym )
-import Outputable ( interppSP, interpp'SP, ifPprShowAll )
-import PprStyle ( PprStyle(..) )
+import Outputable --( interppSP, interpp'SP, ifPprShowAll )
+import PprStyle ( PprStyle(..), userStyle )
import Pretty
import TyCon ( maybeTyConSingleCon )
import PprType ( GenType )
+#if __GLASGOW_HASKELL__ >= 202
+import Name
+#endif
\end{code}
Patterns come in distinct before- and after-typechecking flavo(u)rs.
instance (Outputable name, NamedThing name) => Outputable (InPat name) where
ppr = pprInPat
-pprInPat :: (Outputable name, NamedThing name) => PprStyle -> InPat name -> Pretty
+pprInPat :: (Outputable name, NamedThing name) => PprStyle -> InPat name -> Doc
-pprInPat sty (WildPatIn) = ppChar '_'
+pprInPat sty (WildPatIn) = char '_'
pprInPat sty (VarPatIn var) = ppr sty var
pprInPat sty (LitPatIn s) = ppr sty s
-pprInPat sty (LazyPatIn pat) = ppBeside (ppChar '~') (ppr sty pat)
+pprInPat sty (LazyPatIn pat) = (<>) (char '~') (ppr sty pat)
pprInPat sty (AsPatIn name pat)
- = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen]
+ = parens (hcat [ppr sty name, char '@', ppr sty pat])
pprInPat sty (ConPatIn c pats)
= if null pats then
ppr sty c
else
- ppCat [ppr sty c, interppSP sty pats] -- ParPats put in the parens
+ hsep [ppr sty c, interppSP sty pats] -- ParPats put in the parens
pprInPat sty (ConOpPatIn pat1 op fixity pat2)
- = ppCat [ppr sty pat1, ppr sty op, ppr sty pat2] -- ParPats put in parens
+ = hsep [ppr sty pat1, ppr sty op, ppr sty 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)
= let
pp_pat = pprInPat sty pat
in
- ppBeside (ppChar '-') (
+ (<>) (char '-') (
case pat of
LitPatIn _ -> pp_pat
- _ -> ppParens pp_pat
+ _ -> parens pp_pat
)
pprInPat sty (ParPatIn pat)
- = ppParens (pprInPat sty pat)
+ = parens (pprInPat sty pat)
pprInPat sty (ListPatIn pats)
- = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
+ = brackets (interpp'SP sty pats)
pprInPat sty (TuplePatIn pats)
- = ppParens (interpp'SP sty pats)
+ = parens (interpp'SP sty pats)
pprInPat sty (NPlusKPatIn n k)
- = ppBesides [ppLparen, ppr sty n, ppChar '+', ppr sty k, ppRparen]
+ = parens (hcat [ppr sty n, char '+', ppr sty k])
pprInPat sty (RecPatIn con rpats)
- = ppCat [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))]
+ = hsep [ppr sty con, braces (hsep (punctuate comma (map (pp_rpat sty) rpats)))]
where
- pp_rpat PprForUser (v, _, True) = ppr PprForUser v
- pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppChar '=', ppr sty p]
+ pp_rpat sty (v, _, True) | userStyle sty = ppr PprForUser v
+ pp_rpat sty (v, p, _) = hsep [ppr sty v, char '=', ppr sty p]
\end{code}
\begin{code}
\end{code}
\begin{code}
-pprOutPat sty (WildPat ty) = ppChar '_'
+pprOutPat sty (WildPat ty) = char '_'
pprOutPat sty (VarPat var) = ppr sty var
-pprOutPat sty (LazyPat pat) = ppBesides [ppChar '~', ppr sty pat]
+pprOutPat sty (LazyPat pat) = hcat [char '~', ppr sty pat]
pprOutPat sty (AsPat name pat)
- = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen]
+ = parens (hcat [ppr sty name, char '@', ppr sty pat])
pprOutPat sty (ConPat name ty [])
- = ppBeside (ppr sty name)
+ = (<>) (ppr sty name)
(ifPprShowAll sty (pprConPatTy sty ty))
pprOutPat sty (ConPat name ty pats)
- = ppBesides [ppLparen, ppr sty name, ppSP,
- interppSP sty pats, ppRparen,
- ifPprShowAll sty (pprConPatTy sty ty) ]
+ = hcat [parens (hcat [ppr sty name, space, interppSP sty pats]),
+ ifPprShowAll sty (pprConPatTy sty ty) ]
pprOutPat sty (ConOpPat pat1 op pat2 ty)
- = ppBesides [ppLparen, ppr sty pat1, ppSP, pprSym sty op, ppSP, ppr sty pat2, ppRparen]
+ = parens (hcat [ppr sty pat1, space, ppr sty op, space, ppr sty pat2])
pprOutPat sty (ListPat ty pats)
- = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
+ = brackets (interpp'SP sty pats)
pprOutPat sty (TuplePat pats)
- = ppParens (interpp'SP sty pats)
+ = parens (interpp'SP sty pats)
pprOutPat sty (RecPat con ty rpats)
- = ppBesides [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))]
+ = hcat [ppr sty con, braces (hsep (punctuate comma (map (pp_rpat sty) rpats)))]
where
- pp_rpat PprForUser (v, _, True) = ppr PprForUser v
- pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppChar '=', ppr sty p]
+ pp_rpat sty (v, _, True) | userStyle sty = ppr PprForUser v
+ pp_rpat sty (v, p, _) = hsep [ppr sty v, char '=', ppr sty 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
- = ppBesides [ppLparen, ppr sty n, ppChar '+', ppr sty k, ppRparen]
+ = parens (hcat [ppr sty n, char '+', ppr sty k])
pprOutPat sty (DictPat dicts methods)
- = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")],
- ppBracket (interpp'SP sty dicts),
- ppBesides [ppBracket (interpp'SP sty methods), ppRparen]]
+ = parens (sep [ptext SLIT("{-dict-}"),
+ brackets (interpp'SP sty dicts),
+ brackets (interpp'SP sty methods)])
pprConPatTy sty ty
- = ppParens (ppr sty ty)
+ = parens (ppr sty ty)
\end{code}
%************************************************************************
isNoClassOpPragmas NoClassOpPragmas = True
instance Outputable name => Outputable (ClassPragmas name) where
- ppr sty NoClassPragmas = ppNil
+ ppr sty NoClassPragmas = empty
instance Outputable name => Outputable (ClassOpPragmas name) where
- ppr sty NoClassOpPragmas = ppNil
+ ppr sty NoClassOpPragmas = empty
instance Outputable name => Outputable (InstancePragmas name) where
- ppr sty NoInstancePragmas = ppNil
+ ppr sty NoInstancePragmas = empty
instance Outputable name => Outputable (GenPragmas name) where
- ppr sty NoGenPragmas = ppNil
+ ppr sty 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 = ppNil
+ ppr sty NoClassPragmas = empty
ppr sty (SuperDictPragmas sdsel_prags)
- = ppAbove (ppPStr SLIT("{-superdict pragmas-}"))
+ = ($$) (ptext SLIT("{-superdict pragmas-}"))
(ppr sty sdsel_prags)
instance Outputable name => Outputable (ClassOpPragmas name) where
- ppr sty NoClassOpPragmas = ppNil
+ ppr sty NoClassOpPragmas = empty
ppr sty (ClassOpPragmas op_prags defm_prags)
- = ppAbove (ppCat [ppPStr SLIT("{-meth-}"), ppr sty op_prags])
- (ppCat [ppPStr SLIT("{-defm-}"), ppr sty defm_prags])
+ = ($$) (hsep [ptext SLIT("{-meth-}"), ppr sty op_prags])
+ (hsep [ptext SLIT("{-defm-}"), ppr sty defm_prags])
instance Outputable name => Outputable (InstancePragmas name) where
- ppr sty NoInstancePragmas = ppNil
+ ppr sty NoInstancePragmas = empty
ppr sty (SimpleInstancePragma dfun_pragmas)
- = ppCat [ppPStr SLIT("{-dfun-}"), ppr sty dfun_pragmas]
+ = hsep [ptext SLIT("{-dfun-}"), ppr sty dfun_pragmas]
ppr sty (ConstantInstancePragma dfun_pragmas name_pragma_pairs)
- = ppAbove (ppCat [ppPStr SLIT("{-constm-}"), ppr sty dfun_pragmas])
- (ppAboves (map pp_pair name_pragma_pairs))
+ = ($$) (hsep [ptext SLIT("{-constm-}"), ppr sty dfun_pragmas])
+ (vcat (map pp_pair name_pragma_pairs))
where
pp_pair (n, prags)
- = ppCat [ppr sty n, ppEquals, ppr sty prags]
+ = hsep [ppr sty n, equals, ppr sty prags]
ppr sty (SpecialisedInstancePragma dfun_pragmas spec_pragma_info)
- = ppAbove (ppCat [ppPStr SLIT("{-spec'd-}"), ppr sty dfun_pragmas])
- (ppAboves (map pp_info spec_pragma_info))
+ = ($$) (hsep [ptext SLIT("{-spec'd-}"), ppr sty dfun_pragmas])
+ (vcat (map pp_info spec_pragma_info))
where
pp_info (ty_maybes, num_dicts, prags)
- = ppBesides [ppLbrack, ppInterleave ppSP (map pp_ty ty_maybes), ppRbrack,
- ppLparen, ppInt num_dicts, ppRparen, ppEquals, ppr sty prags]
- pp_ty Nothing = ppPStr SLIT("_N_")
+ = hcat [brackets (hsep (map pp_ty ty_maybes)),
+ parens (int num_dicts), equals, ppr sty prags]
+ pp_ty Nothing = ptext SLIT("_N_")
pp_ty (Just t)= ppr sty t
instance Outputable name => Outputable (GenPragmas name) where
- ppr sty NoGenPragmas = ppNil
+ ppr sty NoGenPragmas = empty
ppr sty (GenPragmas arity_maybe upd_maybe def strictness unfolding specs)
- = ppCat [pp_arity arity_maybe, pp_upd upd_maybe, -- ToDo: print def?
+ = hsep [pp_arity arity_maybe, pp_upd upd_maybe, -- ToDo: print def?
pp_str strictness, pp_unf unfolding,
pp_specs specs]
where
- pp_arity Nothing = ppNil
- pp_arity (Just i) = ppBeside (ppPStr SLIT("ARITY=")) (ppInt i)
+ pp_arity Nothing = empty
+ pp_arity (Just i) = (<>) (ptext SLIT("ARITY=")) (int i)
- pp_upd Nothing = ppNil
+ pp_upd Nothing = empty
pp_upd (Just u) = ppUpdateInfo sty u
- pp_str NoImpStrictness = ppNil
+ pp_str NoImpStrictness = empty
pp_str (ImpStrictness is_bot demands wrkr_prags)
- = ppBesides [ppPStr SLIT("IS_BOT="), ppr sty is_bot,
- ppPStr SLIT("STRICTNESS="), ppStr (showList demands ""),
- ppPStr SLIT(" {"), ppr sty wrkr_prags, ppChar '}']
+ = hcat [ptext SLIT("IS_BOT="), ppr sty is_bot,
+ ptext SLIT("STRICTNESS="), text (showList demands ""),
+ ptext SLIT(" {"), ppr sty wrkr_prags, char '}']
- pp_unf NoImpUnfolding = ppPStr SLIT("NO_UNFOLDING")
- pp_unf (ImpMagicUnfolding m) = ppBeside (ppPStr SLIT("MAGIC=")) (ppPStr m)
- pp_unf (ImpUnfolding g core) = ppBeside (ppPStr SLIT("UNFOLD=")) (ppr sty core)
+ 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_specs [] = ppNil
+ pp_specs [] = empty
pp_specs specs
- = ppBesides [ppPStr SLIT("SPECS=["), ppInterleave ppSP (map pp_spec specs), ppChar ']']
+ = hcat [ptext SLIT("SPECS=["), hsep (map pp_spec specs), char ']']
where
pp_spec (ty_maybes, num_dicts, gprags)
- = ppCat [ppLbrack, ppInterleave ppSP (map pp_MaB ty_maybes), ppRbrack, ppInt num_dicts, ppr sty gprags]
+ = hsep [brackets (hsep (map pp_MaB ty_maybes)), int num_dicts, ppr sty gprags]
- pp_MaB Nothing = ppPStr SLIT("_N_")
+ pp_MaB Nothing = ptext SLIT("_N_")
pp_MaB (Just x) = ppr sty x
\end{code}
EXP_MODULE(HsBasic) ,
EXP_MODULE(HsMatches) ,
EXP_MODULE(HsPat) ,
- EXP_MODULE(HsTypes)
+ EXP_MODULE(HsTypes),
+ NewOrData(..)
) where
IMP_Ubiq()
import HsDecls ( HsDecl(..), TyDecl(..), InstDecl(..), ClassDecl(..),
DefaultDecl(..),
FixityDecl(..),
- ConDecl(..), BangType(..),
+ ConDecl(..), ConDetails(..), BangType(..),
IfaceSig(..), HsIdInfo, SpecDataSig(..), SpecInstSig(..),
hsDeclName
)
import HsPragmas ( ClassPragmas, ClassOpPragmas,
DataPragmas, GenPragmas, InstancePragmas )
import HsCore
+import TyCon ( NewOrData(..) )
-- others:
import FiniteMap ( FiniteMap )
import Outputable ( ifPprShowAll, ifnotPprForUser, interpp'SP, Outputable(..) )
import Pretty
import SrcLoc ( SrcLoc )
+#if __GLASGOW_HASKELL__ >= 202
+import Name
+#endif
\end{code}
@Fake@ is a placeholder type; for when tyvars and uvars aren't used.
ppr sty (HsModule name iface_version exports imports fixities
decls src_loc)
- = ppAboves [
+ = vcat [
ifPprShowAll sty (ppr sty src_loc),
ifnotPprForUser sty (pp_iface_version iface_version),
case exports of
- Nothing -> ppCat [ppPStr SLIT("module"), ppPStr name, ppPStr SLIT("where")]
- Just es -> ppAboves [
- ppCat [ppPStr SLIT("module"), ppPStr name, ppLparen],
- ppNest 8 (interpp'SP sty es),
- ppNest 4 (ppPStr SLIT(") where"))
+ 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 4 (ptext SLIT(") where"))
],
pp_nonnull imports,
pp_nonnull fixities,
pp_nonnull decls
]
where
- pp_nonnull [] = ppNil
- pp_nonnull xs = ppAboves (map (ppr sty) xs)
+ pp_nonnull [] = empty
+ pp_nonnull xs = vcat (map (ppr sty) xs)
- pp_iface_version Nothing = ppNil
- pp_iface_version (Just n) = ppCat [ppStr "{-# INTERFACE", ppInt n, ppStr "#-}"]
+ pp_iface_version Nothing = empty
+ pp_iface_version (Just n) = hsep [text "{-# INTERFACE", int n, text "#-}"]
\end{code}
IMP_Ubiq()
-import Outputable ( interppSP, ifnotPprForUser )
+import Outputable --( interppSP, ifnotPprForUser )
import Kind ( Kind {- instance Outputable -} )
import Name ( nameOccName )
import Pretty
instance (Outputable name) => Outputable (HsTyVar name) where
ppr sty (UserTyVar name) = ppr_hs_tyname sty name
- ppr sty (IfaceTyVar name kind) = ppCat [ppr_hs_tyname sty name, ppPStr SLIT("::"), ppr sty kind]
+ ppr sty (IfaceTyVar name kind) = hsep [ppr_hs_tyname sty name, ptext SLIT("::"), ppr sty kind]
-- Here comes a rather gross hack.
ppr_forall sty ctxt_prec [] [] ty
= ppr_mono_ty sty ctxt_prec ty
ppr_forall sty ctxt_prec tvs ctxt ty
- = ppSep [ppPStr SLIT("_forall_"), ppBracket (interppSP sty tvs),
- pprContext sty ctxt, ppPStr SLIT("=>"),
+ = 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) -> Pretty
-pprContext sty [] = ppNil
+pprContext :: (Outputable name) => PprStyle -> (Context name) -> Doc
+pprContext sty [] = empty
pprContext sty context
- = ppCat [ppCurlies (ppIntersperse pp'SP (map ppr_assert context))]
+ = hsep [braces (hsep (punctuate comma (map ppr_assert context)))]
where
- ppr_assert (clas, ty) = ppCat [ppr sty clas, ppr sty ty]
+ ppr_assert (clas, ty) = hsep [ppr sty clas, ppr sty ty]
\end{code}
\begin{code}
pREC_FUN = (1 :: Int)
pREC_CON = (2 :: Int)
-maybeParen :: Bool -> Pretty -> Pretty
-maybeParen True p = ppParens p
+maybeParen :: Bool -> Doc -> Doc
+maybeParen True p = parens p
maybeParen False p = p
-- printing works more-or-less as for Types
-pprHsType, pprParendHsType :: (Outputable name) => PprStyle -> HsType name -> Pretty
+pprHsType, pprParendHsType :: (Outputable name) => PprStyle -> HsType name -> Doc
pprHsType sty ty = ppr_mono_ty sty pREC_TOP ty
pprParendHsType sty ty = ppr_mono_ty sty pREC_CON ty
p2 = ppr_mono_ty sty pREC_TOP ty2
in
maybeParen (ctxt_prec >= pREC_FUN)
- (ppSep [p1, ppBeside (ppPStr SLIT("-> ")) p2])
+ (sep [p1, (<>) (ptext SLIT("-> ")) p2])
ppr_mono_ty sty ctxt_prec (MonoTupleTy _ tys)
- = ppParens (ppInterleave ppComma (map (ppr sty) tys))
+ = parens (sep (punctuate comma (map (ppr sty) tys)))
ppr_mono_ty sty ctxt_prec (MonoListTy _ ty)
- = ppBesides [ppLbrack, ppr_mono_ty sty pREC_TOP ty, ppRbrack]
+ = brackets (ppr_mono_ty sty pREC_TOP ty)
ppr_mono_ty sty ctxt_prec (MonoTyApp fun_ty arg_ty)
= maybeParen (ctxt_prec >= pREC_CON)
- (ppCat [ppr_mono_ty sty pREC_FUN fun_ty, ppr_mono_ty sty pREC_CON arg_ty])
+ (hsep [ppr_mono_ty sty pREC_FUN fun_ty, ppr_mono_ty sty pREC_CON arg_ty])
ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty)
- = ppCurlies (ppCat [ppr sty clas, ppr_mono_ty sty pREC_CON ty])
+ = braces (hsep [ppr sty clas, ppr_mono_ty sty pREC_CON ty])
-- Curlies are temporary
\end{code}
\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_
+--cmpHsType :: (a -> a -> TAG_) -> HsType a -> HsType a -> TAG_
+--cmpContext :: (a -> a -> TAG_) -> Context a -> Context a -> TAG_
cmpHsTyVar cmp (UserTyVar v1) (UserTyVar v2) = v1 `cmp` v2
cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2
opt_GranMacros,
opt_Haskell_1_3,
opt_HiMap,
- opt_HiSuffix,
- opt_HiSuffixPrelude,
opt_IgnoreIfacePragmas,
opt_IgnoreStrictnessPragmas,
opt_IrrefutableEverything,
opt_Verbose,
opt_WarnNameShadowing,
- opt_NoWarnIncompletePatterns
-
+ opt_WarnUnusedNames,
+ opt_WarnIncompletePatterns,
+ opt_TyConPruning
) where
IMPORT_1_3(Array(array, (//)))
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
import PreludeGlaST -- bad bad bad boy, Will (_Array internals)
+#else
+import GlaExts
+import ArrBase
+import PrelBase (Lift(..))
+#endif
import Argv
CHK_Ubiq() -- debugging consistency check
-- (Sigh, what a HACK, Andy. WDP 96/01)
| SimplCaseMerge
+ | SimplCaseScrutinee -- This flag tells that the expression being simplified is
+ -- the scrutinee of a case expression, so we should
+ -- apply the scrutinee discount when considering inlinings.
+ -- See SimplVar.lhs
\end{code}
%************************************************************************
opt_D_dump_realC = lookUp SLIT("-ddump-realC")
opt_D_dump_rn = lookUp SLIT("-ddump-rn")
opt_D_dump_simpl = lookUp SLIT("-ddump-simpl")
-opt_D_dump_simpl_iterations = lookUp SLIT("-ddump-simpl_iterations")
+opt_D_dump_simpl_iterations = lookUp SLIT("-ddump-simpl-iterations")
opt_D_dump_spec = lookUp SLIT("-ddump-spec")
opt_D_dump_stg = lookUp SLIT("-ddump-stg")
opt_D_dump_stranal = lookUp SLIT("-ddump-stranal")
opt_GlasgowExts = lookUp SLIT("-fglasgow-exts")
opt_Haskell_1_3 = lookUp SLIT("-fhaskell-1.3")
opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files
-opt_HiSuffix = lookup_str "-hisuf="
-opt_HiSuffixPrelude = lookup_str "-hisuf-prelude="
opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas")
opt_IgnoreStrictnessPragmas = lookUp SLIT("-fignore-strictness-pragmas")
opt_IrrefutableEverything = lookUp SLIT("-firrefutable-everything")
opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" lIBERATE_CASE_THRESHOLD
opt_WarnNameShadowing = lookUp SLIT("-fwarn-name-shadowing")
-opt_NoWarnIncompletePatterns = lookUp SLIT("-fno-warn-incomplete-patterns")
+opt_WarnIncompletePatterns = not (lookUp SLIT("-fno-warn-incomplete-patterns"))
+opt_WarnUnusedNames = lookUp SLIT("-fwarn-unused-names")
+opt_TyConPruning = not (lookUp SLIT("-fno-tycon-pruning"))
-- opt_UnfoldingUseThreshold = lookup_int "-funfolding-use-threshold"
-- opt_UnfoldingOverrideThreshold = lookup_int "-funfolding-override-threshold"
tagOf_SimplSwitch SimplNoLetFromStrictLet = ILIT(29)
tagOf_SimplSwitch SimplDontFoldBackAppend = ILIT(30)
tagOf_SimplSwitch SimplCaseMerge = ILIT(31)
+tagOf_SimplSwitch SimplCaseScrutinee = ILIT(32)
+
-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
tagOf_SimplSwitch _ = panic# "tagOf_SimplSwitch"
-lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplCaseMerge)
+lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplCaseScrutinee)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-#if __GLASGOW_HASKELL__ >= 200
+#if __GLASGOW_HASKELL__ == 201
# define ARRAY Array
# define LIFT GHCbase.Lift
# define SET_TO =:
(=:) a b = (a,b)
+#elif __GLASGOW_HASKELL__ >= 202
+# define ARRAY Array
+# define LIFT Lift
+# define SET_TO =:
+(=:) a b = (a,b)
#else
# define ARRAY _Array
# define LIFT _Lift
IMP_Ubiq(){-uitous-}
-import Bag ( bagToList )
+import Bag --( bagToList )
import PprStyle ( PprStyle(..) )
import Pretty
import SrcLoc ( noSrcLoc, SrcLoc{-instance-} )
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable
+#endif
\end{code}
\begin{code}
-type Error = PprStyle -> Pretty
-type Warning = PprStyle -> Pretty
-type Message = PprStyle -> Pretty
+type Error = PprStyle -> Doc
+type Warning = PprStyle -> Doc
+type Message = PprStyle -> Doc
addErrLoc :: SrcLoc -> String -> Error -> Error
addErrLoc locn title rest_of_err_msg sty
- = ppHang (ppBesides [ppr PprForUser locn,
- if null title then ppNil else ppStr (": " ++ title),
- ppChar ':'])
+ = hang (hcat [ppr PprForUser locn,
+ if null title then empty else text (": " ++ title),
+ char ':'])
4 (rest_of_err_msg sty)
addShortErrLocLine, addShortWarnLocLine :: SrcLoc -> Error -> Error
addShortErrLocLine locn rest_of_err_msg sty
- = ppHang (ppBeside (ppr PprForUser locn) (ppChar ':'))
+ = hang ((<>) (ppr PprForUser locn) (char ':'))
4 (rest_of_err_msg sty)
addShortWarnLocLine locn rest_of_err_msg sty
- = ppHang (ppBeside (ppr PprForUser locn) (ppPStr SLIT(":warning:")))
+ = hang ((<>) (ppr PprForUser locn) (ptext SLIT(":warning:")))
4 (rest_of_err_msg sty)
dontAddErrLoc :: String -> Error -> Error
dontAddErrLoc title rest_of_err_msg sty
- = ppHang (ppBesides [ppStr title, ppChar ':'])
+ = hang (hcat [text title, char ':'])
4 (rest_of_err_msg sty)
-pprBagOfErrors :: PprStyle -> Bag Error -> Pretty
+pprBagOfErrors :: PprStyle -> Bag Error -> Doc
pprBagOfErrors sty bag_of_errors
= let pretties = map ( \ e -> e sty ) (bagToList bag_of_errors) in
- ppAboves (map (\ p -> ppAbove ppSP p) pretties)
+ vcat (map (\ p -> ($$) space p) pretties)
\end{code}
\begin{code}
import MkIface -- several functions
import TcModule ( typecheckModule )
-import Desugar ( deSugar, DsMatchContext, pprDsWarnings, DsWarnFlavour {-TEMP!-} )
+import Desugar ( deSugar, pprDsWarnings
+#if __GLASGOW_HASKELL__ <= 200
+ , DsMatchContext, DsWarnFlavour
+#endif
+ )
import SimplCore ( core2core )
import CoreToStg ( topCoreBindsToStg )
import StgSyn ( collectFinalStgBinders )
import PprType ( GenType, GenTyVar ) -- instances
import TyVar ( GenTyVar ) -- instances
import Unique ( Unique ) -- instances
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable ( Outputable(..) )
+#endif
\end{code}
\begin{code}
doIt :: ([CoreToDo], [StgToDo]) -> String -> IO ()
doIt (core_cmds, stg_cmds) input_pgm
- = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.02, for Haskell 1.3" "" >>
+ = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.03, for Haskell 1.4" "" >>
-- ******* READER
show_pass "Reader" >>
case tc_results
of { (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds),
- local_tycons, inst_info, pragma_tycon_specs,
+ local_tycons, local_classes, inst_info, pragma_tycon_specs,
ddump_deriv) ->
doDump opt_D_dump_tc "Typechecked:"
- (pp_show (ppAboves [
+ (pp_show (vcat [
ppr pprStyle recsel_binds,
ppr pprStyle class_binds,
ppr pprStyle inst_binds,
- ppAboves (map (\ (i,e) -> ppr pprStyle (VarMonoBind i e)) const_binds),
+ ppr pprStyle const_binds,
ppr pprStyle val_binds])) >>
doDump opt_D_dump_deriv "Derived instances:"
(if isEmptyBag ds_warnings then
return ()
else
- hPutStr stderr (ppShow pprCols (pprDsWarnings pprErrorsStyle ds_warnings))
+ hPutStr stderr (pp_show (pprDsWarnings pprErrorsStyle ds_warnings))
>> hPutStr stderr "\n"
) >>
- doDump opt_D_dump_ds "Desugared:" (pp_show (ppAboves
+ doDump opt_D_dump_ds "Desugared:" (pp_show (vcat
(map (pprCoreBinding pprStyle) desugared)))
>>
\ (simplified,
SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) ->
- doDump opt_D_dump_simpl "Simplified:" (pp_show (ppAboves
+ doDump opt_D_dump_simpl "Simplified:" (pp_show (vcat
(map (pprCoreBinding pprStyle) simplified)))
>>
\ (stg_binds2, cost_centre_info) ->
doDump opt_D_dump_stg "STG syntax:"
- (pp_show (ppAboves (map (pprPlainStgBinding pprStyle) stg_binds2)))
+ (pp_show (vcat (map (pprPlainStgBinding pprStyle) stg_binds2)))
>>
-- Dump instance decls and type signatures into the interface file
final_ids = collectFinalStgBinders stg_binds2
in
_scc_ "Interface"
- ifaceDecls if_handle rn_mod inst_info final_ids simplified >>
+ ifaceDecls if_handle local_tycons local_classes inst_info final_ids simplified >>
endIface if_handle >>
-- We are definitely done w/ interface-file stuff at this point:
-- (See comments near call to "startIface".)
doDump opt_D_dump_flatC "Flat Abstract C:"
(dumpRealC flat_abstractC) >>
+ _scc_ "CodeOutput"
-- You can have C (c_output) or assembly-language (ncg_output),
-- but not both. [Allowing for both gives a space leak on
-- flat_abstractC. WDP 94/10]
doDump switch hdr string
= if switch
- then hPutStr stderr hdr >>
+ then hPutStr stderr ("\n\n" ++ (take 80 $ repeat '=')) >>
+ hPutStr stderr ('\n': hdr) >>
hPutStr stderr ('\n': string) >>
hPutStr stderr "\n"
else return ()
(pprStyle, pprErrorsStyle)
| opt_PprStyle_All = (PprShowAll, PprShowAll)
| opt_PprStyle_Debug = (PprDebug, PprDebug)
- | opt_PprStyle_User = (PprForUser, PprForUser)
- | otherwise = (PprDebug, PprForUser)
+ | opt_PprStyle_User = (PprQuote, PprQuote)
+ | otherwise = (PprDebug, PprQuote)
-pp_show p = ppShow {-WAS:pprCols-}10000{-random-} p
+pp_show p = show p -- ToDo: use pprCols
checkErrors errs_bag warns_bag
| not (isEmptyBag errs_bag)
- = hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle errs_bag))
+ = hPutStr stderr (pp_show (pprBagOfErrors pprErrorsStyle errs_bag))
>> hPutStr stderr "\n" >>
- hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle warns_bag))
+ hPutStr stderr (pp_show (pprBagOfErrors pprErrorsStyle warns_bag))
>> hPutStr stderr "\n" >>
ghcExit 1
| not (isEmptyBag warns_bag)
- = hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle warns_bag)) >>
+ = hPutStr stderr (pp_show (pprBagOfErrors pprErrorsStyle warns_bag)) >>
hPutStr stderr "\n"
| otherwise = return ()
ppSourceStats (HsModule name version exports imports fixities decls src_loc)
- = ppAboves (map pp_val
+ = vcat (map pp_val
[("ExportAll ", export_all), -- 1 if no export list
("ExportDecls ", export_ds),
("ExportModules ", export_ms),
("SpecialisedBinds ", bind_specs)
])
where
- pp_val (str, 0) = ppNil
- pp_val (str, n) = ppBesides [ppStr str, ppInt n]
+ pp_val (str, 0) = empty
+ pp_val (str, n) = hcat [text str, int n]
fixity_ds = length fixities
type_decls = [d | TyD d@(TySynonym _ _ _ _) <- decls]
- data_decls = [d | TyD d@(TyData _ _ _ _ _ _ _) <- decls]
- newt_decls = [d | TyD d@(TyNew _ _ _ _ _ _ _) <- decls]
+ data_decls = [d | TyD d@(TyData DataType _ _ _ _ _ _ _) <- decls]
+ newt_decls = [d | TyD d@(TyData NewType _ _ _ _ _ _ _) <- decls]
type_ds = length type_decls
data_ds = length data_decls
newt_ds = length newt_decls
count_binds EmptyBinds = (0,0,0,0,0)
count_binds (ThenBinds b1 b2) = count_binds b1 `add5` count_binds b2
- count_binds (SingleBind b) = case count_bind b of
- (vs,fs) -> (vs,fs,0,0,0)
- count_binds (BindWith b sigs) = case (count_bind b, count_sigs sigs) of
- ((vs,fs),(ts,_,ss,is)) -> (vs,fs,ts,ss,is)
-
- count_bind EmptyBind = (0,0)
- count_bind (NonRecBind b) = count_monobinds b
- count_bind (RecBind b) = count_monobinds b
+ count_binds (MonoBind b sigs _) = case (count_monobinds b, count_sigs sigs) of
+ ((vs,fs),(ts,_,ss,is)) -> (vs,fs,ts,ss,is)
count_monobinds EmptyMonoBinds = (0,0)
count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2
spec_info (Just (False, _)) = (0,0,0,0,1,0)
spec_info (Just (True, _)) = (0,0,0,0,0,1)
- data_info (TyData _ _ _ constrs derivs _ _)
+ data_info (TyData _ _ _ _ constrs derivs _ _)
= (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds})
- data_info (TyNew _ _ _ constr derivs _ _)
- = (1, case derivs of {Nothing -> 0; Just ds -> length ds})
class_info (ClassDecl _ _ _ meth_sigs def_meths _ _)
= case count_sigs meth_sigs of
import CmdLineOpts
import Id ( idType, dataConRawArgTys, dataConFieldLabels, isDataCon,
- getIdInfo, idWantsToBeINLINEd, omitIfaceSigForId,
+ getIdInfo, getInlinePragma, omitIfaceSigForId,
dataConStrictMarks, StrictnessMark(..),
SYN_IE(IdSet), idSetToList, unionIdSets, unitIdSet, minusIdSet,
isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet,
- GenId{-instance NamedThing/Outputable-}
+ GenId{-instance NamedThing/Outputable-}, SYN_IE(Id)
+
)
-import IdInfo ( StrictnessInfo, ArityInfo, Unfolding,
+import IdInfo ( StrictnessInfo, ArityInfo,
arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo,
- getWorkerId_maybe, bottomIsGuaranteed
+ getWorkerId_maybe, bottomIsGuaranteed, IdInfo
)
import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding), GenCoreExpr, GenCoreBinding(..) )
-import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..) )
+import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding )
import FreeVars ( addExprFVs )
import Name ( isLocallyDefined, isWiredInName, modAndOcc, getName, pprOccName,
- OccName, occNameString, nameOccName, nameString, isExported, pprNonSym,
- Name {-instance NamedThing-}, Provenance
+ OccName, occNameString, nameOccName, nameString, isExported,
+ Name {-instance NamedThing-}, Provenance, NamedThing(..)
)
-import TyCon ( TyCon{-instance NamedThing-} )
-import Class ( GenClass(..){-instance NamedThing-}, GenClassOp, classOpLocalType )
-import FieldLabel ( FieldLabel{-instance NamedThing-} )
-import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy )
+import TyCon ( TyCon(..) {-instance NamedThing-} )
+import Class ( GenClass(..){-instance NamedThing-}, SYN_IE(Class), GenClassOp,
+ classOpLocalType, classSig )
+import FieldLabel ( FieldLabel{-instance NamedThing-},
+ fieldLabelName, fieldLabelType )
+import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy,
+ mkTyVarTy, SYN_IE(Type)
+ )
import TyVar ( GenTyVar {- instance Eq -} )
import Unique ( Unique {- instance Eq -} )
import PprType
import PprCore ( pprIfaceUnfolding )
import Pretty
-import Unpretty -- ditto
+import Outputable ( printDoc )
-import Bag ( bagToList )
+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 )
+ assertPanic, panic{-ToDo:rm-}, pprTrace,
+ pprPanic
+ )
+import Outputable ( Outputable(..) )
\end{code}
ifaceDecls :: Maybe Handle
- -> RenamedHsModule
+ -> [TyCon] -> [Class]
-> Bag InstInfo
-> [Id] -- Ids used at code-gen time; they have better pragma info!
-> [CoreBinding] -- In dependency order, later depend on earlier
ifaceFixities if_hdl fixities >>
return ()
-ifaceDecls Nothing rn_mod inst_info final_ids simplified = return ()
+ifaceDecls Nothing tycons classes inst_info final_ids simplified = return ()
ifaceDecls (Just hdl)
- (HsModule _ _ _ _ _ decls _)
+ tycons classes
inst_infos
final_ids binds
- | null decls = return ()
+ | null_decls = return ()
-- You could have a module with just (re-)exports/instances in it
| otherwise
= ifaceInstances hdl inst_infos >>= \ needed_ids ->
hPutStr hdl "_declarations_\n" >>
- ifaceTCDecls hdl decls >>
+ ifaceClasses hdl classes >>
+ ifaceTyCons hdl tycons >>
ifaceBinds hdl needed_ids final_ids binds >>
return ()
+ where
+ null_decls = null binds &&
+ null tycons &&
+ null classes &&
+ isEmptyBag inst_infos
\end{code}
\begin{code}
hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
where
upp_uses (m, mv, versions)
- = uppBesides [upp_module m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
- upp_import_versions (sort_versions versions), uppSemi]
+ = hcat [upp_module m, space, int mv, ptext SLIT(" :: "),
+ upp_import_versions (sort_versions versions), semi]
-- For imported versions we do print the version number
upp_import_versions nvs
- = uppIntersperse uppSP [ uppCat [ppr_unqual_name n, uppInt v] | (n,v) <- nvs ]
+ = hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- nvs ]
ifaceInstanceModules if_hdl [] = return ()
ifaceInstanceModules if_hdl imods
= hPutStr if_hdl "_instance_modules_\n" >>
- hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods))) >>
+ printDoc OneLineMode 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)
- = uppBesides [upp_module mod_name, uppSP,
- uppCat (map upp_avail (sortLt lt_avail avails)),
- uppSemi]
+ = hcat [upp_module mod_name, space,
+ hsep (map upp_avail (sortLt lt_avail avails)),
+ semi]
ifaceFixities if_hdl [] = return ()
ifaceFixities if_hdl fixities
= hPutStr if_hdl "_fixities_\n" >>
hPutCol if_hdl upp_fixity fixities
-
-ifaceTCDecls if_hdl decls
- = hPutCol if_hdl ppr_decl tc_decls_for_iface
- where
- tc_decls_for_iface = sortLt lt_decl (filter for_iface decls)
- for_iface decl@(ClD _) = for_iface_name (hsDeclName decl)
- for_iface decl@(TyD _) = for_iface_name (hsDeclName decl)
- for_iface other_decl = False
-
- for_iface_name name = isLocallyDefined name &&
- not (isWiredInName name)
-
- lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2
\end{code}
%************************************************************************
forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty)
renumbered_ty = renumber_ty forall_ty
in
- uppBesides [uppPStr SLIT("instance "), ppr_ty renumbered_ty,
- uppPStr SLIT(" = "), ppr_unqual_name dfun_id, uppSemi]
+ hcat [ptext SLIT("instance "), ppr_ty 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 (Pretty, IdSet) -- The emitted stuff, plus a possibly-augmented set of needed Ids
+ -> Maybe (Doc, 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]
= Nothing -- Well, that was easy!
ifaceId get_idinfo needed_ids is_rec id rhs
- = Just (ppCat [sig_pretty, pp_double_semi, prag_pretty], new_needed_ids)
+ = Just (hsep [sig_pretty, pp_double_semi, prag_pretty], new_needed_ids)
where
- pp_double_semi = ppPStr SLIT(";;")
+ pp_double_semi = ptext SLIT(";;")
idinfo = get_idinfo id
- inline_pragma = idWantsToBeINLINEd id
+ inline_pragma = getInlinePragma id
ty_pretty = pprType PprInterface (initNmbr (nmbrType (idType id)))
- sig_pretty = ppBesides [ppr PprInterface (getOccName id), ppPStr SLIT(" _:_ "), ty_pretty]
+ sig_pretty = hcat [ppr PprInterface (getOccName id), ptext SLIT(" _:_ "), ty_pretty]
prag_pretty
- | opt_OmitInterfacePragmas = ppNil
- | otherwise = ppCat [arity_pretty, strict_pretty, unfold_pretty, pp_double_semi]
+ | opt_OmitInterfacePragmas = empty
+ | otherwise = hsep [arity_pretty, strict_pretty, unfold_pretty, pp_double_semi]
------------ Arity --------------
arity_pretty = ppArityInfo PprInterface (arityInfo idinfo)
strict_pretty = ppStrictnessInfo PprInterface strict_info
------------ Unfolding --------------
- unfold_pretty | show_unfold = ppCat [ppPStr SLIT("_U_"), pprIfaceUnfolding rhs]
- | otherwise = ppNil
+ unfold_pretty | show_unfold = hsep [ptext SLIT("_U_"), pprIfaceUnfolding rhs]
+ | otherwise = empty
- show_unfold = not implicit_unfolding && -- Unnecessary
- (inline_pragma || not dodgy_unfolding) -- Dangerous
+ show_unfold = not implicit_unfolding && -- Not unnecessary
+ not dodgy_unfolding -- Not dangerous
implicit_unfolding = maybeToBool maybe_worker ||
bottomIsGuaranteed strict_info
- dodgy_unfolding = is_rec || -- No recursive unfoldings please!
- case guidance of -- Too big to show
- UnfoldNever -> True
+ dodgy_unfolding = case guidance of -- True <=> too big to show, or the Inline pragma
+ UnfoldNever -> True -- says it shouldn't be inlined
other -> False
guidance = calcUnfoldingGuidance inline_pragma
-> IO ()
ifaceBinds hdl needed_ids final_ids binds
- = hPutStr hdl (uppShow 0 (prettyToUn (ppAboves pretties))) >>
+ = mapIO (printDoc OneLineMode hdl) pretties >>
hPutStr hdl "\n"
where
final_id_map = listToUFM [(id,id) | id <- final_ids]
-- provoke earlier ones to be emitted
go needed [] = if not (isEmptyIdSet needed) then
pprTrace "ifaceBinds: free vars:"
- (ppSep (map (ppr PprDebug) (idSetToList needed))) $
+ (sep (map (ppr PprDebug) (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, [Pretty])
+ go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [Doc])
go_rec needed pairs
| null pretties = (needed, [])
| otherwise = (final_needed, more_pretties ++ pretties)
%* *
%************************************************************************
+\begin{code}
+ifaceTyCons hdl tycons = hPutCol hdl upp_tycon (sortLt (<) (filter (for_iface_name . getName) tycons ))
+ifaceClasses hdl classes = hPutCol hdl upp_class (sortLt (<) (filter (for_iface_name . getName) classes))
+
+for_iface_name name = isLocallyDefined name &&
+ not (isWiredInName name)
+
+upp_tycon tycon = ifaceTyCon PprInterface tycon
+upp_class clas = ifaceClass PprInterface clas
+\end{code}
+
+
+\begin{code}
+ifaceTyCon :: PprStyle -> TyCon -> Doc
+ifaceTyCon sty tycon
+ = case tycon of
+ DataTyCon uniq name kind tyvars theta data_cons deriv new_or_data
+ -> hsep [ ptext (keyword new_or_data),
+ ppr_decl_context sty theta,
+ ppr sty name,
+ hsep (map (pprTyVarBndr sty) tyvars),
+ ptext SLIT("="),
+ hsep (punctuate (ptext SLIT(" | ")) (map ppr_con data_cons)),
+ semi
+ ]
+
+ SynTyCon uniq name kind arity tyvars ty
+ -> hsep [ ptext SLIT("type"),
+ ppr sty name,
+ hsep (map (pprTyVarBndr sty) tyvars),
+ ptext SLIT("="),
+ ppr sty ty,
+ semi
+ ]
+ other -> pprPanic "pprIfaceTyDecl" (ppr PprDebug tycon)
+ where
+ keyword NewType = SLIT("newtype")
+ keyword DataType = SLIT("data")
+
+ ppr_con data_con
+ | null field_labels
+ = hsep [ ppr sty name,
+ hsep (map ppr_arg_ty (strict_marks `zip` arg_tys))
+ ]
+
+ | otherwise
+ = hsep [ ppr sty name,
+ braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels))
+ ]
+ where
+ field_labels = dataConFieldLabels data_con
+ arg_tys = dataConRawArgTys data_con
+ strict_marks = dataConStrictMarks data_con
+ name = getName data_con
+
+ ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType sty ty
+
+ ppr_strict_mark NotMarkedStrict = empty
+ ppr_strict_mark MarkedStrict = ptext SLIT("! ")
+ -- The extra space helps the lexical analyser that lexes
+ -- interface files; it doesn't make the rigid operator/identifier
+ -- 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),
+ ptext SLIT("::"),
+ ppr_strict_mark strict_mark <> pprParendType sty (fieldLabelType field_label)
+ ]
+
+ifaceClass sty clas
+ = hsep [ptext SLIT("class"),
+ ppr_decl_context sty theta,
+ ppr sty clas, -- Print the name
+ pprTyVarBndr sty tyvar,
+ pp_ops,
+ semi
+ ]
+ where
+ (tyvar, super_classes, ops) = classSig clas
+ theta = super_classes `zip` repeat (mkTyVarTy tyvar)
+
+ pp_ops | null ops = empty
+ | otherwise = hsep [ptext SLIT("where"),
+ braces (hsep (punctuate semi (map ppr_classop ops)))
+ ]
+
+ ppr_classop op = hsep [ppr sty (getOccName op),
+ ptext SLIT("::"),
+ ppr sty (classOpLocalType op)
+ ]
+
+ppr_decl_context :: PprStyle -> [(Class,Type)] -> Doc
+ppr_decl_context sty [] = empty
+ppr_decl_context sty theta
+ = braces (hsep (punctuate comma (map (ppr_dict) theta)))
+ <>
+ ptext SLIT(" =>")
+ where
+ ppr_dict (clas,ty) = hsep [ppr sty clas, ppr sty ty]
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Random small things}
+%* *
+%************************************************************************
+
When printing export lists, we print like this:
Avail f f
AvailTC C [C, x, y] C(x,y)
AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
\begin{code}
-upp_avail NotAvailable = uppNil
+upp_avail NotAvailable = empty
upp_avail (Avail name) = upp_occname (getOccName name)
-upp_avail (AvailTC name []) = uppNil
-upp_avail (AvailTC name ns) = uppBesides [upp_occname (getOccName name), bang, upp_export ns']
+upp_avail (AvailTC name []) = empty
+upp_avail (AvailTC name ns) = hcat [upp_occname (getOccName name), bang, upp_export ns']
where
- bang | name `elem` ns = uppNil
- | otherwise = uppChar '!'
+ bang | name `elem` ns = empty
+ | otherwise = char '!'
ns' = filter (/= name) ns
-upp_export [] = uppNil
-upp_export names = uppBesides [uppChar '(',
- uppIntersperse uppSP (map (upp_occname . getOccName) names),
- uppChar ')']
+upp_export [] = empty
+upp_export names = hcat [char '(',
+ hsep (map (upp_occname . getOccName) names),
+ char ')']
-upp_fixity (occ, (Fixity prec dir, prov)) = uppBesides [upp_dir dir, uppSP,
- uppInt prec, uppSP,
- upp_occname occ, uppSemi]
-upp_dir InfixR = uppPStr SLIT("infixr")
-upp_dir InfixL = uppPStr SLIT("infixl")
-upp_dir InfixN = uppPStr SLIT("infix")
+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")
-ppr_unqual_name :: NamedThing a => a -> Unpretty -- Just its occurrence name
+ppr_unqual_name :: NamedThing a => a -> Doc -- Just its occurrence name
ppr_unqual_name name = upp_occname (getOccName name)
-ppr_name :: NamedThing a => a -> Unpretty -- Its full name
-ppr_name n = uppPStr (nameString (getName n))
+ppr_name :: NamedThing a => a -> Doc -- Its full name
+ppr_name n = ptext (nameString (getName n))
-upp_occname :: OccName -> Unpretty
-upp_occname occ = uppPStr (occNameString occ)
+upp_occname :: OccName -> Doc
+upp_occname occ = ptext (occNameString occ)
-upp_module :: Module -> Unpretty
-upp_module mod = uppPStr mod
+upp_module :: Module -> Doc
+upp_module mod = ptext mod
-uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util
+uppSemid x = ppr PprInterface x <> semi -- micro util
-ppr_ty ty = prettyToUn (pprType PprInterface ty)
-ppr_tyvar tv = prettyToUn (ppr PprInterface tv)
-ppr_tyvar_bndr tv = prettyToUn (pprTyVarBndr PprInterface tv)
+ppr_ty ty = pprType PprInterface ty
+ppr_tyvar tv = ppr PprInterface tv
+ppr_tyvar_bndr tv = pprTyVarBndr PprInterface tv
-ppr_decl decl = prettyToUn (ppr PprInterface decl) `uppBeside` uppSemi
+ppr_decl decl = ppr PprInterface decl <> semi
renumber_ty ty = initNmbr (nmbrType ty)
\end{code}
\begin{code}
hPutCol :: Handle
- -> (a -> Unpretty)
+ -> (a -> Doc)
-> [a]
-> IO ()
-hPutCol hdl fmt xs = hPutStr hdl (uppShow 0 (uppAboves (map fmt xs))) >>
- hPutStr hdl "\n"
+hPutCol hdl fmt xs = mapIO (printDoc OneLineMode hdl . fmt) xs
+
+mapIO :: (a -> IO b) -> [a] -> IO ()
+mapIO f [] = return ()
+mapIO f (x:xs) = f x >> mapIO f xs
\end{code}
import Stix
import MachMisc
+#if __GLASGOW_HASKELL__ >= 202
+import MachRegs hiding (Addr)
+#else
import MachRegs
+#endif
import AbsCUtils ( getAmodeRep, mixedTypeLocn,
nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
)
import Constants ( mIN_UPD_SIZE )
+import CLabel ( CLabel )
import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
fastLabelFromCI, closureUpdReqd
)
IMPORT_1_3(IO(Handle))
import MachMisc
+#if __GLASGOW_HASKELL__ >= 202
+import MachRegs hiding (Addr)
+#else
import MachRegs
+#endif
import MachCode
import PprMach
import PrimRep ( PrimRep{-instance Eq-} )
import RegAllocInfo ( mkMRegsState, MRegsState )
import Stix ( StixTree(..), StixReg(..), CodeSegment )
-import UniqSupply ( returnUs, thenUs, mapUs, SYN_IE(UniqSM) )
-import Unpretty ( uppPutStr, uppShow, uppAboves, SYN_IE(Unpretty) )
+import UniqSupply ( returnUs, thenUs, mapUs, SYN_IE(UniqSM), UniqSupply )
+import Outputable ( printDoc )
+import Pretty ( Doc, vcat, Mode(..) )
\end{code}
The 96/03 native-code generator has machine-independent and
machine instructions.
\item[@PprMach@:] @pprInstr@ turns an @Instr@ into text (well, really
- an @Unpretty@).
+ an @Doc@).
\item[@RegAllocInfo@:] In the register allocator, we manipulate
@MRegsState@s, which are @BitSet@s, one bit per machine register.
So, here we go:
\begin{code}
writeRealAsm :: Handle -> AbstractC -> UniqSupply -> IO ()
-
writeRealAsm handle absC us
- = _scc_ "writeRealAsm" (uppPutStr handle 80 (runNCG absC us))
+ = _scc_ "writeRealAsm" (printDoc LeftMode handle (runNCG absC us))
dumpRealAsm :: AbstractC -> UniqSupply -> String
-
-dumpRealAsm absC us = uppShow 80 (runNCG absC us)
+dumpRealAsm absC us = show (runNCG absC us)
runNCG absC
= genCodeAbstractC absC `thenUs` \ treelists ->
@codeGen@ is the top-level code-generation function:
\begin{code}
-codeGen :: [[StixTree]] -> UniqSM Unpretty
+codeGen :: [[StixTree]] -> UniqSM Doc
codeGen trees
= mapUs genMachCode trees `thenUs` \ dynamic_codes ->
let
static_instrs = scheduleMachCode dynamic_codes
in
- returnUs (uppAboves (map pprInstr static_instrs))
+ returnUs (vcat (map pprInstr static_instrs))
\end{code}
Top level code generator for a chunk of stix code:
import MachCode ( SYN_IE(InstrList) )
import MachMisc ( Instr )
+#if __GLASGOW_HASKELL__ >= 202
+import MachRegs hiding (Addr)
+#else
import MachRegs
+#endif
import RegAllocInfo
import AbsCSyn ( MagicId )
IMP_Ubiq(){-uitious-}
import MachMisc -- may differ per-platform
+#if __GLASGOW_HASKELL__ >= 202
+import MachRegs hiding (Addr(..))
+import qualified MachRegs (Addr(..))
+#define MachRegsAddr MachRegs.Addr
+#define MachRegsAddrRegImm MachRegs.AddrRegImm
+#define MachRegsAddrRegReg MachRegs.AddrRegReg
+#else
import MachRegs
+#define MachRegsAddr Addr
+#define MachRegsAddrRegImm AddrRegImm
+#define MachRegsAddrRegReg AddrRegReg
+#endif
import AbsCSyn ( MagicId )
import AbsCUtils ( magicIdPrimRep )
-import CLabel ( isAsmTemp )
+import CLabel ( isAsmTemp, CLabel )
import Maybes ( maybeToBool, expectJust )
import OrdList -- quite a bit of it
-import Pretty ( prettyToUn, ppRational )
+import PprStyle
+import Pretty ( ptext, rational )
import PrimRep ( isFloatingRep, PrimRep(..) )
-import PrimOp ( PrimOp(..) )
+import PrimOp ( PrimOp(..), showPrimOp )
import Stix ( getUniqLabelNCG, StixTree(..),
StixReg(..), CodeSegment(..)
)
import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
mapAccumLUs, SYN_IE(UniqSM)
)
-import Unpretty ( uppPStr )
import Util ( panic, assertPanic )
\end{code}
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
- DATA TF [ImmLab (prettyToUn (ppRational d))],
+ DATA TF [ImmLab (rational d)],
SEGMENT TextSegment,
LDA tmp (AddrImm (ImmCLbl lbl)),
LD TF dst (AddrReg tmp)]
src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
code__2 dst = code .
- mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
+ mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (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 (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
+ mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (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 (Addr (Just src1) Nothing src2)) (OpReg dst))
+ mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (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 (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ MOV L (OpImm src2) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
MOV L (OpReg src1) (OpReg eax),
CLTD,
- IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ IDIV sz (OpAddr (MachRegsAddr (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 (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ MOV L (OpReg src2) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
MOV L (OpReg src1) (OpReg eax),
CLTD,
- IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ IDIV sz (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
in
returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
-----------------------
DATA DF [dblImmLit d],
SEGMENT TextSegment,
SETHI (HI (ImmCLbl lbl)) tmp,
- LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
+ LD DF (MachRegsAddrRegImm tmp (LO (ImmCLbl lbl))) dst]
in
returnUs (Any DoubleRep code)
= case primop of
IntNegOp -> trivialUCode (SUB False False g0) x
IntAbsOp -> absIntCode x
-
NotOp -> trivialUCode (XNOR False g0) x
FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
+
DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
= case primop of
FloatExpOp -> (True, SLIT("exp"))
FloatLogOp -> (True, SLIT("log"))
+ FloatSqrtOp -> (True, SLIT("sqrt"))
FloatSinOp -> (True, SLIT("sin"))
FloatCosOp -> (True, SLIT("cos"))
DoubleExpOp -> (False, SLIT("exp"))
DoubleLogOp -> (False, SLIT("log"))
+ DoubleSqrtOp -> (True, SLIT("sqrt"))
DoubleSinOp -> (False, SLIT("sin"))
DoubleCosOp -> (False, SLIT("cos"))
DoubleSinhOp -> (False, SLIT("sinh"))
DoubleCoshOp -> (False, SLIT("cosh"))
DoubleTanhOp -> (False, SLIT("tanh"))
+ _ -> panic ("Monadic PrimOp not handled: " ++ showPrimOp PprDebug 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 Addr 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 (AddrRegImm reg off) code)
+ returnUs (Amode (MachRegsAddrRegImm reg off) code)
getAmode (StPrim IntAddOp [x, StInt i])
= getNewRegNCG PtrRep `thenUs` \ tmp ->
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnUs (Amode (AddrRegImm reg off) code)
+ returnUs (Amode (MachRegsAddrRegImm reg off) code)
getAmode leaf
| maybeToBool imm
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnUs (Amode (Addr (Just reg) Nothing off) code)
+ returnUs (Amode (MachRegsAddr (Just reg) Nothing off) code)
getAmode (StPrim IntAddOp [x, StInt i])
| maybeToBool imm
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnUs (Amode (Addr (Just reg) Nothing off) code)
+ returnUs (Amode (MachRegsAddr (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 (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
+ returnUs (Amode (MachRegsAddr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
getAmode leaf
| maybeToBool imm
reg = registerName register tmp
off = Nothing
in
- returnUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code)
+ returnUs (Amode (MachRegsAddr (Just reg) Nothing (ImmInt 0)) code)
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnUs (Amode (AddrRegImm reg off) code)
+ returnUs (Amode (MachRegsAddrRegImm reg off) code)
getAmode (StPrim IntAddOp [x, StInt i])
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnUs (Amode (AddrRegImm reg off) code)
+ returnUs (Amode (MachRegsAddrRegImm reg off) code)
getAmode (StPrim IntAddOp [x, y])
= getNewRegNCG PtrRep `thenUs` \ tmp1 ->
reg2 = registerName register2 tmp2
code__2 = asmParThen [code1, code2]
in
- returnUs (Amode (AddrRegReg reg1 reg2) code__2)
+ returnUs (Amode (MachRegsAddrRegReg reg1 reg2) code__2)
getAmode leaf
| maybeToBool imm
let
code = mkSeqInstr (SETHI (HI imm__2) tmp)
in
- returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
+ returnUs (Amode (MachRegsAddrRegImm tmp (LO imm__2)) code)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
reg = registerName register tmp
off = ImmInt 0
in
- returnUs (Amode (AddrRegImm reg off) code)
+ returnUs (Amode (MachRegsAddrRegImm reg off) code)
#endif {- sparc_TARGET_ARCH -}
\end{code}
code = registerCode register tmp
target = registerName register tmp
in
- returnSeq code [JMP (AddrRegReg target g0), NOP]
+ returnSeq code [JMP (MachRegsAddrRegReg target g0), NOP]
#endif {- sparc_TARGET_ARCH -}
\end{code}
code = asmParThen (map ($ asmVoid) argCode)
in
returnSeq code [
- LDA pv (AddrImm (ImmLab (uppPStr fn))),
+ LDA pv (AddrImm (ImmLab (ptext fn))),
JSR ra (AddrReg pv) nRegs,
LDGP gp (AddrReg ra)]
where
call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
MOV L (OpImm (ImmCLbl lbl))
-- this is hardwired
- (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
- JMP (OpImm (ImmLit (uppPStr (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
+ (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 104))),
+ JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
LABEL lbl]
in
returnInstrs call
= mapUs get_call_arg args `thenUs` \ argCode ->
let
nargs = length args
- code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
+ code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 80))),
+ MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
]
]
code2 = asmParThen (map ($ asmVoid) (reverse argCode))
call = [CALL fn__2 -- ,
-- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
- -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
+ -- MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
]
in
returnSeq (code1 . code2) call
-- underscore prefix
-- ToDo:needed (WDP 96/03) ???
fn__2 = case (_HEAD_ fn) of
- '.' -> ImmLit (uppPStr fn)
- _ -> ImmLab (uppPStr fn)
+ '.' -> ImmLit (ptext fn)
+ _ -> ImmLab (ptext fn)
------------
get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code
-- underscore prefix
-- ToDo:needed (WDP 96/03) ???
fn__2 = case (_HEAD_ fn) of
- '.' -> ImmLit (uppPStr fn)
- _ -> ImmLab (uppPStr fn)
+ '.' -> ImmLit (ptext fn)
+ _ -> ImmLab (ptext fn)
------------------------------------
{- Try to get a value into a specific register (or registers) for
code__2 dst = code . mkSeqInstrs [
-- to fix: should spill instead of using R1
- MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- FILD (primRepToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
+ MOV L (OpReg src) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ FILD (primRepToSize pk) (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
in
returnUs (Any pk code__2)
code__2 dst = let
in code . mkSeqInstrs [
FRNDINT,
- FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)),
- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
+ FIST L (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)),
+ MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
in
returnUs (Any IntRep code__2)
--- /dev/null
+_interface_ MachMisc 1
+_exports_
+MachMisc fixedHdrSizeInWords fmtAsmLbl varHdrSizeInWords underscorePrefix;
+_declarations_
+1 fixedHdrSizeInWords _:_ PrelBase.Int ;;
+2 fmtAsmLbl _:_ PrelBase.String -> PrelBase.String ;;
+1 varHdrSizeInWords _:_ SMRep.SMRep -> PrelBase.Int ;;
+1 underscorePrefix _:_ PrelBase.Bool ;;
import AbsCSyn ( MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
+import CLabel ( CLabel )
import CmdLineOpts ( opt_SccProfilingOn )
import Literal ( mkMachInt, Literal(..) )
import MachRegs ( stgReg, callerSaves, RegLoc(..),
- Imm(..), Reg(..), Addr
+ Imm(..), Reg(..)
+#if __GLASGOW_HASKELL__ >= 202
+ )
+import qualified MachRegs (Addr)
+#define MachRegsAddr MachRegs.Addr
+#else
+ , Addr(..)
)
+#define MachRegsAddr Addr
+#endif
+
import OrdList ( OrdList )
import PrimRep ( PrimRep(..) )
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
-- Loads and stores.
- | LD Size Reg Addr -- size, dst, src
- | LDA Reg Addr -- dst, src
- | LDAH Reg Addr -- dst, src
- | LDGP Reg Addr -- 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 Addr -- size, src, dst
+ | ST Size Reg MachRegsAddr -- size, src, dst
-- Int Arithmetic.
| BI Cond Reg Imm
| BF Cond Reg Imm
| BR Imm
- | JMP Reg Addr Int
+ | JMP Reg MachRegsAddr Int
| BSR Imm Int
- | JSR Reg Addr Int
+ | JSR Reg MachRegsAddr Int
-- Alpha-specific pseudo-ops.
| FABS
| FADD Size Operand -- src
| FADDP
- | FIADD Size Addr -- src
+ | FIADD Size MachRegsAddr -- src
| FCHS
| FCOM Size Operand -- src
| FCOS
| FDIV Size Operand -- src
| FDIVP
- | FIDIV Size Addr -- src
+ | FIDIV Size MachRegsAddr -- src
| FDIVR Size Operand -- src
| FDIVRP
- | FIDIVR Size Addr -- src
- | FICOM Size Addr -- src
- | FILD Size Addr Reg -- src, dst
- | FIST Size Addr -- 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 Addr -- src
+ | FIMUL Size MachRegsAddr -- src
| FRNDINT
| FSIN
| FSQRT
| FSTP Size Operand -- dst
| FSUB Size Operand -- src
| FSUBP
- | FISUB Size Addr -- src
+ | FISUB Size MachRegsAddr -- src
| FSUBR Size Operand -- src
| FSUBRP
- | FISUBR Size Addr -- src
+ | FISUBR Size MachRegsAddr -- src
| FTST
| FCOMP Size Operand -- src
| FUCOMPP
| CLTD -- sign extend %eax into %edx:%eax
data Operand
- = OpReg Reg -- register
- | OpImm Imm -- immediate value
- | OpAddr Addr -- memory reference
+ = OpReg Reg -- register
+ | OpImm Imm -- immediate value
+ | OpAddr MachRegsAddr -- memory reference
#endif {- i386_TARGET_ARCH -}
\end{code}
-- Loads and stores.
- | LD Size Addr Reg -- size, src, dst
- | ST Size Reg Addr -- 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 Addr -- target
+ | JMP MachRegsAddr -- target
| CALL Imm Int Bool -- target, args, terminal
data RI = RIReg Reg
#endif
) where
+#if __GLASGOW_HASKELL__ >= 202
+import GlaExts hiding (Addr)
+import FastString
+import Ubiq
+#else
IMP_Ubiq(){-uitous-}
+#endif
import AbsCSyn ( MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
-import Pretty ( ppStr, ppRational, ppShow )
+import CLabel ( CLabel )
+import Outputable ( Outputable(..) )
+import Pretty ( Doc, text, rational )
import PrimOp ( PrimOp(..) )
import PrimRep ( PrimRep(..) )
import Stix ( sStLitLbl, StixTree(..), StixReg(..),
Unique{-instance Ord3-}
)
import UniqSupply ( getUnique, returnUs, thenUs, SYN_IE(UniqSM) )
-import Unpretty ( uppStr, SYN_IE(Unpretty) )
-import Util ( panic )
+import Util ( panic, Ord3(..) )
\end{code}
% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
= ImmInt Int
| ImmInteger Integer -- Sigh.
| ImmCLbl CLabel -- AbstractC Label (with baggage)
- | ImmLab Unpretty -- Simple string label (underscore-able)
- | ImmLit Unpretty -- Simple string
+ | ImmLab Doc -- Simple string label (underscore-able)
+ | ImmLit Doc -- Simple string
IF_ARCH_sparc(
| LO Imm -- Possible restrictions...
| HI Imm
,)
-strImmLit s = ImmLit (uppStr s)
+strImmLit s = ImmLit (text s)
dblImmLit r
= strImmLit (
IF_ARCH_alpha({-prepend nothing-}
,IF_ARCH_i386( '0' : 'd' :
,IF_ARCH_sparc('0' : 'r' :,)))
- ppShow 80 (ppRational r))
+ show (rational r))
\end{code}
% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#ifdef DEBUG
instance Outputable Reg where
- ppr sty r = ppStr (show r)
+ ppr sty r = text (show r)
#endif
cmpReg (FixedReg i) (FixedReg i') = cmp_ihash i i'
--- /dev/null
+module NcgLoop
+
+ (
+ module StixPrim,
+ module MachMisc,
+ module Stix
+ ) where
+
+import StixPrim
+import MachMisc
+import Stix
+
module PprMach ( pprInstr ) where
-IMP_Ubiq(){-uitious-}
IMPORT_1_3(Char(isPrint,isDigit))
-IMPORT_1_3(qualified GHCbase(Addr(..))) -- to see innards
+#if __GLASGOW_HASKELL__ == 201
+import qualified GHCbase(Addr(..)) -- to see innards
+IMP_Ubiq(){-uitious-}
+#elif __GLASGOW_HASKELL__ >= 202
+import qualified GlaExts (Addr(..))
+import GlaExts hiding (Addr(..))
+import FastString
+import Ubiq
+#else
+IMP_Ubiq(){-uitious-}
+#endif
import MachRegs -- may differ per-platform
import MachMisc
import Maybes ( maybeToBool )
import OrdList ( OrdList )
import Stix ( CodeSegment(..), StixTree )
-import Unpretty -- all of it
+import Pretty -- all of it
-#if __GLASGOW_HASKELL__ >= 200
+#if __GLASGOW_HASKELL__ == 201
a_HASH x = GHCbase.A# x
pACK_STR x = packCString x
+#elif __GLASGOW_HASKELL__ >= 202
+a_HASH x = GlaExts.A# x
+pACK_STR x = mkFastCharString x
#else
a_HASH x = A# x
pACK_STR x = mkFastCharString x --_packCString x
For x86, the way we print a register name depends
on which bit of it we care about. Yurgh.
\begin{code}
-pprReg :: IF_ARCH_i386(Size ->,) Reg -> Unpretty
+pprReg :: IF_ARCH_i386(Size ->,) Reg -> Doc
pprReg IF_ARCH_i386(s,) r
= case r of
FixedReg i -> ppr_reg_no IF_ARCH_i386(s,) i
MappedReg i -> ppr_reg_no IF_ARCH_i386(s,) i
- other -> uppStr (show other) -- should only happen when debugging
+ other -> text (show other) -- should only happen when debugging
where
#if alpha_TARGET_ARCH
- ppr_reg_no :: FAST_REG_NO -> Unpretty
- ppr_reg_no i = uppPStr
+ ppr_reg_no :: FAST_REG_NO -> Doc
+ ppr_reg_no i = ptext
(case i of {
ILIT( 0) -> SLIT("$0"); ILIT( 1) -> SLIT("$1");
ILIT( 2) -> SLIT("$2"); ILIT( 3) -> SLIT("$3");
})
#endif
#if i386_TARGET_ARCH
- ppr_reg_no :: Size -> FAST_REG_NO -> Unpretty
- ppr_reg_no B i = uppPStr
+ ppr_reg_no :: Size -> FAST_REG_NO -> Doc
+ ppr_reg_no B i = ptext
(case i of {
ILIT( 0) -> SLIT("%al"); ILIT( 1) -> SLIT("%bl");
ILIT( 2) -> SLIT("%cl"); ILIT( 3) -> SLIT("%dl");
})
{- UNUSED:
- ppr_reg_no HB i = uppPStr
+ ppr_reg_no HB i = ptext
(case i of {
ILIT( 0) -> SLIT("%ah"); ILIT( 1) -> SLIT("%bh");
ILIT( 2) -> SLIT("%ch"); ILIT( 3) -> SLIT("%dh");
-}
{- UNUSED:
- ppr_reg_no S i = uppPStr
+ ppr_reg_no S i = ptext
(case i of {
ILIT( 0) -> SLIT("%ax"); ILIT( 1) -> SLIT("%bx");
ILIT( 2) -> SLIT("%cx"); ILIT( 3) -> SLIT("%dx");
})
-}
- ppr_reg_no L i = uppPStr
+ ppr_reg_no L i = ptext
(case i of {
ILIT( 0) -> SLIT("%eax"); ILIT( 1) -> SLIT("%ebx");
ILIT( 2) -> SLIT("%ecx"); ILIT( 3) -> SLIT("%edx");
_ -> SLIT("very naughty I386 double word register")
})
- ppr_reg_no F i = uppPStr
+ ppr_reg_no F i = ptext
(case i of {
--ToDo: rm these (???)
ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
_ -> SLIT("very naughty I386 float register")
})
- ppr_reg_no DF i = uppPStr
+ ppr_reg_no DF i = ptext
(case i of {
--ToDo: rm these (???)
ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
})
#endif
#if sparc_TARGET_ARCH
- ppr_reg_no :: FAST_REG_NO -> Unpretty
- ppr_reg_no i = uppPStr
+ ppr_reg_no :: FAST_REG_NO -> Doc
+ ppr_reg_no i = ptext
(case i of {
ILIT( 0) -> SLIT("%g0"); ILIT( 1) -> SLIT("%g1");
ILIT( 2) -> SLIT("%g2"); ILIT( 3) -> SLIT("%g3");
%************************************************************************
\begin{code}
-pprSize :: Size -> Unpretty
+pprSize :: Size -> Doc
-pprSize x = uppPStr (case x of
+pprSize x = ptext (case x of
#if alpha_TARGET_ARCH
B -> SLIT("b")
BU -> SLIT("bu")
F -> SLIT("")
-- D -> SLIT("d") UNUSED
DF -> SLIT("d")
+ )
+pprStSize :: Size -> Doc
+pprStSize x = ptext (case x of
+ B -> SLIT("b")
+ BU -> SLIT("b")
+-- HW -> SLIT("hw") UNUSED
+-- HWU -> SLIT("uhw") UNUSED
+ W -> SLIT("")
+ F -> SLIT("")
+-- D -> SLIT("d") UNUSED
+ DF -> SLIT("d")
#endif
)
\end{code}
%************************************************************************
\begin{code}
-pprCond :: Cond -> Unpretty
+pprCond :: Cond -> Doc
-pprCond c = uppPStr (case c of {
+pprCond c = ptext (case c of {
#if alpha_TARGET_ARCH
EQQ -> SLIT("eq");
LTT -> SLIT("lt");
%************************************************************************
\begin{code}
-pprImm :: Imm -> Unpretty
+pprImm :: Imm -> Doc
-pprImm (ImmInt i) = uppInt i
-pprImm (ImmInteger i) = uppInteger i
+pprImm (ImmInt i) = int i
+pprImm (ImmInteger i) = integer i
pprImm (ImmCLbl l) = pprCLabel_asm l
pprImm (ImmLit s) = s
-pprImm (ImmLab s) | underscorePrefix = uppBeside (uppChar '_') s
+pprImm (ImmLab s) | underscorePrefix = (<>) (char '_') s
| otherwise = s
#if sparc_TARGET_ARCH
pprImm (LO i)
- = uppBesides [ pp_lo, pprImm i, uppRparen ]
+ = hcat [ pp_lo, pprImm i, rparen ]
where
- pp_lo = uppPStr (pACK_STR (a_HASH "%lo("#))
+ pp_lo = ptext (pACK_STR (a_HASH "%lo("#))
pprImm (HI i)
- = uppBesides [ pp_hi, pprImm i, uppRparen ]
+ = hcat [ pp_hi, pprImm i, rparen ]
where
- pp_hi = uppPStr (pACK_STR (a_HASH "%hi("#))
+ pp_hi = ptext (pACK_STR (a_HASH "%hi("#))
#endif
\end{code}
%************************************************************************
\begin{code}
-pprAddr :: Addr -> Unpretty
+pprAddr :: Addr -> Doc
#if alpha_TARGET_ARCH
-pprAddr (AddrReg r) = uppParens (pprReg r)
+pprAddr (AddrReg r) = parens (pprReg r)
pprAddr (AddrImm i) = pprImm i
pprAddr (AddrRegImm r1 i)
- = uppBeside (pprImm i) (uppParens (pprReg r1))
+ = (<>) (pprImm i) (parens (pprReg r1))
#endif
-------------------
if (off == 0) then
pp_imm
else if (off < 0) then
- uppBeside pp_imm (uppInt off)
+ (<>) pp_imm (int off)
else
- uppBesides [pp_imm, uppChar '+', uppInt off]
+ hcat [pp_imm, char '+', int off]
pprAddr (Addr base index displacement)
= let
pp_disp = ppr_disp displacement
- pp_off p = uppBeside pp_disp (uppParens p)
+ pp_off p = (<>) pp_disp (parens p)
pp_reg r = pprReg L r
in
case (base,index) of
(Nothing, Nothing) -> pp_disp
(Just b, Nothing) -> pp_off (pp_reg b)
- (Nothing, Just (r,i)) -> pp_off (uppBesides [pp_reg r, uppComma, uppInt i])
- (Just b, Just (r,i)) -> pp_off (uppBesides [pp_reg b, uppComma, pp_reg r, uppComma, uppInt i])
+ (Nothing, Just (r,i)) -> pp_off (hcat [pp_reg r, comma, int i])
+ (Just b, Just (r,i)) -> pp_off (hcat [pp_reg b, comma, pp_reg r, comma, int i])
where
- ppr_disp (ImmInt 0) = uppNil
+ ppr_disp (ImmInt 0) = empty
ppr_disp imm = pprImm imm
#endif
pprAddr (AddrRegReg r1 (FixedReg ILIT(0))) = pprReg r1
pprAddr (AddrRegReg r1 r2)
- = uppBesides [ pprReg r1, uppChar '+', pprReg r2 ]
+ = hcat [ pprReg r1, char '+', pprReg r2 ]
pprAddr (AddrRegImm r1 (ImmInt i))
| i == 0 = pprReg r1
| not (fits13Bits i) = largeOffsetError i
- | otherwise = uppBesides [ pprReg r1, pp_sign, uppInt i ]
+ | otherwise = hcat [ pprReg r1, pp_sign, int i ]
where
- pp_sign = if i > 0 then uppChar '+' else uppNil
+ pp_sign = if i > 0 then char '+' else empty
pprAddr (AddrRegImm r1 (ImmInteger i))
| i == 0 = pprReg r1
| not (fits13Bits i) = largeOffsetError i
- | otherwise = uppBesides [ pprReg r1, pp_sign, uppInteger i ]
+ | otherwise = hcat [ pprReg r1, pp_sign, integer i ]
where
- pp_sign = if i > 0 then uppChar '+' else uppNil
+ pp_sign = if i > 0 then char '+' else empty
pprAddr (AddrRegImm r1 imm)
- = uppBesides [ pprReg r1, uppChar '+', pprImm imm ]
+ = hcat [ pprReg r1, char '+', pprImm imm ]
#endif
\end{code}
%************************************************************************
\begin{code}
-pprInstr :: Instr -> Unpretty
+pprInstr :: Instr -> Doc
-pprInstr (COMMENT s) = uppNil -- nuke 'em
---alpha: = uppBeside (uppPStr SLIT("\t# ")) (uppPStr s)
---i386 : = uppBeside (uppPStr SLIT("# ")) (uppPStr s)
---sparc: = uppBeside (uppPStr SLIT("! ")) (uppPStr s)
+pprInstr (COMMENT s) = empty -- nuke 'em
+--alpha: = (<>) (ptext SLIT("\t# ")) (ptext s)
+--i386 : = (<>) (ptext SLIT("# ")) (ptext s)
+--sparc: = (<>) (ptext SLIT("! ")) (ptext s)
pprInstr (SEGMENT TextSegment)
- = uppPStr
+ = ptext
IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-}
,IF_ARCH_sparc(SLIT("\t.text\n\t.align 4") {-word boundary-}
,IF_ARCH_i386((_PK_ ".text\n\t.align 2\x2c\&0x90") {-needs per-OS variation!-}
,)))
pprInstr (SEGMENT DataSegment)
- = uppPStr
+ = ptext
IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
,IF_ARCH_sparc(SLIT("\t.data\n\t.align 8") {-<8 will break double constants -}
,IF_ARCH_i386(SLIT(".data\n\t.align 2")
= let
pp_lab = pprCLabel_asm clab
in
- uppBesides [
+ hcat [
if not (externallyVisibleCLabel clab) then
- uppNil
+ empty
else
- uppBesides [uppPStr
+ hcat [ptext
IF_ARCH_alpha(SLIT("\t.globl\t")
,IF_ARCH_i386(SLIT(".globl ")
,IF_ARCH_sparc(SLIT("\t.global\t")
,)))
- , pp_lab, uppChar '\n'],
+ , pp_lab, char '\n'],
pp_lab,
- uppChar ':'
+ char ':'
]
pprInstr (ASCII False{-no backslash conversion-} str)
- = uppBesides [ uppPStr SLIT("\t.asciz "), uppChar '\"', uppStr str, uppChar '"' ]
+ = hcat [ ptext SLIT("\t.asciz "), char '\"', text str, char '"' ]
pprInstr (ASCII True str)
- = uppBeside (uppStr "\t.ascii \"") (asciify str 60)
+ = (<>) (text "\t.ascii \"") (asciify str 60)
where
- asciify :: String -> Int -> Unpretty
-
- asciify [] _ = uppStr "\\0\""
- asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60)
- asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
- asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
- asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
- asciify [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\""))
+ asciify :: String -> Int -> Doc
+
+ asciify [] _ = text "\\0\""
+ asciify s n | n <= 0 = (<>) (text "\"\n\t.ascii \"") (asciify s 60)
+ asciify ('\\':cs) n = (<>) (text "\\\\") (asciify cs (n-1))
+ asciify ('\"':cs) n = (<>) (text "\\\"") (asciify cs (n-1))
+ asciify (c:cs) n | isPrint c = (<>) (char c) (asciify cs (n-1))
+ asciify [c] _ = (<>) (text (charToC c)) (text ("\\0\""))
asciify (c:(cs@(d:_))) n
- | isDigit d = uppBeside (uppStr (charToC c)) (asciify cs 0)
- | otherwise = uppBeside (uppStr (charToC c)) (asciify cs (n-1))
+ | isDigit d = (<>) (text (charToC c)) (asciify cs 0)
+ | otherwise = (<>) (text (charToC c)) (asciify cs (n-1))
pprInstr (DATA s xs)
- = uppInterleave (uppChar '\n')
- [uppBeside (uppPStr pp_size) (pprImm x) | x <- xs]
+ = vcat [(<>) (ptext pp_size) (pprImm x) | x <- xs]
where
pp_size = case s of
#if alpha_TARGET_ARCH
#if alpha_TARGET_ARCH
pprInstr (LD size reg addr)
- = uppBesides [
- uppPStr SLIT("\tld"),
+ = hcat [
+ ptext SLIT("\tld"),
pprSize size,
- uppChar '\t',
+ char '\t',
pprReg reg,
- uppComma,
+ comma,
pprAddr addr
]
pprInstr (LDA reg addr)
- = uppBesides [
- uppPStr SLIT("\tlda\t"),
+ = hcat [
+ ptext SLIT("\tlda\t"),
pprReg reg,
- uppComma,
+ comma,
pprAddr addr
]
pprInstr (LDAH reg addr)
- = uppBesides [
- uppPStr SLIT("\tldah\t"),
+ = hcat [
+ ptext SLIT("\tldah\t"),
pprReg reg,
- uppComma,
+ comma,
pprAddr addr
]
pprInstr (LDGP reg addr)
- = uppBesides [
- uppPStr SLIT("\tldgp\t"),
+ = hcat [
+ ptext SLIT("\tldgp\t"),
pprReg reg,
- uppComma,
+ comma,
pprAddr addr
]
pprInstr (LDI size reg imm)
- = uppBesides [
- uppPStr SLIT("\tldi"),
+ = hcat [
+ ptext SLIT("\tldi"),
pprSize size,
- uppChar '\t',
+ char '\t',
pprReg reg,
- uppComma,
+ comma,
pprImm imm
]
pprInstr (ST size reg addr)
- = uppBesides [
- uppPStr SLIT("\tst"),
+ = hcat [
+ ptext SLIT("\tst"),
pprSize size,
- uppChar '\t',
+ char '\t',
pprReg reg,
- uppComma,
+ comma,
pprAddr addr
]
pprInstr (CLR reg)
- = uppBesides [
- uppPStr SLIT("\tclr\t"),
+ = hcat [
+ ptext SLIT("\tclr\t"),
pprReg reg
]
pprInstr (ABS size ri reg)
- = uppBesides [
- uppPStr SLIT("\tabs"),
+ = hcat [
+ ptext SLIT("\tabs"),
pprSize size,
- uppChar '\t',
+ char '\t',
pprRI ri,
- uppComma,
+ comma,
pprReg reg
]
pprInstr (NEG size ov ri reg)
- = uppBesides [
- uppPStr SLIT("\tneg"),
+ = hcat [
+ ptext SLIT("\tneg"),
pprSize size,
- if ov then uppPStr SLIT("v\t") else uppChar '\t',
+ if ov then ptext SLIT("v\t") else char '\t',
pprRI ri,
- uppComma,
+ comma,
pprReg reg
]
pprInstr (ADD size ov reg1 ri reg2)
- = uppBesides [
- uppPStr SLIT("\tadd"),
+ = hcat [
+ ptext SLIT("\tadd"),
pprSize size,
- if ov then uppPStr SLIT("v\t") else uppChar '\t',
+ if ov then ptext SLIT("v\t") else char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (SADD size scale reg1 ri reg2)
- = uppBesides [
- uppPStr (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
- uppPStr SLIT("add"),
+ = hcat [
+ ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
+ ptext SLIT("add"),
pprSize size,
- uppChar '\t',
+ char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (SUB size ov reg1 ri reg2)
- = uppBesides [
- uppPStr SLIT("\tsub"),
+ = hcat [
+ ptext SLIT("\tsub"),
pprSize size,
- if ov then uppPStr SLIT("v\t") else uppChar '\t',
+ if ov then ptext SLIT("v\t") else char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (SSUB size scale reg1 ri reg2)
- = uppBesides [
- uppPStr (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
- uppPStr SLIT("sub"),
+ = hcat [
+ ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
+ ptext SLIT("sub"),
pprSize size,
- uppChar '\t',
+ char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (MUL size ov reg1 ri reg2)
- = uppBesides [
- uppPStr SLIT("\tmul"),
+ = hcat [
+ ptext SLIT("\tmul"),
pprSize size,
- if ov then uppPStr SLIT("v\t") else uppChar '\t',
+ if ov then ptext SLIT("v\t") else char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (DIV size uns reg1 ri reg2)
- = uppBesides [
- uppPStr SLIT("\tdiv"),
+ = hcat [
+ ptext SLIT("\tdiv"),
pprSize size,
- if uns then uppPStr SLIT("u\t") else uppChar '\t',
+ if uns then ptext SLIT("u\t") else char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (REM size uns reg1 ri reg2)
- = uppBesides [
- uppPStr SLIT("\trem"),
+ = hcat [
+ ptext SLIT("\trem"),
pprSize size,
- if uns then uppPStr SLIT("u\t") else uppChar '\t',
+ if uns then ptext SLIT("u\t") else char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (NOT ri reg)
- = uppBesides [
- uppPStr SLIT("\tnot"),
- uppChar '\t',
+ = hcat [
+ ptext SLIT("\tnot"),
+ char '\t',
pprRI ri,
- uppComma,
+ comma,
pprReg reg
]
pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2
pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2
-pprInstr (NOP) = uppPStr SLIT("\tnop")
+pprInstr (NOP) = ptext SLIT("\tnop")
pprInstr (CMP cond reg1 ri reg2)
- = uppBesides [
- uppPStr SLIT("\tcmp"),
+ = hcat [
+ ptext SLIT("\tcmp"),
pprCond cond,
- uppChar '\t',
+ char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (FCLR reg)
- = uppBesides [
- uppPStr SLIT("\tfclr\t"),
+ = hcat [
+ ptext SLIT("\tfclr\t"),
pprReg reg
]
pprInstr (FABS reg1 reg2)
- = uppBesides [
- uppPStr SLIT("\tfabs\t"),
+ = hcat [
+ ptext SLIT("\tfabs\t"),
pprReg reg1,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (FNEG size reg1 reg2)
- = uppBesides [
- uppPStr SLIT("\tneg"),
+ = hcat [
+ ptext SLIT("\tneg"),
pprSize size,
- uppChar '\t',
+ char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3
pprInstr (CVTxy size1 size2 reg1 reg2)
- = uppBesides [
- uppPStr SLIT("\tcvt"),
+ = hcat [
+ ptext SLIT("\tcvt"),
pprSize size1,
- case size2 of {Q -> uppPStr SLIT("qc"); _ -> pprSize size2},
- uppChar '\t',
+ case size2 of {Q -> ptext SLIT("qc"); _ -> pprSize size2},
+ char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (FCMP size cond reg1 reg2 reg3)
- = uppBesides [
- uppPStr SLIT("\tcmp"),
+ = hcat [
+ ptext SLIT("\tcmp"),
pprSize size,
pprCond cond,
- uppChar '\t',
+ char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprReg reg2,
- uppComma,
+ comma,
pprReg reg3
]
pprInstr (FMOV reg1 reg2)
- = uppBesides [
- uppPStr SLIT("\tfmov\t"),
+ = hcat [
+ ptext SLIT("\tfmov\t"),
pprReg reg1,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
-pprInstr (BI NEVER reg lab) = uppNil
+pprInstr (BI NEVER reg lab) = empty
pprInstr (BI cond reg lab)
- = uppBesides [
- uppPStr SLIT("\tb"),
+ = hcat [
+ ptext SLIT("\tb"),
pprCond cond,
- uppChar '\t',
+ char '\t',
pprReg reg,
- uppComma,
+ comma,
pprImm lab
]
pprInstr (BF cond reg lab)
- = uppBesides [
- uppPStr SLIT("\tfb"),
+ = hcat [
+ ptext SLIT("\tfb"),
pprCond cond,
- uppChar '\t',
+ char '\t',
pprReg reg,
- uppComma,
+ comma,
pprImm lab
]
pprInstr (BR lab)
- = uppBeside (uppPStr SLIT("\tbr\t")) (pprImm lab)
+ = (<>) (ptext SLIT("\tbr\t")) (pprImm lab)
pprInstr (JMP reg addr hint)
- = uppBesides [
- uppPStr SLIT("\tjmp\t"),
+ = hcat [
+ ptext SLIT("\tjmp\t"),
pprReg reg,
- uppComma,
+ comma,
pprAddr addr,
- uppComma,
- uppInt hint
+ comma,
+ int hint
]
pprInstr (BSR imm n)
- = uppBeside (uppPStr SLIT("\tbsr\t")) (pprImm imm)
+ = (<>) (ptext SLIT("\tbsr\t")) (pprImm imm)
pprInstr (JSR reg addr n)
- = uppBesides [
- uppPStr SLIT("\tjsr\t"),
+ = hcat [
+ ptext SLIT("\tjsr\t"),
pprReg reg,
- uppComma,
+ comma,
pprAddr addr
]
pprInstr (FUNBEGIN clab)
- = uppBesides [
+ = hcat [
if (externallyVisibleCLabel clab) then
- uppBesides [uppPStr SLIT("\t.globl\t"), pp_lab, uppChar '\n']
+ hcat [ptext SLIT("\t.globl\t"), pp_lab, char '\n']
else
- uppNil,
- uppPStr SLIT("\t.ent "),
+ empty,
+ ptext SLIT("\t.ent "),
pp_lab,
- uppChar '\n',
+ char '\n',
pp_lab,
pp_ldgp,
pp_lab,
where
pp_lab = pprCLabel_asm clab
- pp_ldgp = uppPStr (pACK_STR (a_HASH ":\n\tldgp $29,0($27)\n"#))
- pp_frame = uppPStr (pACK_STR (a_HASH "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#))
+ 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"#))
pprInstr (FUNEND clab)
- = uppBeside (uppPStr SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
+ = (<>) (ptext SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
\end{code}
Continue with Alpha-only printing bits and bobs:
\begin{code}
-pprRI :: RI -> Unpretty
+pprRI :: RI -> Doc
pprRI (RIReg r) = pprReg r
pprRI (RIImm r) = pprImm r
-pprRegRIReg :: FAST_STRING -> Reg -> RI -> Reg -> Unpretty
+pprRegRIReg :: FAST_STRING -> Reg -> RI -> Reg -> Doc
pprRegRIReg name reg1 ri reg2
- = uppBesides [
- uppChar '\t',
- uppPStr name,
- uppChar '\t',
+ = hcat [
+ char '\t',
+ ptext name,
+ char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
-pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Unpretty
+pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc
pprSizeRegRegReg name size reg1 reg2 reg3
- = uppBesides [
- uppChar '\t',
- uppPStr name,
+ = hcat [
+ char '\t',
+ ptext name,
pprSize size,
- uppChar '\t',
+ char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprReg reg2,
- uppComma,
+ comma,
pprReg reg3
]
pprInstr (MOV size (OpReg src) (OpReg dst)) -- hack
| src == dst
- = uppPStr SLIT("")
+ = ptext SLIT("")
pprInstr (MOV size src dst)
= pprSizeOpOp SLIT("mov") size src dst
pprInstr (MOVZX size src dst) = pprSizeOpOpCoerce SLIT("movzx") L size src dst
pprInstr (PUSH size op) = pprSizeOp SLIT("push") size op
pprInstr (POP size op) = pprSizeOp SLIT("pop") size op
-pprInstr (NOP) = uppPStr SLIT("\tnop")
-pprInstr (CLTD) = uppPStr SLIT("\tcltd")
+pprInstr (NOP) = ptext SLIT("\tnop")
+pprInstr (CLTD) = ptext SLIT("\tcltd")
pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op)
pprInstr (JXX cond lab) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
-pprInstr (JMP (OpImm imm)) = uppBeside (uppPStr SLIT("\tjmp ")) (pprImm imm)
-pprInstr (JMP op) = uppBeside (uppPStr SLIT("\tjmp *")) (pprOperand L op)
+pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
+pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
pprInstr (CALL imm)
- = uppBesides [ uppPStr SLIT("\tcall "), pprImm imm ]
+ = hcat [ ptext SLIT("\tcall "), pprImm imm ]
-pprInstr SAHF = uppPStr SLIT("\tsahf")
-pprInstr FABS = uppPStr SLIT("\tfabs")
+pprInstr SAHF = ptext SLIT("\tsahf")
+pprInstr FABS = ptext SLIT("\tfabs")
pprInstr (FADD sz src@(OpAddr _))
- = uppBesides [uppPStr SLIT("\tfadd"), pprSize sz, uppSP, pprOperand sz src]
+ = hcat [ptext SLIT("\tfadd"), pprSize sz, space, pprOperand sz src]
pprInstr (FADD sz src)
- = uppPStr SLIT("\tfadd")
+ = ptext SLIT("\tfadd")
pprInstr FADDP
- = uppPStr SLIT("\tfaddp")
+ = ptext SLIT("\tfaddp")
pprInstr (FMUL sz src)
- = uppBesides [uppPStr SLIT("\tfmul"), pprSize sz, uppSP, pprOperand sz src]
+ = hcat [ptext SLIT("\tfmul"), pprSize sz, space, pprOperand sz src]
pprInstr FMULP
- = uppPStr SLIT("\tfmulp")
+ = ptext SLIT("\tfmulp")
pprInstr (FIADD size op) = pprSizeAddr SLIT("fiadd") size op
-pprInstr FCHS = uppPStr SLIT("\tfchs")
+pprInstr FCHS = ptext SLIT("\tfchs")
pprInstr (FCOM size op) = pprSizeOp SLIT("fcom") size op
-pprInstr FCOS = uppPStr SLIT("\tfcos")
+pprInstr FCOS = ptext SLIT("\tfcos")
pprInstr (FIDIV size op) = pprSizeAddr SLIT("fidiv") size op
pprInstr (FDIV sz src)
- = uppBesides [uppPStr SLIT("\tfdiv"), pprSize sz, uppSP, pprOperand sz src]
+ = hcat [ptext SLIT("\tfdiv"), pprSize sz, space, pprOperand sz src]
pprInstr FDIVP
- = uppPStr SLIT("\tfdivp")
+ = ptext SLIT("\tfdivp")
pprInstr (FDIVR sz src)
- = uppBesides [uppPStr SLIT("\tfdivr"), pprSize sz, uppSP, pprOperand sz src]
+ = hcat [ptext SLIT("\tfdivr"), pprSize sz, space, pprOperand sz src]
pprInstr FDIVRP
- = uppPStr SLIT("\tfdivpr")
+ = ptext SLIT("\tfdivpr")
pprInstr (FIDIVR size op) = pprSizeAddr SLIT("fidivr") size op
pprInstr (FICOM size op) = pprSizeAddr SLIT("ficom") size op
pprInstr (FILD sz op reg) = pprSizeAddrReg SLIT("fild") sz op reg
pprInstr (FIST size op) = pprSizeAddr SLIT("fist") size op
pprInstr (FLD sz (OpImm (ImmCLbl src)))
- = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppSP,pprCLabel_asm src]
+ = hcat [ptext SLIT("\tfld"),pprSize sz,space,pprCLabel_asm src]
pprInstr (FLD sz src)
- = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppSP,pprOperand sz src]
-pprInstr FLD1 = uppPStr SLIT("\tfld1")
-pprInstr FLDZ = uppPStr SLIT("\tfldz")
+ = hcat [ptext SLIT("\tfld"),pprSize sz,space,pprOperand sz src]
+pprInstr FLD1 = ptext SLIT("\tfld1")
+pprInstr FLDZ = ptext SLIT("\tfldz")
pprInstr (FIMUL size op) = pprSizeAddr SLIT("fimul") size op
-pprInstr FRNDINT = uppPStr SLIT("\tfrndint")
-pprInstr FSIN = uppPStr SLIT("\tfsin")
-pprInstr FSQRT = uppPStr SLIT("\tfsqrt")
+pprInstr FRNDINT = ptext SLIT("\tfrndint")
+pprInstr FSIN = ptext SLIT("\tfsin")
+pprInstr FSQRT = ptext SLIT("\tfsqrt")
pprInstr (FST sz dst)
- = uppBesides [uppPStr SLIT("\tfst"), pprSize sz, uppSP, pprOperand sz dst]
+ = hcat [ptext SLIT("\tfst"), pprSize sz, space, pprOperand sz dst]
pprInstr (FSTP sz dst)
- = uppBesides [uppPStr SLIT("\tfstp"), pprSize sz, uppSP, pprOperand sz dst]
+ = hcat [ptext SLIT("\tfstp"), pprSize sz, space, pprOperand sz dst]
pprInstr (FISUB size op) = pprSizeAddr SLIT("fisub") size op
pprInstr (FSUB sz src)
- = uppBesides [uppPStr SLIT("\tfsub"), pprSize sz, uppSP, pprOperand sz src]
+ = hcat [ptext SLIT("\tfsub"), pprSize sz, space, pprOperand sz src]
pprInstr FSUBP
- = uppPStr SLIT("\tfsubp")
+ = ptext SLIT("\tfsubp")
pprInstr (FSUBR size src)
= pprSizeOp SLIT("fsubr") size src
pprInstr FSUBRP
- = uppPStr SLIT("\tfsubpr")
+ = ptext SLIT("\tfsubpr")
pprInstr (FISUBR size op)
= pprSizeAddr SLIT("fisubr") size op
-pprInstr FTST = uppPStr SLIT("\tftst")
+pprInstr FTST = ptext SLIT("\tftst")
pprInstr (FCOMP sz op)
- = uppBesides [uppPStr SLIT("\tfcomp"), pprSize sz, uppSP, pprOperand sz op]
-pprInstr FUCOMPP = uppPStr SLIT("\tfucompp")
-pprInstr FXCH = uppPStr SLIT("\tfxch")
-pprInstr FNSTSW = uppPStr SLIT("\tfnstsw %ax")
-pprInstr FNOP = uppPStr SLIT("")
+ = hcat [ptext SLIT("\tfcomp"), pprSize sz, space, pprOperand sz op]
+pprInstr FUCOMPP = ptext SLIT("\tfucompp")
+pprInstr FXCH = ptext SLIT("\tfxch")
+pprInstr FNSTSW = ptext SLIT("\tfnstsw %ax")
+pprInstr FNOP = ptext SLIT("")
\end{code}
Continue with I386-only printing bits and bobs:
\begin{code}
-pprDollImm :: Imm -> Unpretty
+pprDollImm :: Imm -> Doc
-pprDollImm i = uppBesides [ uppPStr SLIT("$"), pprImm i]
+pprDollImm i = hcat [ ptext SLIT("$"), pprImm i]
-pprOperand :: Size -> Operand -> Unpretty
+pprOperand :: Size -> Operand -> Doc
pprOperand s (OpReg r) = pprReg s r
pprOperand s (OpImm i) = pprDollImm i
pprOperand s (OpAddr ea) = pprAddr ea
-pprSizeOp :: FAST_STRING -> Size -> Operand -> Unpretty
+pprSizeOp :: FAST_STRING -> Size -> Operand -> Doc
pprSizeOp name size op1
- = uppBesides [
- uppChar '\t',
- uppPStr name,
+ = hcat [
+ char '\t',
+ ptext name,
pprSize size,
- uppSP,
+ space,
pprOperand size op1
]
-pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Unpretty
+pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc
pprSizeOpOp name size op1 op2
- = uppBesides [
- uppChar '\t',
- uppPStr name,
+ = hcat [
+ char '\t',
+ ptext name,
pprSize size,
- uppSP,
+ space,
pprOperand size op1,
- uppComma,
+ comma,
pprOperand size op2
]
-pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> Unpretty
+pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> Doc
pprSizeOpReg name size op1 reg
- = uppBesides [
- uppChar '\t',
- uppPStr name,
+ = hcat [
+ char '\t',
+ ptext name,
pprSize size,
- uppSP,
+ space,
pprOperand size op1,
- uppComma,
+ comma,
pprReg size reg
]
-pprSizeAddr :: FAST_STRING -> Size -> Addr -> Unpretty
+pprSizeAddr :: FAST_STRING -> Size -> Addr -> Doc
pprSizeAddr name size op
- = uppBesides [
- uppChar '\t',
- uppPStr name,
+ = hcat [
+ char '\t',
+ ptext name,
pprSize size,
- uppSP,
+ space,
pprAddr op
]
-pprSizeAddrReg :: FAST_STRING -> Size -> Addr -> Reg -> Unpretty
+pprSizeAddrReg :: FAST_STRING -> Size -> Addr -> Reg -> Doc
pprSizeAddrReg name size op dst
- = uppBesides [
- uppChar '\t',
- uppPStr name,
+ = hcat [
+ char '\t',
+ ptext name,
pprSize size,
- uppSP,
+ space,
pprAddr op,
- uppComma,
+ comma,
pprReg size dst
]
-pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Unpretty
+pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc
pprOpOp name size op1 op2
- = uppBesides [
- uppChar '\t',
- uppPStr name, uppSP,
+ = hcat [
+ char '\t',
+ ptext name, space,
pprOperand size op1,
- uppComma,
+ comma,
pprOperand size op2
]
-pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> Unpretty
+pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> Doc
pprSizeOpOpCoerce name size1 size2 op1 op2
- = uppBesides [ uppChar '\t', uppPStr name, uppSP,
+ = hcat [ char '\t', ptext name, space,
pprOperand size1 op1,
- uppComma,
+ comma,
pprOperand size2 op2
]
-pprCondInstr :: FAST_STRING -> Cond -> Unpretty -> Unpretty
+pprCondInstr :: FAST_STRING -> Cond -> Doc -> Doc
pprCondInstr name cond arg
- = uppBesides [ uppChar '\t', uppPStr name, pprCond cond, uppSP, arg]
+ = hcat [ char '\t', ptext name, pprCond cond, space, arg]
#endif {-i386_TARGET_ARCH-}
\end{code}
-- a clumsy hack for now, to handle possible double alignment problems
pprInstr (LD DF addr reg) | maybeToBool off_addr
- = uppBesides [
+ = hcat [
pp_ld_lbracket,
pprAddr addr,
pp_rbracket_comma,
pprReg reg,
- uppChar '\n',
+ char '\n',
pp_ld_lbracket,
pprAddr addr2,
pp_rbracket_comma,
addr2 = case off_addr of Just x -> x
pprInstr (LD size addr reg)
- = uppBesides [
- uppPStr SLIT("\tld"),
+ = hcat [
+ ptext SLIT("\tld"),
pprSize size,
- uppChar '\t',
- uppLbrack,
+ char '\t',
+ lbrack,
pprAddr addr,
pp_rbracket_comma,
pprReg reg
-- The same clumsy hack as above
pprInstr (ST DF reg addr) | maybeToBool off_addr
- = uppBesides [
- uppPStr SLIT("\tst\t"),
+ = hcat [
+ ptext SLIT("\tst\t"),
pprReg reg,
pp_comma_lbracket,
pprAddr addr,
- uppPStr SLIT("]\n\tst\t"),
+ ptext SLIT("]\n\tst\t"),
pprReg (fPair reg),
pp_comma_lbracket,
pprAddr addr2,
- uppRbrack
+ rbrack
]
where
off_addr = addrOffset addr 4
addr2 = case off_addr of Just x -> x
+-- no distinction is made between signed and unsigned bytes on stores for the
+-- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
+-- so we call a special-purpose pprSize for ST..
+
pprInstr (ST size reg addr)
- = uppBesides [
- uppPStr SLIT("\tst"),
- pprSize size,
- uppChar '\t',
+ = hcat [
+ ptext SLIT("\tst"),
+ pprStSize size,
+ char '\t',
pprReg reg,
pp_comma_lbracket,
pprAddr addr,
- uppRbrack
+ rbrack
]
pprInstr (ADD x cc reg1 ri reg2)
| not x && not cc && riZero ri
- = uppBesides [ uppPStr SLIT("\tmov\t"), pprReg reg1, uppComma, pprReg reg2 ]
+ = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
| otherwise
= pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
pprInstr (SUB x cc reg1 ri reg2)
| not x && cc && reg2 == g0
- = uppBesides [ uppPStr SLIT("\tcmp\t"), pprReg reg1, uppComma, pprRI ri ]
+ = hcat [ ptext SLIT("\tcmp\t"), pprReg reg1, comma, pprRI ri ]
| not x && not cc && riZero ri
- = uppBesides [ uppPStr SLIT("\tmov\t"), pprReg reg1, uppComma, pprReg reg2 ]
+ = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
| otherwise
= pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
pprInstr (OR b reg1 ri reg2)
| not b && reg1 == g0
- = uppBesides [ uppPStr SLIT("\tmov\t"), pprRI ri, uppComma, pprReg reg2 ]
+ = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ]
| otherwise
= pprRegRIReg SLIT("or") b reg1 ri reg2
pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2
pprInstr (SETHI imm reg)
- = uppBesides [
- uppPStr SLIT("\tsethi\t"),
+ = hcat [
+ ptext SLIT("\tsethi\t"),
pprImm imm,
- uppComma,
+ comma,
pprReg reg
]
-pprInstr NOP = uppPStr SLIT("\tnop")
+pprInstr NOP = ptext SLIT("\tnop")
pprInstr (FABS F reg1 reg2) = pprSizeRegReg SLIT("fabs") F reg1 reg2
pprInstr (FABS DF reg1 reg2)
- = uppBeside (pprSizeRegReg SLIT("fabs") F reg1 reg2)
- (if (reg1 == reg2) then uppNil
- else uppBeside (uppChar '\n')
+ = (<>) (pprSizeRegReg SLIT("fabs") F reg1 reg2)
+ (if (reg1 == reg2) then empty
+ else (<>) (char '\n')
(pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
pprInstr (FADD size reg1 reg2 reg3)
pprInstr (FMOV F reg1 reg2) = pprSizeRegReg SLIT("fmov") F reg1 reg2
pprInstr (FMOV DF reg1 reg2)
- = uppBeside (pprSizeRegReg SLIT("fmov") F reg1 reg2)
- (if (reg1 == reg2) then uppNil
- else uppBeside (uppChar '\n')
+ = (<>) (pprSizeRegReg SLIT("fmov") F reg1 reg2)
+ (if (reg1 == reg2) then empty
+ else (<>) (char '\n')
(pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
pprInstr (FMUL size reg1 reg2 reg3)
pprInstr (FNEG F reg1 reg2) = pprSizeRegReg SLIT("fneg") F reg1 reg2
pprInstr (FNEG DF reg1 reg2)
- = uppBeside (pprSizeRegReg SLIT("fneg") F reg1 reg2)
- (if (reg1 == reg2) then uppNil
- else uppBeside (uppChar '\n')
+ = (<>) (pprSizeRegReg SLIT("fneg") F reg1 reg2)
+ (if (reg1 == reg2) then empty
+ else (<>) (char '\n')
(pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
pprInstr (FxTOy size1 size2 reg1 reg2)
- = uppBesides [
- uppPStr SLIT("\tf"),
- uppPStr
+ = hcat [
+ ptext SLIT("\tf"),
+ ptext
(case size1 of
W -> SLIT("ito")
F -> SLIT("sto")
DF -> SLIT("dto")),
- uppPStr
+ ptext
(case size2 of
W -> SLIT("i\t")
F -> SLIT("s\t")
DF -> SLIT("d\t")),
- pprReg reg1, uppComma, pprReg reg2
+ pprReg reg1, comma, pprReg reg2
]
pprInstr (BI cond b lab)
- = uppBesides [
- uppPStr SLIT("\tb"), pprCond cond,
- if b then pp_comma_a else uppNil,
- uppChar '\t',
+ = hcat [
+ ptext SLIT("\tb"), pprCond cond,
+ if b then pp_comma_a else empty,
+ char '\t',
pprImm lab
]
pprInstr (BF cond b lab)
- = uppBesides [
- uppPStr SLIT("\tfb"), pprCond cond,
- if b then pp_comma_a else uppNil,
- uppChar '\t',
+ = hcat [
+ ptext SLIT("\tfb"), pprCond cond,
+ if b then pp_comma_a else empty,
+ char '\t',
pprImm lab
]
-pprInstr (JMP addr) = uppBeside (uppPStr SLIT("\tjmp\t")) (pprAddr addr)
+pprInstr (JMP addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
pprInstr (CALL imm n _)
- = uppBesides [ uppPStr SLIT("\tcall\t"), pprImm imm, uppComma, uppInt n ]
+ = hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ]
\end{code}
Continue with SPARC-only printing bits and bobs:
\begin{code}
-pprRI :: RI -> Unpretty
+pprRI :: RI -> Doc
pprRI (RIReg r) = pprReg r
pprRI (RIImm r) = pprImm r
-pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Unpretty
+pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Doc
pprSizeRegReg name size reg1 reg2
- = uppBesides [
- uppChar '\t',
- uppPStr name,
+ = hcat [
+ char '\t',
+ ptext name,
(case size of
- F -> uppPStr SLIT("s\t")
- DF -> uppPStr SLIT("d\t")),
+ F -> ptext SLIT("s\t")
+ DF -> ptext SLIT("d\t")),
pprReg reg1,
- uppComma,
+ comma,
pprReg reg2
]
-pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Unpretty
+pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc
pprSizeRegRegReg name size reg1 reg2 reg3
- = uppBesides [
- uppChar '\t',
- uppPStr name,
+ = hcat [
+ char '\t',
+ ptext name,
(case size of
- F -> uppPStr SLIT("s\t")
- DF -> uppPStr SLIT("d\t")),
+ F -> ptext SLIT("s\t")
+ DF -> ptext SLIT("d\t")),
pprReg reg1,
- uppComma,
+ comma,
pprReg reg2,
- uppComma,
+ comma,
pprReg reg3
]
-pprRegRIReg :: FAST_STRING -> Bool -> Reg -> RI -> Reg -> Unpretty
+pprRegRIReg :: FAST_STRING -> Bool -> Reg -> RI -> Reg -> Doc
pprRegRIReg name b reg1 ri reg2
- = uppBesides [
- uppChar '\t',
- uppPStr name,
- if b then uppPStr SLIT("cc\t") else uppChar '\t',
+ = hcat [
+ char '\t',
+ ptext name,
+ if b then ptext SLIT("cc\t") else char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
-pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Unpretty
+pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Doc
pprRIReg name b ri reg1
- = uppBesides [
- uppChar '\t',
- uppPStr name,
- if b then uppPStr SLIT("cc\t") else uppChar '\t',
+ = hcat [
+ char '\t',
+ ptext name,
+ if b then ptext SLIT("cc\t") else char '\t',
pprRI ri,
- uppComma,
+ comma,
pprReg reg1
]
-pp_ld_lbracket = uppPStr (pACK_STR (a_HASH "\tld\t["#))
-pp_rbracket_comma = uppPStr (pACK_STR (a_HASH "],"#))
-pp_comma_lbracket = uppPStr (pACK_STR (a_HASH ",["#))
-pp_comma_a = uppPStr (pACK_STR (a_HASH ",a"#))
+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"#))
#endif {-sparc_TARGET_ARCH-}
\end{code}
freeRegSet
) where
+#if __GLASGOW_HASKELL__ >= 202
+import qualified GlaExts (Addr(..))
+import GlaExts hiding (Addr(..))
+import FastString
+import Ubiq
+#else
IMP_Ubiq(){-uitous-}
+import Pretty ( Doc )
+#endif
IMPORT_1_3(List(partition))
import MachMisc
import PrimRep ( PrimRep(..) )
import Stix ( StixTree, CodeSegment )
import UniqSet -- quite a bit of it
-import Unpretty ( uppShow )
\end{code}
%************************************************************************
lookup lbl
= case (lookupFM env lbl) of
Just rs -> rs
- Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel_asm lbl)) ++
+ Nothing -> trace ("Missing " ++ (show (pprCLabel_asm lbl)) ++
" in future?") emptyRegSet
in
case instr of -- the rest is machine-specific...
--- /dev/null
+_interface_ Stix 1
+_exports_
+Stix StixTree;
+_declarations_
+1 data StixTree;
import AbsCSyn ( node, infoptr, MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
-import CLabel ( mkAsmTempLabel )
+import CLabel ( mkAsmTempLabel, CLabel )
+import PrimRep ( PrimRep )
+import PrimOp ( PrimOp )
+import Unique ( Unique )
import UniqSupply ( returnUs, thenUs, getUnique, SYN_IE(UniqSM) )
-import Unpretty ( uppPStr, SYN_IE(Unpretty) )
+import Pretty ( ptext, Doc )
\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 Unpretty -- literal labels
+ | StLitLbl Doc -- literal labels
-- (will be _-prefixed on some machines)
| StLitLit FAST_STRING -- innards from CLitLit
| StCLbl CLabel -- labels that we might index into
| StComment FAST_STRING
sStLitLbl :: FAST_STRING -> StixTree
-sStLitLbl s = StLitLbl (uppPStr s)
+sStLitLbl s = StLitLbl (ptext s)
\end{code}
Stix registers can have two forms. They {\em may} or {\em may not}
import Stix -- all of it
import StixPrim ( amodeToStix )
import UniqSupply ( returnUs, SYN_IE(UniqSM) )
-import Unpretty ( uppBesides, uppPStr, uppInt, uppChar )
+import Pretty ( hcat, ptext, int, char )
\end{code}
Generating code for info tables (arrays of data).
tag]
SpecialisedRep _ _ _ updatable ->
- let rtbl = uppBesides (
+ let rtbl = hcat (
if is_selector then
- [uppPStr SLIT("Select__"),
- uppInt select_word,
- uppPStr SLIT("_rtbl")]
+ [ptext SLIT("Select__"),
+ int select_word,
+ ptext SLIT("_rtbl")]
else
- [uppPStr (case updatable of
+ [ptext (case updatable of
SMNormalForm -> SLIT("Spec_N_")
SMSingleEntry -> SLIT("Spec_S_")
SMUpdatable -> SLIT("Spec_U_")
),
- uppInt size,
- uppChar '_',
- uppInt ptrs,
- uppPStr SLIT("_rtbl")])
+ int size,
+ char '_',
+ int ptrs,
+ ptext SLIT("_rtbl")])
in
case updatable of
SMNormalForm -> [upd_code, StLitLbl rtbl, tag]
IMPORT_DELOOPER(NcgLoop) ( amodeToStix )
import MachMisc
+#if __GLASGOW_HASKELL__ >= 202
+import MachRegs hiding (Addr)
+#else
import MachRegs
+#endif
import AbsCSyn -- bits and bobs...
import Constants ( mIN_MP_INT_SIZE )
IMPORT_DELOOPER(NcgLoop) ( amodeToStix )
import MachMisc
+#if __GLASGOW_HASKELL__ >= 202
+import MachRegs hiding (Addr)
+#else
import MachRegs
+#endif
import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode )
import Constants ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
--- /dev/null
+_interface_ StixPrim 1
+_exports_
+StixPrim amodeToStix;
+_declarations_
+1 amodeToStix _:_ AbsCSyn.CAddrMode -> Stix.StixTree ;;
IMPORT_DELOOPER(NcgLoop) -- paranoia checking only
import MachMisc
+#if __GLASGOW_HASKELL__ >= 202
+import MachRegs hiding (Addr)
+#else
import MachRegs
+#endif
import AbsCSyn
import AbsCUtils ( getAmodeRep, mixedTypeLocn )
import StixMacro ( heapCheck )
import StixInteger {- everything -}
import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) )
-import Unpretty ( uppBeside, uppPStr, uppInt )
+import Pretty ( (<>), ptext, int )
import Util ( panic )
#ifdef REALLY_HASKELL_1_3
in
returnUs (\xs -> assign : xs)
-primCode [lhs] WriteArrayOp [obj, ix, v]
+primCode [] WriteArrayOp [obj, ix, v]
= let
obj' = amodeToStix obj
ix' = amodeToStix ix
ReturnsPrim pk -> pk
_ -> simplePrim_error op
-simplePrim _ op _ = simplePrim_error op
+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")
-- For CharLike and IntLike, we attempt some trivial constant-folding here.
amodeToStix (CCharLike (CLit (MachChar c)))
- = StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off))
+ = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closures+")) (int off))
where
off = charLikeSize * ord c
EXP_MODULE(U_ttype)
) where
+#if __GLASGOW_HASKELL__ <= 201
import PreludeGlaST
+#else
+import GlaExts
+#endif
IMP_Ubiq(){-uitous-}
IMP_Ubiq()
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
import PreludeGlaST
+#else
+import GlaExts
+import Name
+#endif
-#if __GLASGOW_HASKELL__ >= 200
+#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
gconnty : ttype;
gconnline : long; >;
+ /* constr with a prefixed context C => ... */
+ constrcxt : < gconcxt : list;
+ gconcon : constr; >;
+
field : < gfieldn : list;
gfieldt : ttype; >;
end;
maybefixes fixes fix ops
dtyclses dtycls_list
gdrhs gdpat valrhs
- lampats cexps
+ lampats cexps gd
%type <umaybe> maybeexports impspec deriving
%type <utree> exp oexp dexp kexp fexp aexp rbind texps
expL oexpL kexpL expLno oexpLno dexpLno kexpLno
- vallhs funlhs qual gd leftexp
+ vallhs funlhs qual leftexp
pat cpat bpat apat apatc conpat rpat
patk bpatk apatck conpatk
%type <upbinding> valrhs1 altrest
-%type <uttype> simple ctype type atype btype
+%type <uttype> simple ctype sigtype sigarrowtype type atype bigatype btype
gtyconvars
- bbtype batype bxtype bang_atype
- class tyvar
+ bbtype batype bxtype wierd_atype
+ class tyvar contype
-%type <uconstr> constr field
+%type <uconstr> constr constr_after_context field
%type <ustring> FLOAT INTEGER INTPRIM
FLOATPRIM DOUBLEPRIM CLITLIT
to real mischief (ugly, but likely to work).
*/
-decl : qvarsk DCOLON ctype
+decl : qvarsk DCOLON sigtype
{ $$ = mksbind($1,$3,startlineno);
PREVPATT = NULL; FN = NULL; SAMEFN = 0;
}
context. Blaach!
*/
+/* A sigtype is a rank 2 type; it can have for-alls as function args:
+ f :: All a => (All b => ...) -> Int
+*/
+sigtype : type DARROW sigarrowtype { $$ = mkcontext(type2context($1),$3); }
+ | sigarrowtype
+ ;
+
+sigarrowtype : bigatype RARROW sigarrowtype { $$ = mktfun($1,$3); }
+ | btype RARROW sigarrowtype { $$ = mktfun($1,$3); }
+ | btype
+ ;
+
+/* A "big" atype can be a forall-type in brackets. */
+bigatype: OPAREN type DARROW type CPAREN { $$ = mkcontext(type2context($2),$4); }
+ ;
+
/* 1 S/R conflict at DARROW -> shift */
ctype : type DARROW type { $$ = mkcontext(type2context($1),$3); }
| type
;
/* 1 S/R conflict at RARROW -> shift */
-type : btype { $$ = $1; }
- | btype RARROW type { $$ = mktfun($1,$3); }
+type : btype RARROW type { $$ = mktfun($1,$3); }
+ | btype { $$ = $1; }
;
-btype : atype { $$ = $1; }
- | btype atype { $$ = mktapp($1,$2); }
+btype : btype atype { $$ = mktapp($1,$2); }
+ | atype { $$ = $1; }
;
atype : gtycon { $$ = mktname($1); }
| constrs VBAR constr { $$ = lapp($1,$3); }
;
-constr : btype { qid tyc; list tys;
- splittyconapp($1, &tyc, &tys);
- $$ = mkconstrpre(tyc,tys,hsplineno); }
- | bxtype { qid tyc; list tys;
- splittyconapp($1, &tyc, &tys);
- $$ = mkconstrpre(tyc,tys,hsplineno); }
+constr : constr_after_context
+ | type DARROW constr_after_context { $$ = mkconstrcxt ( type2context($1), $3 ); }
+ ;
+
+constr_after_context :
/* We have to parse the constructor application as a *type*, else we get
into terrible ambiguity problems. Consider the difference between
second.
*/
- | btype qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); }
- | bang_atype qconop bbtype { $$ = mkconstrinf( $1, $2, $3, hsplineno ); }
+/* Con !Int (Tree a) */
+ contype { qid tyc; list tys;
+ splittyconapp($1, &tyc, &tys);
+ $$ = mkconstrpre(tyc,tys,hsplineno); }
+/* !Int `Con` Tree a */
+ | bbtype qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); }
+/* (::) (Tree a) Int */
| OPAREN qconsym CPAREN batypes { $$ = mkconstrpre($2,$4,hsplineno); }
+
+/* Con { op1 :: Int } */
| gtycon OCURLY fields CCURLY { $$ = mkconstrrec($1,$3,hsplineno); }
/* 1 S/R conflict on OCURLY -> shift */
;
-/* S !Int Bool */
-bxtype : btype bang_atype { $$ = mktapp($1, $2); }
- | bxtype bbtype { $$ = mktapp($1, $2); }
+
+/* contype has to reduce to a btype unless there are !'s, so that
+ we don't get reduce/reduce conflicts with the second production of constr.
+ But as soon as we see a ! we must switch to using bxtype. */
+
+contype : btype { $$ = $1 }
+ | bxtype { $$ = $1 }
;
+/* S !Int Bool; at least one ! */
+bxtype : btype wierd_atype { $$ = mktapp($1, $2); }
+ | bxtype batype { $$ = mktapp($1, $2); }
+ ;
bbtype : btype { $$ = $1; }
- | bang_atype { $$ = $1; }
+ | wierd_atype { $$ = $1; }
;
batype : atype { $$ = $1; }
- | bang_atype { $$ = $1; }
+ | wierd_atype { $$ = $1; }
;
-bang_atype : BANG atype { $$ = mktbang( $2 ) }
- ;
+/* A wierd atype is one that isn't a regular atype;
+ it starts with a "!", or with a forall. */
+wierd_atype : BANG bigatype { $$ = mktbang( $2 ) }
+ | BANG atype { $$ = mktbang( $2 ) }
+ | bigatype
+ ;
batypes : { $$ = Lnil; }
| batypes batype { $$ = lapp($1,$2); }
| fields COMMA field { $$ = lapp($1,$3); }
;
-field : qvars_list DCOLON type { $$ = mkfield($1,$3); }
+field : qvars_list DCOLON ctype { $$ = mkfield($1,$3); }
| qvars_list DCOLON BANG atype { $$ = mkfield($1,mktbang($4)); }
+ | qvars_list DCOLON BANG bigatype { $$ = mkfield($1,mktbang($4)); }
;
constr1 : gtycon atype { $$ = lsing(mkconstrnew($1,$2,hsplineno)); }
| /* empty */ { $$ = mknullbind(); }
;
-gd : VBAR oexp { $$ = $2; }
+gd : VBAR quals { $$ = $2; }
;
qual : letdecls { $$ = mkseqlet($1); }
| expL { $$ = $1; }
- | {inpat=TRUE;} expLno {inpat=FALSE;}leftexp
+ | {inpat=TRUE;} expLno
+ {inpat=FALSE;} leftexp
{ if ($4 == NULL) {
expORpat(LEGIT_EXPR,$2);
$$ = mkguard($2);
pnoguards : < gpnoguard : tree; >;
pguards : < gpguards : list; >;
- pgdexp : < gpguard : tree;
+
+ pgdexp : < gpguard : list; /* Experimental change: guards are lists of quals */
gpexp : tree; >;
end;
case clitlit:
error_if_patt_wanted(wanted, "``literal-literal'' in pattern");
+ break;
default: /* the others only occur in pragmas */
hsperror("not a valid literal pattern or expression");
eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR, compare_RDR,
minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR,
- enumFromThenTo_RDR, fromEnum_RDR, toEnum_RDR,
+ enumFromThenTo_RDR, fromEnum_RDR, toEnum_RDR, ratioDataCon_RDR,
range_RDR, index_RDR, inRange_RDR, readsPrec_RDR, readList_RDR,
showsPrec_RDR, showList_RDR, plus_RDR, times_RDR, ltTag_RDR, eqTag_RDR, gtTag_RDR,
eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR, eqH_Addr_RDR, ltH_Addr_RDR,
numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, creturnableClass_RDR,
monadZeroClass_RDR, enumClass_RDR, evalClass_RDR, ordClass_RDR,
- main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME,
+ main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME, allClass_NAME,
- needsDataDeclCtxtClassKeys, cCallishClassKeys, isNoDictClass,
+ needsDataDeclCtxtClassKeys, cCallishClassKeys, cCallishTyKeys, isNoDictClass,
isNumericClass, isStandardClass, isCcallishClass
) where
IMP_Ubiq()
+#if __GLASGOW_HASKELL__ >= 202
+import IdUtils ( primOpName )
+#else
IMPORT_DELOOPER(PrelLoop) ( primOpName )
+#endif
-- IMPORT_DELOOPER(IdLoop) ( SpecEnv )
-- friends:
import Type
import Bag
import Unique -- *Key stuff
-import UniqFM ( UniqFM, listToUFM )
+import UniqFM ( UniqFM, listToUFM, Uniquable(..) )
import Util ( isIn )
\end{code}
mkKnownKeyGlobal :: (RdrName, Unique) -> Name
mkKnownKeyGlobal (Qual mod occ, uniq) = mkGlobalName uniq mod occ VanillaDefn Implicit
+allClass_NAME = mkKnownKeyGlobal (allClass_RDR, allClassKey)
main_NAME = mkKnownKeyGlobal (main_RDR, mainKey)
mainPrimIO_NAME = mkKnownKeyGlobal (mainPrimIO_RDR, mainPrimIoKey)
ioTyCon_NAME = mkKnownKeyGlobal (ioTyCon_RDR, iOTyConKey)
knownKeyNames :: [Name]
knownKeyNames
- = [main_NAME, mainPrimIO_NAME, ioTyCon_NAME]
+ = [main_NAME, mainPrimIO_NAME, ioTyCon_NAME, allClass_NAME]
++
map mkKnownKeyGlobal
[
-- Type constructors (synonyms especially)
(orderingTyCon_RDR, orderingTyConKey)
, (rationalTyCon_RDR, rationalTyConKey)
+ , (ratioDataCon_RDR, ratioDataConKey)
, (ratioTyCon_RDR, ratioTyConKey)
+ , (byteArrayTyCon_RDR, byteArrayTyConKey)
+ , (mutableByteArrayTyCon_RDR, mutableByteArrayTyConKey)
+
-- Classes. *Must* include:
-- classes that are grabbed by key (e.g., eqClassKey)
orderingTyCon_RDR = tcQual (pREL_BASE, SLIT("Ordering"))
rationalTyCon_RDR = tcQual (pREL_NUM, SLIT("Rational"))
ratioTyCon_RDR = tcQual (pREL_NUM, SLIT("Ratio"))
+ratioDataCon_RDR = varQual (pREL_NUM, SLIT(":%"))
+
+byteArrayTyCon_RDR = tcQual (aRR_BASE, SLIT("ByteArray"))
+mutableByteArrayTyCon_RDR = tcQual (aRR_BASE, SLIT("MutableByteArray"))
+allClass_RDR = tcQual (gHC__, SLIT("All"))
eqClass_RDR = tcQual (pREL_BASE, SLIT("Eq"))
ordClass_RDR = tcQual (pREL_BASE, SLIT("Ord"))
evalClass_RDR = tcQual (pREL_BASE, SLIT("Eval"))
thenM_RDR = varQual (pREL_BASE, SLIT(">>="))
returnM_RDR = varQual (pREL_BASE, SLIT("return"))
zeroM_RDR = varQual (pREL_BASE, SLIT("zero"))
-fromRational_RDR = varQual (pREL_NUM, SLIT("fromRational"))
+fromRational_RDR = varQual (pREL_NUM, SLIT("fromRational"))
negate_RDR = varQual (pREL_BASE, SLIT("negate"))
eq_RDR = varQual (pREL_BASE, SLIT("=="))
deriving_occ_info
= [ (eqClassKey, [intTyCon_RDR, and_RDR, not_RDR])
- , (ordClassKey, [intTyCon_RDR, compose_RDR])
+ , (ordClassKey, [intTyCon_RDR, compose_RDR, eqTag_RDR])
+ -- EQ (from Ordering) is needed to force in the constructors
+ -- as well as the type constructor.
, (enumClassKey, [intTyCon_RDR, map_RDR])
, (evalClassKey, [intTyCon_RDR])
, (boundedClassKey, [intTyCon_RDR])
cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
+ -- Renamer always imports these data decls replete with constructors
+ -- so that desugarer can always see the constructor. Ugh!
+cCallishTyKeys = [ addrTyConKey, wordTyConKey, byteArrayTyConKey, mutableByteArrayTyConKey ]
+
standardClassKeys
= derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
--
--- /dev/null
+module PrelLoop where
module PrelMods
(
- isPreludeModule, -- :: Module -> Bool
-
gHC__, pRELUDE, pREL_BASE,
pREL_READ , pREL_NUM, pREL_LIST,
pREL_TUP , pACKED_STRING, cONC_BASE,
append a special suffix for prelude modules:
\begin{code}
-isPreludeModule :: Module -> Bool
-isPreludeModule mod = mod `elementOfUniqSet` preludeNames
-
preludeNames :: UniqSet FAST_STRING
preludeNames =
mkUniqSet
module PrelVals where
IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..), nullSpecEnv, SpecEnv )
+IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..), mkUnfolding, nullSpecEnv, SpecEnv )
import Id ( SYN_IE(Id), GenId, mkImported, mkTemplateLocals )
IMPORT_DELOOPER(PrelLoop)
import CoreSyn -- quite a bit
import IdInfo -- quite a bit
import Literal ( mkMachInt )
-import Name ( mkWiredInIdName )
+import Name ( mkWiredInIdName, SYN_IE(Module) )
import PragmaInfo
import PrimOp ( PrimOp(..) )
+#if __GLASGOW_HASKELL__ >= 202
+import Type
+#else
import Type ( mkTyVarTy )
-import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar )
+#endif
+import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar, SYN_IE(TyVar) )
import Unique -- lots of *Keys
import Util ( panic )
\end{code}
\begin{code}
-- only used herein:
+
+mk_inline_unfolding = mkUnfolding IWantToBeINLINEd
+
pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
pcMiscPrelId key mod occ ty info
seqId = pcMiscPrelId seqIdKey pRELUDE SLIT("seq")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [alphaTy, betaTy] betaTy))
- (noIdInfo `addUnfoldInfo` (mkUnfolding True seq_template))
+ (noIdInfo `addUnfoldInfo` (mk_inline_unfolding seq_template))
where
[x, y, z]
= mkTemplateLocals [
parId = pcMiscPrelId parIdKey cONC_BASE SLIT("par")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [alphaTy, betaTy] betaTy))
- (noIdInfo `addUnfoldInfo` (mkUnfolding True par_template))
+ (noIdInfo `addUnfoldInfo` (mk_inline_unfolding par_template))
where
[x, y, z]
= mkTemplateLocals [
forkId = pcMiscPrelId forkIdKey cONC_BASE SLIT("fork")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [alphaTy, betaTy] betaTy))
- (noIdInfo `addUnfoldInfo` (mkUnfolding True fork_template))
+ (noIdInfo `addUnfoldInfo` (mk_inline_unfolding fork_template))
where
[x, y, z]
= mkTemplateLocals [
parLocalId = pcMiscPrelId parLocalIdKey cONC_BASE SLIT("parLocal")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
- (noIdInfo `addUnfoldInfo` (mkUnfolding True parLocal_template))
+ (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parLocal_template))
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, x, y, z]
parGlobalId = pcMiscPrelId parGlobalIdKey cONC_BASE SLIT("parGlobal")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
- (noIdInfo `addUnfoldInfo` (mkUnfolding True parGlobal_template))
+ (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parGlobal_template))
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, x, y, z]
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
alphaTy, betaTy, gammaTy] gammaTy))
- (noIdInfo `addUnfoldInfo` (mkUnfolding True parAt_template))
+ (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAt_template))
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, v, x, y, z]
parAtAbsId = pcMiscPrelId parAtAbsIdKey cONC_BASE SLIT("parAtAbs")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
- (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtAbs_template))
+ (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtAbs_template))
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, v, x, y, z]
parAtRelId = pcMiscPrelId parAtRelIdKey cONC_BASE SLIT("parAtRel")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
- (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtRel_template))
+ (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtRel_template))
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, v, x, y, z]
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
alphaTy, betaTy, gammaTy] gammaTy))
- (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtForNow_template))
+ (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtForNow_template))
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, v, x, y, z]
copyableId = pcMiscPrelId copyableIdKey cONC_BASE SLIT("copyable")
(mkSigmaTy [alphaTyVar] []
alphaTy)
- (noIdInfo `addUnfoldInfo` (mkUnfolding True copyable_template))
+ (noIdInfo `addUnfoldInfo` (mk_inline_unfolding copyable_template))
where
-- Annotations: x: closure that's tagged to by copyable
[x, z]
noFollowId = pcMiscPrelId noFollowIdKey cONC_BASE SLIT("noFollow")
(mkSigmaTy [alphaTyVar] []
alphaTy)
- (noIdInfo `addUnfoldInfo` (mkUnfolding True noFollow_template))
+ (noIdInfo `addUnfoldInfo` (mk_inline_unfolding noFollow_template))
where
-- Annotations: x: closure that's tagged to not follow
[x, z]
`addArityInfo` exactArity 1
`addStrictnessInfo` mkStrictnessInfo [WwStrict] Nothing
`addArgUsageInfo` mkArgUsageInfo [ArgUsage 1]
- -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding True run_ST_template)
+ -- ABSOLUTELY NO UNFOLDING, e.g.: (mk_inline_unfolding run_ST_template)
-- see example below
{- OUT:
[m, t, r, wild]
--- /dev/null
+_interface_ PrimOp 1
+_exports_
+PrimOp PrimOp;
+_declarations_
+1 data PrimOp;
import CStrings ( identToC )
import Constants ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset )
-import PprStyle ( codeStyle, ifaceStyle )
+import PprStyle --( codeStyle, ifaceStyle )
import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} )
import Pretty
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
import TyCon ( TyCon{-instances-} )
-import Type ( getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts,
+import Type {- ( getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts,
mkForAllTys, mkFunTy, mkFunTys, applyTyCon, typePrimRep
- )
-import TyVar ( alphaTyVar, betaTyVar, gammaTyVar, GenTyVar{-instance Eq-} )
+ ) -}
+import TyVar --( alphaTyVar, betaTyVar, gammaTyVar, GenTyVar{-instance Eq-} )
import Unique ( Unique{-instance Eq-} )
import Util ( panic#, assoc, panic{-ToDo:rm-} )
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable
+#endif
\end{code}
%************************************************************************
primOpInfo IntRemOp = Dyadic SLIT("remInt#") intPrimTy
primOpInfo IntNegOp = Monadic SLIT("negateInt#") intPrimTy
+primOpInfo IntAbsOp = Monadic SLIT("absInt#") intPrimTy
\end{code}
%************************************************************************
Output stuff:
\begin{code}
-pprPrimOp :: PprStyle -> PrimOp -> Pretty
+pprPrimOp :: PprStyle -> PrimOp -> Doc
showPrimOp :: PprStyle -> PrimOp -> String
-showPrimOp sty op
- = ppShow 1000{-random-} (pprPrimOp sty op)
+showPrimOp sty op = render (pprPrimOp sty op)
pprPrimOp sty (CCallOp fun is_casm may_gc arg_tys res_ty)
= let
if may_gc then "_ccall_GC_ " else "_ccall_ "
after
- = if is_casm then ppStr "''" else ppNil
+ = if is_casm then text "''" else empty
pp_tys
- = ppCat (map (pprParendGenType sty) (res_ty:arg_tys))
+ = hsep (map (pprParendGenType sty) (res_ty:arg_tys))
in
- ppBesides [ppStr before, ppPStr fun, after, ppSP, ppLbrack, pp_tys, ppRbrack]
+ 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.
- = ppPStr SLIT("GHC.") `ppBeside` ppPStr str
+ = ptext SLIT("GHC.") <> ptext str
| otherwise -- Unqualified is good enough
- = ppPStr str
+ = ptext str
where
str = primOp_str other_op
import Pretty -- pretty-printing code
import Util
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable
+#endif
+-- Oh dear.
#include "../../includes/GhcConstants.h"
\end{code}
\begin{code}
instance Outputable PrimRep where
- ppr sty kind = ppStr (showPrimRep kind)
+ ppr sty kind = text (showPrimRep kind)
showPrimRep :: PrimRep -> String
-- dumping PrimRep tag for unfoldings
-ppPrimRep :: PrimRep -> Pretty
+ppPrimRep :: PrimRep -> Doc
guessPrimRep :: String -> PrimRep -- a horrible "inverse" function
decodePrimRep :: Char -> PrimRep -- of equal nature
ppPrimRep k =
- ppChar
+ char
(case k of
PtrRep -> 'P'
CodePtrRep -> 'p'
--- /dev/null
+_interface_ StdIdInfo 1
+_exports_
+StdIdInfo addStandardIdInfo;
+_declarations_
+1 addStandardIdInfo _:_ Id.Id -> Id.Id ;;
import Type
import CoreSyn
import Literal
-import CoreUnfold ( mkUnfolding )
+import CoreUnfold ( mkUnfolding, PragmaInfo(..) )
import TysWiredIn ( tupleCon )
import Id ( GenId, mkTemplateLocals, idType,
dataConStrictMarks, dataConFieldLabels, dataConArgTys,
StrictnessMark(..),
isDataCon, isMethodSelId_maybe, isSuperDictSelId_maybe,
isRecordSelector, isPrimitiveId_maybe,
- addIdUnfolding, addIdArity
+ addIdUnfolding, addIdArity,
+ SYN_IE(Id)
)
import IdInfo ( ArityInfo, exactArity )
import Class ( GenClass, GenClassOp, classSig, classOpLocalType )
import Util ( assertPanic, pprTrace,
assoc
)
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable
+#endif
\end{code}
= con_id `addIdUnfolding` unfolding
`addIdArity` exactArity (length locals)
where
- unfolding = mkUnfolding True {- Always inline constructors -} con_rhs
+ unfolding = mkUnfolding IWantToBeINLINEd {- Always inline constructors -} con_rhs
- (tyvars,theta,arg_tys,tycon) = dataConSig con_id
- dict_tys = [mkDictTy clas ty | (clas,ty) <- theta]
- n_dicts = length dict_tys
- result_ty = applyTyCon tycon (mkTyVarTys tyvars)
+ (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) = dataConSig con_id
- locals = mkTemplateLocals (dict_tys ++ arg_tys)
+ dict_tys = [mkDictTy clas ty | (clas,ty) <- theta]
+ con_dict_tys = [mkDictTy clas ty | (clas,ty) <- con_theta]
+ n_dicts = length dict_tys
+ result_ty = applyTyCon tycon (mkTyVarTys tyvars)
+
+ locals = mkTemplateLocals (dict_tys ++ con_dict_tys ++ arg_tys)
data_args = drop n_dicts locals
(data_arg1:_) = data_args -- Used for newtype only
strict_marks = dataConStrictMarks con_id
`addIdArity` exactArity 1
-- ToDo: consider adding further IdInfo
where
- unfolding = mkUnfolding False {- Don't inline every selector -} sel_rhs
+ unfolding = mkUnfolding NoPragmaInfo {- Don't inline every selector -} sel_rhs
(tyvars, theta, tau) = splitSigmaTy (idType sel_id)
field_lbl = recordSelectorFieldLabel sel_id
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 = ppShow 80 (ppSep [ppStr "No match in record selector", ppr PprForUser sel_id])
+ full_msg = show (sep [text "No match in record selector", ppr PprForUser sel_id])
msg_lit = NoRepStr (_PK_ full_msg)
\end{code}
maybe_sc_sel_id = isSuperDictSelId_maybe sel_id
Just (cls, the_sc) = maybe_sc_sel_id
- unfolding = mkUnfolding True {- Always inline selectors -} rhs
+ unfolding = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
rhs = mk_dict_selector [tyvar] dict_id arg_ids the_arg_id
(tyvar, scs, ops) = classSig cls
maybe_meth_sel_id = isMethodSelId_maybe sel_id
Just (cls, the_op) = maybe_meth_sel_id
- unfolding = mkUnfolding True {- Always inline selectors -} rhs
+ unfolding = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
rhs = mk_dict_selector [tyvar] dict_id arg_ids the_arg_id
(tyvar, scs, ops) = classSig cls
maybe_prim_id = isPrimitiveId_maybe prim_id
Just prim_op = maybe_prim_id
- unfolding = mkUnfolding True {- Always inline PrimOps -} rhs
+ unfolding = mkUnfolding IWantToBeINLINEd {- Always inline PrimOps -} rhs
(tyvars, tau) = splitForAllTy (idType prim_id)
(arg_tys, _) = splitFunTy tau
--- /dev/null
+_interface_ TysPrim 1
+_exports_
+TysPrim voidTy;
+_declarations_
+1 voidTy _:_ Type.Type ;;
import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
import Name ( mkWiredInTyConName )
import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn
-import TyCon ( mkPrimTyCon, mkDataTyCon, NewOrData(..) )
-import Type ( applyTyCon, mkTyVarTys, mkTyConTy )
+import TyCon --( mkPrimTyCon, mkDataTyCon, NewOrData(..) )
+import Type --( applyTyCon, mkTyVarTys, mkTyConTy )
import TyVar ( GenTyVar(..), alphaTyVars )
import Usage ( usageOmega )
import PrelMods ( gHC__ )
--- /dev/null
+_interface_ TysWiredIn 1
+_exports_
+TysWiredIn tupleCon tupleTyCon;
+_declarations_
+1 tupleCon _:_ PrelBase.Int -> Id.Id ;;
+1 tupleTyCon _:_ PrelBase.Int -> TyCon.TyCon ;;
--import Kind
IMP_Ubiq()
-IMPORT_DELOOPER(TyLoop) ( mkDataCon, mkTupleCon, StrictnessMark(..) )
-IMPORT_DELOOPER(IdLoop) ( SpecEnv )
+IMPORT_DELOOPER(TyLoop) --( mkDataCon, mkTupleCon, StrictnessMark(..) )
+IMPORT_DELOOPER(IdLoop) ( SpecEnv, nullSpecEnv,
+ mkTupleCon, mkDataCon,
+ StrictnessMark(..) )
-- friends:
import PrelMods
-- others:
import Kind ( mkBoxedTypeKind, mkArrowKind )
-import Name ( mkWiredInTyConName, mkWiredInIdName, mkTupNameStr )
+import Name --( mkWiredInTyConName, mkWiredInIdName, mkTupNameStr )
import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon,
- NewOrData(..), TyCon
+ NewOrData(..), TyCon, SYN_IE(Arity)
)
import Type ( mkTyConTy, applyTyCon, mkSigmaTy, mkTyVarTys,
mkFunTy, mkFunTys, maybeAppTyCon,
import Unique
import Util ( assoc, panic )
-nullSpecEnv = error "TysWiredIn:nullSpecEnv = "
+--nullSpecEnv = error "TysWiredIn:nullSpecEnv = "
addOneToSpecEnv = error "TysWiredIn:addOneToSpecEnv = "
pc_gen_specs = error "TysWiredIn:pc_gen_specs "
mkSpecInfo = error "TysWiredIn:SpecInfo"
data_con = mkDataCon name
[ NotMarkedStrict | a <- arg_tys ]
[ {- no labelled fields -} ]
- tyvars context arg_tys tycon
+ 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
+ = pc_gen_specs --False err err err ty
where
err = panic "PrelUtils:GenerateDataSpecs"
\end{code}
wordTy = mkTyConTy wordTyCon
wordTyCon = pcDataTyCon wordTyConKey fOREIGN SLIT("Word") [] [wordDataCon]
-wordDataCon = pcDataCon wordDataConKey gHC__ SLIT("W#") [] [] [wordPrimTy] wordTyCon nullSpecEnv
+wordDataCon = pcDataCon wordDataConKey fOREIGN SLIT("W#") [] [] [wordPrimTy] wordTyCon nullSpecEnv
\end{code}
\begin{code}
addrTy = mkTyConTy addrTyCon
addrTyCon = pcDataTyCon addrTyConKey fOREIGN SLIT("Addr") [] [addrDataCon]
-addrDataCon = pcDataCon addrDataConKey gHC__ SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv
+addrDataCon = pcDataCon addrDataConKey fOREIGN SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv
\end{code}
\begin{code}
--- /dev/null
+_interface_ CostCentre 1
+_exports_
+CostCentre CostCentre noCostCentre useCurrentCostCentre overheadCostCentre dontCareCostCentre subsumedCosts preludeCafsCostCentre mkAllCafsCC preludeDictsCostCentre mkAllDictsCC cafifyCC mkUserCC;
+_declarations_
+1 data CostCentre;
+1 noCostCentre _:_ CostCentre ;;
+1 useCurrentCostCentre _:_ CostCentre ;;
+1 overheadCostCentre _:_ CostCentre ;;
+1 dontCareCostCentre _:_ CostCentre ;;
+1 subsumedCosts _:_ CostCentre ;;
+1 preludeCafsCostCentre _:_ CostCentre ;;
+1 mkAllCafsCC _:_ FastString.FastString -> FastString.FastString -> CostCentre ;;;;
+1 preludeDictsCostCentre _:_ PrelBase.Bool -> CostCentre ;;
+1 mkAllDictsCC _:_ FastString.FastString -> FastString.FastString -> PrelBase.Bool -> CostCentre ;;
+1 cafifyCC _:_ CostCentre -> CostCentre ;;
+1 mkUserCC _:_ FastString.FastString -> FastString.FastString -> FastString.FastString -> CostCentre ;;
import Id ( externallyVisibleId, GenId, showId, SYN_IE(Id) )
import CStrings ( identToC, stringToC )
import Name ( OccName, getOccString, moduleString )
-import Pretty ( ppShow, prettyToUn )
-import PprStyle ( PprStyle(..) )
+import PprStyle ( PprStyle(..), codeStyle, ifaceStyle )
import UniqSet
-import Unpretty
+import Pretty
import Util
pprIdInUnfolding = panic "Whoops"
\begin{code}
showCostCentre :: PprStyle -> Bool -> CostCentre -> String
-uppCostCentre :: PprStyle -> Bool -> CostCentre -> Unpretty
-uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Unpretty
+uppCostCentre :: PprStyle -> Bool -> CostCentre -> Doc
+uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Doc
+{- PprUnfolding is gone now
showCostCentre PprUnfolding print_as_string cc
= ASSERT(not print_as_string) -- we never "print as string w/ Unfolding"
ASSERT(not (noCostCentreAttached cc))
ASSERT(not (currentOrSubsumedCosts cc))
uppShow 80 (upp_cc_uf cc)
+-}
showCostCentre sty print_as_string cc
- = uppShow 80 (uppCostCentre sty print_as_string cc)
+ = show (uppCostCentre sty print_as_string cc)
uppCostCentre sty print_as_string NoCostCentre
- | friendly_style sty = uppNil
- | print_as_string = uppStr "\"NO_CC\""
- | otherwise = uppPStr SLIT("NO_CC")
+ | friendly_style sty = empty
+ | print_as_string = text "\"NO_CC\""
+ | otherwise = ptext SLIT("NO_CC")
uppCostCentre sty print_as_string SubsumedCosts
- | print_as_string = uppStr "\"SUBSUMED\""
- | otherwise = uppPStr SLIT("CC_SUBSUMED")
+ | print_as_string = text "\"SUBSUMED\""
+ | otherwise = ptext SLIT("CC_SUBSUMED")
uppCostCentre sty print_as_string CurrentCC
- | print_as_string = uppStr "\"CURRENT_CC\""
- | otherwise = uppPStr SLIT("CCC")
+ | print_as_string = text "\"CURRENT_CC\""
+ | otherwise = ptext SLIT("CCC")
uppCostCentre sty print_as_string OverheadCC
- | print_as_string = uppStr "\"OVERHEAD\""
- | otherwise = uppPStr SLIT("CC_OVERHEAD")
+ | print_as_string = text "\"OVERHEAD\""
+ | otherwise = ptext SLIT("CC_OVERHEAD")
uppCostCentre sty print_as_string cc
= let
- prefix_CC = uppPStr SLIT("CC_")
+ prefix_CC = ptext SLIT("CC_")
basic_thing = do_cc cc
= if friendly_sty then basic_thing else stringToC basic_thing
in
if print_as_string then
- uppBesides [uppChar '"', uppStr basic_thing_string, uppChar '"']
+ hcat [char '"', text basic_thing_string, char '"']
else if friendly_sty then
- uppStr basic_thing
+ text basic_thing
else
- uppBesides [prefix_CC,
- prettyToUn (identToC (_PK_ basic_thing))]
+ hcat [prefix_CC, identToC (_PK_ basic_thing)]
where
friendly_sty = friendly_style sty
do_dupd _ str = str
friendly_style sty -- i.e., probably for human consumption
- = case sty of
- PprForUser -> True
- PprDebug -> True
- PprShowAll -> True
- _ -> False
+ = not (codeStyle sty || ifaceStyle sty)
\end{code}
Printing unfoldings is sufficiently weird that we do it separately.
even if we won't ultimately do a \tr{SET_CCC} from it.
\begin{code}
upp_cc_uf (PreludeDictsCC d)
- = uppCat [uppPStr SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d]
+ = hsep [ptext SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d]
upp_cc_uf (AllDictsCC m g d)
- = uppCat [uppPStr SLIT("_ALL_DICTS_CC_"),
- uppChar '"',uppPStr m,uppChar '"',
- uppChar '"',uppPStr g,uppChar '"',
+ = hsep [ptext SLIT("_ALL_DICTS_CC_"),
+ char '"',ptext m,char '"',
+ char '"',ptext g,char '"',
upp_dupd d]
upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf)
= ASSERT(sccAbleCostCentre cc)
- uppCat [pp_kind cc_kind,
- uppChar '"', uppPStr m, uppChar '"',
- uppChar '"', uppPStr g, uppChar '"',
+ hsep [pp_kind cc_kind,
+ char '"', ptext m, char '"',
+ char '"', ptext g, char '"',
upp_dupd is_dupd, pp_caf is_caf]
where
- pp_kind (UserCC name) = uppBesides [uppPStr SLIT("_USER_CC_ "), uppChar '"', uppPStr name, uppChar '"']
- pp_kind (AutoCC id) = uppBeside (uppPStr SLIT("_AUTO_CC_ ")) (show_id id)
- pp_kind (DictCC id) = uppBeside (uppPStr SLIT("_DICT_CC_ ")) (show_id id)
+ pp_kind (UserCC name) = hcat [ptext SLIT("_USER_CC_ "), char '"', ptext name, char '"']
+ pp_kind (AutoCC id) = (<>) (ptext SLIT("_AUTO_CC_ ")) (show_id id)
+ pp_kind (DictCC id) = (<>) (ptext SLIT("_DICT_CC_ ")) (show_id id)
- show_id id = prettyToUn (pprIdInUnfolding no_in_scopes id)
+ show_id id = pprIdInUnfolding no_in_scopes id
where
no_in_scopes = emptyUniqSet
- pp_caf IsCafCC = uppPStr SLIT("_CAF_CC_")
- pp_caf IsNotCafCC = uppPStr SLIT("_N_")
+ pp_caf IsCafCC = ptext SLIT("_CAF_CC_")
+ pp_caf IsNotCafCC = ptext SLIT("_N_")
#ifdef DEBUG
upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre PprDebug True other))
#endif
-upp_dupd AnOriginalCC = uppPStr SLIT("_N_")
-upp_dupd ADupdCC = uppPStr SLIT("_D_")
+upp_dupd AnOriginalCC = ptext SLIT("_N_")
+upp_dupd ADupdCC = ptext SLIT("_D_")
\end{code}
\begin{code}
| otherwise
#endif
= if is_local then
- uppBesides [
- uppPStr SLIT("CC_DECLARE"),uppChar '(',
- upp_ident, uppComma,
- uppCostCentre sty True {-as String!-} cc, uppComma,
- pp_str mod_name, uppComma,
- pp_str grp_name, uppComma,
- uppStr is_subsumed, uppComma,
- if externally_visible then uppNil else uppPStr SLIT("static"),
- uppStr ");"]
+ hcat [
+ ptext SLIT("CC_DECLARE"),char '(',
+ upp_ident, comma,
+ uppCostCentre sty True {-as String!-} cc, comma,
+ pp_str mod_name, comma,
+ pp_str grp_name, comma,
+ text is_subsumed, comma,
+ if externally_visible then empty else ptext SLIT("static"),
+ text ");"]
else
- uppBesides [ uppPStr SLIT("CC_EXTERN"),uppChar '(', upp_ident, uppStr ");" ]
+ hcat [ ptext SLIT("CC_EXTERN"),char '(', upp_ident, text ");" ]
where
upp_ident = uppCostCentre sty False{-as identifier!-} cc
- pp_str s = uppBesides [uppChar '"',uppPStr s, uppChar '"' ]
- pp_char c = uppBesides [uppChar '\'', uppPStr c, uppChar '\'']
+ pp_str s = doubleQuotes (ptext s)
(mod_name, grp_name, is_subsumed, externally_visible)
= case cc of
opt_CompilingGhcInternals
)
import CostCentre -- lots of things
-import Id ( idType, mkSysLocal, emptyIdSet )
+import Id ( idType, mkSysLocal, emptyIdSet, SYN_IE(Id) )
import Maybes ( maybeToBool )
import PprStyle -- ToDo: rm
import SrcLoc ( noSrcLoc )
import Type ( splitSigmaTy, getFunTy_maybe )
-import UniqSupply ( getUnique, splitUniqSupply )
+import UniqSupply ( getUnique, splitUniqSupply, UniqSupply )
+import Unique ( Unique )
import Util ( removeDups, assertPanic )
infixr 9 `thenMM`, `thenMM_`
) where
-IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper))
+IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper,isLower, isSpace, ord))
IMPORT_DELOOPER(Ubiq)
IMPORT_DELOOPER(IdLoop) -- get the CostCentre type&constructors from here
import Demand ( Demand(..) {- instance Read -} )
import UniqFM ( UniqFM, listToUFM, lookupUFM)
--import FiniteMap ( FiniteMap, listToFM, lookupFM )
+#if __GLASGOW_HASKELL__ >= 202
+import Maybes ( MaybeErr(..) )
+#else
import Maybes ( Maybe(..), MaybeErr(..) )
+#endif
import Pretty
-import CharSeq ( CSeq )
import FastString
import StringBuffer
+#if __GLASGOW_HASKELL__ <= 201
import PreludeGlaST
-
+#else
+import GlaExts
+#endif
\end{code}
%************************************************************************
lex_demand (stepOnUntil (not . isSpace)
(stepOnBy# buf 3#)) -- past _S_
's'# -> case prefixMatch (stepOnBy# buf 2#) "cc_" of
- Just buf' -> lex_scc (stepOnUntil (not . isSpace)
- (stepOverLexeme buf'))
+ Just buf' -> lex_scc (stepOnUntil (not . isSpace) (stepOverLexeme buf'))
Nothing -> lex_keyword (stepOnBy# buf 1#) -- drop the '_' and assume
-- it is a keyword.
_ -> lex_keyword (stepOn buf)
Just buf' ->
case untilChar# (stepOverLexeme buf') '\"'# of
buf'' -> ITscc (mkAllCafsCC ({-module-}lexemeToFastString buf'') _NIL_):
- lexIface (stepOverLexeme buf'')
+ lexIface (stepOn (stepOverLexeme buf''))
Nothing ->
case prefixMatch (stepOn buf) "DICTs_in_...\"" of
Just buf' -> ITscc (preludeDictsCostCentre True) : lexIface (stepOverLexeme buf')
Just buf' ->
case untilChar# (stepOverLexeme buf') '\"'# of
buf'' -> ITscc (mkAllDictsCC (lexemeToFastString buf'') _NIL_ True):
- lexIface (stepOverLexeme buf'')
+ lexIface (stepOn (stepOverLexeme buf''))
Nothing ->
case prefixMatch (stepOn buf) "CAF:" of
Just buf' ->
case untilChar# (stepOverLexeme buf') '\"'# of
buf'' -> ITscc (cafifyCC (mkUserCC (lexemeToFastString buf'') _NIL_ _NIL_)):
- lexIface (stepOverLexeme buf'')
+ lexIface (stepOn (stepOverLexeme buf''))
Nothing ->
case untilChar# (stepOn buf) '\"'# of
buf' -> ITscc (mkUserCC (lexemeToFastString buf') _NIL_ _NIL_):
- lexIface (stepOverLexeme buf')
+ lexIface (stepOn (stepOverLexeme buf'))
c -> ITunknown [C# c] : lexIface (stepOn buf)
is_sym c#=
case c# of {
- ':'# -> True; '_'# -> True; '\''# -> True; '!'# -> True;
- '#'# -> True; '$'# -> True; ':'# -> True; '%'# -> True;
- '&'# -> True; '*'# -> True; '+'# -> True; '.'# -> True;
- '/'# -> True; '<'# -> True; '='# -> True; '>'# -> True;
- '?'# -> True; '\\'# -> True; '^'# -> True; '|'# -> True;
- '-'# -> True; '~'# -> True; '@'# -> True; _ -> False }
+ ':'# -> True; '_'# -> True; '\''# -> True; '!'# -> True;
+ '#'# -> True; '$'# -> True; ':'# -> True; '%'# -> True;
+ '&'# -> True; '*'# -> True; '+'# -> True; '.'# -> True;
+ '/'# -> True; '<'# -> True; '='# -> True; '>'# -> True;
+ '?'# -> True; '\\'# -> True; '^'# -> True; '|'# -> True;
+ '-'# -> True; '~'# -> True; '@'# -> True; _ -> False }
--isAlphanum c || c `elem` ":_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
map (\ (x,y) -> (_PK_ x,y))
[("/\\_", ITbiglam)
,("@_", ITatsign)
+ ,("letrec_", ITletrec)
,("interface_", ITinterface)
,("usages_", ITusages)
,("versions_", ITversions)
,("of", ITof)
,("in", ITin)
,("let", ITlet)
- ,("letrec", ITletrec)
,("deriving", ITderiving)
,("->", ITrarrow)
else
doDiscard inStr (incLexeme buf)
'"'# ->
+ let
+ odd_slashes buf flg i# =
+ case lookAhead# buf i# of
+ '\\'# -> odd_slashes buf (not flg) (i# -# 1#)
+ _ -> flg
+ in
case lookAhead# buf (negateInt# 1#) of --backwards, actually
- '\\'# -> -- false alarm, escaped.
- doDiscard inStr (incLexeme buf)
+ '\\'# -> -- escaping something..
+ if odd_slashes buf True (negateInt# 2#) then
+ -- odd number of slashes, " is escaped.
+ doDiscard inStr (incLexeme buf)
+ else
+ -- even number of slashes, \ is escaped.
+ doDiscard (not inStr) (incLexeme buf)
_ -> case inStr of -- forced to avoid build-up
True -> doDiscard False (incLexeme buf)
False -> doDiscard True (incLexeme buf)
-----------------------------------------------------------------
ifaceParseErr ln toks sty
- = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppPStr SLIT("toks="), ppStr (show (take 10 toks))]
+ = hsep [ptext SLIT("Interface-file parse error: line"), int ln, ptext SLIT("toks="), text (show (take 10 toks))]
\end{code}
import HsSyn
import RdrHsSyn
import Util ( panic )
+import SrcLoc ( SrcLoc )
#ifdef REALLY_HASKELL_1_3
ord = fromEnum :: Char -> Int
| RdrMatch_Guards
SrcLine SrcFun
RdrNamePat
- [(RdrNameHsExpr, RdrNameHsExpr)]
+ [([RdrNameStmt], RdrNameHsExpr)]
-- (guard, expr)
RdrBinding
\end{code}
cvBinds :: SrcFile -> SigConverter -> RdrBinding -> RdrNameHsBinds
cvBinds sf sig_cvtr binding
= case (cvMonoBindsAndSigs sf sig_cvtr binding) of { (mbs, sigs) ->
- if (null sigs)
- then SingleBind (RecBind mbs)
- else BindWith (RecBind mbs) sigs
+ MonoBind mbs sigs recursive
}
\end{code}
RdrMatch_NoGuard ln b c expr d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc sf ln)])
RdrMatch_Guards ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps)
-cvGRHS :: SrcFile -> SrcLine -> (RdrNameHsExpr, RdrNameHsExpr) -> RdrNameGRHS
+cvGRHS :: SrcFile -> SrcLine -> ([RdrNameStmt], RdrNameHsExpr) -> RdrNameGRHS
cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc sf sl)
\end{code}
module RdrHsSyn (
SYN_IE(RdrNameArithSeqInfo),
SYN_IE(RdrNameBangType),
- SYN_IE(RdrNameBind),
SYN_IE(RdrNameClassDecl),
SYN_IE(RdrNameClassOpSig),
SYN_IE(RdrNameConDecl),
import HsSyn
import Lex
import PrelMods ( pRELUDE )
-import Name ( ExportFlag(..), Module(..), pprModule,
- OccName(..), pprOccName, prefixOccName )
+import Name {- ( ExportFlag(..), Module(..), pprModule,
+ OccName(..), pprOccName, prefixOccName ) -}
import Pretty
import PprStyle ( PprStyle(..) )
-import Util ( cmpPString, panic, thenCmp )
+import Util --( cmpPString, panic, thenCmp )
+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 RdrNameBangType = BangType RdrName
-type RdrNameBind = Bind Fake Fake RdrName RdrNamePat
type RdrNameClassDecl = ClassDecl Fake Fake RdrName RdrNamePat
type RdrNameClassOpSig = Sig RdrName
type RdrNameConDecl = ConDecl RdrName
ieOcc ie = rdrNameOcc (ieName ie)
instance Text RdrName where -- debugging
- showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn))
+ showsPrec _ rn = showString (show (ppr PprDebug rn))
instance Eq RdrName where
a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
cmp = cmpRdr
instance Outputable RdrName where
- ppr sty (Unqual n) = pprOccName sty n
- ppr sty (Qual m n) = ppBesides [pprModule sty m, ppChar '.', pprOccName sty n]
+ 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]
instance NamedThing RdrName where -- Just so that pretty-printing of expressions works
getOccName = rdrNameOcc
getName = panic "no getName for RdrNames"
-showRdr sty rdr = ppShow 100 (ppr sty rdr)
+showRdr sty rdr = render (ppr sty rdr)
\end{code}
IMP_Ubiq()
IMPORT_1_3(IO(hPutStr, stderr))
-IMPORT_1_3(GHCio(stThen))
+#if __GLASGOW_HASKELL__ == 201
+import GHCio(stThen)
+#elif __GLASGOW_HASKELL__ >= 202
+import GlaExts
+import IOBase
+import PrelRead
+#endif
import UgenAll -- all Yacc parser gumpff...
import PrefixSyn -- and various syntaxen.
import HsSyn
import HsTypes ( HsTyVar(..) )
import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas )
-import RdrHsSyn
+import RdrHsSyn
import PrefixToHs
import ErrUtils ( addErrLoc, ghcExit )
import FiniteMap ( elemFM, FiniteMap )
-import Name ( RdrName(..), OccName(..) )
+import Name ( OccName(..), SYN_IE(Module) )
import Lex ( isLexConId )
import PprStyle ( PprStyle(..) )
import PrelMods
import Pretty
import SrcLoc ( mkGeneratedSrcLoc, noSrcLoc, SrcLoc )
import Util ( nOfThem, pprError, panic )
+
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable ( Outputable(..) )
+#endif
+
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-#if __GLASGOW_HASKELL__ >= 200
+#if __GLASGOW_HASKELL__ == 201
# define PACK_STR packCString
-# define CCALL_THEN `stThen`
+#elif __GLASGOW_HASKELL__ >= 202
+# define PACK_STR mkFastCharString
#else
# define PACK_STR mkFastCharString
-# define CCALL_THEN `thenPrimIO`
#endif
rdModule :: IO (Module, -- this module's name
RdrNameHsModule) -- the main goods
rdModule
- = _ccall_ hspmain CCALL_THEN \ pt -> -- call the Yacc parser!
+ = _ccall_ hspmain `CCALL_THEN` \ pt -> -- call the Yacc parser!
let
srcfile = PACK_STR ``input_filename'' -- What A Great Hack! (TM)
in
U_comprh cexp cquals -> -- list comprehension
wlkExpr cexp `thenUgn` \ expr ->
- wlkList rd_qual cquals `thenUgn` \ quals ->
+ wlkQuals cquals `thenUgn` \ quals ->
getSrcLocUgn `thenUgn` \ loc ->
returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc)
- where
- rd_qual pt
- = rdU_tree pt `thenUgn` \ qual ->
- wlk_qual qual
-
- wlk_qual qual
- = case qual of
- U_guard exp ->
- wlkExpr exp `thenUgn` \ expr ->
- getSrcLocUgn `thenUgn` \ loc ->
- returnUgn (GuardStmt expr loc)
-
- U_qual qpat qexp ->
- wlkPat qpat `thenUgn` \ pat ->
- wlkExpr qexp `thenUgn` \ expr ->
- getSrcLocUgn `thenUgn` \ loc ->
- returnUgn (BindStmt pat expr loc)
-
- U_seqlet seqlet ->
- wlkBinding seqlet `thenUgn` \ bs ->
- getSrcFileUgn `thenUgn` \ sf ->
- let
- binds = cvBinds sf cvValSig bs
- in
- returnUgn (LetStmt binds)
U_eenum efrom estep eto -> -- arithmetic sequence
wlkExpr efrom `thenUgn` \ e1 ->
Nothing -> (rvar, HsVar rvar, True{-pun-})
Just re -> (rvar, re, False)
)
+
+wlkQuals cquals
+ = wlkList rd_qual cquals
+ where
+ rd_qual pt
+ = rdU_tree pt `thenUgn` \ qual ->
+ wlk_qual qual
+
+ wlk_qual qual
+ = case qual of
+ U_guard exp ->
+ wlkExpr exp `thenUgn` \ expr ->
+ getSrcLocUgn `thenUgn` \ loc ->
+ returnUgn (GuardStmt expr loc)
+
+ U_qual qpat qexp ->
+ wlkPat qpat `thenUgn` \ pat ->
+ wlkExpr qexp `thenUgn` \ expr ->
+ getSrcLocUgn `thenUgn` \ loc ->
+ returnUgn (BindStmt pat expr loc)
+
+ U_seqlet seqlet ->
+ wlkBinding seqlet `thenUgn` \ bs ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ binds = cvBinds sf cvValSig bs
+ in
+ returnUgn (LetStmt binds)
\end{code}
Patterns: just bear in mind that lists of patterns are represented as
_ -> getSrcLocUgn `thenUgn` \ loc ->
let
err = addErrLoc loc "Illegal pattern `application'"
- (\sty -> ppInterleave ppSP (map (ppr sty) (lpat:lpats)))
- msg = ppShow 100 (err PprForUser)
+ (\sty -> hsep (map (ppr sty) (lpat:lpats)))
+ msg = show (err PprForUser)
in
-#if __GLASGOW_HASKELL__ >= 200
+#if __GLASGOW_HASKELL__ == 201
ioToUgnM (GHCbase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
ioToUgnM (GHCbase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ ->
+#elif __GLASGOW_HASKELL__ >= 202
+ ioToUgnM (IOBase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
+ ioToUgnM (IOBase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ ->
#else
ioToUgnM (hPutStr stderr msg) `thenUgn` \ _ ->
ioToUgnM (ghcExit 1) `thenUgn` \ _ ->
where
as_char s = _HEAD_ s
as_integer s = readInteger (_UNPK_ s)
-#if __GLASGOW_HASKELL__ >= 200
+#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 } -- ToDo, use non-std readRational__
#else
as_rational s = _readRational (_UNPK_ s) -- non-std
#endif
wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
wlkList rdConDecl tcons `thenUgn` \ cons ->
wlkDerivings tderivs `thenUgn` \ derivings ->
- returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings noDataPragmas src_loc))
+ returnUgn (RdrTyDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
-- "newtype" declaration
U_ntbind ntctxt nttype ntcon ntderivs srcline ->
mkSrcLocUgn srcline $ \ src_loc ->
wlkContext ntctxt `thenUgn` \ ctxt ->
wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
- wlkList rdConDecl ntcon `thenUgn` \ [con] ->
+ wlkList rdConDecl ntcon `thenUgn` \ cons ->
wlkDerivings ntderivs `thenUgn` \ derivings ->
- returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings noDataPragmas src_loc))
+ returnUgn (RdrTyDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
-- "type" declaration
U_nbind nbindid nbindas srcline ->
wlkMonoType ttype
= case ttype of
+ -- Glasgow extension: nested polymorhism
+ U_context tcontextl tcontextt -> -- context
+ wlkContext tcontextl `thenUgn` \ ctxt ->
+ wlkMonoType tcontextt `thenUgn` \ ty ->
+ returnUgn (HsPreForAllTy ctxt ty)
+
U_namedtvar tv -> -- type variable
wlkTvId tv `thenUgn` \ tyvar ->
returnUgn (MonoTyVar tyvar)
wlkConDecl :: U_constr -> UgnM RdrNameConDecl
+wlkConDecl (U_constrcxt ccxt ccdecl)
+ = wlkContext ccxt `thenUgn` \ theta ->
+ wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ details loc) ->
+ returnUgn (ConDecl con theta details loc)
+
wlkConDecl (U_constrpre ccon ctys srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkDataId ccon `thenUgn` \ con ->
wlkList rdBangType ctys `thenUgn` \ tys ->
- returnUgn (ConDecl con tys src_loc)
+ returnUgn (ConDecl con [] (VanillaCon tys) src_loc)
wlkConDecl (U_constrinf cty1 cop cty2 srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkBangType cty1 `thenUgn` \ ty1 ->
wlkDataId cop `thenUgn` \ op ->
wlkBangType cty2 `thenUgn` \ ty2 ->
- returnUgn (ConOpDecl ty1 op ty2 src_loc)
+ returnUgn (ConDecl op [] (InfixCon ty1 ty2) src_loc)
wlkConDecl (U_constrnew ccon cty srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkDataId ccon `thenUgn` \ con ->
wlkMonoType cty `thenUgn` \ ty ->
- returnUgn (NewConDecl con ty src_loc)
+ returnUgn (ConDecl con [] (NewCon ty) src_loc)
wlkConDecl (U_constrrec ccon cfields srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkDataId ccon `thenUgn` \ con ->
wlkList rd_field cfields `thenUgn` \ fields_lists ->
- returnUgn (RecConDecl con fields_lists src_loc)
+ returnUgn (ConDecl con [] (RecCon fields_lists) src_loc)
where
rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
rd_field pt
where
rd_gd_expr pt
= rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
- wlkExpr g `thenUgn` \ guard ->
+ wlkQuals g `thenUgn` \ guard ->
wlkExpr e `thenUgn` \ expr ->
returnUgn (guard, expr)
\end{code}
import Literal
import HsPragmas ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas )
import IdInfo ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo,
- ArgUsageInfo, FBTypeInfo
+ ArgUsageInfo, FBTypeInfo, ArityInfo, StrictnessInfo
)
import Kind ( Kind, mkArrowKind, mkTypeKind )
import Lex
)
import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
-import Name ( OccName(..), isTCOcc, Provenance )
+import Name ( OccName(..), isTCOcc, Provenance, SYN_IE(Module) )
import SrcLoc ( mkIfaceSrcLoc )
import Util ( panic{-, pprPanic ToDo:rm-} )
import ParseType ( parseType )
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 $2 $3 $4 $5 $6 noDataPragmas mkIfaceSrcLoc) }
- | NEWTYPE decl_context tc_name tv_bndrs EQUAL constr1 deriving SEMI
- { TyD (TyNew $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) }
+ { 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 id_info
----------------------------------------------------------------
}
-constrs :: { [RdrNameConDecl] }
+constrs :: { [RdrNameConDecl] {- empty for handwritten abstract -} }
: { [] }
| EQUAL constrs1 { $2 }
| constr VBAR constrs1 { $1 : $3 }
constr :: { RdrNameConDecl }
-constr : data_name batypes { ConDecl $1 $2 mkIfaceSrcLoc }
- | data_name OCURLY fields1 CCURLY { RecConDecl $1 $3 mkIfaceSrcLoc }
+constr : data_name batypes { ConDecl $1 [] (VanillaCon $2) mkIfaceSrcLoc }
+ | data_name OCURLY fields1 CCURLY { ConDecl $1 [] (RecCon $3) mkIfaceSrcLoc }
-constr1 :: { RdrNameConDecl {- For a newtype -} }
-constr1 : data_name atype { NewConDecl $1 $2 mkIfaceSrcLoc }
+newtype_constr :: { [RdrNameConDecl] {- Empty if handwritten abstract -} }
+newtype_constr : { [] }
+ | EQUAL data_name atype { [ConDecl $2 [] (NewCon $3) mkIfaceSrcLoc] }
deriving :: { Maybe [RdrName] }
: { Nothing }
- | DERIVING OPAREN qtc_names1 CPAREN { Just $3 }
+ | DERIVING OPAREN tc_names1 CPAREN { Just $3 }
batypes :: { [RdrNameBangType] }
batypes : { [] }
| class COMMA context_list1 { $1 : $3 }
class :: { (RdrName, RdrNameHsType) }
-class : qtc_name atype { ($1, $2) }
+class : tc_name atype { ($1, $2) }
type :: { RdrNameHsType }
type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 }
- | tautype { $1 }
-
-tautype :: { RdrNameHsType }
-tautype : btype { $1 }
- | btype RARROW tautype { MonoFunTy $1 $3 }
+ | btype RARROW type { MonoFunTy $1 $3 }
+ | btype { $1 }
types2 :: { [RdrNameHsType] {- Two or more -} }
types2 : type COMMA type { [$1,$3] }
| btype atype { MonoTyApp $1 $2 }
atype :: { RdrNameHsType }
-atype : qtc_name { MonoTyVar $1 }
+atype : tc_name { MonoTyVar $1 }
| tv_name { MonoTyVar $1 }
| OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 }
| OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 }
- | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 }
+ | OCURLY tc_name atype CCURLY { MonoDictTy $2 $3 }
| OPAREN type CPAREN { $2 }
atypes :: { [RdrNameHsType] {- Zero or more -} }
| CONSYM { Unqual (VarOcc $1) }
-qtc_name :: { RdrName }
-qtc_name : QCONID { tcQual $1 }
-
-qtc_names1 :: { [RdrName] }
- : qtc_name { [$1] }
- | qtc_name COMMA qtc_names1 { $1 : $3 }
+tc_names1 :: { [RdrName] }
+ : tc_name { [$1] }
+ | tc_name COMMA tc_names1 { $1 : $3 }
tc_name :: { RdrName }
tc_name : tc_occ { Unqual $1 }
+ | QCONID { tcQual $1 }
tv_name :: { RdrName }
tv_name : VARID { Unqual (TvOcc $1) }
import Name ( OccName(..), isTCOcc, Provenance )
import SrcLoc ( mkIfaceSrcLoc )
import Util ( panic{-, pprPanic ToDo:rm-} )
-import Pretty ( ppShow )
+import Pretty ( Doc )
import PprStyle -- PprDebug for panic
import Maybes ( MaybeErr(..) )
------------------------------------------------------------------
-parseType :: [IfaceToken] -> MaybeErr RdrNameHsType (PprStyle -> Int -> Bool -> PrettyRep)
+parseType :: [IfaceToken] -> MaybeErr RdrNameHsType (PprStyle -> Doc)
parseType ls =
let
res =
case parseT ls of
v@(Succeeded _) -> v
- Failed err -> panic (ppShow 80 (err PprDebug))
+ Failed err -> panic (show (err PprDebug))
in
res
type :: { RdrNameHsType }
type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 }
- | tautype { $1 }
+ | btype RARROW type { MonoFunTy $1 $3 }
+ | btype { $1 }
forall : OBRACK tv_bndrs CBRACK { $2 }
| class COMMA context_list1 { $1 : $3 }
class :: { (RdrName, RdrNameHsType) }
-class : qtc_name atype { ($1, $2) }
+class : tc_name atype { ($1, $2) }
-tautype :: { RdrNameHsType }
-tautype : btype { $1 }
- | btype RARROW tautype { MonoFunTy $1 $3 }
-
types2 :: { [RdrNameHsType] {- Two or more -} }
types2 : type COMMA type { [$1,$3] }
| type COMMA types2 { $1 : $3 }
| btype atype { MonoTyApp $1 $2 }
atype :: { RdrNameHsType }
-atype : qtc_name { MonoTyVar $1 }
+atype : tc_name { MonoTyVar $1 }
| tv_name { MonoTyVar $1 }
| OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 }
| OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 }
- | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 }
+ | OCURLY tc_name atype CCURLY { MonoDictTy $2 $3 }
| OPAREN type CPAREN { $2 }
atypes :: { [RdrNameHsType] {- Zero or more -} }
tv_names :: { [RdrName] }
: { [] }
| tv_name tv_names { $1 : $2 }
-qtc_name :: { RdrName }
-qtc_name : QCONID { tcQual $1 }
+
+tc_name :: { RdrName }
+tc_name : QCONID { tcQual $1 }
+ | CONID { Unqual (TCOcc $1) }
+ | CONSYM { Unqual (TCOcc $1) }
+ | OPAREN RARROW CPAREN { Unqual (TCOcc SLIT("->")) }
import PrimRep ( decodePrimRep )
import HsPragmas ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas )
import IdInfo ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo,
- ArgUsageInfo, FBTypeInfo
+ ArgUsageInfo, FBTypeInfo, ArityInfo, StrictnessInfo
)
import Kind ( Kind, mkArrowKind, mkTypeKind )
import Lex
)
import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
-import Name ( OccName(..), isTCOcc, Provenance )
+import Name ( OccName(..), isTCOcc, Provenance, SYN_IE(Module) )
import SrcLoc ( mkIfaceSrcLoc )
import Util ( panic{-, pprPanic ToDo:rm-} )
-import Pretty ( ppShow )
+import Pretty ( Doc )
import PprStyle -- PprDebug for panic
import Maybes ( MaybeErr(..) )
case parseUnfold ls of
v@(Succeeded _) -> v
-- ill-formed unfolding, crash and burn.
- Failed err -> panic (ppShow 80 (err PprDebug))
+ Failed err -> panic (show (err PprDebug))
in
res
}
core_expr :: { UfExpr RdrName }
core_expr : any_var_name { UfVar $1 }
- | qdata_name { UfVar $1 }
+ | data_name { UfVar $1 }
| core_lit { UfLit $1 }
| OPAREN core_expr CPAREN { $2 }
- | qdata_name OCURLY data_args CCURLY { UfCon $1 $3 }
+ | data_name OCURLY data_args CCURLY { UfCon $1 $3 }
| core_expr ATSIGN atype { UfApp $1 (UfTyArg $3) }
| core_expr core_arg { UfApp $1 $2 }
UfPrim (UfCCallOp $2 is_casm may_gc $5 $4)
$7
}
- | SCC OPAREN core_expr CPAREN { UfSCC $1 $3 }
+ | 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 }
+coerce : COERCE_IN data_name { UfIn $2 }
+ | COERCE_OUT data_name { UfOut $2 }
prim_alts :: { [(Literal,UfExpr RdrName)] }
: { [] }
alg_alts :: { [(RdrName, [RdrName], UfExpr RdrName)] }
: { [] }
- | qdata_name var_names RARROW
+ | data_name var_names RARROW
core_expr SEMI alg_alts { ($1,$2,$4) : $6 }
core_default :: { UfDefault RdrName }
| var_name RARROW core_expr SEMI { UfBindDefault $1 $3 }
core_arg :: { UfArg RdrName }
- : var_name { UfVarArg $1 }
- | qvar_name { UfVarArg $1 }
- | qdata_name { UfVarArg $1 }
+ : any_var_name { UfVarArg $1 }
+ | data_name { UfVarArg $1 }
| core_lit { UfLitArg $1 }
core_args :: { [UfArg RdrName] }
| VARSYM { VarOcc $1 }
| BANG { VarOcc SLIT("!") {-sigh, double-sigh-} }
-qdata_name :: { RdrName }
-qdata_name : QCONID { varQual $1 }
+data_name :: { RdrName }
+data_name : QCONID { varQual $1 }
| QCONSYM { varQual $1 }
+ | CONID { Unqual (VarOcc $1) }
+ | CONSYM { Unqual (VarOcc $1) }
qvar_name :: { RdrName }
: QVARID { varQual $1 }
| class COMMA context_list1 { $1 : $3 }
class :: { (RdrName, RdrNameHsType) }
-class : qtc_name atype { ($1, $2) }
+class : tc_name atype { ($1, $2) }
type :: { RdrNameHsType }
type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 }
- | tautype { $1 }
-
-tautype :: { RdrNameHsType }
-tautype : btype { $1 }
- | btype RARROW tautype { MonoFunTy $1 $3 }
+ | btype RARROW type { MonoFunTy $1 $3 }
+ | btype { $1 }
types2 :: { [RdrNameHsType] {- Two or more -} }
types2 : type COMMA type { [$1,$3] }
| btype atype { MonoTyApp $1 $2 }
atype :: { RdrNameHsType }
-atype : qtc_name { MonoTyVar $1 }
+atype : tc_name { MonoTyVar $1 }
| tv_name { MonoTyVar $1 }
| OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 }
| OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 }
- | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 }
+ | OCURLY tc_name atype CCURLY { MonoDictTy $2 $3 }
| OPAREN type CPAREN { $2 }
atypes :: { [RdrNameHsType] {- Zero or more -} }
tv_names :: { [RdrName] }
: { [] }
| tv_name tv_names { $1 : $2 }
-qtc_name :: { RdrName }
-qtc_name : QCONID { tcQual $1 }
+
+tc_name :: { RdrName }
+tc_name : QCONID { tcQual $1 }
+ | CONID { Unqual (TCOcc $1) }
+ | CONSYM { Unqual (TCOcc $1) }
+ | OPAREN RARROW CPAREN { Unqual (TCOcc SLIT("->")) }
module Rename ( renameModule ) where
+#if __GLASGOW_HASKELL__ <= 201
import PreludeGlaST ( thenPrimIO )
+#else
+import GlaExts
+import IO
+#endif
IMP_Ubiq()
IMPORT_1_3(List(partition))
import HsSyn
-import RdrHsSyn ( RdrName, SYN_IE(RdrNameHsModule), SYN_IE(RdrNameImportDecl) )
+import RdrHsSyn ( RdrName(..), SYN_IE(RdrNameHsModule), SYN_IE(RdrNameImportDecl) )
import RnHsSyn ( SYN_IE(RenamedHsModule), SYN_IE(RenamedHsDecl), extractHsTyNames )
-import CmdLineOpts ( opt_HiMap )
+import CmdLineOpts ( opt_HiMap, opt_WarnNameShadowing, opt_D_show_rn_trace,
+ opt_D_dump_rn, opt_D_show_passes
+ )
import RnMonad
import RnNames ( getGlobalNames )
import RnSource ( rnDecl )
import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getSpecialInstModules,
- mkSearchPath
+ getDeferredDataDecls,
+ mkSearchPath, getSlurpedNames, getRnStats
)
import RnEnv ( availsToNameSet, addAvailToNameSet,
addImplicitOccsRn, lookupImplicitOccRn )
import Id ( GenId {- instance NamedThing -} )
import Name ( Name, Provenance, ExportFlag(..), isLocallyDefined,
- NameSet(..), elemNameSet, mkNameSet, unionNameSets, nameSetToList,
- isWiredInName, modAndOcc
+ NameSet(..), elemNameSet, mkNameSet, unionNameSets,
+ nameSetToList, minusNameSet, NamedThing(..),
+ modAndOcc, pprModule, pprOccName, nameOccName
)
import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon )
import PrelInfo ( ioTyCon_NAME, primIoTyCon_NAME )
import FiniteMap ( emptyFM, eltsFM, fmToList, addToFM, FiniteMap )
import Pretty
import PprStyle ( PprStyle(..) )
-import Util ( panic, assertPanic, pprTrace )
+import Util ( cmpPString, equivClasses, panic, assertPanic, pprTrace )
+#if __GLASGOW_HASKELL__ >= 202
+import UniqSupply
+#endif
\end{code}
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, local_avails) ->
+ Just (export_env, rn_env, explicit_names) ->
-- RENAME THE SOURCE
initRnMS rn_env mod_name SourceMode (
getImportVersions mod_name exports `thenRn` \ import_versions ->
getNameSupplyRn `thenRn` \ name_supply ->
+ -- REPORT UNUSED NAMES
+ reportUnusedNames explicit_names `thenRn_`
-- GENERATE THE SPECIAL-INSTANCE MODULE LIST
-- The "special instance" modules are those modules that contain instance
in
-
-- RETURN THE RENAMED MODULE
let
import_mods = [mod | ImportDecl mod _ _ _ _ <- imports]
rn_all_decls
loc
in
+ rnStats rn_all_decls `thenRn_`
returnRn (Just (renamed_module,
(import_versions, export_env, special_inst_mods),
name_supply,
case maybe_unresolved of
-- No more unresolved names
- Nothing -> -- Slurp instance declarations
+ Nothing -> -- Instance decls still pending?
getImportedInstDecls `thenRn` \ inst_decls ->
- traceRn (ppSep [ppPStr SLIT("Slurped"), ppInt (length inst_decls), ppPStr SLIT("instance decls")])
+ traceRn (sep [ptext SLIT("Slurped"), int (length inst_decls), ptext SLIT("instance decls")])
`thenRn_`
-
- -- None? then at last we are done
- if null inst_decls then
- returnRn decls
- else
- mapRn rn_inst_decl inst_decls `thenRn` \ new_inst_decls ->
-
- -- We *must* loop again here. Why? Two reasons:
- -- (a) an instance decl will give rise to an unresolved dfun, whose
- -- decl we must slurp to get its version number; that's the version
- -- number for the whole instance decl.
- -- (b) an instance decl might give rise to a new unresolved class,
- -- whose decl we must slurp, which might let in some new instance decls,
- -- and so on. Example: instance Foo a => Baz [a] where ...
-
- closeDecls (new_inst_decls ++ decls)
+ if not (null inst_decls) then
+ mapRn rn_inst_decl inst_decls `thenRn` \ new_inst_decls ->
+
+ -- We *must* loop again here. Why? Two reasons:
+ -- (a) an instance decl will give rise to an unresolved dfun, whose
+ -- decl we must slurp to get its version number; that's the version
+ -- number for the whole instance decl. (And its unfolding might mention new
+ -- unresolved names.)
+ -- (b) an instance decl might give rise to a new unresolved class,
+ -- whose decl we must slurp, which might let in some new instance decls,
+ -- and so on. Example: instance Foo a => Baz [a] where ...
+
+ closeDecls (new_inst_decls ++ decls)
+ else
+
+ -- No more instance decls, so all we have left is
+ -- to deal with the deferred data type decls.
+ getDeferredDataDecls `thenRn` \ data_decls ->
+ mapRn rn_data_decl data_decls `thenRn` \ rn_data_decls ->
+ returnRn (rn_data_decls ++ decls)
-- An unresolved name
Just (name,necessity)
-> -- Slurp its declaration, if any
--- traceRn (ppSep [ppPStr SLIT("Considering"), ppr PprDebug name]) `thenRn_`
+-- traceRn (sep [ptext SLIT("Considering"), ppr PprDebug name]) `thenRn_`
importDecl name necessity `thenRn` \ maybe_decl ->
case maybe_decl of
-- Found a declaration... rename it
Just decl -> rn_iface_decl mod_name decl `thenRn` \ new_decl ->
closeDecls (new_decl : decls)
- where
- (mod_name,_) = modAndOcc name
- where
+ where
+ (mod_name,_) = modAndOcc name
+
+
+rn_iface_decl mod_name decl = initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl decl)
-- Notice that the rnEnv starts empty
- rn_iface_decl mod_name decl = initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl decl)
- rn_inst_decl (mod_name,decl) = rn_iface_decl mod_name (InstD decl)
+rn_inst_decl (mod_name,decl) = rn_iface_decl mod_name (InstD decl)
+
+rn_data_decl (tycon_name,ty_decl) = rn_iface_decl mod_name (TyD ty_decl)
+ where
+ (mod_name, _) = modAndOcc tycon_name
\end{code}
+\begin{code}
+reportUnusedNames explicit_avail_names
+ | not opt_WarnNameShadowing
+ = returnRn ()
+
+ | otherwise
+ = getSlurpedNames `thenRn` \ slurped_names ->
+ let
+ 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
+
+ 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 (nameModule n), char ':'],
+ nest 4 (sep (map (pprOccName sty . 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))]
+ in
+ (if null imported_unused
+ then returnRn ()
+ else addWarnRn pp_imp) `thenRn_`
+
+ (if null local_unused
+ then returnRn ()
+ else addWarnRn pp_local)
+
+nameModule n = fst (modAndOcc n)
+
+rnStats :: [RenamedHsDecl] -> RnMG ()
+rnStats all_decls
+ | opt_D_show_rn_trace ||
+ opt_D_dump_rn ||
+ opt_D_show_passes
+ = getRnStats all_decls `thenRn` \ msg ->
+ ioToRnMG (hPutStr stderr (show msg) >>
+ hPutStr stderr "\n") `thenRn_`
+ returnRn ()
+
+ | otherwise = returnRn ()
+\end{code}
--- /dev/null
+_interface_ RnBinds 1
+_exports_
+RnBinds rnBinds;
+_declarations_
+1 rnBinds _:_ _forall_ [a b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS a (b, RnMonad.FreeVars)) -> RnMonad.RnMS a (b, RnMonad.FreeVars) ;;
import RnHsSyn
import RnMonad
import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
-import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, isUnboundName )
+import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, newLocalNames, isUnboundName )
import CmdLineOpts ( opt_SigsRequired )
-import Digraph ( stronglyConnComp )
+import Digraph ( stronglyConnComp, SCC(..) )
import ErrUtils ( addErrLoc, addShortErrLocLine )
import Name ( OccName(..), Provenance,
Name {- instance Eq -},
import Maybes ( catMaybes )
--import PprStyle--ToDo:rm
import Pretty
-import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic )
+import Util ( Ord3(..), thenCmp, isIn, removeDups, panic, panic#, assertPanic, assocDefault )
import UniqSet ( SYN_IE(UniqSet) )
import ListSetOps ( minusList )
import Bag ( bagToList )
import UniqFM ( UniqFM )
import ErrUtils ( SYN_IE(Error) )
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable
+#endif
+
\end{code}
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
rnTopBinds :: RdrNameHsBinds -> RnMS s RenamedHsBinds
rnTopBinds EmptyBinds = returnRn EmptyBinds
-rnTopBinds (SingleBind (RecBind bind)) = rnTopMonoBinds bind []
-rnTopBinds (BindWith (RecBind bind) sigs) = rnTopMonoBinds bind sigs
+rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
-- The parser doesn't produce other forms
-> (RenamedHsBinds -> RnMS s (result, FreeVars))
-> RnMS s (result, FreeVars)
-rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds
-rnBinds (SingleBind (RecBind bind)) thing_inside = rnMonoBinds bind [] thing_inside
-rnBinds (BindWith (RecBind bind) sigs) thing_inside = rnMonoBinds bind sigs thing_inside
+rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds
+rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
-- the parser doesn't produce other forms
= -- 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 "binding group" mbinders_w_srclocs $ \ new_mbinders ->
+ bindLocatedLocalsRn (\_ -> text "binding group") mbinders_w_srclocs $ \ new_mbinders ->
let
binder_set = mkNameSet new_mbinders
in
flattenMonoBinds 0 siglist mbinds `thenRn` \ (_, mbinds_info) ->
-- Do the SCC analysis
- let vertices = mkVertices mbinds_info
- edges = mkEdges mbinds_info
- scc_result = stronglyConnComp (==) edges vertices
- final_binds = foldr1 ThenBinds (map (reconstructCycle edges mbinds_info) scc_result)
+ let edges = mkEdges mbinds_info
+ scc_result = stronglyConnComp edges
+ final_binds = foldr1 ThenBinds (map reconstructCycle scc_result)
-- Deal with bound and free-var calculation
rhs_fvs = unionManyNameSets [fvs | (_,_,fvs,_,_) <- mbinds_info]
flattenMonoBinds :: Int -- Next free vertex tag
-> [RenamedSig] -- Signatures
-> RdrNameMonoBinds
- -> RnMS s (Int, FlatMonoBindsInfo)
+ -> RnMS s (Int, [FlatMonoBindsInfo])
flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, [])
rnMethodBinds (FunMonoBind occname inf matches locn)
= pushSrcLocRn locn $
mapRn (checkPrecMatch inf occname) matches `thenRn_`
- lookupBndrRn occname `thenRn` \ op_name ->
+
+ newLocalNames [(occname, locn)] `thenRn` \ [op_name] ->
+ -- Make a fresh local for the bound variable; it must be different
+ -- to occurrences of the same thing on the LHS, which refer to the global
+ -- selectors.
+
mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
returnRn (FunMonoBind op_name inf new_matches locn)
rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
= pushSrcLocRn locn $
- lookupBndrRn occname `thenRn` \ op_name ->
+ newLocalNames [(occname, locn)] `thenRn` \ [op_name] ->
rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) ->
returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
as the two cases are similar.
\begin{code}
-reconstructCycle :: [Edge] -- Original edges
- -> FlatMonoBindsInfo
- -> Cycle
+reconstructCycle :: SCC FlatMonoBindsInfo
-> RenamedHsBinds
-reconstructCycle edges mbi cycle
- = mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle)
+reconstructCycle (AcyclicSCC (_, _, _, binds, sigs))
+ = MonoBind binds sigs nonRecursive
+
+reconstructCycle (CyclicSCC cycle)
+ = MonoBind this_gp_binds this_gp_sigs recursive
where
- relevant_binds_and_sigs = [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi,
- vertex `is_elem` cycle]
- (binds, sig_lists) = unzip relevant_binds_and_sigs
- this_gp_binds = foldr1 AndMonoBinds binds
- this_gp_sigs = foldr1 (++) sig_lists
-
- is_elem = isIn "reconstructRec"
-
- mk_binds :: RenamedMonoBinds -> [RenamedSig] -> Bool -> RenamedHsBinds
- mk_binds bs [] True = SingleBind (RecBind bs)
- mk_binds bs ss True = BindWith (RecBind bs) ss
- mk_binds bs [] False = SingleBind (NonRecBind bs)
- mk_binds bs ss False = BindWith (NonRecBind bs) ss
-
- -- moved from Digraph, as this is the only use here
- -- (avoid overloading cost). We have to use elem
- -- (not FiniteMaps or whatever), because there may be
- -- many edges out of one vertex. We give it its own
- -- "elem" just for speed.
-
- isCyclic es [] = panic "isCyclic: empty component"
- isCyclic es [v] = (v,v) `elem` es
- isCyclic es vs = True
-
- elem _ [] = False
- elem x (y:ys) = x==y || elem x ys
+ this_gp_binds = foldr1 AndMonoBinds [binds | (_, _, _, binds, _) <- cycle]
+ this_gp_sigs = foldr1 (++) [sigs | (_, _, _, _, sigs) <- cycle]
\end{code}
%************************************************************************
\begin{code}
type FlatMonoBindsInfo
- = [(VertexTag, -- Identifies the vertex
- NameSet, -- Set of names defined in this vertex
- NameSet, -- Set of names used in this vertex
- RenamedMonoBinds, -- Binding for this vertex (always just one binding, either fun or pat)
- [RenamedSig]) -- Signatures, if any, for this vertex
- ]
+ = (VertexTag, -- Identifies the vertex
+ NameSet, -- Set of names defined in this vertex
+ NameSet, -- Set of names used in this vertex
+ RenamedMonoBinds, -- Binding for this vertex (always just one binding, either fun or pat)
+ [RenamedSig]) -- Signatures, if any, for this vertex
-mkVertices :: FlatMonoBindsInfo -> [VertexTag]
-mkEdges :: FlatMonoBindsInfo -> [Edge]
-mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
+mkEdges :: [FlatMonoBindsInfo] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])]
-mkEdges flat_info -- An edge (v,v') indicates that v depends on v'
- = [ (source_vertex, target_vertex)
- | (source_vertex, _, used_names, _, _) <- flat_info,
- target_name <- nameSetToList used_names,
- target_vertex <- vertices_defining target_name flat_info
+mkEdges flat_info
+ = [ (info, tag, dest_vertices (nameSetToList names_used))
+ | info@(tag, names_defined, names_used, mbind, sigs) <- flat_info
]
- where
- -- If each name only has one binding in this group, then
- -- vertices_defining will always return the empty list, or a
- -- singleton. The case when there is more than one binding (an
- -- error) needs more thought.
-
- vertices_defining name flat_info2
- = [ vertex | (vertex, names_defined, _, _, _) <- flat_info2,
- name `elemNameSet` names_defined
- ]
+ where
+ -- An edge (v,v') indicates that v depends on v'
+ dest_vertices src_mentions = [ target_vertex
+ | (target_vertex, names_defined, _, _, _) <- flat_info,
+ mentioned_name <- src_mentions,
+ mentioned_name `elemNameSet` names_defined
+ ]
\end{code}
renameSig (Sig v ty src_loc)
= pushSrcLocRn src_loc $
- lookupBndrRn v `thenRn` \ new_v ->
- rnHsType ty `thenRn` \ new_ty ->
+ lookupBndrRn v `thenRn` \ new_v ->
+ rnHsSigType (\ sty -> ppr sty 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 ->
- rnHsType ty `thenRn` \ new_ty ->
- rn_using using `thenRn` \ new_using ->
+ rnHsSigType (\ sty -> ppr sty v) ty `thenRn` \ new_ty ->
+ rn_using using `thenRn` \ new_using ->
returnRn (SpecSig new_v new_ty new_using src_loc)
where
rn_using Nothing = returnRn Nothing
\begin{code}
dupSigDeclErr (sig:sigs)
= pushSrcLocRn loc $
- addErrRn (\sty -> ppSep [ppPStr SLIT("more than one"),
- ppPStr what_it_is, ppPStr SLIT("given for"),
- ppQuote (ppr sty (sig_name sig))])
+ addErrRn (\sty -> sep [ptext SLIT("more than one"),
+ ptext what_it_is, ptext SLIT("given for"),
+ ppr sty (sig_name sig)])
where
(what_it_is, loc) = sig_doc sig
unknownSigErr sig
= pushSrcLocRn loc $
- addErrRn (\sty -> ppSep [ppPStr flavour, ppPStr SLIT("but no definition for"),
- ppQuote (ppr sty (sig_name sig))])
+ addErrRn (\sty -> sep [ptext flavour, ptext SLIT("but no definition for"),
+ ppr sty (sig_name sig)])
where
(flavour, loc) = sig_doc sig
sig_doc (MagicUnfoldingSig _ _ loc) = (SLIT("MAGIC_UNFOLDING pragma"),loc)
missingSigErr var sty
- = ppSep [ppPStr SLIT("a definition but no type signature for"), ppQuote (ppr sty var)]
+ = sep [ptext SLIT("a definition but no type signature for"), ppr sty var]
methodBindErr mbind sty
- = ppHang (ppPStr SLIT("Can't handle multiple methods defined by one pattern binding"))
+ = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))
4 (ppr sty mbind)
\end{code}
occNameString, occNameFlavour,
SYN_IE(NameSet), emptyNameSet, addListToNameSet,
mkLocalName, mkGlobalName, modAndOcc, isLocallyDefinedName,
- isWiredInName, nameOccName, setNameProvenance, isVarOcc,
- pprProvenance, pprOccName, pprModule, pprNonSymOcc, pprNameProvenance
+ nameOccName, setNameProvenance, isVarOcc, getNameProvenance,
+ pprProvenance, pprOccName, pprModule, pprNameProvenance,
+ NamedThing(..)
)
import TyCon ( TyCon )
import TysWiredIn ( tupleTyCon, listTyCon, charTyCon, intTyCon )
import FiniteMap
+import Outputable
import Unique ( Unique, unboundKey )
+import UniqFM ( Uniquable(..) )
import Maybes ( maybeToBool )
import UniqSupply
import SrcLoc ( SrcLoc, noSrcLoc )
import Pretty
import PprStyle ( PprStyle(..) )
-import Util ( panic, removeDups, pprTrace, assertPanic )
+import Util --( panic, removeDups, pprTrace, assertPanic )
+#if __GLASGOW_HASKELL__ >= 202
+import List (nub)
+#endif
\end{code}
-- 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)
+ --
+ -- 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
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
- Nothing -> mkGlobalName uniq mod occ VanillaDefn provenance
+ Just name | is_implicit_prov
+ -> setNameProvenance name provenance
+ where
+ is_implicit_prov = case getNameProvenance name of
+ Implicit -> True
+ other -> False
+ other -> mkGlobalName uniq mod occ VanillaDefn provenance
+
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us', inst_ns, new_cache) `thenRn_`
\end{code}
\begin{code}
-bindLocatedLocalsRn :: String -- Documentation string for error message
+bindLocatedLocalsRn :: (PprStyle -> Doc) -- Documentation string for error message
-> [(RdrName,SrcLoc)]
-> ([Name] -> RnMS s a)
-> RnMS s a
bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
- = -- Check for use of qualified names
- mapRn (qualNameErr doc_str) quals `thenRn_`
- -- Check for dupicated names in a binding group
- mapRn (dupNamesErr doc_str) dups `thenRn_`
+ = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
getNameEnv `thenRn` \ name_env ->
(if opt_WarnNameShadowing
in
setNameEnv new_name_env (enclosed_scope names)
where
- quals = filter (isQual.fst) rdr_names_w_loc
- (these, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `cmp` n2) rdr_names_w_loc
check_shadow name_env (rdr_name,loc)
= case lookupFM name_env rdr_name of
Nothing -> returnRn ()
bindLocalsRn doc_str rdr_names enclosed_scope
= getSrcLocRn `thenRn` \ loc ->
- bindLocatedLocalsRn doc_str (rdr_names `zip` repeat loc) enclosed_scope
+ bindLocatedLocalsRn (\_ -> text doc_str)
+ (rdr_names `zip` repeat loc)
+ enclosed_scope
bindTyVarsRn doc_str tyvar_names enclosed_scope
= getSrcLocRn `thenRn` \ loc ->
in
bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
enclosed_scope (zipWith replaceTyVarName tyvar_names names)
+
+ -- Works in any variant of the renamer monad
+checkDupOrQualNames, checkDupNames :: (PprStyle -> Doc)
+ -> [(RdrName, SrcLoc)]
+ -> RnM s d ()
+
+checkDupOrQualNames doc_str rdr_names_w_loc
+ = -- Check for use of qualified names
+ mapRn (qualNameErr doc_str) quals `thenRn_`
+ checkDupNames doc_str rdr_names_w_loc
+ where
+ quals = filter (isQual.fst) rdr_names_w_loc
+
+checkDupNames doc_str rdr_names_w_loc
+ = -- Check for dupicated names in a binding group
+ mapRn (dupNamesErr doc_str) dups `thenRn_`
+ returnRn ()
+ where
+ (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `cmp` n2) rdr_names_w_loc
\end{code}
= mapRn (addErrRn.nameClashErr) (conflictsFM (/=) n1 n2) `thenRn_`
returnRn (n1 `plusFM` n2)
-addOneToNameEnvRn :: NameEnv -> RdrName -> Name -> RnM s d NameEnv
-addOneToNameEnvRn env rdr_name name
- = mapRn (addErrRn.nameClashErr) (conflictFM (/=) env rdr_name name) `thenRn_`
- returnRn (addToFM env rdr_name name)
+addOneToNameEnv :: NameEnv -> RdrName -> Name -> NameEnv
+addOneToNameEnv env rdr_name name = addToFM env rdr_name name
lookupNameEnv :: NameEnv -> RdrName -> Maybe Name
lookupNameEnv = lookupFM
+
+delOneFromNameEnv :: NameEnv -> RdrName -> NameEnv
+delOneFromNameEnv env rdr_name = delFromFM env rdr_name
\end{code}
=============== FixityEnv ================
= mapRn (addErrRn.fixityClashErr) (conflictsFM bad_fix f1 f2) `thenRn_`
returnRn (f1 `plusFM` f2)
-addOneToFixityEnvRn env rdr_name fixity
- = mapRn (addErrRn.fixityClashErr) (conflictFM bad_fix env rdr_name fixity) `thenRn_`
- returnRn (addToFM env rdr_name fixity)
+addOneToFixityEnv env rdr_name fixity = addToFM env rdr_name fixity
lookupFixityEnv env rdr_name
= case lookupFM env rdr_name of
bad_fix :: (Fixity, Provenance) -> (Fixity, Provenance) -> Bool
bad_fix (f1,_) (f2,_) = f1 /= f2
-pprFixityProvenance :: PprStyle -> (Fixity,Provenance) -> Pretty
+pprFixityProvenance :: PprStyle -> (Fixity,Provenance) -> Doc
pprFixityProvenance sty (fixity, prov) = pprProvenance sty prov
\end{code}
plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2))
plusAvail a NotAvailable = a
plusAvail NotAvailable a = a
+-- Added SOF 4/97
+#ifdef DEBUG
+plusAvail a1 a2 = panic ("RnEnv.plusAvail " ++ (show (hsep [pprAvail PprDebug a1,pprAvail PprDebug a2])))
+#endif
addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
addAvailToNameSet names avail = addListToNameSet names (availNames avail)
filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
| sub_names_ok = AvailTC n (filter is_wanted ns)
- | otherwise = pprTrace "filterAvail" (ppCat [ppr PprDebug ie, pprAvail PprDebug avail]) $
+ | otherwise = pprTrace "filterAvail" (hsep [ppr PprDebug ie, pprAvail PprDebug avail]) $
NotAvailable
where
is_wanted name = nameOccName name `elem` wanted_occs
filterAvail ie avail = NotAvailable
-
+{- OLD to be deleted
hideAvail :: RdrNameIE -- Hide this
-> AvailInfo -- Available
-> AvailInfo -- Resulting available;
where
keep n = nameOccName n `notElem` hide_occs
hide_occs = map rdrNameOcc (hide : hides)
-
-
--- pprAvail gets given the OccName of the "host" thing
-pprAvail sty NotAvailable = ppPStr SLIT("NotAvailable")
-pprAvail sty (AvailTC n ns) = ppCat [pprOccName sty (nameOccName n),
- ppChar '(',
- ppInterleave ppComma (map (pprOccName sty.nameOccName) ns),
- ppChar ')']
-pprAvail sty (Avail n) = pprOccName sty (nameOccName n)
+-}
+
+-- 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
+
+ppr_avail pp_name NotAvailable = ptext SLIT("NotAvailable")
+ppr_avail pp_name (AvailTC n ns) = hsep [
+ pp_name n,
+ parens $ hsep $ punctuate comma $
+ map pp_name ns
+ ]
+ppr_avail pp_name (Avail n) = pp_name n
\end{code}
\begin{code}
nameClashErr (rdr_name, (name1,name2)) sty
- = ppHang (ppCat [ppPStr SLIT("Conflicting definitions for: "), ppr sty rdr_name])
- 4 (ppAboves [pprNameProvenance sty name1,
+ = hang (hsep [ptext SLIT("Conflicting definitions for: "), ppr sty rdr_name])
+ 4 (vcat [pprNameProvenance sty name1,
pprNameProvenance sty name2])
fixityClashErr (rdr_name, (fp1,fp2)) sty
- = ppHang (ppCat [ppPStr SLIT("Conflicting fixities for: "), ppr sty rdr_name])
- 4 (ppAboves [pprFixityProvenance sty fp1,
+ = hang (hsep [ptext SLIT("Conflicting fixities for: "), ppr sty rdr_name])
+ 4 (vcat [pprFixityProvenance sty fp1,
pprFixityProvenance sty fp2])
shadowedNameWarn shadow sty
- = ppBesides [ppPStr SLIT("This binding for"),
- ppQuote (ppr sty shadow),
- ppPStr SLIT("shadows an existing binding")]
+ = hcat [ptext SLIT("This binding for"),
+ ppr sty shadow,
+ ptext SLIT("shadows an existing binding")]
unknownNameErr name sty
- = ppSep [ppStr flavour, ppPStr SLIT("not in scope:"), ppr sty name]
+ = sep [text flavour, ptext SLIT("not in scope:"), ppr sty name]
where
flavour = occNameFlavour (rdrNameOcc name)
qualNameErr descriptor (name,loc)
= pushSrcLocRn loc $
- addErrRn (\sty -> ppBesides [ppPStr SLIT("invalid use of qualified "),
- ppStr descriptor, ppPStr SLIT(": "),
- pprNonSymOcc sty (rdrNameOcc name) ])
+ addErrRn (\sty -> hsep [ ptext SLIT("invalid use of qualified name"),
+ ppr sty name,
+ ptext SLIT("in"),
+ descriptor sty])
dupNamesErr descriptor ((name,loc) : dup_things)
= pushSrcLocRn loc $
- addErrRn (\sty -> ppBesides [ppPStr SLIT("duplicate bindings of `"),
- ppr sty name, ppPStr SLIT("' in "),
- ppStr descriptor])
+ addErrRn (\sty -> hsep [ptext SLIT("duplicate bindings of"),
+ ppr sty name,
+ ptext SLIT("in"), descriptor sty])
\end{code}
import RnHsSyn
import RnMonad
import RnEnv
+import CmdLineOpts ( opt_GlasgowExts )
import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR,
creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
- negate_RDR
+ ratioDataCon_RDR, negate_RDR
)
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon
import ErrUtils ( addErrLoc, addShortErrLocLine )
import Name
import Pretty
-import Unique ( Unique, otherwiseIdKey )
import UniqFM ( lookupUFM{-, ufmToList ToDo:rm-} )
import UniqSet ( emptyUniqSet, unitUniqSet,
unionUniqSets, unionManyUniqSets,
)
import PprStyle ( PprStyle(..) )
import Util ( Ord3(..), removeDups, panic, pprPanic, assertPanic )
+import Outputable
+
\end{code}
************************************************************************
\begin{code}
-rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
+--rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
rnMatch (PatMatch pat match)
= bindLocalsRn "pattern" binders $ \ new_binders ->
%************************************************************************
\begin{code}
-rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars)
+--rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars)
rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
= rnBinds binds $ \ binds' ->
rnGRHS (GRHS guard expr locn)
= pushSrcLocRn locn $
- rnExpr guard `thenRn` \ (guard', fvsg) ->
- rnExpr expr `thenRn` \ (expr', fvse) ->
+ (if not (opt_GlasgowExts || is_standard_guard guard) then
+ addWarnRn (nonStdGuardErr guard)
+ else
+ returnRn ()
+ ) `thenRn_`
- -- Turn an "otherwise" guard into an OtherwiseGRHS.
- -- This is the first moment that we can be sure we havn't got a shadowed binding
- -- of "otherwise".
- let grhs' = case guard' of
- HsVar v | uniqueOf v == otherwiseIdKey -> OtherwiseGRHS expr' locn
- other -> GRHS guard' expr' locn
- in
- returnRn (grhs', fvsg `unionNameSets` fvse)
+ (rnStmts rnExpr guard $ \ guard' ->
+ -- This nested thing deals with scope and
+ -- the free vars of the guard, and knocking off the
+ -- free vars of the rhs that are bound by the guard
+
+ rnExpr expr `thenRn` \ (expr', fvse) ->
+ returnRn (GRHS guard' expr' locn, fvse))
rnGRHS (OtherwiseGRHS expr locn)
= pushSrcLocRn locn $
rnExpr expr `thenRn` \ (expr', fvs) ->
- returnRn (OtherwiseGRHS expr' locn, 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 [GuardStmt _ _] = True
+ is_standard_guard other = False
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
+--rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
rnExprs ls =
rnExprs' ls [] `thenRn` \ (exprs, fvExprs) ->
returnRn (exprs, unionManyNameSets fvExprs)
rnExpr (HsDo do_or_lc stmts src_loc)
= pushSrcLocRn src_loc $
lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too
- rnStmts stmts `thenRn` \ (stmts', fvStmts) ->
- returnRn (HsDo do_or_lc stmts' src_loc, fvStmts)
+ (rnStmts rnExpr stmts $ \ stmts' ->
+ returnRn (HsDo do_or_lc stmts' src_loc, emptyNameSet))
rnExpr (ExplicitList exps)
= addImplicitOccRn listType_name `thenRn_`
returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds)
rnExpr (ExprWithTySig expr pty)
- = rnExpr expr `thenRn` \ (expr', fvExpr) ->
- rnHsType pty `thenRn` \ pty' ->
+ = rnExpr expr `thenRn` \ (expr', fvExpr) ->
+ rnHsSigType (\ sty -> text "an expression") pty `thenRn` \ pty' ->
returnRn (ExprWithTySig expr' pty', fvExpr)
rnExpr (HsIf p b1 b2 src_loc)
Quals.
\begin{code}
-rnStmts :: [RdrNameStmt] -> RnMS s ([RenamedStmt], FreeVars)
+type RnExprTy s = RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
-rnStmts [] = returnRn ([], emptyNameSet)
+rnStmts :: RnExprTy s
+ -> [RdrNameStmt]
+ -> ([RenamedStmt] -> RnMS s (a, FreeVars))
+ -> RnMS s (a, FreeVars)
-rnStmts (stmt:stmts)
- = rnStmt stmt $ \ stmt' ->
- rnStmts stmts `thenRn` \ (stmts', fv_stmts) ->
- returnRn (stmt':stmts', fv_stmts)
+rnStmts rn_expr [] thing_inside
+ = thing_inside []
+rnStmts rn_expr (stmt:stmts) thing_inside
+ = rnStmt rn_expr stmt $ \ stmt' ->
+ rnStmts rn_expr stmts $ \ stmts' ->
+ thing_inside (stmt' : stmts')
--- rnStmt :: RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars)
--- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2]
+rnStmt :: RnExprTy s -> RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars)
+-- Because of mutual recursion we have to pass in rnExpr.
-rnStmt (BindStmt pat expr src_loc) thing_inside
+rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
= pushSrcLocRn src_loc $
- rnExpr expr `thenRn` \ (expr', fv_expr) ->
+ rn_expr expr `thenRn` \ (expr', fv_expr) ->
bindLocalsRn "pattern in do binding" binders $ \ new_binders ->
rnPat pat `thenRn` \ pat' ->
where
binders = collectPatBinders pat
-rnStmt (ExprStmt expr src_loc) thing_inside
+rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
= pushSrcLocRn src_loc $
- rnExpr expr `thenRn` \ (expr', fv_expr) ->
+ rn_expr expr `thenRn` \ (expr', fv_expr) ->
thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
returnRn (result, fv_expr `unionNameSets` fvs)
-rnStmt (GuardStmt expr src_loc) thing_inside
+rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
= pushSrcLocRn src_loc $
- rnExpr expr `thenRn` \ (expr', fv_expr) ->
+ rn_expr expr `thenRn` \ (expr', fv_expr) ->
thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
returnRn (result, fv_expr `unionNameSets` fvs)
-rnStmt (ReturnStmt expr) thing_inside
- = rnExpr expr `thenRn` \ (expr', fv_expr) ->
+rnStmt rn_expr (ReturnStmt expr) thing_inside
+ = rn_expr expr `thenRn` \ (expr', fv_expr) ->
thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
returnRn (result, fv_expr `unionNameSets` fvs)
-rnStmt (LetStmt binds) thing_inside
+rnStmt rn_expr (LetStmt binds) thing_inside
= rnBinds binds $ \ binds' ->
thing_inside (LetStmt binds')
\end{code}
returnRn (OpApp e11 op1 fix1 new_e)
where
(nofix_error, rearrange_me) = compareFixity fix1 fix2
- get (HsVar n) = n
-mkOpAppRn e1@(NegApp neg_arg neg_id)
+mkOpAppRn e1@(NegApp neg_arg neg_op)
op2
fix2@(Fixity prec2 dir2)
e2
- | prec2 > 6 -- Precedence of unary - is wired in as 6!
+ | nofix_error
+ = addErrRn (precParseErr (get neg_op,fix_neg) (get op2,fix2)) `thenRn_`
+ returnRn (OpApp e1 op2 fix2 e2)
+
+ | rearrange_me
= mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
- returnRn (NegApp new_e neg_id)
+ returnRn (NegApp new_e neg_op)
+ where
+ fix_neg = Fixity 6 InfixL -- Precedence of unary negate is wired in as infixl 6!
+ (nofix_error, rearrange_me) = compareFixity fix_neg fix2
mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
= ASSERT( right_op_ok fix e2 )
returnRn (OpApp e1 op fix e2)
+get (HsVar n) = n
+
-- Parser left-associates everything, but
-- derived instances may have correctly-associated things to
-- in the right operarand. So we just check that the right operand is OK
= True
-- Parser initially makes negation bind more tightly than any other operator
-mkNegAppRn mode neg_arg neg_id
+mkNegAppRn mode neg_arg neg_op
= ASSERT( not_op_app mode neg_arg )
- returnRn (NegApp neg_arg neg_id)
+ returnRn (NegApp neg_arg neg_op)
not_op_app SourceMode (OpApp _ _ _ _) = False
not_op_app mode other = True
= lookupImplicitOccRn numClass_RDR -- Int and Integer are forced in by Num
litOccurrence (HsFrac _)
- = lookupImplicitOccRn fractionalClass_RDR -- ... similarly Rational
-
+ = lookupImplicitOccRn fractionalClass_RDR `thenRn_`
+ 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.
+
litOccurrence (HsIntPrim _)
= addImplicitOccRn (getName intPrimTyCon)
\begin{code}
dupFieldErr str (dup:rest) sty
- = ppBesides [ppPStr SLIT("duplicate field name `"),
+ = hcat [ptext SLIT("duplicate field name `"),
ppr sty dup,
- ppPStr SLIT("' in record "), ppStr str]
+ ptext SLIT("' in record "), text str]
negPatErr pat sty
- = ppSep [ppPStr SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat]
+ = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat]
precParseNegPatErr op sty
- = ppHang (ppPStr SLIT("precedence parsing error"))
- 4 (ppBesides [ppPStr SLIT("prefix `-' has lower precedence than "),
+ = hang (ptext SLIT("precedence parsing error"))
+ 4 (hcat [ptext SLIT("prefix `-' has lower precedence than "),
pp_op sty op,
- ppPStr SLIT(" in pattern")])
+ ptext SLIT(" in pattern")])
precParseErr op1 op2 sty
- = ppHang (ppPStr SLIT("precedence parsing error"))
- 4 (ppBesides [ppPStr SLIT("cannot mix "), pp_op sty op1, ppPStr SLIT(" and "), pp_op sty op2,
- ppPStr SLIT(" in the same infix expression")])
+ = 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")])
+
+nonStdGuardErr guard sty
+ = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
+ 4 (ppr sty guard)
-pp_op sty (op, fix) = ppBesides [pprSym sty op, ppLparen, ppr sty fix, ppRparen]
+pp_op sty (op, fix) = hcat [ppr sty op, space, parens (ppr sty fix)]
\end{code}
IMP_Ubiq()
import HsSyn
+#if __GLASGOW_HASKELL__ >= 202
+import HsPragmas
+#endif
import Id ( GenId, SYN_IE(Id) )
import Name ( Name )
\begin{code}
type RenamedArithSeqInfo = ArithSeqInfo Fake Fake Name RenamedPat
-type RenamedBind = Bind Fake Fake Name RenamedPat
type RenamedClassDecl = ClassDecl Fake Fake Name RenamedPat
type RenamedClassOpSig = Sig Name
type RenamedConDecl = ConDecl Name
module RnIfaces (
getInterfaceExports,
getImportedInstDecls,
- getSpecialInstModules,
+ getSpecialInstModules, getDeferredDataDecls,
importDecl, recordSlurp,
- getImportVersions,
+ getImportVersions, getSlurpedNames, getRnStats,
checkUpToDate,
) where
IMP_Ubiq()
+#if __GLASGOW_HASKELL__ >= 202
+import IO
+#endif
-import CmdLineOpts ( opt_HiSuffix, opt_HiSuffixPrelude )
-import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, Bind, HsExpr, Sig(..), HsType(..),
- HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), BangType, IfaceSig(..),
+import CmdLineOpts ( opt_TyConPruning )
+import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, HsExpr, Sig(..), HsType(..),
+ HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), ConDetails(..), BangType, IfaceSig(..),
FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), SYN_IE(Version), HsIdInfo,
- IE(..)
+ IE(..), NewOrData(..), hsDeclName
)
import HsPragmas ( noGenPragmas )
-import RdrHsSyn ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl),
+import RdrHsSyn ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl), SYN_IE(RdrNameTyDecl),
RdrName, rdrNameOcc
)
import RnEnv ( newGlobalName, lookupRn, addImplicitOccsRn,
availName, availNames, addAvailToNameSet, pprAvail
)
-import RnSource ( rnHsType )
+import RnSource ( rnHsSigType )
import RnMonad
+import RnHsSyn ( SYN_IE(RenamedHsDecl) )
import ParseIface ( parseIface )
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) )
-import FiniteMap ( FiniteMap, emptyFM, unitFM, lookupFM, addToFM, addToFM_C, addListToFM, fmToList )
+import FiniteMap ( FiniteMap, sizeFM, emptyFM, unitFM, delFromFM,
+ lookupFM, addToFM, addToFM_C, addListToFM,
+ fmToList, eltsFM
+ )
import Name ( Name {-instance NamedThing-}, Provenance, OccName(..),
- modAndOcc, occNameString, moduleString, pprModule,
+ modAndOcc, occNameString, moduleString, pprModule, isLocallyDefined,
NameSet(..), emptyNameSet, unionNameSets, nameSetToList,
- minusNameSet, mkNameSet, elemNameSet,
- isWiredInName, maybeWiredInTyConName, maybeWiredInIdName
+ minusNameSet, mkNameSet, elemNameSet, nameUnique,
+ isWiredInName, maybeWiredInTyConName, maybeWiredInIdName,
+ NamedThing(..)
)
import Id ( GenId, Id(..), idType, dataConTyCon, isDataCon )
import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn )
import Type ( namesOfType )
import TyVar ( GenTyVar )
-import SrcLoc ( mkIfaceSrcLoc )
-import PrelMods ( gHC__, isPreludeModule )
+import SrcLoc ( mkIfaceSrcLoc, SrcLoc )
+import PrelMods ( gHC__ )
+import PrelInfo ( cCallishTyKeys )
import Bag
import Maybes ( MaybeErr(..), expectJust, maybeToBool )
import ListSetOps ( unionLists )
import Pretty
import PprStyle ( PprStyle(..) )
-import Util ( pprPanic, pprTrace )
+import Unique ( Unique )
+import Util ( pprPanic, pprTrace, Ord3(..) )
import StringBuffer ( StringBuffer, hGetStringBuffer, freeStringBuffer )
-
+import Outputable
\end{code}
%*********************************************************
%* *
+\subsection{Statistics}
+%* *
+%*********************************************************
+
+\begin{code}
+getRnStats :: [RenamedHsDecl] -> RnMG Doc
+getRnStats all_decls
+ = getIfacesRn `thenRn` \ ifaces ->
+ let
+ Ifaces this_mod mod_vers_map export_envs decls_fm all_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
+ n_mods = sizeFM mod_vers_map
+
+ decls_imported = filter is_imported_decl all_decls
+ decls_read = [decl | (name, (_, avail, decl)) <- fmToList decls_fm,
+ name == availName avail,
+ -- Data, newtype, and class decls are in the decls_fm
+ -- under multiple names; the tycon/class, and each
+ -- constructor/class op too.
+ not (isLocallyDefined name)
+ ]
+
+ (cd_rd, dd_rd, add_rd, nd_rd, and_rd, sd_rd, vd_rd, _) = count_decls decls_read
+ (cd_sp, dd_sp, add_sp, nd_sp, and_sp, sd_sp, vd_sp, id_sp) = count_decls decls_imported
+
+ inst_decls_unslurped = length (bagToList unslurped_insts)
+ inst_decls_read = id_sp + inst_decls_unslurped
+
+ stats = vcat
+ [int n_mods <> text " interfaces read",
+ hsep [int cd_sp, text "class decls imported, out of",
+ int cd_rd, text "read"],
+ hsep [int dd_sp, text "data decls imported (of which", int add_sp, text "abstractly), out of",
+ int dd_rd, text "read"],
+ hsep [int nd_sp, text "newtype decls imported (of which", int and_sp, text "abstractly), out of",
+ int nd_rd, text "read"],
+ hsep [int sd_sp, text "type synonym decls imported, out of",
+ int sd_rd, text "read"],
+ hsep [int vd_sp, text "value signatures imported, out of",
+ int vd_rd, text "read"],
+ hsep [int id_sp, text "instance decls imported, out of",
+ int inst_decls_read, text "read"]
+ ]
+ in
+ returnRn (hcat [text "Renamer stats: ", stats])
+
+is_imported_decl (DefD _) = False
+is_imported_decl (ValD _) = False
+is_imported_decl decl = not (isLocallyDefined (hsDeclName decl))
+
+count_decls decls
+ = -- pprTrace "count_decls" (ppr PprDebug decls
+ --
+ -- $$
+ -- text "========="
+ -- $$
+ -- ppr PprDebug imported_decls
+ -- ) $
+ (class_decls,
+ data_decls, abstract_data_decls,
+ newtype_decls, abstract_newtype_decls,
+ syn_decls,
+ val_decls,
+ inst_decls)
+ where
+ class_decls = length [() | ClD _ <- decls]
+ data_decls = length [() | TyD (TyData DataType _ _ _ _ _ _ _) <- decls]
+ newtype_decls = length [() | TyD (TyData NewType _ _ _ _ _ _ _) <- decls]
+ abstract_data_decls = length [() | TyD (TyData DataType _ _ _ [] _ _ _) <- decls]
+ abstract_newtype_decls = length [() | TyD (TyData NewType _ _ _ [] _ _ _) <- decls]
+ syn_decls = length [() | TyD (TySynonym _ _ _ _) <- decls]
+ val_decls = length [() | SigD _ <- decls]
+ inst_decls = length [() | InstD _ <- decls]
+
+\end{code}
+
+%*********************************************************
+%* *
\subsection{Loading a new interface file}
%* *
%*********************************************************
\begin{code}
-loadInterface :: Pretty -> Module -> RnMG Ifaces
+loadInterface :: Doc -> Module -> RnMG Ifaces
loadInterface doc_str load_mod
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers_map export_envs decls all_names imp_names insts inst_mods = ifaces
+ Ifaces this_mod mod_vers_map export_envs decls all_names imp_names insts deferred_data_decls inst_mods = ifaces
in
-- CHECK WHETHER WE HAVE IT ALREADY
if maybeToBool (lookupFM export_envs load_mod)
new_export_envs = addToFM export_envs load_mod ([],[])
new_ifaces = Ifaces this_mod mod_vers_map
new_export_envs
- decls all_names imp_names insts inst_mods
+ decls all_names imp_names insts deferred_data_decls inst_mods
in
setIfacesRn new_ifaces `thenRn_`
failWithRn new_ifaces (noIfaceErr load_mod) ;
new_decls
all_names imp_names
new_insts
+ deferred_data_decls
new_inst_mods
in
setIfacesRn new_ifaces `thenRn_`
-- We find the gates by renaming the instance type with in a
-- and returning the occurrence pool.
initRnMS emptyRnEnv mod_name InterfaceMode (
- findOccurrencesRn (rnHsType munged_inst_ty)
+ findOccurrencesRn (rnHsSigType (\sty -> text "an instance decl") munged_inst_ty)
) `thenRn` \ gate_names ->
returnRn (((mod_name, decl), gate_names) `consBag` insts)
\end{code}
= findAndReadIface doc_str mod_name `thenRn` \ read_result ->
case read_result of
Nothing -> -- Old interface file not found, so we'd better bail out
- traceRn (ppSep [ppPStr SLIT("Didnt find old iface"),
+ traceRn (sep [ptext SLIT("Didnt find old iface"),
pprModule PprDebug mod_name]) `thenRn_`
returnRn False
checkModUsage usages
where
-- Only look in current directory, with suffix .hi
- doc_str = ppSep [ppPStr SLIT("Need usage info from"), pprModule PprDebug mod_name]
-
+ doc_str = sep [ptext SLIT("Need usage info from"), pprModule PprDebug mod_name]
checkModUsage [] = returnRn True -- Yes! Everything is up to date!
checkModUsage ((mod, old_mod_vers, old_local_vers) : rest)
= loadInterface doc_str mod `thenRn` \ ifaces ->
let
- Ifaces _ mod_vers _ decls _ _ _ _ = ifaces
+ Ifaces _ mod_vers _ decls _ _ _ _ _ = ifaces
maybe_new_mod_vers = lookupFM mod_vers mod
Just new_mod_vers = maybe_new_mod_vers
in
-- If the module version hasn't changed, just move on
if new_mod_vers == old_mod_vers then
- traceRn (ppSep [ppPStr SLIT("Module version unchanged:"), pprModule PprDebug mod]) `thenRn_`
+ traceRn (sep [ptext SLIT("Module version unchanged:"), pprModule PprDebug mod]) `thenRn_`
checkModUsage rest
else
- traceRn (ppSep [ppPStr SLIT("Module version has changed:"), pprModule PprDebug mod]) `thenRn_`
+ traceRn (sep [ptext SLIT("Module version has changed:"), pprModule PprDebug mod]) `thenRn_`
-- New module version, so check entities inside
checkEntityUsage mod decls old_local_vers `thenRn` \ up_to_date ->
if up_to_date then
- traceRn (ppPStr SLIT("...but the bits I use haven't.")) `thenRn_`
+ 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 = ppSep [ppPStr SLIT("need version info for"), pprModule PprDebug mod]
+ doc_str = sep [ptext SLIT("need version info for"), pprModule PprDebug mod]
checkEntityUsage mod decls []
case lookupFM decls name of
Nothing -> -- We used it before, but it ain't there now
- traceRn (ppSep [ppPStr SLIT("...and this no longer exported:"), ppr PprDebug name]) `thenRn_`
+ traceRn (sep [ptext SLIT("...and this no longer exported:"), ppr PprDebug name]) `thenRn_`
returnRn False
Just (new_vers,_,_) -- It's there, but is it up to date?
| otherwise
-- Out of date, so bale out
- -> traceRn (ppSep [ppPStr SLIT("...and this is out of date:"), ppr PprDebug name]) `thenRn_`
+ -> traceRn (sep [ptext SLIT("...and this is out of date:"), ppr PprDebug name]) `thenRn_`
returnRn False
\end{code}
importDecl name necessity
= checkSlurped name `thenRn` \ already_slurped ->
if already_slurped then
- -- traceRn (ppSep [ppStr "Already slurped:", ppr PprDebug name]) `thenRn_`
+ -- traceRn (sep [text "Already slurped:", ppr PprDebug name]) `thenRn_`
returnRn Nothing -- Already dealt with
else
if isWiredInName name then
else
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod _ _ _ _ _ _ _ = ifaces
+ Ifaces this_mod _ _ _ _ _ _ _ _ = ifaces
(mod,_) = modAndOcc name
in
if mod == this_mod then -- Don't bring in decls from
--
else
getNonWiredInDecl name necessity
-
\end{code}
\begin{code}
getNonWiredInDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl)
-getNonWiredInDecl name necessity
+getNonWiredInDecl needed_name necessity
= traceRn doc_str `thenRn_`
- loadInterface doc_str mod `thenRn` \ (Ifaces _ _ _ decls _ _ _ _) ->
- case lookupFM decls name of
+ loadInterface doc_str mod `thenRn` \ (Ifaces _ _ _ decls _ _ _ _ _) ->
+ case lookupFM decls needed_name of
+
+ -- Special case for data/newtype type declarations
+ Just (version, avail, TyD ty_decl) | is_data_or_newtype ty_decl
+ -> getNonWiredDataDecl needed_name version avail ty_decl `thenRn` \ (avail', maybe_decl) ->
+ recordSlurp (Just version) avail' `thenRn_`
+ returnRn maybe_decl
- Just (version,avail,decl) -> recordSlurp (Just version) avail `thenRn_`
- returnRn (Just decl)
+ Just (version,avail,decl)
+ -> recordSlurp (Just version) avail `thenRn_`
+ returnRn (Just decl)
Nothing -> -- Can happen legitimately for "Optional" occurrences
case necessity of {
- Optional -> addWarnRn (getDeclWarn name);
- other -> addErrRn (getDeclErr name)
+ Optional -> addWarnRn (getDeclWarn needed_name);
+ other -> addErrRn (getDeclErr needed_name)
} `thenRn_`
returnRn Nothing
where
- doc_str = ppSep [ppPStr SLIT("Need decl for"), ppr PprDebug name]
- (mod,_) = modAndOcc name
+ doc_str = sep [ptext SLIT("Need decl for"), ppr PprDebug needed_name]
+ (mod,_) = modAndOcc needed_name
+
+ is_data_or_newtype (TyData _ _ _ _ _ _ _ _) = True
+ is_data_or_newtype other = False
\end{code}
@getWiredInDecl@ maps a wired-in @Name@ to what it makes available.
main_name = availName avail
main_is_tc = case avail of { AvailTC _ _ -> True; Avail _ -> False }
(mod,_) = modAndOcc main_name
- doc_str = ppSep [ppPStr SLIT("Need home module for wired in thing"), ppr PprDebug name]
+ doc_str = sep [ptext SLIT("Need home module for wired in thing"), ppr PprDebug name]
in
(if not main_is_tc || mod == gHC__ then
returnRn ()
get_wired_tycon tycon
| isSynTyCon tycon
= addImplicitOccsRn (nameSetToList mentioned) `thenRn_`
- returnRn (Avail (getName tycon))
+ returnRn (AvailTC tc_name [tc_name])
where
+ tc_name = getName tycon
(tyvars,ty) = getSynTyConDefn tycon
- mentioned = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars)
+ mentioned = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars)
get_wired_tycon tycon
| otherwise -- data or newtype
\end{code}
-\begin{code}
-checkSlurped name
- = getIfacesRn `thenRn` \ (Ifaces _ _ _ _ slurped_names _ _ _) ->
- returnRn (name `elemNameSet` slurped_names)
-
-recordSlurp maybe_version avail
- = -- traceRn (ppSep [ppStr "Record slurp:", pprAvail PprDebug avail]) `thenRn_`
- getIfacesRn `thenRn` \ ifaces ->
- let
- Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts inst_mods = ifaces
- new_slurped_names = addAvailToNameSet slurped_names avail
-
- new_imp_names = case maybe_version of
- Just version -> (availName avail, version) : imp_names
- Nothing -> imp_names
-
- new_ifaces = Ifaces this_mod mod_vers export_envs decls
- new_slurped_names
- new_imp_names
- insts
- inst_mods
- in
- setIfacesRn new_ifaces
-\end{code}
%*********************************************************
%* *
-\subsection{Getting other stuff}
+\subsection{Getting what a module exports}
%* *
%*********************************************************
\begin{code}
getInterfaceExports :: Module -> RnMG (Avails, [(OccName,Fixity)])
getInterfaceExports mod
- = loadInterface doc_str mod `thenRn` \ (Ifaces _ _ export_envs _ _ _ _ _) ->
+ = loadInterface doc_str mod `thenRn` \ (Ifaces _ _ export_envs _ _ _ _ _ _) ->
case lookupFM export_envs mod of
Nothing -> -- Not there; it must be that the interface file wasn't found;
-- the error will have been reported already.
Just stuff -> returnRn stuff
where
- doc_str = ppSep [pprModule PprDebug mod, ppPStr SLIT("is directly imported")]
+ doc_str = sep [pprModule PprDebug mod, ptext SLIT("is directly imported")]
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Data type declarations are handled specially}
+%* *
+%*********************************************************
+
+Data type declarations get special treatment. If we import a data type decl
+with all its constructors, we end up importing all the types mentioned in
+the constructors' signatures, and hence {\em their} data type decls, and so on.
+In effect, we get the transitive closure of data type decls. Worse, this drags
+in tons on instance decls, and their unfoldings, and so on.
+If only the type constructor is mentioned, then all this is a waste of time.
+If any of the data constructors are mentioned then we really have to
+drag in the whole declaration.
+So when we import the type constructor for a @data@ or @newtype@ decl, we
+put it in the "deferred data/newtype decl" pile in Ifaces. Right at the end
+we slurp these decls, if they havn't already been dragged in by an occurrence
+of a constructor.
+
+\begin{code}
+getNonWiredDataDecl needed_name
+ version
+ avail@(AvailTC tycon_name _)
+ ty_decl@(TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
+ | needed_name == tycon_name
+ && opt_TyConPruning
+ && 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_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
+ new_ifaces = Ifaces this_mod mod_vers_map export_envs 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
+ -- Nota bene: we nuke both the constructors and the context in the deferred decl.
+ -- If we don't nuke the context then renaming the deferred data decls can give
+ -- new unresolved names (for the classes). This could be handled, but there's
+ -- no point. If the data type is completely abstract then we aren't interested
+ -- its context.
+ in
+ setIfacesRn new_ifaces `thenRn_`
+ returnRn (AvailTC tycon_name [tycon_name], Nothing)
+
+ | otherwise
+ = -- 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_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
+ new_ifaces = Ifaces this_mod mod_vers_map export_envs 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
+ setIfacesRn new_ifaces `thenRn_`
+ returnRn (avail, Just (TyD ty_decl))
+\end{code}
+
+\begin{code}
+getDeferredDataDecls :: RnMG [(Name, RdrNameTyDecl)]
+getDeferredDataDecls
+ = getIfacesRn `thenRn` \ (Ifaces _ _ _ _ _ _ _ deferred_data_decls _) ->
+ let
+ deferred_list = fmToList deferred_data_decls
+ trace_msg = hang (text "Slurping abstract data/newtype decls for: ")
+ 4 (ppr PprDebug (map fst deferred_list))
+ in
+ traceRn trace_msg `thenRn_`
+ returnRn deferred_list
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Instance declarations are handled specially}
+%* *
+%*********************************************************
+
+\begin{code}
getImportedInstDecls :: RnMG [(Module,RdrNameInstDecl)]
getImportedInstDecls
= -- First load any special-instance modules that aren't aready loaded
-- removing them from the bag kept in Ifaces
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts inst_mods = ifaces
+ Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts deferred_data_decls inst_mods = ifaces
-- An instance decl is ungated if all its gates have been slurped
select_ungated :: IfaceInst -- A gated inst decl
new_ifaces = Ifaces this_mod mod_vers export_envs decls slurped_names imp_names
(listToBag still_gated_insts)
+ deferred_data_decls
inst_mods
in
setIfacesRn new_ifaces `thenRn_`
returnRn un_gated_insts
where
load_it mod = loadInterface (doc_str mod) mod
- doc_str mod = ppSep [pprModule PprDebug mod, ppPStr SLIT("is a special-instance module")]
+ doc_str mod = sep [pprModule PprDebug mod, ptext SLIT("is a special-instance module")]
getSpecialInstModules :: RnMG [Module]
getSpecialInstModules
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces _ _ _ _ _ _ _ inst_mods = ifaces
+ Ifaces _ _ _ _ _ _ _ _ inst_mods = ifaces
in
returnRn inst_mods
\end{code}
+
+%*********************************************************
+%* *
+\subsection{Keeping track of what we've slurped, and version numbers}
+%* *
+%*********************************************************
+
getImportVersions figures out what the "usage information" for this moudule is;
that is, what it must record in its interface file as the things it uses.
It records:
getImportVersions this_mod exports
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces _ mod_versions_map _ _ _ imp_names _ _ = ifaces
+ Ifaces _ mod_versions_map _ _ _ imp_names _ _ _ = ifaces
mod_version mod = expectJust "import_versions" (lookupFM mod_versions_map mod)
-- mv_map groups together all the things imported from a particular module.
add_mod mv_map mod = addToFM mv_map mod []
\end{code}
+\begin{code}
+checkSlurped name
+ = getIfacesRn `thenRn` \ (Ifaces _ _ _ _ slurped_names _ _ _ _) ->
+ returnRn (name `elemNameSet` slurped_names)
+
+getSlurpedNames :: RnMG NameSet
+getSlurpedNames
+ = getIfacesRn `thenRn` \ ifaces ->
+ let
+ Ifaces _ _ _ _ slurped_names _ _ _ _ = ifaces
+ in
+ returnRn slurped_names
+
+recordSlurp maybe_version avail
+ = -- traceRn (sep [text "Record slurp:", pprAvail PprDebug avail]) `thenRn_`
+ getIfacesRn `thenRn` \ ifaces ->
+ let
+ Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts deferred_data_decls inst_mods = ifaces
+ new_slurped_names = addAvailToNameSet slurped_names avail
+
+ new_imp_names = case maybe_version of
+ Just version -> (availName avail, version) : imp_names
+ Nothing -> imp_names
+
+ new_ifaces = Ifaces this_mod mod_vers export_envs decls
+ new_slurped_names
+ new_imp_names
+ insts
+ deferred_data_decls
+ inst_mods
+ in
+ setIfacesRn new_ifaces
+\end{code}
+
+
%*********************************************************
%* *
\subsection{Getting binders out of a declaration}
-> RdrNameHsDecl
-> RnMG AvailInfo
-getDeclBinders new_name (TyD (TyData _ tycon _ condecls _ _ src_loc))
+getDeclBinders new_name (TyD (TyData _ _ tycon _ condecls _ _ src_loc))
= new_name tycon src_loc `thenRn` \ tycon_name ->
getConFieldNames new_name condecls `thenRn` \ sub_names ->
returnRn (AvailTC tycon_name (tycon_name : sub_names))
-getDeclBinders new_name (TyD (TyNew _ tycon _ (NewConDecl con _ con_loc) _ _ src_loc))
- = new_name tycon src_loc `thenRn` \ tycon_name ->
- new_name con src_loc `thenRn` \ con_name ->
- returnRn (AvailTC tycon_name [tycon_name, con_name])
-
getDeclBinders new_name (TyD (TySynonym tycon _ _ src_loc))
= new_name tycon src_loc `thenRn` \ tycon_name ->
- returnRn (Avail tycon_name)
+ returnRn (AvailTC tycon_name [tycon_name])
getDeclBinders new_name (ClD (ClassDecl _ cname _ sigs _ _ src_loc))
= new_name cname src_loc `thenRn` \ class_name ->
getDeclBinders new_name (InstD _) = returnRn NotAvailable
----------------
-getConFieldNames new_name (ConDecl con _ src_loc : rest)
- = new_name con src_loc `thenRn` \ n ->
- getConFieldNames new_name rest `thenRn` \ ns ->
- returnRn (n:ns)
-
-getConFieldNames new_name (NewConDecl con _ src_loc : rest)
- = new_name con src_loc `thenRn` \ n ->
- getConFieldNames new_name rest `thenRn` \ ns ->
- returnRn (n:ns)
-
-getConFieldNames new_name (ConOpDecl _ con _ src_loc : rest)
- = new_name con src_loc `thenRn` \ n ->
- getConFieldNames new_name rest `thenRn` \ ns ->
- returnRn (n:ns)
-
-getConFieldNames new_name (RecConDecl con fielddecls src_loc : rest)
+getConFieldNames new_name (ConDecl con _ (RecCon fielddecls) src_loc : rest)
= mapRn (\n -> new_name n src_loc) (con:fields) `thenRn` \ cfs ->
getConFieldNames new_name rest `thenRn` \ ns ->
returnRn (cfs ++ ns)
where
fields = concat (map fst fielddecls)
+getConFieldNames new_name (ConDecl con _ _ src_loc : rest)
+ = new_name con src_loc `thenRn` \ n ->
+ getConFieldNames new_name rest `thenRn` \ ns ->
+ returnRn (n:ns)
+
getConFieldNames new_name [] = returnRn []
getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc
%*********************************************************
\begin{code}
-findAndReadIface :: Pretty -> Module -> RnMG (Maybe ParsedIface)
+findAndReadIface :: Doc -> Module -> RnMG (Maybe ParsedIface)
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
-findAndReadIface doc_str mod
+findAndReadIface doc_str filename
= traceRn trace_msg `thenRn_`
getSearchPathRn `thenRn` \ dirs ->
try dirs dirs
where
- trace_msg = ppHang (ppBesides [ppPStr SLIT("Reading interface for "),
- pprModule PprDebug mod, ppSemi])
- 4 (ppBesides [ppPStr SLIT("reason: "), doc_str])
-
- mod_str = moduleString mod
- hisuf =
- if isPreludeModule mod then
- case opt_HiSuffixPrelude of { Just hisuf -> hisuf; _ -> ".hi"}
- else
- case opt_HiSuffix of {Just hisuf -> hisuf; _ -> ".hi"}
-
- try all_dirs [] = traceRn (ppPStr SLIT("...failed")) `thenRn_`
+ trace_msg = hang (hcat [ptext SLIT("Reading interface for "),
+ ptext filename, semi])
+ 4 (hcat [ptext SLIT("reason: "), doc_str])
+
+ try all_dirs [] = traceRn (ptext SLIT("...failed")) `thenRn_`
returnRn Nothing
- try all_dirs (dir:dirs)
+ try all_dirs ((dir,hisuf):dirs)
= readIface file_path `thenRn` \ read_result ->
case read_result of
Nothing -> try all_dirs dirs
- Just iface -> traceRn (ppPStr SLIT("...done")) `thenRn_`
+ Just iface -> traceRn (ptext SLIT("...done")) `thenRn_`
returnRn (Just iface)
where
- file_path = dir ++ "/" ++ moduleString mod ++ hisuf
+ file_path = dir ++ "/" ++ moduleString filename ++ hisuf
\end{code}
@readIface@ trys just one file.
Succeeded iface -> --ioToRnMG (freeStringBuffer contents) `thenRn` \ _ ->
returnRn (Just iface)
+#if __GLASGOW_HASKELL__ >= 202
+ Left err ->
+ if isDoesNotExistError err then
+ returnRn Nothing
+ else
+ 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 of directories, and turns it into
-a list of directories. For example:
+mkSearchPath takes a string consisting of a colon-separated list of directories and corresponding
+suffixes, and turns it into a list of (directory, suffix) pairs. For example:
- mkSearchPath "foo:.:baz" = ["foo", ".", "baz"]
+\begin{verbatim}
+ mkSearchPath "foo%.hi:.%.p_hi:baz%.mc_hi" = [("foo",".hi"),( ".", ".p_hi"), ("baz",".mc_hi")]
+\begin{verbatim}
\begin{code}
mkSearchPath :: Maybe String -> SearchPath
-mkSearchPath Nothing = ["."]
+mkSearchPath Nothing = [(".",".hi")]
mkSearchPath (Just s)
= go s
where
- go "" = []
- go s = first : go (drop 1 rest)
- where
- (first,rest) = span (/= ':') s
+ go s =
+ case span (/= '%') s of
+ (dir,'%':rs) ->
+ case span (/= ':') rs of
+ (hisuf,_:rest) -> (dir,hisuf):go rest
+ (hisuf,[]) -> [(dir,hisuf)]
+
\end{code}
%*********************************************************
%*********************************************************
\begin{code}
-noIfaceErr mod sty
- = ppBesides [ppPStr SLIT("Could not find valid interface file for "), ppQuote (pprModule sty mod)]
--- , ppStr " in"]) 4 (ppAboves (map ppStr dirs))
+noIfaceErr filename sty
+ = hcat [ptext SLIT("Could not find valid interface file "), quotes (pprModule sty filename)]
+-- , text " in"]) 4 (vcat (map text dirs))
cannaeReadFile file err sty
- = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppPStr SLIT("; error="), ppStr (show err)]
+ = hcat [ptext SLIT("Failed in reading file: "), text file, ptext SLIT("; error="), text (show err)]
getDeclErr name sty
- = ppSep [ppPStr SLIT("Failed to find interface decl for"), ppr sty name]
+ = sep [ptext SLIT("Failed to find interface decl for"), ppr sty name]
getDeclWarn name sty
- = ppSep [ppPStr SLIT("Warning: failed to find (optional) interface decl for"), ppr sty name]
+ = sep [ptext SLIT("Warning: failed to find (optional) interface decl for"), ppr sty name]
\end{code}
--- /dev/null
+module RnLoop
+
+ (
+ module RnBinds,
+ module RnSource
+
+ ) where
+
+import RnBinds
+import RnSource
import RnHsSyn ( RenamedHsBinds(..), RenamedHsType(..) )
import RnBinds ( rnBinds )
import RnMonad ( RnMS(..), FreeVars )
-import RnSource ( rnHsType )
+import RnSource ( rnHsSigType )
import UniqSet ( UniqSet(..) )
+import PprStyle ( PprStyle )
+import Pretty ( Doc )
import Name ( Name )
rnBinds :: RdrNameHsBinds
-> (RenamedHsBinds -> RnMS s (result, FreeVars))
-> RnMS s (result, FreeVars)
-rnHsType :: RdrNameHsType
- -> RnMS s RenamedHsType
+rnHsSigType :: (PprStyle -> Doc)
+ -> RdrNameHsType
+ -> RnMS s RenamedHsType
\end{code}
IMP_Ubiq(){-uitous-}
import SST
+#if __GLASGOW_HASKELL__ <= 201
import PreludeGlaST ( SYN_IE(ST), thenStrictlyST, returnStrictlyST )
+#define MkIO
+#else
+import GlaExts
+import IO
+import ST
+import IOBase
+#define IOError13 IOError
+#define MkIO IO
+#endif
import HsSyn
import RdrHsSyn
import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
import UniqSet
import Util
+#if __GLASGOW_HASKELL__ >= 202
+import UniqSupply
+#endif
infixr 9 `thenRn`, `thenRn_`
\end{code}
\begin{code}
sstToIO :: SST REAL_WORLD r -> IO r
-sstToIO sst
- = sstToST sst `thenStrictlyST` \ r ->
- returnStrictlyST (Right r)
+sstToIO sst =
+ MkIO (
+ sstToST sst `thenStrictlyST` \ r ->
+ returnStrictlyST (Right r))
ioToRnMG :: IO r -> RnMG (Either IOError13 r)
-ioToRnMG io rn_down g_down = stToSST io
+ioToRnMG (MkIO io) rn_down g_down = stToSST io
-traceRn :: Pretty -> RnMG ()
-traceRn msg | opt_D_show_rn_trace = ioToRnMG (hPutStr stderr (ppShow 80 msg) >>
+traceRn :: Doc -> RnMG ()
+traceRn msg | opt_D_show_rn_trace = ioToRnMG (hPutStr stderr (show msg) >>
hPutStr stderr "\n") `thenRn_`
returnRn ()
| otherwise = returnRn ()
data RnSMode = SourceMode
| InterfaceMode
-type SearchPath = [String] -- List of directories to seach for interface files
+type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search
+ -- for interface files.
type FreeVars = NameSet
\end{code}
| AvailTC Name -- The name of the type or class
[Name] -- The available pieces of type/class. NB: If the type or
-- class is itself to be in scope, it must be in this list.
- -- Thus, typically: Avail Eq [Eq, ==, /=]
+ -- Thus, typically: AvailTC Eq [Eq, ==, /=]
\end{code}
===================================================
-- whether locally defined or not) that have been slurped in so far.
[(Name,Version)] -- All the (a) non-wired-in (b) "big" (c) non-locally-defined names that
- -- have been slurped in so far, with their versions. Subset of
- -- the previous field. This is used to generate the "usage" information
- -- for this module.
+ -- have been slurped in so far, with their versions.
+ -- This is used to generate the "usage" information for this module.
+ -- Subset of the previous field.
- (Bag IfaceInst) -- Un-slurped instance decls; this bag is depleted when we
+ (Bag IfaceInst) -- The as-yet un-slurped instance decls; this bag is depleted when we
-- slurp an instance decl so that we don't slurp the same one twice.
+ (FiniteMap Name RdrNameTyDecl)
+ -- Deferred data type declarations; each has the following properties
+ -- * it's a data type decl
+ -- * its TyCon is needed
+ -- * the decl may or may not have been slurped, depending on whether any
+ -- of the constrs are needed.
+
[Module] -- Set of modules with "special" instance declarations
-- Excludes this module
+
type DeclsMap = FiniteMap Name (Version, AvailInfo, RdrNameHsDecl)
type IfaceInst = ((Module, RdrNameInstDecl), -- Instance decl
[Name]) -- "Gate" names. Slurp this instance decl when this
emptyIfaces :: Module -> Ifaces
-emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyNameSet [] emptyBag []
+emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyNameSet [] emptyBag emptyFM []
builtins :: FiniteMap (Module,OccName) Name
builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames)
returnSST result
)
where
- display errs = ppShow 80 (pprBagOfErrors PprDebug errs)
+ display errs = show (pprBagOfErrors PprDebug errs)
{-# INLINE thenRn #-}
{-# INLINE thenRn_ #-}
import Pretty
import PprStyle ( PprStyle(..) )
import Util ( panic, pprTrace, assertPanic )
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable
+#endif
\end{code}
\begin{code}
getGlobalNames :: RdrNameHsModule
- -> RnMG (Maybe (ExportEnv, RnEnv, [AvailInfo]))
+ -> RnMG (Maybe (ExportEnv, RnEnv, NameSet))
-- Nothing <=> no need to recompile
+ -- The NameSet is the set of names that are
+ -- either locally defined,
+ -- or explicitly imported
getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc)
= fixRn (\ ~(rec_exp_fn, _) ->
-- PROCESS LOCAL DECLS
-- Do these *first* so that the correct provenance gets
-- into the global name cache.
- importsFromLocalDecls rec_exp_fn m `thenRn` \ (local_rn_env, local_mod_avails) ->
+ importsFromLocalDecls rec_exp_fn m `thenRn` \ (local_rn_env, local_mod_avails, local_avails) ->
-- PROCESS IMPORT DECLS
- mapAndUnzipRn importsFromImportDecl all_imports
- `thenRn` \ (imp_rn_envs, imp_avails_s) ->
+ mapAndUnzip3Rn importsFromImportDecl all_imports
+ `thenRn` \ (imp_rn_envs, imp_avails_s, explicit_imports_s) ->
-- CHECK FOR EARLY EXIT
checkEarlyExit this_mod `thenRn` \ early_exit ->
let
all_avails :: ModuleAvails
all_avails = foldr plusModuleAvails local_mod_avails imp_avails_s
- local_avails = expectJust "getGlobalNames" (lookupModuleAvails local_mod_avails this_mod)
+
+ explicit_names :: NameSet -- locally defined or explicitly imported
+ 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
-- RECORD THAT LOCALLY DEFINED THINGS ARE AVAILABLE
mapRn (recordSlurp Nothing) local_avails `thenRn_`
- returnRn (export_fn, Just (export_env, rn_env, local_avails))
+ returnRn (export_fn, Just (export_env, rn_env, explicit_names))
) `thenRn` \ (_, result) ->
returnRn result
where
\begin{code}
importsFromImportDecl :: RdrNameImportDecl
- -> RnMG (RnEnv, ModuleAvails)
+ -> RnMG (RnEnv, ModuleAvails, [AvailInfo])
importsFromImportDecl (ImportDecl mod qual_only as_mod import_spec loc)
= pushSrcLocRn loc $
getInterfaceExports mod `thenRn` \ (avails, fixities) ->
- filterImports mod import_spec avails `thenRn` \ filtered_avails ->
+ 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 ]
(not qual_only) -- Maybe want unqualified names
as_mod
(ExportEnv filtered_avails' fixities')
+ hides
+ `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)
True -- Want unqualified names
Nothing -- No "as M" part
(ExportEnv avails fixities)
+ [] -- Hide nothing
+ `thenRn` \ (rn_env, mod_avails) ->
+ returnRn (rn_env, mod_avails, avails)
where
newLocalName rdr_name loc
= newLocallyDefinedGlobalName mod (rdrNameOcc rdr_name) rec_exp_fn loc
filterImports :: Module
-> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hidin
-> [AvailInfo] -- What's available
- -> RnMG [AvailInfo] -- What's actually imported
- -- Complains if import spec mentions things the
- -- module doesn't export
+ -> RnMG ([AvailInfo], -- What's actually imported
+ [AvailInfo], -- What's to be hidden (the unqualified version, that is)
+ [AvailInfo]) -- What was imported explicitly
+
+ -- Complains if import spec mentions things that the module doesn't export
filterImports mod Nothing imports
- = returnRn imports
+ = returnRn (imports, [], [])
filterImports mod (Just (want_hiding, import_items)) avails
- = foldlRn (filter_item want_hiding) initial_avails import_items
- where
- initial_avails | want_hiding = avails
- | otherwise = []
+ = mapRn check_item import_items `thenRn` \ item_avails ->
+ if want_hiding
+ then
+ returnRn (avails, item_avails, []) -- All imported; item_avails to be hidden
+ else
+ returnRn (item_avails, [], item_avails) -- Just item_avails imported; nothing to be hidden
+ where
import_fm :: FiniteMap OccName AvailInfo
import_fm = listToFM [ (nameOccName name, avail)
| avail <- avails,
name <- availEntityNames avail]
- filter_item want_hiding avails_so_far item@(IEModuleContents _)
+ check_item item@(IEModuleContents _)
= addErrRn (badImportItemErr mod item) `thenRn_`
- returnRn avails_so_far
+ returnRn NotAvailable
- filter_item want_hiding avails_so_far item
+ check_item item
| not (maybeToBool maybe_in_import_avails) ||
(case filtered_avail of { NotAvailable -> True; other -> False })
= addErrRn (badImportItemErr mod item) `thenRn_`
- returnRn avails_so_far
+ returnRn NotAvailable
- | want_hiding = returnRn (foldr hide_it [] avails_so_far)
- | otherwise = returnRn (filtered_avail : avails_so_far) -- Explicit import list
+ | otherwise = returnRn filtered_avail
where
maybe_in_import_avails = lookupFM import_fm (ieOcc item)
Just avail = maybe_in_import_avails
filtered_avail = filterAvail item avail
- hide_it avail avails = case hideAvail item avail of
- NotAvailable -> avails
- avail' -> avail' : avails
\end{code}
-> Bool -- True <=> want unqualified import
-> Maybe Module -- Optional "as M" part
-> ExportEnv -- What's imported
+ -> [AvailInfo] -- What's to be hidden
-> RnMG (RnEnv, ModuleAvails)
-qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities)
- = -- Make the qualified-name environments, checking of course for clashes
- foldlRn add_name emptyNameEnv avails `thenRn` \ name_env ->
- foldlRn (add_fixity name_env) emptyFixityEnv fixities `thenRn` \ fixity_env ->
- returnRn (RnEnv name_env fixity_env, mod_avail_env)
- where
- show_it (rdr, (fix,prov)) = ppSep [ppLbrack, ppr PprDebug rdr, ppr PprDebug fix, pprProvenance PprDebug prov, ppRbrack]
+qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities) hides
+ = let
+ -- Make the name environment. Since we're talking about a single import module
+ -- there can't be name clashes, so we don't need to be in the monad
+ name_env1 = foldl add_avail emptyNameEnv avails
+ -- Delete things that are hidden
+ name_env2 = foldl del_avail name_env1 hides
+
+ -- Create the fixity env
+ fixity_env = foldl (add_fixity name_env2) emptyFixityEnv fixities
+
+ -- The "module M" syntax only applies to *unqualified* imports (1.4 Report, Section 5.1.1)
+ mod_avail_env | unqual_imp = unitFM qual_mod avails
+ | otherwise = emptyFM
+ in
+ returnRn (RnEnv name_env2 fixity_env, mod_avail_env)
+ where
qual_mod = case as_mod of
Nothing -> this_mod
Just another_name -> another_name
- mod_avail_env = unitFM qual_mod avails
-
- add_name name_env avail = foldlRn add_one name_env (availNames avail)
-
- add_one :: NameEnv -> Name -> RnMG NameEnv
- add_one env name = add_to_env addOneToNameEnvRn env occ_name name
- where
- occ_name = nameOccName name
-
- add_to_env add_fn env occ thing | qual_imp && unqual_imp = both
- | qual_imp = qual_only
- | unqual_imp = unqual_only
- where
- unqual_only = add_fn env (Unqual occ) thing
- qual_only = add_fn env (Qual qual_mod occ) thing
- both = unqual_only `thenRn` \ env' ->
- add_fn env' (Qual qual_mod occ) thing
+ add_avail env avail = foldl add_name env (availNames avail)
+ add_name env name = env2
+ where
+ env1 | qual_imp = addOneToNameEnv env (Qual qual_mod occ) name
+ | otherwise = env
+ env2 | unqual_imp = addOneToNameEnv env1 (Unqual occ) name
+ | otherwise = env1
+ occ = nameOccName name
+
+ del_avail env avail = foldl delOneFromNameEnv env rdr_names
+ where
+ rdr_names = map (Unqual . nameOccName) (availNames avail)
- add_fixity name_env fixity_env (occ_name, (fixity, provenance))
- | maybeToBool (lookupFM name_env rdr_name) -- It's imported
- = add_to_env addOneToFixityEnvRn fixity_env occ_name (fixity,provenance)
- | otherwise -- It ain't imported
- = returnRn fixity_env
- where
- -- rdr_name is a name by which the thing is guaranteed to be known,
- -- *if it is imported at all*
- rdr_name | qual_imp = Qual qual_mod occ_name
- | otherwise = Unqual occ_name
+ add_fixity name_env fix_env (occ_name, (fixity, provenance))
+ = add qual $ add unqual $ fix_env
+ where
+ qual = Qual qual_mod occ_name
+ unqual = Unqual occ_name
+
+ add rdr_name fix_env | maybeToBool (lookupFM name_env rdr_name)
+ = addOneToFixityEnv fix_env rdr_name (fixity,provenance)
+ | otherwise
+ = fix_env
\end{code}
unQualify adds an Unqual binding for every existing Qual binding.
\begin{code}
badImportItemErr mod ie sty
- = ppSep [ppPStr SLIT("Module"), pprModule sty mod, ppPStr SLIT("does not export"), ppr sty ie]
+ = sep [ptext SLIT("Module"), pprModule sty mod, ptext SLIT("does not export"), ppr sty ie]
modExportErr mod sty
- = ppCat [ ppPStr SLIT("Unknown module in export list: module"), ppPStr mod]
+ = hsep [ ptext SLIT("Unknown module in export list: module"), ptext mod]
exportItemErr export_item NotAvailable sty
- = ppSep [ ppPStr SLIT("Export item not in scope:"), ppr sty export_item ]
+ = sep [ ptext SLIT("Export item not in scope:"), ppr sty export_item ]
exportItemErr export_item avail sty
- = ppHang (ppPStr SLIT("Export item not fully in scope:"))
- 4 (ppAboves [ppCat [ppPStr SLIT("Wanted: "), ppr sty export_item],
- ppCat [ppPStr SLIT("Available: "), ppr sty (ieOcc export_item), pprAvail sty 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]])
availClashErr (occ_name, ((ie1,avail1), (ie2,avail2))) sty
- = ppHang (ppCat [ppPStr SLIT("Conflicting exports for local name: "), ppr sty occ_name])
- 4 (ppAboves [ppr sty ie1, ppr sty ie2])
+ = hang (hsep [ptext SLIT("Conflicting exports for local name: "), ppr sty occ_name])
+ 4 (vcat [ppr sty ie1, ppr sty ie2])
\end{code}
--- /dev/null
+_interface_ RnSource 1
+_exports_
+RnSource rnHsSigType;
+_declarations_
+1 rnHsSigType _:_ _forall_ [a] => (PprStyle.PprStyle -> Pretty.Doc)
+ -> RdrHsSyn.RdrNameHsType
+ -> RnMonad.RnMS a RnHsSyn.RenamedHsType ;;
+
\begin{code}
#include "HsVersions.h"
-module RnSource ( rnDecl, rnHsType ) where
+module RnSource ( rnDecl, rnHsType, rnHsSigType ) where
IMP_Ubiq()
IMPORT_DELOOPER(RnLoop) -- *check* the RnPass/RnExpr/RnBinds loop-breaking
+IMPORT_1_3(List(partition))
import HsSyn
import HsDecls ( HsIdInfo(..) )
import RnBinds ( rnTopBinds, rnMethodBinds )
import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
- lookupOptionalOccRn, newSysName, newDfunName,
+ lookupOptionalOccRn, newSysName, newDfunName, checkDupOrQualNames, checkDupNames,
listType_RDR, tupleType_RDR )
import RnMonad
import Lex ( isLexCon )
import CoreUnfold ( Unfolding(..), SimpleUnfolding )
import MagicUFs ( MagicUnfoldingFun )
-import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR )
+import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NAME )
import ListSetOps ( unionLists, minusList )
import Maybes ( maybeToBool, catMaybes )
import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
import Outputable ( Outputable(..){-instances-} )
---import PprStyle -- ToDo:rm
+import PprStyle
import Pretty
import SrcLoc ( SrcLoc )
-- import TyCon ( TyCon{-instance NamedThing-} )
import Unique ( Unique )
import UniqSet ( SYN_IE(UniqSet) )
import UniqFM ( UniqFM, lookupUFM )
-import Util ( isIn, isn'tIn, thenCmp, removeDups, cmpPString,
- panic, assertPanic{- , pprTrace ToDo:rm-} )
+import Util {- ( isIn, isn'tIn, thenCmp, removeDups, cmpPString,
+ panic, assertPanic{- , pprTrace ToDo:rm-} ) -}
\end{code}
rnDecl `renames' declarations.
checks at the same time.
\begin{code}
-rnDecl (TyD (TyData context tycon tyvars condecls derivings pragmas src_loc))
+rnDecl (TyD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
= pushSrcLocRn src_loc $
- lookupBndrRn tycon `thenRn` \ tycon' ->
- bindTyVarsRn "data declaration" tyvars $ \ tyvars' ->
- rnContext context `thenRn` \ context' ->
- mapRn rnConDecl condecls `thenRn` \ condecls' ->
- rnDerivs derivings `thenRn` \ derivings' ->
+ lookupBndrRn tycon `thenRn` \ tycon' ->
+ bindTyVarsRn data_doc tyvars $ \ tyvars' ->
+ rnContext context `thenRn` \ context' ->
+ checkDupOrQualNames data_doc con_names `thenRn_`
+ mapRn rnConDecl condecls `thenRn` \ condecls' ->
+ rnDerivs derivings `thenRn` \ derivings' ->
ASSERT(isNoDataPragmas pragmas)
- returnRn (TyD (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc))
-
-rnDecl (TyD (TyNew context tycon tyvars condecl derivings pragmas src_loc))
- = pushSrcLocRn src_loc $
- lookupBndrRn tycon `thenRn` \ tycon' ->
- bindTyVarsRn "newtype declaration" tyvars $ \ tyvars' ->
- rnContext context `thenRn` \ context' ->
- rnConDecl condecl `thenRn` \ condecl' ->
- rnDerivs derivings `thenRn` \ derivings' ->
- ASSERT(isNoDataPragmas pragmas)
- returnRn (TyD (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc))
+ 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
+ con_names = map conDeclName condecls
rnDecl (TyD (TySynonym name tyvars ty src_loc))
= pushSrcLocRn src_loc $
lookupBndrRn name `thenRn` \ name' ->
- bindTyVarsRn "type declaration" tyvars $ \ tyvars' ->
+ bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
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
\end{code}
%*********************************************************
\begin{code}
rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc))
= pushSrcLocRn src_loc $
- bindTyVarsRn "class declaration" [tyvar] $ \ [tyvar'] ->
+ bindTyVarsRn cls_doc [tyvar] $ \ [tyvar'] ->
rnContext context `thenRn` \ context' ->
lookupBndrRn cname `thenRn` \ cname' ->
+
+ -- Check the signatures
+ checkDupOrQualNames sig_doc sig_names `thenRn_`
mapRn (rn_op cname' (getTyVarName tyvar')) sigs `thenRn` \ sigs' ->
+
+
+ -- Check the methods
+ checkDupOrQualNames meth_doc meth_names `thenRn_`
rnMethodBinds mbinds `thenRn` \ mbinds' ->
+
+ -- Typechecker is responsible for checking that we only
+ -- give default-method bindings for things in this class.
+ -- The renamer *could* check this for class decls, but can't
+ -- for instance decls.
+
ASSERT(isNoClassPragmas pragmas)
returnRn (ClD (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas 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
+
+ sig_names = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
+ meth_names = bagToList (collectMonoBinders mbinds)
+
rn_op clas clas_tyvar sig@(ClassOpSig op _ ty locn)
= pushSrcLocRn locn $
+ lookupBndrRn op `thenRn` \ op_name ->
+ rnHsSigType (\sty -> ppr sty op) ty `thenRn` \ new_ty ->
+
+ -- Call up interface info for default method, if such info exists
let
dm_occ = prefixOccName SLIT("$m") (rdrNameOcc op)
in
- lookupBndrRn op `thenRn` \ op_name ->
newSysName dm_occ Exported locn `thenRn` \ dm_name ->
addOccurrenceName Optional dm_name `thenRn_`
- -- Call up interface info for default method, if such info exists
- rnHsType ty `thenRn` \ new_ty ->
+
+ -- Checks.....
let
(ctxt, op_ty) = case new_ty of
HsForAllTy tvs ctxt op_ty -> (ctxt, op_ty)
op_ty_fvs = extractHsTyNames op_ty -- Includes tycons/classes but we
-- don't care about that
in
- -- check that class tyvar appears in op_ty
+ -- Check that class tyvar appears in op_ty
checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
(classTyVarNotInOpTyErr clas_tyvar sig)
`thenRn_`
- -- check that class tyvar *doesn't* appear in the sig's context
+ -- Check that class tyvar *doesn't* appear in the sig's context
checkRn (not (clas_tyvar `elemNameSet` ctxt_fvs))
(classTyVarInOpCtxtErr clas_tyvar sig)
`thenRn_`
--- ASSERT(isNoClassOpPragmas pragmas)
returnRn (ClassOpSig op_name dm_name new_ty locn)
\end{code}
\begin{code}
rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
= pushSrcLocRn src_loc $
- rnHsType inst_ty `thenRn` \ inst_ty' ->
+ rnHsSigType (\sty -> text "an instance decl") inst_ty `thenRn` \ inst_ty' ->
+
+
+ -- Rename the bindings
+ -- NB meth_names can be qualified!
+ checkDupNames meth_doc meth_names `thenRn_`
rnMethodBinds mbinds `thenRn` \ mbinds' ->
mapRn rn_uprag uprags `thenRn` \ new_uprags ->
-- The dfun is not optional, because we use its version number
-- to identify the version of the instance declaration
+ -- 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_names = bagToList (collectMonoBinders mbinds)
+
rn_uprag (SpecSig op ty using locn)
= pushSrcLocRn src_loc $
- lookupBndrRn op `thenRn` \ op_name ->
- rnHsType ty `thenRn` \ new_ty ->
- rn_using using `thenRn` \ new_using ->
+ lookupBndrRn op `thenRn` \ op_name ->
+ rnHsSigType (\sty -> ppr sty op) ty `thenRn` \ new_ty ->
+ rn_using using `thenRn` \ new_using ->
returnRn (SpecSig op_name new_ty new_using locn)
rn_uprag (InlineSig op locn)
\end{code}
\begin{code}
-rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl
+conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
+conDeclName (ConDecl n _ _ l) = (n,l)
-rnConDecl (ConDecl name tys src_loc)
- = pushSrcLocRn src_loc $
- checkConName name `thenRn_`
- lookupBndrRn name `thenRn` \ new_name ->
- mapRn rnBangTy tys `thenRn` \ new_tys ->
- returnRn (ConDecl new_name new_tys src_loc)
-
-rnConDecl (ConOpDecl ty1 op ty2 src_loc)
- = pushSrcLocRn src_loc $
- lookupBndrRn op `thenRn` \ new_op ->
- rnBangTy ty1 `thenRn` \ new_ty1 ->
+rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl
+rnConDecl (ConDecl name cxt details locn)
+ = pushSrcLocRn locn $
+ checkConName name `thenRn_`
+ lookupBndrRn name `thenRn` \ new_name ->
+ rnConDetails name locn details `thenRn` \ new_details ->
+ rnContext cxt `thenRn` \ new_context ->
+ returnRn (ConDecl new_name new_context new_details locn)
+
+rnConDetails con locn (VanillaCon tys)
+ = mapRn rnBangTy tys `thenRn` \ new_tys ->
+ returnRn (VanillaCon new_tys)
+
+rnConDetails con locn (InfixCon ty1 ty2)
+ = rnBangTy ty1 `thenRn` \ new_ty1 ->
rnBangTy ty2 `thenRn` \ new_ty2 ->
- returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
+ returnRn (InfixCon new_ty1 new_ty2)
-rnConDecl (NewConDecl name ty src_loc)
- = pushSrcLocRn src_loc $
- checkConName name `thenRn_`
- lookupBndrRn name `thenRn` \ new_name ->
- rnHsType ty `thenRn` \ new_ty ->
- returnRn (NewConDecl new_name new_ty src_loc)
+rnConDetails con locn (NewCon ty)
+ = rnHsType ty `thenRn` \ new_ty ->
+ returnRn (NewCon new_ty)
-rnConDecl (RecConDecl name fields src_loc)
- = pushSrcLocRn src_loc $
- lookupBndrRn name `thenRn` \ new_name ->
- mapRn rnField fields `thenRn` \ new_fields ->
- returnRn (RecConDecl new_name new_fields src_loc)
+rnConDetails con locn (RecCon fields)
+ = checkDupOrQualNames fld_doc field_names `thenRn_`
+ mapRn rnField fields `thenRn` \ new_fields ->
+ returnRn (RecCon new_fields)
+ where
+ fld_doc sty = text "the fields of constructor" <> ppr sty con
+ field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
rnField (names, ty)
= mapRn lookupBndrRn names `thenRn` \ new_names ->
%*********************************************************
\begin{code}
-rnHsType :: RdrNameHsType -> RnMS s RenamedHsType
-
-rnHsType (HsForAllTy tvs ctxt ty)
- = rn_poly_help tvs ctxt ty
+rnHsSigType :: (PprStyle -> Doc) -> RdrNameHsType -> RnMS s RenamedHsType
+ -- rnHsSigType is used for source-language type signatures,
+ -- which use *implicit* universal quantification.
-rnHsType full_ty@(HsPreForAllTy ctxt ty)
+rnHsSigType doc_str full_ty@(HsPreForAllTy ctxt ty) -- From source code (no kinds on tyvars)
= getNameEnv `thenRn` \ name_env ->
let
mentioned_tyvars = extractHsTyVars full_ty
not_in_scope tv = case lookupFM name_env tv of
Nothing -> True
Just _ -> False
+
+ non_foralld_constrained = [tv | (clas, ty) <- ctxt,
+ tv <- extractHsTyVars ty,
+ not (tv `elem` forall_tyvars)
+ ]
+ in
+-- checkRn (null non_foralld_constrained)
+-- (ctxtErr sig_doc non_foralld_constrained) `thenRn_`
+
+ (bindTyVarsRn sig_doc (map UserTyVar forall_tyvars) $ \ new_tyvars ->
+ rnContext ctxt `thenRn` \ new_ctxt ->
+ rnHsType ty `thenRn` \ new_ty ->
+ returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
+ )
+ where
+ sig_doc sty = text "the type signature for" <+> doc_str sty
+
+
+rnHsSigType doc_str other_ty = rnHsType other_ty
+
+rnHsType :: RdrNameHsType -> RnMS s RenamedHsType
+rnHsType (HsForAllTy tvs ctxt ty) -- From an interface file (tyvars may be kinded)
+ = rn_poly_help tvs ctxt ty
+
+rnHsType full_ty@(HsPreForAllTy ctxt ty) -- A (context => ty) embedded in a type.
+ -- Universally quantify over tyvars in context
+ = getNameEnv `thenRn` \ name_env ->
+ let
+ forall_tyvars = foldr unionLists [] (map (extractHsTyVars . snd) ctxt)
in
rn_poly_help (map UserTyVar forall_tyvars) ctxt ty
rnHsType ty `thenRn` \ ty' ->
returnRn (MonoDictTy clas' ty')
-
rn_poly_help :: [HsTyVar RdrName] -- Universally quantified tyvars
-> RdrNameContext
-> RdrNameHsType
-> RnMS s RenamedHsType
-
rn_poly_help tyvars ctxt ty
- = bindTyVarsRn "type signature" tyvars $ \ new_tyvars ->
+ = bindTyVarsRn sig_doc tyvars $ \ new_tyvars ->
rnContext ctxt `thenRn` \ new_ctxt ->
rnHsType ty `thenRn` \ new_ty ->
returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
+ where
+ sig_doc sty = text "a nested for-all type"
\end{code}
= mapRn rn_ctxt ctxt `thenRn` \ result ->
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
- -- If this isn't an error, then it ought to be:
- mapRn (addWarnRn . dupClassAssertWarn result) dup_asserts `thenRn_`
- returnRn result
+
+ -- Check for duplicate assertions
+ -- If this isn't an error, then it ought to be:
+ mapRn (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
+
+ -- Check for All constraining a non-type-variable
+ mapRn (addWarnRn . allOfNonTyVar) non_tyvar_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)
- = lookupOccRn clas `thenRn` \ clas_name ->
+ = -- 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.
+ -- Easiest thing is simply not to put it in the occurrence set.
+ lookupBndrRn clas `thenRn` \ clas_name ->
+ (if clas_name /= allClass_NAME then
+ addOccurrenceName Compulsory clas_name
+ else
+ returnRn clas_name
+ ) `thenRn_`
rnHsType ty `thenRn` \ ty' ->
returnRn (clas_name, ty')
cmp_assert (c1,ty1) (c2,ty2)
= (c1 `cmp` c2) `thenCmp` (cmpHsType cmp ty1 ty2)
+
+ is_tyvar (MonoTyVar _) = True
+ is_tyvar other = False
\end{code}
\begin{code}
derivingNonStdClassErr clas sty
- = ppCat [ppPStr SLIT("non-standard class in deriving:"), ppr sty clas]
+ = hsep [ptext SLIT("non-standard class in deriving:"), ppr sty clas]
classTyVarNotInOpTyErr clas_tyvar sig sty
- = ppHang (ppBesides [ppPStr SLIT("Class type variable `"),
+ = hang (hcat [ptext SLIT("Class type variable `"),
ppr sty clas_tyvar,
- ppPStr SLIT("' does not appear in method signature:")])
+ ptext SLIT("' does not appear in method signature:")])
4 (ppr sty sig)
classTyVarInOpCtxtErr clas_tyvar sig sty
- = ppHang (ppBesides [ ppPStr SLIT("Class type variable `"), ppr sty clas_tyvar,
- ppPStr SLIT("' present in method's local overloading context:")])
+ = hang (hcat [ ptext SLIT("Class type variable `"), ppr sty clas_tyvar,
+ ptext SLIT("' present in method's local overloading context:")])
4 (ppr sty sig)
dupClassAssertWarn ctxt dups sty
- = ppHang (ppBesides [ppPStr SLIT("Duplicate class assertion `"),
+ = hang (hcat [ptext SLIT("Duplicate class assertion `"),
ppr sty dups,
- ppPStr SLIT("' in context:")])
+ ptext SLIT("' in context:")])
4 (ppr sty ctxt)
badDataCon name sty
- = ppCat [ppPStr SLIT("Illegal data constructor name:"), ppr sty name]
-\end{code}
-
+ = hsep [ptext SLIT("Illegal data constructor name:"), ppr sty name]
+allOfNonTyVar ty sty
+ = hsep [ptext SLIT("`All' applied to a non-type variable:"), ppr sty ty]
-
-
-=================== OLD STUFF ======================
-
-%*********************************************************
-%* *
-\subsection{SPECIALIZE data pragmas}
-%* *
-%*********************************************************
-
-\begin{pseudocode}
-rnSpecDataSig :: RdrNameSpecDataSig
- -> RnMS s RenamedSpecDataSig
-
-rnSpecDataSig (SpecDataSig tycon ty src_loc)
- = pushSrcLocRn src_loc $
- let
- tyvars = filter extractHsTyNames ty
- in
- mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
- lookupOccRn tycon `thenRn` \ tycon' ->
- rnHsType tv_env ty `thenRn` \ ty' ->
- returnRn (SpecDataSig tycon' ty' src_loc)
-
-\end{pseudocode}
-
-%*********************************************************
-%* *
-\subsection{@SPECIALIZE instance@ user-pragmas}
-%* *
-%*********************************************************
-
-\begin{pseudocode}
-rnSpecInstSig :: RdrNameSpecInstSig
- -> RnMS s RenamedSpecInstSig
-
-rnSpecInstSig (SpecInstSig clas ty src_loc)
- = pushSrcLocRn src_loc $
- let
- tyvars = extractHsTyNames is_tyvar_name ty
- in
- mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
- lookupOccRn clas `thenRn` \ new_clas ->
- rnHsType tv_env ty `thenRn` \ new_ty ->
- returnRn (SpecInstSig new_clas new_ty src_loc)
-\end{pseudocode}
+ctxtErr doc tyvars sty
+ = hsep [ptext SLIT("Context constrains type variable(s)"),
+ hsep (punctuate comma (map (ppr sty) tyvars))]
+ $$ nest 4 (ptext SLIT("in") <+> doc sty)
+\end{code}
projects / ghc-hetmet.git / commitdiff