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 PrimOp ( PrimOp, tagOf_PrimOp )
25 import Kind ( Kind {- instance Outputable -} )
26 import Type ( GenType {- instance Outputable -} )
29 import Literal ( Literal )
35 %************************************************************************
37 \subsection[HsCore-types]{Types for read/written Core unfoldings}
39 %************************************************************************
45 | UfCon name [UfArg name]
46 | UfPrim (UfPrimOp name) [UfArg name]
47 | UfLam (UfBinder name) (UfExpr name)
48 | UfApp (UfExpr name) (UfArg name)
49 | UfCase (UfExpr name) (UfAlts name)
50 | UfLet (UfBinding name) (UfExpr name)
51 | UfSCC CostCentre (UfExpr name)
52 | UfCoerce (UfCoercion name) (HsType name) (UfExpr name)
55 = UfCCallOp FAST_STRING -- callee
56 Bool -- True <=> casm, rather than ccall
57 Bool -- True <=> might cause GC
58 [HsType name] -- arg types, incl state token
59 -- (which will be first)
60 (HsType name) -- return type
64 data UfCoercion name = UfIn name | UfOut name
67 = UfAlgAlts [(name, [name], UfExpr name)]
69 | UfPrimAlts [(Literal, UfExpr name)]
74 | UfBindDefault name (UfExpr name)
77 = UfNonRec (UfBinder name)
79 | UfRec [(UfBinder name, UfExpr name)]
82 = UfValBinder name (HsType name)
83 | UfTyBinder name Kind
88 | UfTyArg (HsType name)
91 %************************************************************************
93 \subsection[HsCore-print]{Printing Core unfoldings}
95 %************************************************************************
98 instance Outputable name => Outputable (UfExpr name) where
100 ppr (UfLit l) = ppr l
103 = hsep [text "UfCon", ppr c, ppr as, char ')']
105 = hsep [text "UfPrim", ppr o, ppr as, char ')']
108 = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
110 ppr (UfApp fun (UfTyArg ty))
111 = hsep [ppr fun, char '@', pprParendHsType ty]
113 ppr (UfApp fun (UfLitArg lit))
114 = hsep [ppr fun, ppr lit]
116 ppr (UfApp fun (UfVarArg var))
117 = hsep [ppr fun, ppr var]
119 ppr (UfCase scrut alts)
120 = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of {"), pp_alts alts, char '}']
122 pp_alts (UfAlgAlts alts deflt)
123 = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
125 pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
126 pp_alts (UfPrimAlts alts deflt)
127 = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
129 pp_alt (l,rhs) = hsep [ppr l, ppr_arrow, ppr rhs]
131 pp_deflt UfNoDefault = empty
132 pp_deflt (UfBindDefault b rhs) = hsep [ppr b, ppr_arrow, ppr rhs]
134 ppr_arrow = ptext SLIT("->")
136 ppr (UfLet (UfNonRec b rhs) body)
137 = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body]
138 ppr (UfLet (UfRec pairs) body)
139 = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body]
141 pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs]
143 ppr (UfSCC uf_cc body)
144 = hsep [ptext SLIT("_scc_ <cost-centre[ToDo]>"), ppr body]
146 instance Outputable name => Outputable (UfPrimOp name) where
147 ppr (UfCCallOp str is_casm can_gc arg_tys result_ty)
149 before = ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
150 after = if is_casm then text "'' " else space
152 hcat [before, ptext str, after,
153 brackets (ppr arg_tys), space, ppr result_ty]
158 instance Outputable name => Outputable (UfArg name) where
159 ppr (UfVarArg v) = ppr v
160 ppr (UfLitArg l) = ppr l
161 ppr (UfTyArg ty) = pprParendHsType ty
163 instance Outputable name => Outputable (UfBinder name) where
164 ppr (UfValBinder name ty) = hsep [ppr name, ptext SLIT("::"), ppr ty]
165 ppr (UfTyBinder name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]