2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 %************************************************************************
6 \section[HsCore]{Core-syntax unfoldings in Haskell interface files}
8 %************************************************************************
10 We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
11 @TyVars@ as well. Currently trying the former... MEGA SIGH.
15 UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
16 UfBinding(..), UfCon(..),
17 HsIdInfo(..), HsStrictnessInfo(..),
18 IfaceSig(..), UfRuleBody(..)
21 #include "HsVersions.h"
24 import HsTypes ( HsType, pprParendHsType )
27 import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo, CprInfo )
28 import CoreSyn ( CoreBndr, CoreExpr )
29 import Demand ( Demand )
30 import Const ( Literal )
33 import SrcLoc ( SrcLoc )
37 %************************************************************************
39 \subsection[HsCore-types]{Types for read/written Core unfoldings}
41 %************************************************************************
46 | UfType (HsType name)
47 | UfCon (UfCon name) [UfExpr name]
48 | UfTuple name [UfExpr name] -- Type arguments omitted
49 | UfLam (UfBinder name) (UfExpr name)
50 | UfApp (UfExpr name) (UfExpr name)
51 | UfCase (UfExpr name) name [UfAlt name]
52 | UfLet (UfBinding name) (UfExpr name)
53 | UfNote (UfNote name) (UfExpr name)
55 data UfNote name = UfSCC CostCentre
56 | UfCoerce (HsType name)
60 type UfAlt name = (UfCon name, [name], UfExpr name)
62 data UfCon name = UfDefault
65 | UfLitLitCon FAST_STRING (HsType name)
67 | UfCCallOp FAST_STRING -- callee
68 Bool -- True => dynamic (first arg is fun. pointer)
69 Bool -- True <=> casm, rather than ccall
70 Bool -- True <=> might cause GC
73 = UfNonRec (UfBinder name)
75 | UfRec [(UfBinder name, UfExpr name)]
78 = UfValBinder name (HsType name)
79 | UfTyBinder name Kind
83 %************************************************************************
85 \subsection[HsCore-print]{Printing Core unfoldings}
87 %************************************************************************
90 instance Outputable name => Outputable (UfExpr name) where
92 ppr (UfType ty) = char '@' <+> pprParendHsType ty
95 = hsep [text "UfCon", ppr c, ppr as]
97 ppr (UfTuple c as) = parens (hsep (punctuate comma (map ppr as)))
100 = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
102 ppr (UfApp fun arg) = ppr fun <+> ppr arg
104 ppr (UfCase scrut bndr alts)
105 = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of"), ppr bndr,
106 braces (hsep (punctuate semi (map pp_alt alts)))]
108 pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
110 ppr_arrow = ptext SLIT("->")
112 ppr (UfLet (UfNonRec b rhs) body)
113 = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body]
114 ppr (UfLet (UfRec pairs) body)
115 = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body]
117 pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs]
119 ppr (UfNote note body)
120 = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body]
122 instance Outputable name => Outputable (UfCon name) where
123 ppr UfDefault = text "DEFAULT"
124 ppr (UfDataCon d) = ppr d
125 ppr (UfPrimOp p) = ppr p
126 ppr (UfCCallOp str is_dyn is_casm can_gc)
127 = hcat [before, ptext str, after]
129 before = (if is_dyn then ptext SLIT("_dyn_") else empty) <>
130 ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
131 after = if is_casm then text "'' " else space
133 instance Outputable name => Outputable (UfBinder name) where
134 ppr (UfValBinder name ty) = hsep [ppr name, dcolon, ppr ty]
135 ppr (UfTyBinder name kind) = hsep [ppr name, dcolon, ppr kind]
139 %************************************************************************
141 \subsection{Signatures in interface files}
143 %************************************************************************
152 instance (Outputable name) => Outputable (IfaceSig name) where
153 ppr (IfaceSig var ty _ _)
154 = hang (hsep [ppr var, dcolon])
159 | HsStrictness HsStrictnessInfo
160 | HsUnfold InlinePragInfo (UfExpr name)
161 | HsUpdate UpdateInfo
162 | HsSpecialise (UfRuleBody name)
165 | HsWorker name -- Worker, if any
167 data HsStrictnessInfo
168 = HsStrictnessInfo ([Demand], Bool)
173 %************************************************************************
175 \subsection{Rules in interface files}
177 %************************************************************************
180 data UfRuleBody name = UfRuleBody FAST_STRING [UfBinder name] [UfExpr name] (UfExpr name) -- Pre typecheck
181 | CoreRuleBody FAST_STRING [CoreBndr] [CoreExpr] CoreExpr -- Post typecheck