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.
15 UfExpr(..), UfAlts(..), UfBinder(..), UfCoercion(..),
16 UfDefault(..), UfBinding(..),
17 UfArg(..), UfPrimOp(..)
20 #include "HsVersions.h"
23 import HsTypes ( HsType, pprParendHsType )
24 import Kind ( Kind {- instance Outputable -} )
27 import Literal ( Literal )
33 %************************************************************************
35 \subsection[HsCore-types]{Types for read/written Core unfoldings}
37 %************************************************************************
43 | UfCon name [UfArg name]
44 | UfPrim (UfPrimOp name) [UfArg name]
45 | UfLam (UfBinder name) (UfExpr name)
46 | UfApp (UfExpr name) (UfArg name)
47 | UfCase (UfExpr name) (UfAlts name)
48 | UfLet (UfBinding name) (UfExpr name)
49 | UfSCC CostCentre (UfExpr name)
50 | UfCoerce (UfCoercion name) (HsType name) (UfExpr name)
53 = UfCCallOp FAST_STRING -- callee
54 Bool -- True <=> casm, rather than ccall
55 Bool -- True <=> might cause GC
56 [HsType name] -- arg types, incl state token
57 -- (which will be first)
58 (HsType name) -- return type
62 data UfCoercion name = UfIn name | UfOut name
65 = UfAlgAlts [(name, [name], UfExpr name)]
67 | UfPrimAlts [(Literal, UfExpr name)]
72 | UfBindDefault name (UfExpr name)
75 = UfNonRec (UfBinder name)
77 | UfRec [(UfBinder name, UfExpr name)]
80 = UfValBinder name (HsType name)
81 | UfTyBinder name Kind
86 | UfTyArg (HsType name)
89 %************************************************************************
91 \subsection[HsCore-print]{Printing Core unfoldings}
93 %************************************************************************
96 instance Outputable name => Outputable (UfExpr name) where
101 = hsep [text "UfCon", ppr c, ppr as, char ')']
103 = hsep [text "UfPrim", ppr o, ppr as, char ')']
106 = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
108 ppr (UfApp fun (UfTyArg ty))
109 = hsep [ppr fun, char '@', pprParendHsType ty]
111 ppr (UfApp fun (UfLitArg lit))
112 = hsep [ppr fun, ppr lit]
114 ppr (UfApp fun (UfVarArg var))
115 = hsep [ppr fun, ppr var]
117 ppr (UfCase scrut alts)
118 = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of {"), pp_alts alts, char '}']
120 pp_alts (UfAlgAlts alts deflt)
121 = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
123 pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
124 pp_alts (UfPrimAlts alts deflt)
125 = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
127 pp_alt (l,rhs) = hsep [ppr l, ppr_arrow, ppr rhs]
129 pp_deflt UfNoDefault = empty
130 pp_deflt (UfBindDefault b rhs) = hsep [ppr b, ppr_arrow, ppr rhs]
132 ppr_arrow = ptext SLIT("->")
134 ppr (UfLet (UfNonRec b rhs) body)
135 = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body]
136 ppr (UfLet (UfRec pairs) body)
137 = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body]
139 pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs]
141 ppr (UfSCC uf_cc body)
142 = hsep [ptext SLIT("_scc_ <cost-centre[ToDo]>"), ppr body]
144 instance Outputable name => Outputable (UfPrimOp name) where
145 ppr (UfCCallOp str is_casm can_gc arg_tys result_ty)
147 before = ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
148 after = if is_casm then text "'' " else space
150 hcat [before, ptext str, after,
151 brackets (ppr arg_tys), space, ppr result_ty]
156 instance Outputable name => Outputable (UfArg name) where
157 ppr (UfVarArg v) = ppr v
158 ppr (UfLitArg l) = ppr l
159 ppr (UfTyArg ty) = pprParendHsType ty
161 instance Outputable name => Outputable (UfBinder name) where
162 ppr (UfValBinder name ty) = hsep [ppr name, ptext SLIT("::"), ppr ty]
163 ppr (UfTyBinder name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]