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 | ConAppPPP con (IExpr con var) (IExpr con var) (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 ConAppPPP _ _ _ _ -> "ConAppPPP"
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 pprIBind :: (Outputable var, Outputable con) => IBind con var -> SDoc
255 pprIBind (IBind v e) = ppr v <+> char '=' <+> pprIExpr e
257 pprAltAlg (AltAlg tag vars rhs)
258 = text "Tag_" <> int tag <+> hsep (map ppr vars)
259 <+> text "->" <+> pprIExpr rhs
261 pprAltPrim (AltPrim tag rhs)
262 = pprIExpr tag <+> text "->" <+> pprIExpr rhs
264 instance Outputable Rep where
268 instance Outputable Addr where
269 ppr addr = text (show addr)
271 pprDefault Nothing = text "NO_DEFAULT"
272 pprDefault (Just e) = text "DEFAULT ->" $$ nest 2 (pprIExpr e)
274 pprIExpr :: (Outputable var, Outputable con) => IExpr con var -> SDoc
275 pprIExpr (expr:: IExpr con var)
277 PrimOpI op args -> doPrimOp 'I' op args
278 PrimOpP op args -> doPrimOp 'P' op args
282 LitI i# -> int (I# i#) <> char '#'
284 LamPP v e -> doLam "PP" v e
285 LamPI v e -> doLam "PI" v e
286 LamIP v e -> doLam "IP" v e
287 LamII v e -> doLam "II" v e
289 AppPP f a -> doApp "PP" f a
290 AppPI f a -> doApp "PI" f a
291 AppIP f a -> doApp "IP" f a
292 AppII f a -> doApp "II" f a
294 Native v -> ptext SLIT("Native") <+> ppr v
296 CasePrimI b sc alts def -> doCasePrim 'I' b sc alts def
297 CasePrimP b sc alts def -> doCasePrim 'P' b sc alts def
299 CaseAlgI b sc alts def -> doCaseAlg 'I' b sc alts def
300 CaseAlgP b sc alts def -> doCaseAlg 'P' b sc alts def
302 NonRecP bind body -> doNonRec 'P' bind body
303 NonRecI bind body -> doNonRec 'I' bind body
305 ConApp i -> doConApp "" i ([] :: [IExpr con var])
306 ConAppI i a1 -> doConApp "" i [a1]
307 ConAppP i a1 -> doConApp "" i [a1]
308 ConAppPP i a1 a2 -> doConApp "" i [a1,a2]
309 ConAppPPP i a1 a2 a3 -> doConApp "" i [a1,a2,a3]
311 other -> text "pprIExpr: unimplemented tag:"
312 <+> text (showExprTag other)
314 doConApp repstr itbl args
315 = text "Con" <> text repstr
316 <+> char '[' <> hsep (map pprIExpr args) <> char ']'
318 doPrimOp repchar op args
319 = char repchar <> ppr op <+> char '[' <> hsep (map pprIExpr args) <> char ']'
321 doNonRec repchr bind body
322 = vcat [text "let" <> char repchr <+> pprIBind bind, text "in", pprIExpr body]
324 doCasePrim repchr b sc alts def
325 = sep [text "CasePrim" <> char repchr
326 <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
327 nest 2 (vcat (map pprAltPrim alts) $$ pprDefault def),
331 doCaseAlg repchr b sc alts def
332 = sep [text "CaseAlg" <> char repchr
333 <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
334 nest 2 (vcat (map pprAltAlg alts) $$ pprDefault def),
339 = text "(@" <> text repstr <+> pprIExpr f <+> pprIExpr a <> char ')'
341 = (char '\\' <> text repstr <+> ppr v <+> text "->") $$ pprIExpr e