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 Name Name
236 type LinkedIExpr = IExpr Addr HValue
238 type UnlinkedIBind = IBind Name Name
239 type LinkedIBind = IBind Addr HValue
241 type UnlinkedAltAlg = AltAlg Name Name
242 type LinkedAltAlg = AltAlg Addr HValue
244 type UnlinkedAltPrim = AltPrim Name Name
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
273 instance Outputable Addr where
274 ppr addr = text (show addr)
276 pprDefault Nothing = text "NO_DEFAULT"
277 pprDefault (Just e) = text "DEFAULT ->" $$ nest 2 (pprIExpr e)
279 pprIExpr :: (Outputable var, Outputable con) => IExpr con var -> SDoc
280 pprIExpr (expr:: IExpr con var)
282 PrimOpI op args -> doPrimOp 'I' op args
283 PrimOpP op args -> doPrimOp 'P' op args
287 LitI i# -> int (I# i#) <> char '#'
289 LamPP v e -> doLam "PP" v e
290 LamPI v e -> doLam "PI" v e
291 LamIP v e -> doLam "IP" v e
292 LamII v e -> doLam "II" v e
294 AppPP f a -> doApp "PP" f a
295 AppPI f a -> doApp "PI" f a
296 AppIP f a -> doApp "IP" f a
297 AppII f a -> doApp "II" f a
299 Native v -> ptext SLIT("Native") <+> ppr v
301 CasePrimI b sc alts def -> doCasePrim 'I' b sc alts def
302 CasePrimP b sc alts def -> doCasePrim 'P' b sc alts def
304 CaseAlgI b sc alts def -> doCaseAlg 'I' b sc alts def
305 CaseAlgP b sc alts def -> doCaseAlg 'P' b sc alts def
307 NonRecP bind body -> doNonRec 'P' bind body
308 NonRecI bind body -> doNonRec 'I' bind body
310 RecP binds body -> doRec 'P' binds body
311 RecI binds body -> doRec 'I' binds body
313 ConApp i -> doConApp "" i ([] :: [IExpr con var])
314 ConAppI i a1 -> doConApp "" i [a1]
315 ConAppP i a1 -> doConApp "" i [a1]
316 ConAppPP i a1 a2 -> doConApp "" i [a1,a2]
317 ConAppGen i args -> doConApp "" i args
319 other -> text "pprIExpr: unimplemented tag:"
320 <+> text (showExprTag other)
322 doConApp repstr itbl args
323 = text "Con" <> text repstr
324 <+> char '[' <> hsep (map pprIExpr args) <> char ']'
326 doPrimOp repchar op args
327 = char repchar <> ppr op <+> char '[' <> hsep (map pprIExpr args) <> char ']'
329 doNonRec repchr bind body
330 = vcat [text "let" <> char repchr <+> pprIBind bind, text "in", pprIExpr body]
332 doRec repchr binds body
333 = vcat [text "letrec" <> char repchr <+> vcat (map pprIBind binds),
334 text "in", pprIExpr body]
336 doCasePrim repchr b sc alts def
337 = sep [text "CasePrim" <> char repchr
338 <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
339 nest 2 (vcat (map pprAltPrim alts) $$ pprDefault def),
343 doCaseAlg repchr b sc alts def
344 = sep [text "CaseAlg" <> char repchr
345 <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
346 nest 2 (vcat (map pprAltAlg alts) $$ pprDefault def),
351 = text "(@" <> text repstr <+> pprIExpr f <+> pprIExpr a <> char ')'
353 = (char '\\' <> text repstr <+> ppr v <+> text "->") $$ pprIExpr e