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.
51 -- index???OffClosure needs to traverse indirection nodes.
53 -- You can always tell the representation of an IExpr by examining
56 = CaseAlgP Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
57 | CaseAlgI Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
59 | CasePrimP Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
60 | CasePrimI Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
62 -- saturated constructor apps; args are in heap order.
63 -- The Addrs are the info table pointers. Descriptors refer to the
64 -- arg reps; all constructor applications return pointer rep.
66 | ConAppI con (IExpr con var)
67 | ConAppP con (IExpr con var)
68 | ConAppPP con (IExpr con var) (IExpr con var)
69 | ConAppPPP con (IExpr con var) (IExpr con var) (IExpr con var)
71 | PrimOpI PrimOp [(IExpr con var)]
72 | PrimOpP PrimOp [(IExpr con var)]
74 | NonRecP (IBind con var) (IExpr con var)
75 | RecP [IBind con var] (IExpr con var)
77 | NonRecI (IBind con var) (IExpr con var)
78 | RecI [IBind con var] (IExpr con var)
90 | Native var -- pointer to a Real Closure
97 -- LamXY indicates a function of reps X -> Y
98 -- ie var rep = X, result rep = Y
99 -- NOTE: repOf (LamXY _ _) = RepI regardless of X and Y
101 | LamPP Id (IExpr con var)
102 | LamPI Id (IExpr con var)
103 | LamPF Id (IExpr con var)
104 | LamPD Id (IExpr con var)
105 | LamIP Id (IExpr con var)
106 | LamII Id (IExpr con var)
107 | LamIF Id (IExpr con var)
108 | LamID Id (IExpr con var)
109 | LamFP Id (IExpr con var)
110 | LamFI Id (IExpr con var)
111 | LamFF Id (IExpr con var)
112 | LamFD Id (IExpr con var)
113 | LamDP Id (IExpr con var)
114 | LamDI Id (IExpr con var)
115 | LamDF Id (IExpr con var)
116 | LamDD Id (IExpr con var)
118 -- AppXY means apply a fn (always of Ptr rep) to
119 -- an arg of rep X giving result of Rep Y
120 -- therefore: repOf (AppXY _ _) = RepY
121 | AppPP (IExpr con var) (IExpr con var)
122 | AppPI (IExpr con var) (IExpr con var)
123 | AppPF (IExpr con var) (IExpr con var)
124 | AppPD (IExpr con var) (IExpr con var)
125 | AppIP (IExpr con var) (IExpr con var)
126 | AppII (IExpr con var) (IExpr con var)
127 | AppIF (IExpr con var) (IExpr con var)
128 | AppID (IExpr con var) (IExpr con var)
129 | AppFP (IExpr con var) (IExpr con var)
130 | AppFI (IExpr con var) (IExpr con var)
131 | AppFF (IExpr con var) (IExpr con var)
132 | AppFD (IExpr con var) (IExpr con var)
133 | AppDP (IExpr con var) (IExpr con var)
134 | AppDI (IExpr con var) (IExpr con var)
135 | AppDF (IExpr con var) (IExpr con var)
136 | AppDD (IExpr con var) (IExpr con var)
139 showExprTag :: IExpr c v -> String
142 CaseAlgP _ _ _ _ -> "CaseAlgP"
143 CasePrimP _ _ _ _ -> "CasePrimP"
144 CaseAlgI _ _ _ _ -> "CaseAlgI"
145 CasePrimI _ _ _ _ -> "CasePrimI"
147 ConAppI _ _ -> "ConAppI"
148 ConAppP _ _ -> "ConAppP"
149 ConAppPP _ _ _ -> "ConAppPP"
150 ConAppPPP _ _ _ _ -> "ConAppPPP"
151 PrimOpI _ _ -> "PrimOpI"
152 NonRecP _ _ -> "NonRecP"
154 NonRecI _ _ -> "NonRecI"
169 other -> "(showExprTag:unhandled case)"
171 -----------------------------------------------------------------------------
172 -- Instantiations of the IExpr type
174 type UnlinkedIExpr = IExpr RdrName RdrName
175 type LinkedIExpr = IExpr Addr HValue
177 type UnlinkedIBind = IBind RdrName RdrName
178 type LinkedIBind = IBind Addr HValue
180 type UnlinkedAltAlg = AltAlg RdrName RdrName
181 type LinkedAltAlg = AltAlg Addr HValue
183 type UnlinkedAltPrim = AltPrim RdrName RdrName
184 type LinkedAltPrim = AltPrim Addr HValue
186 -----------------------------------------------------------------------------
189 instance Outputable HValue where
190 ppr x = text (show (A# (unsafeCoerce# x :: Addr#)))
191 -- ptext SLIT("<O>") -- unidentified lurking object
193 pprIBind :: (Outputable var, Outputable con) => IBind con var -> SDoc
194 pprIBind (IBind v e) = ppr v <+> char '=' <+> pprIExpr e
196 pprAltAlg (AltAlg tag vars rhs)
197 = text "Tag_" <> int tag <+> hsep (map ppr vars)
198 <+> text "->" <+> pprIExpr rhs
200 pprAltPrim (AltPrim tag rhs)
201 = pprIExpr tag <+> text "->" <+> pprIExpr rhs
203 instance Outputable Rep where
207 instance Outputable Addr where
208 ppr addr = text (show addr)
210 pprDefault Nothing = text "NO_DEFAULT"
211 pprDefault (Just e) = text "DEFAULT ->" $$ nest 2 (pprIExpr e)
213 pprIExpr :: (Outputable var, Outputable con) => IExpr con var -> SDoc
214 pprIExpr (expr:: IExpr con var)
216 PrimOpI op args -> doPrimOp 'I' op args
217 PrimOpP op args -> doPrimOp 'P' op args
221 LitI i# -> int (I# i#) <> char '#'
222 LitS s -> char '"' <> ptext s <> char '"'
224 LamPP v e -> doLam "PP" v e
225 LamPI v e -> doLam "PI" v e
226 LamIP v e -> doLam "IP" v e
227 LamII v e -> doLam "II" v e
229 AppPP f a -> doApp "PP" f a
230 AppPI f a -> doApp "PI" f a
231 AppIP f a -> doApp "IP" f a
232 AppII f a -> doApp "II" f a
234 Native v -> ptext SLIT("Native") <+> ppr v
236 CasePrimI b sc alts def -> doCasePrim 'I' b sc alts def
237 CasePrimP b sc alts def -> doCasePrim 'P' b sc alts def
239 CaseAlgI b sc alts def -> doCaseAlg 'I' b sc alts def
240 CaseAlgP b sc alts def -> doCaseAlg 'P' b sc alts def
242 NonRecP bind body -> doNonRec 'P' bind body
243 NonRecI bind body -> doNonRec 'I' bind body
245 ConApp i -> doConApp "" i ([] :: [IExpr con var])
246 ConAppI i a1 -> doConApp "" i [a1]
247 ConAppP i a1 -> doConApp "" i [a1]
248 ConAppPP i a1 a2 -> doConApp "" i [a1,a2]
249 ConAppPPP i a1 a2 a3 -> doConApp "" i [a1,a2,a3]
251 other -> text "pprIExpr: unimplemented tag:"
252 <+> text (showExprTag other)
254 doConApp repstr itbl args
255 = text "Con" <> text repstr
256 <+> char '[' <> hsep (map pprIExpr args) <> char ']'
258 doPrimOp repchar op args
259 = char repchar <> ppr op <+> char '[' <> hsep (map pprIExpr args) <> char ']'
261 doNonRec repchr bind body
262 = vcat [text "let" <> char repchr <+> pprIBind bind, text "in", pprIExpr body]
264 doCasePrim repchr b sc alts def
265 = sep [text "CasePrim" <> char repchr
266 <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
267 nest 2 (vcat (map pprAltPrim alts) $$ pprDefault def),
271 doCaseAlg repchr b sc alts def
272 = sep [text "CaseAlg" <> char repchr
273 <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
274 nest 2 (vcat (map pprAltAlg alts) $$ pprDefault def),
279 = text "(@" <> text repstr <+> pprIExpr f <+> pprIExpr a <> char ')'
281 = (char '\\' <> text repstr <+> ppr v <+> text "->") $$ pprIExpr e