2 % (c) The University of Glasgow 2000
4 \section[InterpSyn]{Abstract syntax for interpretable trees}
7 module InterpSyn {- Todo: ( ... ) -} where
9 #include "HsVersions.h"
16 import PrelAddr -- tmp
18 import GlaExts ( Int(..) )
20 -----------------------------------------------------------------------------
21 -- The interpretable expression type
23 data HValue = HValue -- dummy type, actually a pointer to some Real Code.
25 data IBind con var = IBind Id (IExpr con var)
27 binder (IBind v e) = v
28 bindee (IBind v e) = e
30 data AltAlg con var = AltAlg Int{-tagNo-} [(Id,Rep)] (IExpr con var)
31 data AltPrim con var = AltPrim (Lit con var) (IExpr con var)
33 -- HACK ALERT! A Lit may *only* be one of LitI, LitL, LitF, LitD
34 type Lit con var = IExpr con var
41 -- we're assuming that Char# is sufficiently compatible with Int# that
42 -- we only need one rep for both.
53 -- index???OffClosure needs to traverse indirection nodes.
55 -- You can always tell the representation of an IExpr by examining
58 = CaseAlgP Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
59 | CaseAlgI Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
60 | CaseAlgF Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
61 | CaseAlgD Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
63 | CasePrimP Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
64 | CasePrimI Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
65 | CasePrimF Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
66 | CasePrimD Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
68 -- saturated constructor apps; args are in heap order.
69 -- The Addrs are the info table pointers. Descriptors refer to the
70 -- arg reps; all constructor applications return pointer rep.
72 | ConAppI con (IExpr con var)
73 | ConAppP con (IExpr con var)
74 | ConAppPP con (IExpr con var) (IExpr con var)
75 | ConAppGen con [IExpr con var]
77 | PrimOpP PrimOp [(IExpr con var)]
78 | PrimOpI PrimOp [(IExpr con var)]
79 | PrimOpF PrimOp [(IExpr con var)]
80 | PrimOpD PrimOp [(IExpr con var)]
82 | NonRecP (IBind con var) (IExpr con var)
83 | NonRecI (IBind con var) (IExpr con var)
84 | NonRecF (IBind con var) (IExpr con var)
85 | NonRecD (IBind con var) (IExpr con var)
87 | RecP [IBind con var] (IExpr con var)
88 | RecI [IBind con var] (IExpr con var)
89 | RecF [IBind con var] (IExpr con var)
90 | RecD [IBind con var] (IExpr con var)
101 | Native var -- pointer to a Real Closure
108 -- LamXY indicates a function of reps X -> Y
109 -- ie var rep = X, result rep = Y
110 -- NOTE: repOf (LamXY _ _) = RepI regardless of X and Y
112 | LamPP Id (IExpr con var)
113 | LamPI Id (IExpr con var)
114 | LamPF Id (IExpr con var)
115 | LamPD Id (IExpr con var)
116 | LamIP Id (IExpr con var)
117 | LamII Id (IExpr con var)
118 | LamIF Id (IExpr con var)
119 | LamID Id (IExpr con var)
120 | LamFP Id (IExpr con var)
121 | LamFI Id (IExpr con var)
122 | LamFF Id (IExpr con var)
123 | LamFD Id (IExpr con var)
124 | LamDP Id (IExpr con var)
125 | LamDI Id (IExpr con var)
126 | LamDF Id (IExpr con var)
127 | LamDD Id (IExpr con var)
129 -- AppXY means apply a fn (always of Ptr rep) to
130 -- an arg of rep X giving result of Rep Y
131 -- therefore: repOf (AppXY _ _) = RepY
132 | AppPP (IExpr con var) (IExpr con var)
133 | AppPI (IExpr con var) (IExpr con var)
134 | AppPF (IExpr con var) (IExpr con var)
135 | AppPD (IExpr con var) (IExpr con var)
136 | AppIP (IExpr con var) (IExpr con var)
137 | AppII (IExpr con var) (IExpr con var)
138 | AppIF (IExpr con var) (IExpr con var)
139 | AppID (IExpr con var) (IExpr con var)
140 | AppFP (IExpr con var) (IExpr con var)
141 | AppFI (IExpr con var) (IExpr con var)
142 | AppFF (IExpr con var) (IExpr con var)
143 | AppFD (IExpr con var) (IExpr con var)
144 | AppDP (IExpr con var) (IExpr con var)
145 | AppDI (IExpr con var) (IExpr con var)
146 | AppDF (IExpr con var) (IExpr con var)
147 | AppDD (IExpr con var) (IExpr con var)
150 showExprTag :: IExpr c v -> String
154 CaseAlgP _ _ _ _ -> "CaseAlgP"
155 CaseAlgI _ _ _ _ -> "CaseAlgI"
156 CaseAlgF _ _ _ _ -> "CaseAlgF"
157 CaseAlgD _ _ _ _ -> "CaseAlgD"
159 CasePrimP _ _ _ _ -> "CasePrimP"
160 CasePrimI _ _ _ _ -> "CasePrimI"
161 CasePrimF _ _ _ _ -> "CasePrimF"
162 CasePrimD _ _ _ _ -> "CasePrimD"
165 ConAppI _ _ -> "ConAppI"
166 ConAppP _ _ -> "ConAppP"
167 ConAppPP _ _ _ -> "ConAppPP"
168 ConAppGen _ _ -> "ConAppGen"
170 PrimOpP _ _ -> "PrimOpP"
171 PrimOpI _ _ -> "PrimOpI"
172 PrimOpF _ _ -> "PrimOpF"
173 PrimOpD _ _ -> "PrimOpD"
175 NonRecP _ _ -> "NonRecP"
176 NonRecI _ _ -> "NonRecI"
177 NonRecF _ _ -> "NonRecF"
178 NonRecD _ _ -> "NonRecD"
230 other -> "(showExprTag:unhandled case)"
232 -----------------------------------------------------------------------------
233 -- Instantiations of the IExpr type
235 type UnlinkedIExpr = IExpr RdrName RdrName
236 type LinkedIExpr = IExpr Addr HValue
238 type UnlinkedIBind = IBind RdrName RdrName
239 type LinkedIBind = IBind Addr HValue
241 type UnlinkedAltAlg = AltAlg RdrName RdrName
242 type LinkedAltAlg = AltAlg Addr HValue
244 type UnlinkedAltPrim = AltPrim RdrName RdrName
245 type LinkedAltPrim = AltPrim Addr HValue
247 -----------------------------------------------------------------------------
250 instance Outputable HValue where
251 ppr x = text (show (A# (unsafeCoerce# x :: Addr#)))
252 -- ptext SLIT("<O>") -- unidentified lurking object
254 instance (Outputable var, Outputable con) => Outputable (IBind con var) where
255 ppr ibind = pprIBind ibind
257 pprIBind :: (Outputable var, Outputable con) => IBind con var -> SDoc
258 pprIBind (IBind v e) = ppr v <+> char '=' <+> pprIExpr e
260 pprAltAlg (AltAlg tag vars rhs)
261 = text "Tag_" <> int tag <+> hsep (map ppr vars)
262 <+> text "->" <+> pprIExpr rhs
264 pprAltPrim (AltPrim tag rhs)
265 = pprIExpr tag <+> text "->" <+> pprIExpr rhs
267 instance Outputable Rep where
271 instance Outputable Addr where
272 ppr addr = text (show addr)
274 pprDefault Nothing = text "NO_DEFAULT"
275 pprDefault (Just e) = text "DEFAULT ->" $$ nest 2 (pprIExpr e)
277 pprIExpr :: (Outputable var, Outputable con) => IExpr con var -> SDoc
278 pprIExpr (expr:: IExpr con var)
280 PrimOpI op args -> doPrimOp 'I' op args
281 PrimOpP op args -> doPrimOp 'P' op args
285 LitI i# -> int (I# i#) <> char '#'
287 LamPP v e -> doLam "PP" v e
288 LamPI v e -> doLam "PI" v e
289 LamIP v e -> doLam "IP" v e
290 LamII v e -> doLam "II" v e
292 AppPP f a -> doApp "PP" f a
293 AppPI f a -> doApp "PI" f a
294 AppIP f a -> doApp "IP" f a
295 AppII f a -> doApp "II" f a
297 Native v -> ptext SLIT("Native") <+> ppr v
299 CasePrimI b sc alts def -> doCasePrim 'I' b sc alts def
300 CasePrimP b sc alts def -> doCasePrim 'P' b sc alts def
302 CaseAlgI b sc alts def -> doCaseAlg 'I' b sc alts def
303 CaseAlgP b sc alts def -> doCaseAlg 'P' b sc alts def
305 NonRecP bind body -> doNonRec 'P' bind body
306 NonRecI bind body -> doNonRec 'I' bind body
308 RecP binds body -> doRec 'P' binds body
309 RecI binds body -> doRec 'I' binds body
311 ConApp i -> doConApp "" i ([] :: [IExpr con var])
312 ConAppI i a1 -> doConApp "" i [a1]
313 ConAppP i a1 -> doConApp "" i [a1]
314 ConAppPP i a1 a2 -> doConApp "" i [a1,a2]
315 ConAppGen i args -> doConApp "" i args
317 other -> text "pprIExpr: unimplemented tag:"
318 <+> text (showExprTag other)
320 doConApp repstr itbl args
321 = text "Con" <> text repstr
322 <+> char '[' <> hsep (map pprIExpr args) <> char ']'
324 doPrimOp repchar op args
325 = char repchar <> ppr op <+> char '[' <> hsep (map pprIExpr args) <> char ']'
327 doNonRec repchr bind body
328 = vcat [text "let" <> char repchr <+> pprIBind bind, text "in", pprIExpr body]
330 doRec repchr binds body
331 = vcat [text "letrec" <> char repchr <+> vcat (map pprIBind binds),
332 text "in", pprIExpr body]
334 doCasePrim repchr b sc alts def
335 = sep [text "CasePrim" <> char repchr
336 <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
337 nest 2 (vcat (map pprAltPrim alts) $$ pprDefault def),
341 doCaseAlg repchr b sc alts def
342 = sep [text "CaseAlg" <> char repchr
343 <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
344 nest 2 (vcat (map pprAltAlg alts) $$ pprDefault def),
349 = text "(@" <> text repstr <+> pprIExpr f <+> pprIExpr a <> char ')'
351 = (char '\\' <> text repstr <+> ppr v <+> text "->") $$ pprIExpr e