2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
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.
14 #include "HsVersions.h"
17 UfExpr(..), UfAlts(..), UfBinder(..), UfCoercion(..),
18 UfDefault(..), UfBinding(..),
19 UfArg(..), UfPrimOp(..)
25 import HsTypes ( HsType, pprParendHsType )
26 import PrimOp ( PrimOp, tagOf_PrimOp )
27 import Kind ( Kind {- instance Outputable -} )
28 import Type ( GenType {- instance Outputable -} )
31 import Literal ( Literal )
32 import Outputable ( Outputable(..) )
35 #if __GLASGOW_HASKELL__ >= 202
40 %************************************************************************
42 \subsection[HsCore-types]{Types for read/written Core unfoldings}
44 %************************************************************************
50 | UfCon name [UfArg name]
51 | UfPrim (UfPrimOp name) [UfArg name]
52 | UfLam (UfBinder name) (UfExpr name)
53 | UfApp (UfExpr name) (UfArg name)
54 | UfCase (UfExpr name) (UfAlts name)
55 | UfLet (UfBinding name) (UfExpr name)
56 | UfSCC CostCentre (UfExpr name)
57 | UfCoerce (UfCoercion name) (HsType name) (UfExpr name)
60 = UfCCallOp FAST_STRING -- callee
61 Bool -- True <=> casm, rather than ccall
62 Bool -- True <=> might cause GC
63 [HsType name] -- arg types, incl state token
64 -- (which will be first)
65 (HsType name) -- return type
69 data UfCoercion name = UfIn name | UfOut name
72 = UfAlgAlts [(name, [name], UfExpr name)]
74 | UfPrimAlts [(Literal, UfExpr name)]
79 | UfBindDefault name (UfExpr name)
82 = UfNonRec (UfBinder name)
84 | UfRec [(UfBinder name, UfExpr name)]
87 = UfValBinder name (HsType name)
88 | UfTyBinder name Kind
94 | UfTyArg (HsType name)
98 %************************************************************************
100 \subsection[HsCore-print]{Printing Core unfoldings}
102 %************************************************************************
105 instance Outputable name => Outputable (UfExpr name) where
106 ppr sty (UfVar v) = ppr sty v
107 ppr sty (UfLit l) = ppr sty l
110 = hsep [text "UfCon", ppr sty c, ppr sty as, char ')']
111 ppr sty (UfPrim o as)
112 = hsep [text "UfPrim", ppr sty o, ppr sty as, char ')']
114 ppr sty (UfLam b body)
115 = hsep [char '\\', ppr sty b, ptext SLIT("->"), ppr sty body]
117 ppr sty (UfApp fun (UfTyArg ty))
118 = hsep [ppr sty fun, char '@', pprParendHsType sty ty]
120 ppr sty (UfApp fun (UfLitArg lit))
121 = hsep [ppr sty fun, ppr sty lit]
123 ppr sty (UfApp fun (UfVarArg var))
124 = hsep [ppr sty fun, ppr sty var]
126 ppr sty (UfCase scrut alts)
127 = hsep [ptext SLIT("case"), ppr sty scrut, ptext SLIT("of {"), pp_alts alts, char '}']
129 pp_alts (UfAlgAlts alts deflt)
130 = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
132 pp_alt (c,bs,rhs) = hsep [ppr sty c, ppr sty bs, ppr_arrow, ppr sty rhs]
133 pp_alts (UfPrimAlts alts deflt)
134 = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
136 pp_alt (l,rhs) = hsep [ppr sty l, ppr_arrow, ppr sty rhs]
138 pp_deflt UfNoDefault = empty
139 pp_deflt (UfBindDefault b rhs) = hsep [ppr sty b, ppr_arrow, ppr sty rhs]
141 ppr_arrow = ptext SLIT("->")
143 ppr sty (UfLet (UfNonRec b rhs) body)
144 = hsep [ptext SLIT("let"), ppr sty b, equals, ppr sty rhs, ptext SLIT("in"), ppr sty body]
145 ppr sty (UfLet (UfRec pairs) body)
146 = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr sty body]
148 pp_pair (b,rhs) = hsep [ppr sty b, equals, ppr sty rhs]
150 ppr sty (UfSCC uf_cc body)
151 = hsep [ptext SLIT("_scc_ <cost-centre[ToDo]>"), ppr sty body]
153 instance Outputable name => Outputable (UfPrimOp name) where
154 ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
156 before = ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
157 after = if is_casm then text "'' " else space
159 hcat [before, ptext str, after,
160 brackets (ppr sty arg_tys), space, ppr sty result_ty]
162 ppr sty (UfOtherOp op)
165 instance Outputable name => Outputable (UfArg name) where
166 ppr sty (UfVarArg v) = ppr sty v
167 ppr sty (UfLitArg l) = ppr sty l
168 ppr sty (UfTyArg ty) = pprParendHsType sty ty
169 ppr sty (UfUsageArg name) = ppr sty name
171 instance Outputable name => Outputable (UfBinder name) where
172 ppr sty (UfValBinder name ty) = hsep [ppr sty name, ptext SLIT("::"), ppr sty ty]
173 ppr sty (UfTyBinder name kind) = hsep [ppr sty name, ptext SLIT("::"), ppr sty kind]
174 ppr sty (UfUsageBinder name) = ppr sty name