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(..) )
37 %************************************************************************
39 \subsection[HsCore-types]{Types for read/written Core unfoldings}
41 %************************************************************************
47 | UfCon name [UfArg name]
48 | UfPrim (UfPrimOp name) [UfArg name]
49 | UfLam (UfBinder name) (UfExpr name)
50 | UfApp (UfExpr name) (UfArg name)
51 | UfCase (UfExpr name) (UfAlts name)
52 | UfLet (UfBinding name) (UfExpr name)
53 | UfSCC CostCentre (UfExpr name)
54 | UfCoerce (UfCoercion name) (HsType name) (UfExpr name)
57 = UfCCallOp FAST_STRING -- callee
58 Bool -- True <=> casm, rather than ccall
59 Bool -- True <=> might cause GC
60 [HsType name] -- arg types, incl state token
61 -- (which will be first)
62 (HsType name) -- return type
66 data UfCoercion name = UfIn name | UfOut name
69 = UfAlgAlts [(name, [name], UfExpr name)]
71 | UfPrimAlts [(Literal, UfExpr name)]
76 | UfBindDefault name (UfExpr name)
79 = UfNonRec (UfBinder name)
81 | UfRec [(UfBinder name, UfExpr name)]
84 = UfValBinder name (HsType name)
85 | UfTyBinder name Kind
91 | UfTyArg (HsType name)
95 %************************************************************************
97 \subsection[HsCore-print]{Printing Core unfoldings}
99 %************************************************************************
102 instance Outputable name => Outputable (UfExpr name) where
103 ppr sty (UfVar v) = ppr sty v
104 ppr sty (UfLit l) = ppr sty l
107 = ppCat [ppStr "UfCon", ppr sty c, ppr sty as, ppChar ')']
108 ppr sty (UfPrim o as)
109 = ppCat [ppStr "UfPrim", ppr sty o, ppr sty as, ppChar ')']
111 ppr sty (UfLam b body)
112 = ppCat [ppChar '\\', ppr sty b, ppPStr SLIT("->"), ppr sty body]
114 ppr sty (UfApp fun (UfTyArg ty))
115 = ppCat [ppr sty fun, ppChar '@', pprParendHsType sty ty]
117 ppr sty (UfApp fun (UfLitArg lit))
118 = ppCat [ppr sty fun, ppr sty lit]
120 ppr sty (UfApp fun (UfVarArg var))
121 = ppCat [ppr sty fun, ppr sty var]
123 ppr sty (UfCase scrut alts)
124 = ppCat [ppPStr SLIT("case"), ppr sty scrut, ppPStr SLIT("of {"), pp_alts alts, ppChar '}']
126 pp_alts (UfAlgAlts alts deflt)
127 = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
129 pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppr_arrow, ppr sty rhs]
130 pp_alts (UfPrimAlts alts deflt)
131 = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
133 pp_alt (l,rhs) = ppCat [ppr sty l, ppr_arrow, ppr sty rhs]
135 pp_deflt UfNoDefault = ppNil
136 pp_deflt (UfBindDefault b rhs) = ppCat [ppr sty b, ppr_arrow, ppr sty rhs]
138 ppr_arrow = ppPStr SLIT("->")
140 ppr sty (UfLet (UfNonRec b rhs) body)
141 = ppCat [ppPStr SLIT("let"), ppr sty b, ppEquals, ppr sty rhs, ppPStr SLIT("in"), ppr sty body]
142 ppr sty (UfLet (UfRec pairs) body)
143 = ppCat [ppPStr SLIT("letrec {"), ppInterleave ppSemi (map pp_pair pairs), ppPStr SLIT("} in"), ppr sty body]
145 pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs]
147 ppr sty (UfSCC uf_cc body)
148 = ppCat [ppPStr SLIT("_scc_ <cost-centre[ToDo]>"), ppr sty body]
150 instance Outputable name => Outputable (UfPrimOp name) where
151 ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
153 before = ppPStr (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
154 after = if is_casm then ppStr "'' " else ppSP
156 ppBesides [before, ppPStr str, after,
157 ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
159 ppr sty (UfOtherOp op)
162 instance Outputable name => Outputable (UfArg name) where
163 ppr sty (UfVarArg v) = ppr sty v
164 ppr sty (UfLitArg l) = ppr sty l
165 ppr sty (UfTyArg ty) = pprParendHsType sty ty
166 ppr sty (UfUsageArg name) = ppr sty name
168 instance Outputable name => Outputable (UfBinder name) where
169 ppr sty (UfValBinder name ty) = ppCat [ppr sty name, ppPStr SLIT("::"), ppr sty ty]
170 ppr sty (UfTyBinder name kind) = ppCat [ppr sty name, ppPStr SLIT("::"), ppr sty kind]
171 ppr sty (UfUsageBinder name) = ppr sty name