2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section{Read pragmatic interface info, including Core}
7 #include "HsVersions.h"
20 import RdrLoop -- break dependency loop
22 import UgenAll -- all Yacc parser gumpff...
23 import PrefixSyn -- and various syntaxen.
26 import HsPragmas -- NB: we are concerned with grimy
27 import HsCore -- *Pragmas and *Core stuff here
30 import CoreUnfold ( UnfoldingGuidance(..) )
31 import Id ( mkTupleCon )
33 import IdUtils ( primOpNameInfo )
34 import Literal ( mkMachInt, Literal(..) )
35 import Name ( Name(..) )
36 import PrelInfo ( nilDataCon )
37 import PrimOp ( PrimOp(..), allThePrimOps )
38 import PrimRep ( guessPrimRep ) -- really, VERY horrible...
39 import ProtoName ( ProtoName(..) )
40 import Util ( assertPanic, panic )
45 readUnfoldingPrimOp :: FAST_STRING -> PrimOp
49 -- "reverse" lookup table
50 tbl = map (\ o -> let { (str,_) = primOpNameInfo o } in (str, o)) allThePrimOps
52 \ str -> case [ op | (s, op) <- tbl, s == str ] of
55 [] -> panic "readUnfoldingPrimOp" -- ++ _UNPK_ str ++"::"++show (map fst tbl))
60 wlkDataPragma :: U_hpragma -> UgnM ProtoNameDataPragmas
64 U_no_pragma -> returnUgn (DataPragmas [] [])
65 U_idata_pragma cs ss ->
66 wlkList rdConDecl cs `thenUgn` \ cons ->
67 wlkList rd_spec ss `thenUgn` \ specs ->
68 returnUgn (DataPragmas cons specs)
71 = rdU_hpragma pt `thenUgn` \ stuff ->
72 case stuff of { U_idata_pragma_4s ss ->
74 wlkList rdMonoTypeMaybe ss `thenUgn` \ specs ->
79 wlkClassPragma :: U_hpragma -> UgnM ProtoNameClassPragmas
83 U_no_pragma -> returnUgn NoClassPragmas
84 U_iclas_pragma gens ->
85 wlkList rdGenPragma gens `thenUgn` \ gen_pragmas ->
86 ASSERT(not (null gen_pragmas))
87 returnUgn (SuperDictPragmas gen_pragmas)
91 wlkInstPragma :: U_hpragma -> UgnM ProtoNameInstancePragmas
96 returnUgn NoInstancePragmas
98 U_iinst_simpl_pragma dfun_gen ->
99 wlkGenPragma dfun_gen `thenUgn` \ gen_pragmas ->
100 returnUgn (SimpleInstancePragma gen_pragmas)
102 U_iinst_const_pragma dfun_gen constm_stuff ->
103 wlkGenPragma dfun_gen `thenUgn` \ gen_pragma ->
104 wlkList rd_constm constm_stuff `thenUgn` \ constm_pragmas ->
105 returnUgn (ConstantInstancePragma gen_pragma constm_pragmas)
108 = rdU_hpragma pt `thenUgn` \ stuff ->
109 case stuff of { U_iname_pragma_pr name gen ->
111 wlkGenPragma gen `thenUgn` \ prag ->
112 returnUgn (name, prag) }
116 rdGenPragma :: ParseTree -> UgnM ProtoNameGenPragmas
118 rdGenPragma pt = rdU_hpragma pt `thenUgn` \ prag -> wlkGenPragma prag
120 wlkGenPragma :: U_hpragma -> UgnM ProtoNameGenPragmas
124 U_no_pragma -> returnUgn noGenPragmas
126 U_igen_pragma aritee update deforest strct uf speccs ->
127 wlk_arity aritee `thenUgn` \ arity ->
128 wlk_update update `thenUgn` \ upd ->
129 wlk_deforest deforest `thenUgn` \ def ->
130 wlk_strict strct `thenUgn` \ strict ->
131 wlk_unfold uf `thenUgn` \ unfold ->
132 wlkList rd_spec speccs `thenUgn` \ specs ->
133 returnUgn (GenPragmas arity upd def strict unfold specs)
137 U_no_pragma -> returnUgn Nothing
138 U_iarity_pragma arity ->
139 returnUgn (Just arity)
144 U_no_pragma -> returnUgn Nothing
145 U_iupdate_pragma upd_spec ->
146 returnUgn (Just ((read (_UNPK_ upd_spec))::UpdateInfo))
151 U_no_pragma -> returnUgn Don'tDeforest
152 U_ideforest_pragma -> returnUgn DoDeforest
157 U_no_pragma -> returnUgn NoImpUnfolding
159 U_imagic_unfolding_pragma magic ->
160 returnUgn (ImpMagicUnfolding magic)
162 U_iunfolding_pragma guide core ->
163 wlkGuidance guide `thenUgn` \ guidance ->
164 wlkCoreExpr core `thenUgn` \ coresyn ->
165 returnUgn (ImpUnfolding guidance coresyn)
170 U_no_pragma -> returnUgn NoImpStrictness
172 U_istrictness_pragma strict_spec wrkr_stuff ->
173 wlkGenPragma wrkr_stuff `thenUgn` \ wrkr_pragma ->
175 strict_spec_str = _UNPK_ strict_spec
176 (is_bot, ww_strict_info)
177 = if (strict_spec_str == "B")
179 else (False, (read strict_spec_str)::[Demand])
181 returnUgn (ImpStrictness is_bot ww_strict_info wrkr_pragma)
185 = rdU_hpragma pt `thenUgn` \ stuff ->
186 case stuff of { U_itype_pragma_pr maybe_tys num_dicts prag ->
188 wlkList rdMonoTypeMaybe maybe_tys `thenUgn` \ mono_tys_maybe ->
189 wlkGenPragma prag `thenUgn` \ gen_prag ->
190 returnUgn (mono_tys_maybe, num_dicts, gen_prag) }
193 The only tricky case is pragmas on signatures; we have no way of
194 knowing whether it is a @GenPragma@ or a @ClassOp@ pragma. So we read
195 whatever comes, store it in a @RdrTySigPragmas@ structure, and someone
196 will sort it out later.
198 wlkTySigPragmas :: U_hpragma -> UgnM RdrTySigPragmas
200 wlkTySigPragmas pragma
202 U_no_pragma -> returnUgn RdrNoPragma
204 U_iclasop_pragma dsel defm ->
205 wlkGenPragma dsel `thenUgn` \ dsel_pragma ->
206 wlkGenPragma defm `thenUgn` \ defm_pragma ->
207 returnUgn (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma))
210 wlkGenPragma other `thenUgn` \ gen_pragmas ->
211 returnUgn (RdrGenPragmas gen_pragmas)
217 U_iunfold_always -> returnUgn UnfoldAlways
219 U_iunfold_if_args num_ty_args num_val_args con_arg_spec size ->
221 con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec))
222 -- if there were 0 args, we want to throw away
223 -- any dummy con_arg_spec stuff...
225 returnUgn (UnfoldIfGoodArgs num_ty_args num_val_args
228 cvt 'C' = True -- want a constructor in this arg position
233 wlkCoreExpr :: U_coresyn -> UgnM ProtoNameUnfoldingCoreExpr
235 wlkCoreExpr core_expr
238 wlkCoreId v `thenUgn` \ var ->
239 returnUgn (UfVar var)
242 wlkBasicLit l `thenUgn` \ lit ->
243 returnUgn (UfLit lit)
246 wlkCoreId c `thenUgn` \ (BoringUfId con) ->
247 wlkList rdCoreType ts `thenUgn` \ tys ->
248 wlkList rdCoreAtom as `thenUgn` \ vs ->
249 returnUgn (UfCon con tys vs)
252 wlk_primop o `thenUgn` \ op ->
253 wlkList rdCoreType ts `thenUgn` \ tys ->
254 wlkList rdCoreAtom as `thenUgn` \ vs ->
256 fixed_vs = case op of { UfOtherOp pop -> fixup pop vs ; _ -> vs }
258 returnUgn (UfPrim op tys fixed_vs)
261 -- Question: why did ccall once panic if you looked at the
262 -- maygc flag? Was this just laziness or is it not needed?
263 -- In that case, modify the stuff that writes them to pragmas
264 -- so that it never adds the _GC_ tag. ADR
268 U_co_primop op_str ->
269 returnUgn (UfOtherOp (readUnfoldingPrimOp op_str))
271 U_co_ccall fun_str may_gc a_tys r_ty ->
272 wlkList rdCoreType a_tys `thenUgn` \ arg_tys ->
273 wlkCoreType r_ty `thenUgn` \ res_ty ->
274 returnUgn (UfCCallOp fun_str False (is_T_or_F may_gc) arg_tys res_ty)
276 U_co_casm litlit may_gc a_tys r_ty ->
277 wlkBasicLit litlit `thenUgn` \ (MachLitLit casm_str _) ->
278 wlkList rdCoreType a_tys `thenUgn` \ arg_tys ->
279 wlkCoreType r_ty `thenUgn` \ res_ty ->
280 returnUgn (UfCCallOp casm_str True (is_T_or_F may_gc) arg_tys res_ty)
285 -- Now *this* is a hack: we can't distinguish Int# literals
286 -- from Word# literals as they come in; this is only likely
287 -- to bite on the args of certain PrimOps (shifts, etc); so
288 -- we look for those and fix things up!!! (WDP 95/05)
290 fixup AndOp [a1, a2] = [fixarg a1, fixarg a2]
291 fixup OrOp [a1, a2] = [fixarg a1, fixarg a2]
292 fixup NotOp [a1] = [fixarg a1]
293 fixup SllOp [a1, a2] = [fixarg a1, a2]
294 fixup SraOp [a1, a2] = [fixarg a1, a2]
295 fixup SrlOp [a1, a2] = [fixarg a1, a2]
296 fixup WordGtOp [a1, a2] = [fixarg a1, fixarg a2]
297 fixup WordGeOp [a1, a2] = [fixarg a1, fixarg a2]
298 fixup WordLtOp [a1, a2] = [fixarg a1, fixarg a2]
299 fixup WordLeOp [a1, a2] = [fixarg a1, fixarg a2]
300 fixup WordEqOp [a1, a2] = [fixarg a1, fixarg a2]
301 fixup WordNeOp [a1, a2] = [fixarg a1, fixarg a2]
304 fixarg (UfCoLitAtom (MachInt i _)) = UfCoLitAtom (MachInt i False{-unsigned-})
308 wlkList rdCoreBinder vars `thenUgn` \ bs ->
309 wlkCoreExpr expr `thenUgn` \ body ->
310 returnUgn (foldr UfLam body bs)
313 wlkCoreExpr f `thenUgn` \ fun ->
314 wlkList rdCoreAtom as `thenUgn` \ args ->
315 returnUgn (foldl UfApp fun args)
318 wlkCoreExpr s `thenUgn` \ scrut ->
319 wlk_alts as `thenUgn` \ alts ->
320 returnUgn (UfCase scrut alts)
322 wlk_alts (U_coalg_alts as d)
323 = wlkList rd_alg_alt as `thenUgn` \ alts ->
324 wlk_deflt d `thenUgn` \ deflt ->
325 returnUgn (UfCoAlgAlts alts deflt)
328 = rdU_coresyn pt `thenUgn` \ (U_coalg_alt c bs exp) ->
330 wlkCoreId c `thenUgn` \ (BoringUfId con) ->
331 wlkList rdCoreBinder bs `thenUgn` \ params ->
332 wlkCoreExpr exp `thenUgn` \ rhs ->
333 returnUgn (con, params, rhs)
335 wlk_alts (U_coprim_alts as d)
336 = wlkList rd_prim_alt as `thenUgn` \ alts ->
337 wlk_deflt d `thenUgn` \ deflt ->
338 returnUgn (UfCoPrimAlts alts deflt)
341 = rdU_coresyn pt `thenUgn` \ (U_coprim_alt l exp) ->
343 wlkBasicLit l `thenUgn` \ lit ->
344 wlkCoreExpr exp `thenUgn` \ rhs ->
347 wlk_deflt U_conodeflt = returnUgn UfCoNoDefault
348 wlk_deflt (U_cobinddeflt v exp)
349 = wlkCoreBinder v `thenUgn` \ b ->
350 wlkCoreExpr exp `thenUgn` \ rhs ->
351 returnUgn (UfCoBindDefault b rhs)
354 wlk_bind b `thenUgn` \ bind ->
355 wlkCoreExpr expr `thenUgn` \ body ->
356 returnUgn (UfLet bind body)
358 wlk_bind (U_cononrec v expr)
359 = wlkCoreBinder v `thenUgn` \ b ->
360 wlkCoreExpr expr `thenUgn` \ rhs ->
361 returnUgn (UfCoNonRec b rhs)
363 wlk_bind (U_corec prs)
364 = wlkList rd_pair prs `thenUgn` \ pairs ->
365 returnUgn (UfCoRec pairs)
368 = rdU_coresyn pt `thenUgn` \ (U_corec_pair v expr) ->
370 wlkCoreBinder v `thenUgn` \ b ->
371 wlkCoreExpr expr `thenUgn` \ rhs ->
375 wlk_cc c `thenUgn` \ cc ->
376 wlkCoreExpr expr `thenUgn` \ body ->
377 returnUgn (UfSCC cc body)
379 wlk_cc (U_co_preludedictscc dupd)
380 = wlk_dupd dupd `thenUgn` \ is_dupd ->
381 returnUgn (UfPreludeDictsCC is_dupd)
383 wlk_cc (U_co_alldictscc m g dupd)
384 = wlk_dupd dupd `thenUgn` \ is_dupd ->
385 returnUgn (UfAllDictsCC m g is_dupd)
387 wlk_cc (U_co_usercc n m g dupd cafd)
388 = wlk_dupd dupd `thenUgn` \ is_dupd ->
389 wlk_cafd cafd `thenUgn` \ is_cafd ->
390 returnUgn (UfUserCC n m g is_dupd is_cafd)
392 wlk_cc (U_co_autocc id m g dupd cafd)
393 = wlkCoreId id `thenUgn` \ i ->
394 wlk_dupd dupd `thenUgn` \ is_dupd ->
395 wlk_cafd cafd `thenUgn` \ is_cafd ->
396 returnUgn (UfAutoCC i m g is_dupd is_cafd)
398 wlk_cc (U_co_dictcc id m g dupd cafd)
399 = wlkCoreId id `thenUgn` \ i ->
400 wlk_dupd dupd `thenUgn` \ is_dupd ->
401 wlk_cafd cafd `thenUgn` \ is_cafd ->
402 returnUgn (UfDictCC i m g is_dupd is_cafd)
405 wlk_cafd U_co_scc_noncaf = returnUgn False
406 wlk_cafd U_co_scc_caf = returnUgn True
408 wlk_dupd U_co_scc_nondupd = returnUgn False
409 wlk_dupd U_co_scc_dupd = returnUgn True
413 type ProtoUfBinder = (ProtoName, PolyType ProtoName)
415 rdCoreBinder :: ParseTree -> UgnM ProtoUfBinder
417 rdCoreBinder pt = rdU_coresyn pt `thenUgn` \ x -> wlkCoreBinder x
419 wlkCoreBinder :: U_coresyn -> UgnM ProtoUfBinder
421 wlkCoreBinder (U_cobinder b t)
422 = wlkCoreType t `thenUgn` \ ty ->
426 = rdU_coresyn pt `thenUgn` \ atom ->
429 wlkBasicLit l `thenUgn` \ lit ->
430 returnUgn (UfCoLitAtom lit)
433 wlkCoreId var `thenUgn` \ v ->
434 returnUgn (UfCoVarAtom v)
438 rdCoreType :: ParseTree -> UgnM ProtoNamePolyType
440 rdCoreType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkCoreType ttype
442 wlkCoreType :: U_ttype -> UgnM ProtoNamePolyType
445 = panic "ReadPragmas:wlkCoreType:ToDo"
447 wlkCoreType (U_uniforall ts t)
448 = wlkList rdU_???unkId ts `thenUgn` \ tvs ->
449 wlkMonoType t `thenUgn` \ ty ->
450 returnUgn (HsForAllTy tvs ty)
453 = wlkMonoType other `thenUgn` \ ty ->
454 returnUgn (UnoverloadedTy ty)
460 = rdU_maybe pt `thenUgn` \ ty_maybe ->
461 wlkMaybe rdMonoType ty_maybe
465 wlkCoreId :: U_coresyn -> UgnM (UfId ProtoName)
467 wlkCoreId (U_co_id v)
468 = returnUgn (BoringUfId (cvt_IdString v))
470 wlkCoreId (U_co_orig_id mod nm)
471 = returnUgn (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm))
473 wlkCoreId (U_co_sdselid clas super_clas)
474 = returnUgn (SuperDictSelUfId clas super_clas)
476 wlkCoreId (U_co_classopid clas method)
477 = returnUgn (ClassOpUfId clas method)
479 wlkCoreId (U_co_defmid clas method)
480 = returnUgn (DefaultMethodUfId clas method)
482 wlkCoreId (U_co_dfunid clas t)
483 = wlkCoreType t `thenUgn` \ ty ->
484 returnUgn (DictFunUfId clas ty)
486 wlkCoreId (U_co_constmid clas op t)
487 = wlkCoreType t `thenUgn` \ ty ->
488 returnUgn (ConstMethodUfId clas op ty)
490 wlkCoreId (U_co_specid id tys)
491 = wlkCoreId id `thenUgn` \ unspec ->
492 wlkList rdMonoTypeMaybe tys `thenUgn` \ ty_maybes ->
493 returnUgn (SpecUfId unspec ty_maybes)
495 wlkCoreId (U_co_wrkrid un)
496 = wlkCoreId un `thenUgn` \ unwrkr ->
497 returnUgn (WorkerUfId unwrkr)
500 cvt_IdString :: FAST_STRING -> ProtoName
503 = if (_HEAD_ s /= '_') then
505 else if (sub_s == SLIT("NIL_")) then
506 Prel (WiredInVal nilDataCon)
507 else if (sub_s == SLIT("TUP_")) then
508 Prel (WiredInVal (mkTupleCon arity))
513 sub_s = _SUBSTR_ s 1 4 -- chars 1--4 (0-origin)
514 arity = read (_UNPK_ (_SUBSTR_ s 5 999999))
515 -- chars 5 onwards give the arity
519 wlkBasicLit :: U_literal -> UgnM Literal
521 wlkBasicLit (U_norepr n d)
523 num = ((read (_UNPK_ n)) :: Integer)
524 den = ((read (_UNPK_ d)) :: Integer)
526 returnUgn (NoRepRational (num % den))
531 U_intprim s -> mkMachInt (as_integer s)
532 U_doubleprim s -> MachDouble (as_rational s)
533 U_floatprim s -> MachFloat (as_rational s)
534 U_charprim s -> MachChar (as_char s)
535 U_stringprim s -> MachStr (as_string s)
537 U_clitlit s k -> MachLitLit (as_string s) (guessPrimRep (_UNPK_ k))
539 U_norepi s -> NoRepInteger (as_integer s)
540 U_noreps s -> NoRepStr (as_string s)
544 as_integer s = readInteger (_UNPK_ s)
545 as_rational s = _readRational (_UNPK_ s) -- non-std