2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[ReadPragmas2]{Read pragmatic interface info, including Core}
7 #include "HsVersions.h"
19 IMPORT_Trace -- ToDo: rm (debugging)
24 import AbsPrel ( nilDataCon, readUnfoldingPrimOp, PrimOp(..)
25 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
26 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
28 import PrimKind ( guessPrimKind, PrimKind )
30 import BasicLit ( mkMachInt, BasicLit(..) )
31 import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
32 import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
33 import Id ( mkTupleCon )
34 import IdInfo -- ( UnfoldingGuidance(..) )
35 import Maybes ( Maybe(..) )
40 import ReadPrefix2 ( wlkList, rdConDecl, wlkMonoType )
45 wlkDataPragma :: U_hpragma -> UgnM ProtoNameDataPragmas
49 U_no_pragma -> returnUgn (DataPragmas [] [])
50 U_idata_pragma cs ss ->
51 wlkList rdConDecl cs `thenUgn` \ cons ->
52 wlkList rd_spec ss `thenUgn` \ specs ->
53 returnUgn (DataPragmas cons specs)
56 = rdU_hpragma pt `thenUgn` \ stuff ->
57 case stuff of { U_idata_pragma_4s ss ->
59 wlkList rdMonoTypeMaybe ss `thenUgn` \ specs ->
64 wlkTypePragma :: U_hpragma -> UgnM TypePragmas
68 U_no_pragma -> returnUgn NoTypePragmas
69 U_itype_pragma -> returnUgn AbstractTySynonym
73 wlkClassPragma :: U_hpragma -> UgnM ProtoNameClassPragmas
77 U_no_pragma -> returnUgn NoClassPragmas
78 U_iclas_pragma gens ->
79 wlkList rdGenPragma gens `thenUgn` \ gen_pragmas ->
80 ASSERT(not (null gen_pragmas))
81 returnUgn (SuperDictPragmas gen_pragmas)
85 wlkInstPragma :: U_hpragma -> UgnM (Maybe FAST_STRING, ProtoNameInstancePragmas)
89 U_no_pragma -> returnUgn (Nothing, NoInstancePragmas)
91 U_iinst_simpl_pragma modname dfun_gen ->
92 wlkGenPragma dfun_gen `thenUgn` \ gen_pragmas ->
93 returnUgn (Just modname, SimpleInstancePragma gen_pragmas)
95 U_iinst_const_pragma modname dfun_gen constm_stuff ->
96 wlkGenPragma dfun_gen `thenUgn` \ gen_pragma ->
97 wlkList rd_constm constm_stuff `thenUgn` \ constm_pragmas ->
98 returnUgn (Just modname, ConstantInstancePragma gen_pragma constm_pragmas)
101 = rdU_hpragma pt `thenUgn` \ stuff ->
102 case stuff of { U_iname_pragma_pr name gen ->
104 wlkGenPragma gen `thenUgn` \ prag ->
105 returnUgn (name, prag) }
109 rdGenPragma :: ParseTree -> UgnM ProtoNameGenPragmas
111 rdGenPragma pt = rdU_hpragma pt `thenUgn` \ prag -> wlkGenPragma prag
113 wlkGenPragma :: U_hpragma -> UgnM ProtoNameGenPragmas
117 U_no_pragma -> returnUgn NoGenPragmas
119 U_igen_pragma aritee update deforest strct uf speccs ->
120 wlk_arity aritee `thenUgn` \ arity ->
121 wlk_update update `thenUgn` \ upd ->
122 wlk_deforest deforest `thenUgn` \ def ->
123 wlk_strict strct `thenUgn` \ strict ->
124 wlk_unfold uf `thenUgn` \ unfold ->
125 wlkList rd_spec speccs `thenUgn` \ specs ->
126 returnUgn (GenPragmas arity upd def strict unfold specs)
130 U_no_pragma -> returnUgn Nothing
131 U_iarity_pragma arity ->
132 returnUgn (Just arity)
137 U_no_pragma -> returnUgn Nothing
138 U_iupdate_pragma upd_spec ->
139 returnUgn (Just ((read (_UNPK_ upd_spec))::UpdateInfo))
144 U_no_pragma -> returnUgn Don'tDeforest
145 U_ideforest_pragma -> returnUgn DoDeforest
150 U_no_pragma -> returnUgn NoImpUnfolding
152 U_imagic_unfolding_pragma magic ->
153 returnUgn (ImpMagicUnfolding magic)
155 U_iunfolding_pragma guide core ->
156 wlkGuidance guide `thenUgn` \ guidance ->
157 wlkCoreExpr core `thenUgn` \ coresyn ->
158 returnUgn (ImpUnfolding guidance coresyn)
163 U_no_pragma -> returnUgn NoImpStrictness
165 U_istrictness_pragma strict_spec wrkr_stuff ->
166 wlkGenPragma wrkr_stuff `thenUgn` \ wrkr_pragma ->
168 strict_spec_str = _UNPK_ strict_spec
169 (is_bot, ww_strict_info)
170 = if (strict_spec_str == "B")
172 else (False, (read strict_spec_str)::[Demand])
174 returnUgn (ImpStrictness is_bot ww_strict_info wrkr_pragma)
178 = rdU_hpragma pt `thenUgn` \ stuff ->
179 case stuff of { U_itype_pragma_pr maybe_tys num_dicts prag ->
181 wlkList rdMonoTypeMaybe maybe_tys `thenUgn` \ mono_tys_maybe ->
182 wlkGenPragma prag `thenUgn` \ gen_prag ->
183 returnUgn (mono_tys_maybe, num_dicts, gen_prag) }
186 The only tricky case is pragmas on signatures; we have no way of
187 knowing whether it is a @GenPragma@ or a @ClassOp@ pragma. So we read
188 whatever comes, store it in a @RdrTySigPragmas@ structure, and someone
189 will sort it out later.
191 wlkTySigPragmas :: U_hpragma -> UgnM RdrTySigPragmas
193 wlkTySigPragmas pragma
195 U_no_pragma -> returnUgn RdrNoPragma
197 U_iclasop_pragma dsel defm ->
198 wlkGenPragma dsel `thenUgn` \ dsel_pragma ->
199 wlkGenPragma defm `thenUgn` \ defm_pragma ->
200 returnUgn (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma))
203 wlkGenPragma other `thenUgn` \ gen_pragmas ->
204 returnUgn (RdrGenPragmas gen_pragmas)
210 U_iunfold_always -> returnUgn UnfoldAlways
212 U_iunfold_if_args num_ty_args num_val_args con_arg_spec size ->
214 con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec))
215 -- if there were 0 args, we want to throw away
216 -- any dummy con_arg_spec stuff...
218 returnUgn (UnfoldIfGoodArgs num_ty_args num_val_args
221 cvt 'C' = True -- want a constructor in this arg position
226 wlkCoreExpr :: U_coresyn -> UgnM ProtoNameUnfoldingCoreExpr
228 wlkCoreExpr core_expr
231 wlkCoreId v `thenUgn` \ var ->
232 returnUgn (UfCoVar var)
235 wlkBasicLit l `thenUgn` \ lit ->
236 returnUgn (UfCoLit lit)
239 wlkCoreId c `thenUgn` \ (BoringUfId con) ->
240 wlkList rdCoreType ts `thenUgn` \ tys ->
241 wlkList rdCoreAtom as `thenUgn` \ vs ->
242 returnUgn (UfCoCon con tys vs)
245 wlk_primop o `thenUgn` \ op ->
246 wlkList rdCoreType ts `thenUgn` \ tys ->
247 wlkList rdCoreAtom as `thenUgn` \ vs ->
249 fixed_vs = case op of { UfOtherOp pop -> fixup pop vs ; _ -> vs }
251 returnUgn (UfCoPrim op tys fixed_vs)
254 -- Question: why did ccall once panic if you looked at the
255 -- maygc flag? Was this just laziness or is it not needed?
256 -- In that case, modify the stuff that writes them to pragmas
257 -- so that it never adds the _GC_ tag. ADR
261 U_co_primop op_str ->
262 returnUgn (UfOtherOp (readUnfoldingPrimOp op_str))
264 U_co_ccall fun_str may_gc a_tys r_ty ->
265 wlkList rdCoreType a_tys `thenUgn` \ arg_tys ->
266 wlkCoreType r_ty `thenUgn` \ res_ty ->
267 returnUgn (UfCCallOp fun_str False (is_T_or_F may_gc) arg_tys res_ty)
269 U_co_casm litlit may_gc a_tys r_ty ->
270 wlkBasicLit litlit `thenUgn` \ (MachLitLit casm_str _) ->
271 wlkList rdCoreType a_tys `thenUgn` \ arg_tys ->
272 wlkCoreType r_ty `thenUgn` \ res_ty ->
273 returnUgn (UfCCallOp casm_str True (is_T_or_F may_gc) arg_tys res_ty)
278 -- Now *this* is a hack: we can't distinguish Int# literals
279 -- from Word# literals as they come in; this is only likely
280 -- to bite on the args of certain PrimOps (shifts, etc); so
281 -- we look for those and fix things up!!! (WDP 95/05)
283 fixup AndOp [a1, a2] = [fixarg a1, fixarg a2]
284 fixup OrOp [a1, a2] = [fixarg a1, fixarg a2]
285 fixup NotOp [a1] = [fixarg a1]
286 fixup SllOp [a1, a2] = [fixarg a1, a2]
287 fixup SraOp [a1, a2] = [fixarg a1, a2]
288 fixup SrlOp [a1, a2] = [fixarg a1, a2]
289 fixup WordGtOp [a1, a2] = [fixarg a1, fixarg a2]
290 fixup WordGeOp [a1, a2] = [fixarg a1, fixarg a2]
291 fixup WordLtOp [a1, a2] = [fixarg a1, fixarg a2]
292 fixup WordLeOp [a1, a2] = [fixarg a1, fixarg a2]
293 fixup WordEqOp [a1, a2] = [fixarg a1, fixarg a2]
294 fixup WordNeOp [a1, a2] = [fixarg a1, fixarg a2]
297 fixarg (UfCoLitAtom (MachInt i _)) = UfCoLitAtom (MachInt i False{-unsigned-})
301 wlkList rdCoreBinder vars `thenUgn` \ bs ->
302 wlkCoreExpr expr `thenUgn` \ body ->
303 returnUgn (UfCoLam bs body)
305 U_cotylam vars expr ->
306 wlkList rdU_unkId vars `thenUgn` \ tvs ->
307 wlkCoreExpr expr `thenUgn` \ body ->
308 returnUgn (foldr UfCoTyLam body tvs)
311 wlkCoreExpr f `thenUgn` \ fun ->
312 wlkList rdCoreAtom as `thenUgn` \ args ->
313 returnUgn (foldl UfCoApp fun args)
316 wlkCoreExpr e `thenUgn` \ expr ->
317 wlkCoreType t `thenUgn` \ ty ->
318 returnUgn (UfCoTyApp expr ty)
321 wlkCoreExpr s `thenUgn` \ scrut ->
322 wlk_alts as `thenUgn` \ alts ->
323 returnUgn (UfCoCase scrut alts)
325 wlk_alts (U_coalg_alts as d)
326 = wlkList rd_alg_alt as `thenUgn` \ alts ->
327 wlk_deflt d `thenUgn` \ deflt ->
328 returnUgn (UfCoAlgAlts alts deflt)
331 = rdU_coresyn pt `thenUgn` \ (U_coalg_alt c bs exp) ->
333 wlkCoreId c `thenUgn` \ (BoringUfId con) ->
334 wlkList rdCoreBinder bs `thenUgn` \ params ->
335 wlkCoreExpr exp `thenUgn` \ rhs ->
336 returnUgn (con, params, rhs)
338 wlk_alts (U_coprim_alts as d)
339 = wlkList rd_prim_alt as `thenUgn` \ alts ->
340 wlk_deflt d `thenUgn` \ deflt ->
341 returnUgn (UfCoPrimAlts alts deflt)
344 = rdU_coresyn pt `thenUgn` \ (U_coprim_alt l exp) ->
346 wlkBasicLit l `thenUgn` \ lit ->
347 wlkCoreExpr exp `thenUgn` \ rhs ->
350 wlk_deflt U_conodeflt = returnUgn UfCoNoDefault
351 wlk_deflt (U_cobinddeflt v exp)
352 = wlkCoreBinder v `thenUgn` \ b ->
353 wlkCoreExpr exp `thenUgn` \ rhs ->
354 returnUgn (UfCoBindDefault b rhs)
357 wlk_bind b `thenUgn` \ bind ->
358 wlkCoreExpr expr `thenUgn` \ body ->
359 returnUgn (UfCoLet bind body)
361 wlk_bind (U_cononrec v expr)
362 = wlkCoreBinder v `thenUgn` \ b ->
363 wlkCoreExpr expr `thenUgn` \ rhs ->
364 returnUgn (UfCoNonRec b rhs)
366 wlk_bind (U_corec prs)
367 = wlkList rd_pair prs `thenUgn` \ pairs ->
368 returnUgn (UfCoRec pairs)
371 = rdU_coresyn pt `thenUgn` \ (U_corec_pair v expr) ->
373 wlkCoreBinder v `thenUgn` \ b ->
374 wlkCoreExpr expr `thenUgn` \ rhs ->
378 wlk_cc c `thenUgn` \ cc ->
379 wlkCoreExpr expr `thenUgn` \ body ->
380 returnUgn (UfCoSCC cc body)
382 wlk_cc (U_co_preludedictscc dupd)
383 = wlk_dupd dupd `thenUgn` \ is_dupd ->
384 returnUgn (UfPreludeDictsCC is_dupd)
386 wlk_cc (U_co_alldictscc m g dupd)
387 = wlk_dupd dupd `thenUgn` \ is_dupd ->
388 returnUgn (UfAllDictsCC m g is_dupd)
390 wlk_cc (U_co_usercc n m g dupd cafd)
391 = wlk_dupd dupd `thenUgn` \ is_dupd ->
392 wlk_cafd cafd `thenUgn` \ is_cafd ->
393 returnUgn (UfUserCC n m g is_dupd is_cafd)
395 wlk_cc (U_co_autocc id m g dupd cafd)
396 = wlkCoreId id `thenUgn` \ i ->
397 wlk_dupd dupd `thenUgn` \ is_dupd ->
398 wlk_cafd cafd `thenUgn` \ is_cafd ->
399 returnUgn (UfAutoCC i m g is_dupd is_cafd)
401 wlk_cc (U_co_dictcc id m g dupd cafd)
402 = wlkCoreId id `thenUgn` \ i ->
403 wlk_dupd dupd `thenUgn` \ is_dupd ->
404 wlk_cafd cafd `thenUgn` \ is_cafd ->
405 returnUgn (UfDictCC i m g is_dupd is_cafd)
408 wlk_cafd U_co_scc_noncaf = returnUgn False
409 wlk_cafd U_co_scc_caf = returnUgn True
411 wlk_dupd U_co_scc_nondupd = returnUgn False
412 wlk_dupd U_co_scc_dupd = returnUgn True
416 type ProtoUfBinder = (ProtoName, PolyType ProtoName)
418 rdCoreBinder :: ParseTree -> UgnM ProtoUfBinder
420 rdCoreBinder pt = rdU_coresyn pt `thenUgn` \ x -> wlkCoreBinder x
422 wlkCoreBinder :: U_coresyn -> UgnM ProtoUfBinder
424 wlkCoreBinder (U_cobinder b t)
425 = wlkCoreType t `thenUgn` \ ty ->
429 = rdU_coresyn pt `thenUgn` \ atom ->
432 wlkBasicLit l `thenUgn` \ lit ->
433 returnUgn (UfCoLitAtom lit)
436 wlkCoreId var `thenUgn` \ v ->
437 returnUgn (UfCoVarAtom v)
441 rdCoreType :: ParseTree -> UgnM ProtoNamePolyType
443 rdCoreType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkCoreType ttype
445 wlkCoreType :: U_ttype -> UgnM ProtoNamePolyType
447 wlkCoreType (U_uniforall ts t)
448 = wlkList rdU_unkId ts `thenUgn` \ tvs ->
449 wlkMonoType t `thenUgn` \ ty ->
450 returnUgn (ForAllTy tvs ty)
453 = wlkMonoType other `thenUgn` \ ty ->
454 returnUgn (UnoverloadedTy ty)
459 wlkCoreTypeMaybe :: ParseTree -> RETN_TYPE(Maybe ProtoNamePolyType, FAST_STRING)
461 wlkCoreTypeMaybe ('2' : 'D' : xs) = RETN(Nothing, xs)
462 wlkCoreTypeMaybe ('2' : 'E' : xs)
463 = wlkCoreType xs) `thenUgn` \ (ty, xs1) ->
469 = rdU_ttype pt `thenUgn` \ ty ->
471 U_ty_maybe_nothing -> returnUgn Nothing
474 wlkMonoType t `thenUgn` \ mono_ty ->
475 returnUgn (Just mono_ty)
479 wlkCoreId :: U_coresyn -> UgnM (UfId ProtoName)
481 wlkCoreId (U_co_id v)
482 = returnUgn (BoringUfId (cvt_IdString v))
484 wlkCoreId (U_co_orig_id mod nm)
485 = returnUgn (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm))
487 wlkCoreId (U_co_sdselid clas super_clas)
488 = returnUgn (SuperDictSelUfId clas super_clas)
490 wlkCoreId (U_co_classopid clas method)
491 = returnUgn (ClassOpUfId clas method)
493 wlkCoreId (U_co_defmid clas method)
494 = returnUgn (DefaultMethodUfId clas method)
496 wlkCoreId (U_co_dfunid clas t)
497 = wlkCoreType t `thenUgn` \ ty ->
498 returnUgn (DictFunUfId clas ty)
500 wlkCoreId (U_co_constmid clas op t)
501 = wlkCoreType t `thenUgn` \ ty ->
502 returnUgn (ConstMethodUfId clas op ty)
504 wlkCoreId (U_co_specid id tys)
505 = wlkCoreId id `thenUgn` \ unspec ->
506 wlkList rdMonoTypeMaybe tys `thenUgn` \ ty_maybes ->
507 returnUgn (SpecUfId unspec ty_maybes)
509 wlkCoreId (U_co_wrkrid un)
510 = wlkCoreId un `thenUgn` \ unwrkr ->
511 returnUgn (WorkerUfId unwrkr)
514 cvt_IdString :: FAST_STRING -> ProtoName
517 = if (_HEAD_ s /= '_') then
518 -- trace (show s++(show (_HEAD_ s /= '_'))++(_HEAD_ s):'_':"/*0*/\n") (
521 else if (sub_s == SLIT("NIL_")) then
522 -- trace (show s++"/*1*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
523 Prel (WiredInVal nilDataCon)
525 else if (sub_s == SLIT("TUP_")) then
526 -- trace (show s++"/*2*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
527 Prel (WiredInVal (mkTupleCon arity))
530 -- trace (show s++"/*3*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
535 sub_s = _SUBSTR_ s 1 4 -- chars 1--4 (0-origin)
536 arity = read (_UNPK_ (_SUBSTR_ s 5 999999))
537 -- chars 5 onwards give the arity
541 wlkBasicLit :: U_literal -> UgnM BasicLit
543 wlkBasicLit (U_norepr n d)
545 num = ((read (_UNPK_ n)) :: Integer)
546 den = ((read (_UNPK_ d)) :: Integer)
548 returnUgn (NoRepRational (num % den))
553 U_intprim s -> mkMachInt (as_integer s)
554 U_doubleprim s -> MachDouble (as_rational s)
555 U_floatprim s -> MachFloat (as_rational s)
556 U_charprim s -> MachChar (as_char s)
557 U_stringprim s -> MachStr (as_string s)
559 U_clitlit s k -> MachLitLit (as_string s) (guessPrimKind (_UNPK_ k))
561 U_norepi s -> NoRepInteger (as_integer s)
562 U_noreps s -> NoRepStr (as_string s)
566 as_integer s = readInteger (_UNPK_ s)
567 as_rational s = _readRational (_UNPK_ s) -- non-std