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
19 -----------------------------------------------------------------------------
20 -- The interpretable expression type
22 data HValue = HValue -- dummy type, actually a pointer to some Real Code.
24 data IBind con var = IBind Id (IExpr con var)
26 binder (IBind v e) = v
27 bindee (IBind v e) = e
29 data AltAlg con var = AltAlg Int{-tagNo-} [(Id,Rep)] (IExpr con var)
30 data AltPrim con var = AltPrim (Lit con var) (IExpr con var)
32 -- HACK ALERT! A Lit may *only* be one of LitI, LitL, LitF, LitD
33 type Lit con var = IExpr con var
40 -- we're assuming that Char# is sufficiently compatible with Int# that
41 -- we only need one rep for both.
52 -- index???OffClosure needs to traverse indirection nodes.
54 -- You can always tell the representation of an IExpr by examining
57 = CaseAlgP Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
58 | CaseAlgI Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
59 | CaseAlgF Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
60 | CaseAlgD Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
62 | CasePrimP Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
63 | CasePrimI Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
64 | CasePrimF Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
65 | CasePrimD Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
67 -- saturated constructor apps; args are in heap order.
68 -- The Addrs are the info table pointers. Descriptors refer to the
69 -- arg reps; all constructor applications return pointer rep.
71 | ConAppI con (IExpr con var)
72 | ConAppP con (IExpr con var)
73 | ConAppPP con (IExpr con var) (IExpr con var)
74 | ConAppPPP con (IExpr con var) (IExpr con var) (IExpr con var)
76 | PrimOpP PrimOp [(IExpr con var)]
77 | PrimOpI PrimOp [(IExpr con var)]
78 | PrimOpF PrimOp [(IExpr con var)]
79 | PrimOpD PrimOp [(IExpr con var)]
81 | NonRecP (IBind con var) (IExpr con var)
82 | NonRecI (IBind con var) (IExpr con var)
83 | NonRecF (IBind con var) (IExpr con var)
84 | NonRecD (IBind con var) (IExpr con var)
86 | RecP [IBind con var] (IExpr con var)
87 | RecI [IBind con var] (IExpr con var)
88 | RecF [IBind con var] (IExpr con var)
89 | RecD [IBind con var] (IExpr con var)
100 | Native var -- pointer to a Real Closure
107 -- LamXY indicates a function of reps X -> Y
108 -- ie var rep = X, result rep = Y
109 -- NOTE: repOf (LamXY _ _) = RepI regardless of X and Y
111 | LamPP Id (IExpr con var)
112 | LamPI Id (IExpr con var)
113 | LamPF Id (IExpr con var)
114 | LamPD Id (IExpr con var)
115 | LamIP Id (IExpr con var)
116 | LamII Id (IExpr con var)
117 | LamIF Id (IExpr con var)
118 | LamID Id (IExpr con var)
119 | LamFP Id (IExpr con var)
120 | LamFI Id (IExpr con var)
121 | LamFF Id (IExpr con var)
122 | LamFD Id (IExpr con var)
123 | LamDP Id (IExpr con var)
124 | LamDI Id (IExpr con var)
125 | LamDF Id (IExpr con var)
126 | LamDD Id (IExpr con var)
128 -- AppXY means apply a fn (always of Ptr rep) to
129 -- an arg of rep X giving result of Rep Y
130 -- therefore: repOf (AppXY _ _) = RepY
131 | AppPP (IExpr con var) (IExpr con var)
132 | AppPI (IExpr con var) (IExpr con var)
133 | AppPF (IExpr con var) (IExpr con var)
134 | AppPD (IExpr con var) (IExpr con var)
135 | AppIP (IExpr con var) (IExpr con var)
136 | AppII (IExpr con var) (IExpr con var)
137 | AppIF (IExpr con var) (IExpr con var)
138 | AppID (IExpr con var) (IExpr con var)
139 | AppFP (IExpr con var) (IExpr con var)
140 | AppFI (IExpr con var) (IExpr con var)
141 | AppFF (IExpr con var) (IExpr con var)
142 | AppFD (IExpr con var) (IExpr con var)
143 | AppDP (IExpr con var) (IExpr con var)
144 | AppDI (IExpr con var) (IExpr con var)
145 | AppDF (IExpr con var) (IExpr con var)
146 | AppDD (IExpr con var) (IExpr con var)
149 showExprTag :: IExpr c v -> String
153 CaseAlgP _ _ _ _ -> "CaseAlgP"
154 CaseAlgI _ _ _ _ -> "CaseAlgI"
155 CaseAlgF _ _ _ _ -> "CaseAlgF"
156 CaseAlgD _ _ _ _ -> "CaseAlgD"
158 CasePrimP _ _ _ _ -> "CasePrimP"
159 CasePrimI _ _ _ _ -> "CasePrimI"
160 CasePrimF _ _ _ _ -> "CasePrimF"
161 CasePrimD _ _ _ _ -> "CasePrimD"
164 ConAppI _ _ -> "ConAppI"
165 ConAppP _ _ -> "ConAppP"
166 ConAppPP _ _ _ -> "ConAppPP"
167 ConAppPPP _ _ _ _ -> "ConAppPPP"
169 PrimOpP _ _ -> "PrimOpP"
170 PrimOpI _ _ -> "PrimOpI"
171 PrimOpF _ _ -> "PrimOpF"
172 PrimOpD _ _ -> "PrimOpD"
174 NonRecP _ _ -> "NonRecP"
175 NonRecI _ _ -> "NonRecI"
176 NonRecF _ _ -> "NonRecF"
177 NonRecD _ _ -> "NonRecD"
229 other -> "(showExprTag:unhandled case)"
231 -----------------------------------------------------------------------------
232 -- Instantiations of the IExpr type
234 type UnlinkedIExpr = IExpr RdrName RdrName
235 type LinkedIExpr = IExpr Addr HValue
237 type UnlinkedIBind = IBind RdrName RdrName
238 type LinkedIBind = IBind Addr HValue
240 type UnlinkedAltAlg = AltAlg RdrName RdrName
241 type LinkedAltAlg = AltAlg Addr HValue
243 type UnlinkedAltPrim = AltPrim RdrName RdrName
244 type LinkedAltPrim = AltPrim Addr HValue
246 -----------------------------------------------------------------------------
249 instance Outputable HValue where
250 ppr x = text (show (A# (unsafeCoerce# x :: Addr#)))
251 -- ptext SLIT("<O>") -- unidentified lurking object
253 pprIBind :: (Outputable var, Outputable con) => IBind con var -> SDoc
254 pprIBind (IBind v e) = ppr v <+> char '=' <+> pprIExpr e
256 pprAltAlg (AltAlg tag vars rhs)
257 = text "Tag_" <> int tag <+> hsep (map ppr vars)
258 <+> text "->" <+> pprIExpr rhs
260 pprAltPrim (AltPrim tag rhs)
261 = pprIExpr tag <+> text "->" <+> pprIExpr rhs
263 instance Outputable Rep where
267 instance Outputable Addr where
268 ppr addr = text (show addr)
270 pprDefault Nothing = text "NO_DEFAULT"
271 pprDefault (Just e) = text "DEFAULT ->" $$ nest 2 (pprIExpr e)
273 pprIExpr :: (Outputable var, Outputable con) => IExpr con var -> SDoc
274 pprIExpr (expr:: IExpr con var)
276 PrimOpI op args -> doPrimOp 'I' op args
277 PrimOpP op args -> doPrimOp 'P' op args
281 LitI i# -> int (I# i#) <> char '#'
283 LamPP v e -> doLam "PP" v e
284 LamPI v e -> doLam "PI" v e
285 LamIP v e -> doLam "IP" v e
286 LamII v e -> doLam "II" v e
288 AppPP f a -> doApp "PP" f a
289 AppPI f a -> doApp "PI" f a
290 AppIP f a -> doApp "IP" f a
291 AppII f a -> doApp "II" f a
293 Native v -> ptext SLIT("Native") <+> ppr v
295 CasePrimI b sc alts def -> doCasePrim 'I' b sc alts def
296 CasePrimP b sc alts def -> doCasePrim 'P' b sc alts def
298 CaseAlgI b sc alts def -> doCaseAlg 'I' b sc alts def
299 CaseAlgP b sc alts def -> doCaseAlg 'P' b sc alts def
301 NonRecP bind body -> doNonRec 'P' bind body
302 NonRecI bind body -> doNonRec 'I' bind body
304 ConApp i -> doConApp "" i ([] :: [IExpr con var])
305 ConAppI i a1 -> doConApp "" i [a1]
306 ConAppP i a1 -> doConApp "" i [a1]
307 ConAppPP i a1 a2 -> doConApp "" i [a1,a2]
308 ConAppPPP i a1 a2 a3 -> doConApp "" i [a1,a2,a3]
310 other -> text "pprIExpr: unimplemented tag:"
311 <+> text (showExprTag other)
313 doConApp repstr itbl args
314 = text "Con" <> text repstr
315 <+> char '[' <> hsep (map pprIExpr args) <> char ']'
317 doPrimOp repchar op args
318 = char repchar <> ppr op <+> char '[' <> hsep (map pprIExpr args) <> char ']'
320 doNonRec repchr bind body
321 = vcat [text "let" <> char repchr <+> pprIBind bind, text "in", pprIExpr body]
323 doCasePrim repchr b sc alts def
324 = sep [text "CasePrim" <> char repchr
325 <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
326 nest 2 (vcat (map pprAltPrim alts) $$ pprDefault def),
330 doCaseAlg repchr b sc alts def
331 = sep [text "CaseAlg" <> char repchr
332 <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
333 nest 2 (vcat (map pprAltAlg alts) $$ pprDefault def),
338 = text "(@" <> text repstr <+> pprIExpr f <+> pprIExpr a <> char ')'
340 = (char '\\' <> text repstr <+> ppr v <+> text "->") $$ pprIExpr e