%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
-\section[ReadPragmas]{Read pragmatic interface info, including Core}
+\section{Read pragmatic interface info, including Core}
\begin{code}
--- HBC does not have stack stubbing; you get a space leak w/
--- default defns from HsVersions.h.
+#include "HsVersions.h"
--- GHC may be overly slow to compile w/ the defaults...
+module ReadPragmas (
+ ProtoUfBinder(..),
-#define BIND {--}
-#define _TO_ `thenLft` ( \ {--}
-#define BEND )
-#define RETN returnLft
-#define RETN_TYPE LiftM
+ wlkClassPragma,
+ wlkDataPragma,
+ wlkInstPragma,
+ wlkTySigPragmas
+ ) where
-#include "HsVersions.h"
-\end{code}
+import Ubiq{-uitous-}
-\begin{code}
-module ReadPragmas where
-
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty
-
-import AbsPrel ( nilDataCon, readUnfoldingPrimOp, PrimOp(..), PrimKind
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AbsSyn
-import BasicLit ( mkMachInt, BasicLit(..) )
-import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
+import RdrLoop -- break dependency loop
+
+import UgenAll -- all Yacc parser gumpff...
+import PrefixSyn -- and various syntaxen.
+import HsSyn
+import RdrHsSyn
+import HsPragmas -- NB: we are concerned with grimy
+import HsCore -- *Pragmas and *Core stuff here
+
+-- others:
+import CoreUnfold ( UnfoldingGuidance(..) )
import Id ( mkTupleCon )
-import IdInfo -- ( UnfoldingGuidance(..) )
-import LiftMonad
-import Maybes ( Maybe(..) )
-import PrefixToHs
-import PrefixSyn
-import ProtoName
-import Outputable
-import ReadPrefix ( rdList, rdId, rdIdString, rdString, rdConDecl, rdMonoType )
-import Util
+import IdInfo
+import IdUtils ( primOpNameInfo )
+import Literal ( mkMachInt, Literal(..) )
+import Name ( Name(..) )
+import PrelInfo ( nilDataCon )
+import PrimOp ( PrimOp(..), allThePrimOps )
+import PrimRep ( guessPrimRep ) -- really, VERY horrible...
+import ProtoName ( ProtoName(..) )
+import Util ( assertPanic, panic )
\end{code}
+Only used here:
\begin{code}
-rdDataPragma :: String -> RETN_TYPE (ProtoNameDataPragmas, String)
+readUnfoldingPrimOp :: FAST_STRING -> PrimOp
-rdDataPragma ('P' : 'N' : xs) = RETN (DataPragmas [] [], xs)
-
-rdDataPragma ('P' : 'd' : xs)
- = BIND (rdList (rdConDecl srcfile) xs) _TO_ (cons, xs1) ->
- BIND (rdList rd_spec xs1) _TO_ (specs, xs2) ->
- RETN (DataPragmas cons specs, xs2)
- BEND BEND
- where
- srcfile = SLIT("<pragma>")
-
- rd_spec ('P' : '4' : xs)
- = BIND (rdList rdMonoTypeMaybe xs) _TO_ (spec, xs1) ->
- RETN (spec, xs1)
- BEND
+readUnfoldingPrimOp
+ = let
+ -- "reverse" lookup table
+ tbl = map (\ o -> let { (str,_) = primOpNameInfo o } in (str, o)) allThePrimOps
+ in
+ \ str -> case [ op | (s, op) <- tbl, s == str ] of
+ (op:_) -> op
+#ifdef DEBUG
+ [] -> panic "readUnfoldingPrimOp" -- ++ _UNPK_ str ++"::"++show (map fst tbl))
+#endif
\end{code}
\begin{code}
-rdTypePragma :: String -> RETN_TYPE (TypePragmas, String)
+wlkDataPragma :: U_hpragma -> UgnM ProtoNameDataPragmas
+
+wlkDataPragma pragma
+ = case pragma of
+ U_no_pragma -> returnUgn (DataPragmas [] [])
+ U_idata_pragma cs ss ->
+ wlkList rdConDecl cs `thenUgn` \ cons ->
+ wlkList rd_spec ss `thenUgn` \ specs ->
+ returnUgn (DataPragmas cons specs)
+ where
+ rd_spec pt
+ = rdU_hpragma pt `thenUgn` \ stuff ->
+ case stuff of { U_idata_pragma_4s ss ->
-rdTypePragma ('P' : 'N' : xs) = RETN (NoTypePragmas, xs)
-rdTypePragma ('P' : 't' : xs) = RETN (AbstractTySynonym, xs)
+ wlkList rdMonoTypeMaybe ss `thenUgn` \ specs ->
+ returnUgn specs }
\end{code}
\begin{code}
-rdClassPragma :: String -> RETN_TYPE (ProtoNameClassPragmas, String)
-
-rdClassPragma ('P' : 'N' : xs) = RETN (NoClassPragmas, xs)
-rdClassPragma ('P' : 'c' : xs)
- = BIND (rdList rdGenPragma xs) _TO_ (gen_pragmas, xs1) ->
- ASSERT(not (null gen_pragmas))
- RETN (SuperDictPragmas gen_pragmas, xs1)
- BEND
+wlkClassPragma :: U_hpragma -> UgnM ProtoNameClassPragmas
+
+wlkClassPragma pragma
+ = case pragma of
+ U_no_pragma -> returnUgn NoClassPragmas
+ U_iclas_pragma gens ->
+ wlkList rdGenPragma gens `thenUgn` \ gen_pragmas ->
+ ASSERT(not (null gen_pragmas))
+ returnUgn (SuperDictPragmas gen_pragmas)
\end{code}
\begin{code}
-rdInstPragma :: String -> RETN_TYPE (Maybe FAST_STRING, ProtoNameInstancePragmas, String)
-
-rdInstPragma ('P' : 'N' : xs) = RETN (Nothing, NoInstancePragmas, xs)
-
-rdInstPragma ('P' : 'i' : 's' : xs)
- = BIND (rdIdString xs) _TO_ (modname, xs1) ->
- BIND (rdGenPragma xs1) _TO_ (gen_pragmas, xs2) ->
- RETN (Just modname, SimpleInstancePragma gen_pragmas, xs2)
- BEND BEND
-
-rdInstPragma ('P' : 'i' : 'c' : xs)
- = BIND (rdIdString xs) _TO_ (modname, xs1) ->
- BIND (rdGenPragma xs1) _TO_ (gen_pragma, xs2) ->
- BIND (rdList rd_constm xs2) _TO_ (constm_pragmas, xs3) ->
- RETN (Just modname, ConstantInstancePragma gen_pragma constm_pragmas, xs3)
- BEND BEND BEND
-
-rd_constm ('P' : '1' : xs)
- = BIND (rdId xs) _TO_ (name, xs1) ->
- BIND (rdGenPragma xs1) _TO_ (prag, xs2) ->
- RETN ((name, prag), xs2)
- BEND BEND
+wlkInstPragma :: U_hpragma -> UgnM ProtoNameInstancePragmas
+
+wlkInstPragma pragma
+ = case pragma of
+ U_no_pragma ->
+ returnUgn NoInstancePragmas
+
+ U_iinst_simpl_pragma dfun_gen ->
+ wlkGenPragma dfun_gen `thenUgn` \ gen_pragmas ->
+ returnUgn (SimpleInstancePragma gen_pragmas)
+
+ U_iinst_const_pragma dfun_gen constm_stuff ->
+ wlkGenPragma dfun_gen `thenUgn` \ gen_pragma ->
+ wlkList rd_constm constm_stuff `thenUgn` \ constm_pragmas ->
+ returnUgn (ConstantInstancePragma gen_pragma constm_pragmas)
+
+rd_constm pt
+ = rdU_hpragma pt `thenUgn` \ stuff ->
+ case stuff of { U_iname_pragma_pr name gen ->
+
+ wlkGenPragma gen `thenUgn` \ prag ->
+ returnUgn (name, prag) }
\end{code}
\begin{code}
-rdGenPragma :: String -> RETN_TYPE (ProtoNameGenPragmas, String)
-
-rdGenPragma ('P' : 'N' : xs) = RETN (NoGenPragmas, xs)
-
-rdGenPragma ('P': 'g' : xs)
- = BIND (rd_arity xs) _TO_ (arity, xs1) ->
- BIND (rd_update xs1) _TO_ (upd, xs2) ->
- BIND (rd_strict xs2) _TO_ (strict, xs3) ->
- BIND (rd_unfold xs3) _TO_ (unfold, xs4) ->
- BIND (rdList rd_spec xs4) _TO_ (specs, xs5) ->
-ToDo: do something for DeforestInfo
- RETN (GenPragmas arity upd strict unfold specs, xs5)
- BEND BEND BEND BEND BEND
+rdGenPragma :: ParseTree -> UgnM ProtoNameGenPragmas
+
+rdGenPragma pt = rdU_hpragma pt `thenUgn` \ prag -> wlkGenPragma prag
+
+wlkGenPragma :: U_hpragma -> UgnM ProtoNameGenPragmas
+
+wlkGenPragma pragma
+ = case pragma of
+ U_no_pragma -> returnUgn noGenPragmas
+
+ U_igen_pragma aritee update deforest strct uf speccs ->
+ wlk_arity aritee `thenUgn` \ arity ->
+ wlk_update update `thenUgn` \ upd ->
+ wlk_deforest deforest `thenUgn` \ def ->
+ wlk_strict strct `thenUgn` \ strict ->
+ wlk_unfold uf `thenUgn` \ unfold ->
+ wlkList rd_spec speccs `thenUgn` \ specs ->
+ returnUgn (GenPragmas arity upd def strict unfold specs)
where
- rd_arity ('P' : 'N' : xs) = RETN (Nothing, xs)
- rd_arity ('P' : 'A' : xs)
- = BIND (rdIdString xs) _TO_ (a_str, xs1) ->
- RETN (Just ((read (_UNPK_ a_str))::Int), xs1)
- BEND
-
- rd_update ('P' : 'N' : xs) = RETN (Nothing, xs)
- rd_update ('P' : 'u' : xs)
- = BIND (rdIdString xs) _TO_ (upd_spec, xs1) ->
- RETN (Just ((read (_UNPK_ upd_spec))::UpdateInfo), xs1)
- BEND
-
- rd_unfold ('P' : 'N' : xs) = RETN (NoImpUnfolding, xs)
-
- rd_unfold ('P' : 'M' : xs)
- = BIND (rdIdString xs) _TO_ (str, xs1) ->
- RETN (ImpMagicUnfolding str, xs1)
- BEND
-
- rd_unfold ('P' : 'U' : xs)
- = BIND (rdGuidance xs) _TO_ (guidance, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (core, xs2) ->
- RETN (ImpUnfolding guidance core, xs2)
- BEND BEND
-
- rd_strict ('P' : 'N' : xs) = RETN (NoImpStrictness, xs)
- rd_strict ('P' : 'S' : xs)
- = BIND (rdString xs) _TO_ (strict_spec, xs1) ->
- BIND (rdGenPragma xs1) _TO_ (wrkr_pragma, xs2) ->
- let
- ww_strict_info = (read (_UNPK_ strict_spec))::[Demand]
- in
- RETN (ImpStrictness (trace "ImpStrictness" False) ww_strict_info wrkr_pragma, xs2)
- BEND BEND
-
- rd_spec ('P' : '2' : xs)
- = BIND (rdList rdMonoTypeMaybe xs) _TO_ (mono_tys_maybe, xs1) ->
- BIND (rdIdString xs1) _TO_ (num_dicts, xs2) ->
- BIND (rdGenPragma xs2) _TO_ (gen_prag, xs3) ->
- RETN ((mono_tys_maybe, ((read (_UNPK_ num_dicts))::Int), gen_prag), xs3)
- BEND BEND BEND
+ wlk_arity stuff
+ = case stuff of
+ U_no_pragma -> returnUgn Nothing
+ U_iarity_pragma arity ->
+ returnUgn (Just arity)
+
+ ------------
+ wlk_update stuff
+ = case stuff of
+ U_no_pragma -> returnUgn Nothing
+ U_iupdate_pragma upd_spec ->
+ returnUgn (Just ((read (_UNPK_ upd_spec))::UpdateInfo))
+
+ ------------
+ wlk_deforest stuff
+ = case stuff of
+ U_no_pragma -> returnUgn Don'tDeforest
+ U_ideforest_pragma -> returnUgn DoDeforest
+
+ ------------
+ wlk_unfold stuff
+ = case stuff of
+ U_no_pragma -> returnUgn NoImpUnfolding
+
+ U_imagic_unfolding_pragma magic ->
+ returnUgn (ImpMagicUnfolding magic)
+
+ U_iunfolding_pragma guide core ->
+ wlkGuidance guide `thenUgn` \ guidance ->
+ wlkCoreExpr core `thenUgn` \ coresyn ->
+ returnUgn (ImpUnfolding guidance coresyn)
+
+ ------------
+ wlk_strict stuff
+ = case stuff of
+ U_no_pragma -> returnUgn NoImpStrictness
+
+ U_istrictness_pragma strict_spec wrkr_stuff ->
+ wlkGenPragma wrkr_stuff `thenUgn` \ wrkr_pragma ->
+ let
+ strict_spec_str = _UNPK_ strict_spec
+ (is_bot, ww_strict_info)
+ = if (strict_spec_str == "B")
+ then (True, [])
+ else (False, (read strict_spec_str)::[Demand])
+ in
+ returnUgn (ImpStrictness is_bot ww_strict_info wrkr_pragma)
+
+ ------------
+ rd_spec pt
+ = rdU_hpragma pt `thenUgn` \ stuff ->
+ case stuff of { U_itype_pragma_pr maybe_tys num_dicts prag ->
+
+ wlkList rdMonoTypeMaybe maybe_tys `thenUgn` \ mono_tys_maybe ->
+ wlkGenPragma prag `thenUgn` \ gen_prag ->
+ returnUgn (mono_tys_maybe, num_dicts, gen_prag) }
\end{code}
The only tricky case is pragmas on signatures; we have no way of
whatever comes, store it in a @RdrTySigPragmas@ structure, and someone
will sort it out later.
\begin{code}
-rdTySigPragmas :: String -> RETN_TYPE (RdrTySigPragmas, String)
+wlkTySigPragmas :: U_hpragma -> UgnM RdrTySigPragmas
-rdTySigPragmas ('P' : 'N' : xs) = RETN (RdrNoPragma, xs)
+wlkTySigPragmas pragma
+ = case pragma of
+ U_no_pragma -> returnUgn RdrNoPragma
-rdTySigPragmas ('P' : 'o' : xs)
- = BIND (rdGenPragma xs) _TO_ (dsel_pragma, xs1) ->
- BIND (rdGenPragma xs1) _TO_ (defm_pragma, xs2) ->
- RETN (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma), xs2)
- BEND BEND
+ U_iclasop_pragma dsel defm ->
+ wlkGenPragma dsel `thenUgn` \ dsel_pragma ->
+ wlkGenPragma defm `thenUgn` \ defm_pragma ->
+ returnUgn (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma))
-rdTySigPragmas xs
- = BIND (rdGenPragma xs) _TO_ (gen_pragmas, xs1) ->
- RETN (RdrGenPragmas gen_pragmas, xs1)
- BEND
+ other ->
+ wlkGenPragma other `thenUgn` \ gen_pragmas ->
+ returnUgn (RdrGenPragmas gen_pragmas)
\end{code}
\begin{code}
-rdGuidance ('P' : 'x' : xs) = RETN (UnfoldAlways, xs)
-
--- EssentialUnfolding should never appear in interfaces, so we
--- don't have any way to read them.
-
-rdGuidance ('P' : 'y' : xs)
- = BIND (rdIdString xs) _TO_ (m_ty_args, xs1) ->
- BIND (rdIdString xs1) _TO_ (n_val_args, xs2) ->
- BIND (rdIdString xs2) _TO_ (con_arg_spec, xs3) ->
- BIND (rdIdString xs3) _TO_ (size_str, xs4) ->
- let
- num_val_args = ((read (_UNPK_ n_val_args)) :: Int)
- con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec))
- -- if there were 0 args, we want to throw away
- -- any dummy con_arg_spec stuff...
- in
- RETN (UnfoldIfGoodArgs (read (_UNPK_ m_ty_args)) num_val_args
- con_arg_info (read (_UNPK_ size_str)), xs4)
- BEND BEND BEND BEND
- where
- cvt 'C' = True -- want a constructor in this arg position
- cvt _ = False
-
-{- OLD:
-rdGuidance ('P' : 'z' : xs)
- = BIND (rdIdString xs) _TO_ (m_ty_args, xs1) ->
- BIND (rdIdString xs1) _TO_ (size, xs2) ->
- RETN (trace "read:UnfoldIsCon" UnfoldNever, xs2) -- ToDo: rm
- BEND BEND
--}
+wlkGuidance guide
+ = case guide of
+ U_iunfold_always -> returnUgn UnfoldAlways
+
+ U_iunfold_if_args num_ty_args num_val_args con_arg_spec size ->
+ let
+ con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec))
+ -- if there were 0 args, we want to throw away
+ -- any dummy con_arg_spec stuff...
+ in
+ returnUgn (UnfoldIfGoodArgs num_ty_args num_val_args
+ con_arg_info size)
+ where
+ cvt 'C' = True -- want a constructor in this arg position
+ cvt _ = False
\end{code}
\begin{code}
-rdCoreExpr :: String -> RETN_TYPE (ProtoNameUnfoldingCoreExpr, String)
-
-rdCoreExpr ('F' : 'g' : xs)
- = BIND (rdCoreId xs) _TO_ (var, xs1) ->
- RETN (UfCoVar var, xs1)
- BEND
-
-rdCoreExpr ('F' : 'h' : xs)
- = BIND (rdBasicLit xs) _TO_ (lit, xs1) ->
- RETN (UfCoLit lit, xs1)
- BEND
-
-rdCoreExpr ('F' : 'i' : xs)
- = BIND (rdCoreId xs) _TO_ (BoringUfId con, xs1) ->
- BIND (rdList rdCoreType xs1) _TO_ (tys, xs2) ->
- BIND (rdList rdCoreAtom xs2) _TO_ (vs, xs3) ->
- RETN (UfCoCon con tys vs, xs3)
- BEND BEND BEND
-
-rdCoreExpr ('F' : 'j' : xs)
- = BIND (rd_primop xs) _TO_ (op, xs1) ->
- BIND (rdList rdCoreType xs1) _TO_ (tys, xs2) ->
- BIND (rdList rdCoreAtom xs2) _TO_ (vs, xs3) ->
- RETN (UfCoPrim op tys vs, xs3)
- BEND BEND BEND
- where
-
--- Question: why did ccall once panic if you looked at the maygc flag?
--- Was this just laziness or is it not needed? In that case, modify
--- the stuff that writes them to pragmas so that it never adds the _GC_
--- tag. ADR
-
- rd_primop ('F' : 'w' : xs)
- = BIND (rdIdString xs) _TO_ (op_str, xs1) ->
- RETN (UfOtherOp (readUnfoldingPrimOp op_str), xs1)
- BEND
- rd_primop ('F' : 'x' : t_or_f : xs)
- = BIND (rdIdString xs) _TO_ (fun_str, xs1) ->
- BIND (rdList rdCoreType xs1) _TO_ (arg_tys, xs2) ->
- BIND (rdCoreType xs2) _TO_ (res_ty, xs3) ->
- RETN (UfCCallOp fun_str False (is_T_or_F t_or_f) arg_tys res_ty, xs3)
- BEND BEND BEND
- rd_primop ('F' : 'y' : t_or_f : xs)
- = BIND (rdBasicLit xs) _TO_ (casm_litlit, xs1) ->
- BIND (rdList rdCoreType xs1) _TO_ (arg_tys, xs2) ->
- BIND (rdCoreType xs2) _TO_ (res_ty, xs3) ->
+wlkCoreExpr :: U_coresyn -> UgnM ProtoNameUnfoldingCoreExpr
+
+wlkCoreExpr core_expr
+ = case core_expr of
+ U_covar v ->
+ wlkCoreId v `thenUgn` \ var ->
+ returnUgn (UfVar var)
+
+ U_coliteral l ->
+ wlkBasicLit l `thenUgn` \ lit ->
+ returnUgn (UfLit lit)
+
+ U_cocon c ts as ->
+ wlkCoreId c `thenUgn` \ (BoringUfId con) ->
+ wlkList rdCoreType ts `thenUgn` \ tys ->
+ wlkList rdCoreAtom as `thenUgn` \ vs ->
+ returnUgn (UfCon con tys vs)
+
+ U_coprim o ts as ->
+ wlk_primop o `thenUgn` \ op ->
+ wlkList rdCoreType ts `thenUgn` \ tys ->
+ wlkList rdCoreAtom as `thenUgn` \ vs ->
let
- (MachLitLit casm_str _) = casm_litlit
+ fixed_vs = case op of { UfOtherOp pop -> fixup pop vs ; _ -> vs }
in
- RETN (UfCCallOp casm_str True (is_T_or_F t_or_f) arg_tys res_ty, xs3)
- BEND BEND BEND
-
- is_T_or_F 'T' = True
- is_T_or_F 'F' = False
-
-rdCoreExpr ('F' : 'k' : xs)
- = BIND (rdList rdCoreBinder xs) _TO_ (bs, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (body, xs2) ->
- RETN (UfCoLam bs body, xs2)
- BEND BEND
-
-rdCoreExpr ('F' : 'l' : xs)
- = BIND (rdList rdId xs) _TO_ (tvs, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (body, xs2) ->
- RETN (foldr UfCoTyLam body tvs, xs2)
- BEND BEND
-
-rdCoreExpr ('F' : 'm' : xs)
- = BIND (rdCoreExpr xs) _TO_ (fun, xs1) ->
- BIND (rdList rdCoreAtom xs1) _TO_ (args, xs2) ->
- RETN (foldl UfCoApp fun args, xs2)
- BEND BEND
-
-
-rdCoreExpr ('F' : 'n' : xs)
- = BIND (rdCoreExpr xs) _TO_ (expr, xs1) ->
- BIND (rdCoreType xs1) _TO_ (ty, xs2) ->
- RETN (UfCoTyApp expr ty, xs2)
- BEND BEND
-
-rdCoreExpr ('F' : 'o' : xs)
- = BIND (rdCoreExpr xs) _TO_ (scrut, xs1) ->
- BIND (rd_alts xs1) _TO_ (alts, xs2) ->
- RETN (UfCoCase scrut alts, xs2)
- BEND BEND
- where
- rd_alts ('F' : 'q' : xs)
- = BIND (rdList rd_alg_alt xs) _TO_ (alts, xs1) ->
- BIND (rd_deflt xs1) _TO_ (deflt, xs2) ->
- RETN (UfCoAlgAlts alts deflt, xs2)
- BEND BEND
- where
- rd_alg_alt ('F' : 'r' : xs)
- = BIND (rdCoreId xs) _TO_ (BoringUfId con, xs1) ->
- BIND (rdList rdCoreBinder xs1) _TO_ (params, xs2) ->
- BIND (rdCoreExpr xs2) _TO_ (rhs, xs3) ->
- RETN ((con, params, rhs), xs3)
- BEND BEND BEND
-
- rd_alts ('F' : 's' : xs)
- = BIND (rdList rd_prim_alt xs) _TO_ (alts, xs1) ->
- BIND (rd_deflt xs1) _TO_ (deflt, xs2) ->
- RETN (UfCoPrimAlts alts deflt, xs2)
- BEND BEND
- where
- rd_prim_alt ('F' : 't' : xs)
- = BIND (rdBasicLit xs) _TO_ (lit, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (rhs, xs2) ->
- RETN ((lit, rhs), xs2)
- BEND BEND
-
- rd_deflt ('F' : 'u' : xs) = RETN (UfCoNoDefault, xs)
- rd_deflt ('F' : 'v' : xs)
- = BIND (rdCoreBinder xs) _TO_ (b, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (rhs, xs2) ->
- RETN (UfCoBindDefault b rhs, xs2)
- BEND BEND
-
-rdCoreExpr ('F' : 'p' : xs)
- = BIND (rd_bind xs) _TO_ (bind, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (body, xs2) ->
- RETN (UfCoLet bind body, xs2)
- BEND BEND
- where
- rd_bind ('F' : 'd' : xs)
- = BIND (rdCoreBinder xs) _TO_ (b, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (rhs, xs2) ->
- RETN (UfCoNonRec b rhs, xs2)
- BEND BEND
-
- rd_bind ('F' : 'e' : xs)
- = BIND (rdList rd_pair xs) _TO_ (pairs, xs1) ->
- RETN (UfCoRec pairs, xs1)
- BEND
+ returnUgn (UfPrim op tys fixed_vs)
+ where
+
+ -- Question: why did ccall once panic if you looked at the
+ -- maygc flag? Was this just laziness or is it not needed?
+ -- In that case, modify the stuff that writes them to pragmas
+ -- so that it never adds the _GC_ tag. ADR
+
+ wlk_primop op
+ = case op of
+ U_co_primop op_str ->
+ returnUgn (UfOtherOp (readUnfoldingPrimOp op_str))
+
+ U_co_ccall fun_str may_gc a_tys r_ty ->
+ wlkList rdCoreType a_tys `thenUgn` \ arg_tys ->
+ wlkCoreType r_ty `thenUgn` \ res_ty ->
+ returnUgn (UfCCallOp fun_str False (is_T_or_F may_gc) arg_tys res_ty)
+
+ U_co_casm litlit may_gc a_tys r_ty ->
+ wlkBasicLit litlit `thenUgn` \ (MachLitLit casm_str _) ->
+ wlkList rdCoreType a_tys `thenUgn` \ arg_tys ->
+ wlkCoreType r_ty `thenUgn` \ res_ty ->
+ returnUgn (UfCCallOp casm_str True (is_T_or_F may_gc) arg_tys res_ty)
+ where
+ is_T_or_F 0 = False
+ is_T_or_F _ = True
+
+ -- Now *this* is a hack: we can't distinguish Int# literals
+ -- from Word# literals as they come in; this is only likely
+ -- to bite on the args of certain PrimOps (shifts, etc); so
+ -- we look for those and fix things up!!! (WDP 95/05)
+
+ fixup AndOp [a1, a2] = [fixarg a1, fixarg a2]
+ fixup OrOp [a1, a2] = [fixarg a1, fixarg a2]
+ fixup NotOp [a1] = [fixarg a1]
+ fixup SllOp [a1, a2] = [fixarg a1, a2]
+ fixup SraOp [a1, a2] = [fixarg a1, a2]
+ fixup SrlOp [a1, a2] = [fixarg a1, a2]
+ fixup WordGtOp [a1, a2] = [fixarg a1, fixarg a2]
+ fixup WordGeOp [a1, a2] = [fixarg a1, fixarg a2]
+ fixup WordLtOp [a1, a2] = [fixarg a1, fixarg a2]
+ fixup WordLeOp [a1, a2] = [fixarg a1, fixarg a2]
+ fixup WordEqOp [a1, a2] = [fixarg a1, fixarg a2]
+ fixup WordNeOp [a1, a2] = [fixarg a1, fixarg a2]
+ fixup _ as = as
+
+ fixarg (UfCoLitAtom (MachInt i _)) = UfCoLitAtom (MachInt i False{-unsigned-})
+ fixarg arg = arg
+
+ U_colam vars expr ->
+ wlkList rdCoreBinder vars `thenUgn` \ bs ->
+ wlkCoreExpr expr `thenUgn` \ body ->
+ returnUgn (foldr UfLam body bs)
+
+ U_coapp f as ->
+ wlkCoreExpr f `thenUgn` \ fun ->
+ wlkList rdCoreAtom as `thenUgn` \ args ->
+ returnUgn (foldl UfApp fun args)
+
+ U_cocase s as ->
+ wlkCoreExpr s `thenUgn` \ scrut ->
+ wlk_alts as `thenUgn` \ alts ->
+ returnUgn (UfCase scrut alts)
+ where
+ wlk_alts (U_coalg_alts as d)
+ = wlkList rd_alg_alt as `thenUgn` \ alts ->
+ wlk_deflt d `thenUgn` \ deflt ->
+ returnUgn (UfCoAlgAlts alts deflt)
+ where
+ rd_alg_alt pt
+ = rdU_coresyn pt `thenUgn` \ (U_coalg_alt c bs exp) ->
+
+ wlkCoreId c `thenUgn` \ (BoringUfId con) ->
+ wlkList rdCoreBinder bs `thenUgn` \ params ->
+ wlkCoreExpr exp `thenUgn` \ rhs ->
+ returnUgn (con, params, rhs)
+
+ wlk_alts (U_coprim_alts as d)
+ = wlkList rd_prim_alt as `thenUgn` \ alts ->
+ wlk_deflt d `thenUgn` \ deflt ->
+ returnUgn (UfCoPrimAlts alts deflt)
+ where
+ rd_prim_alt pt
+ = rdU_coresyn pt `thenUgn` \ (U_coprim_alt l exp) ->
+
+ wlkBasicLit l `thenUgn` \ lit ->
+ wlkCoreExpr exp `thenUgn` \ rhs ->
+ returnUgn (lit, rhs)
+
+ wlk_deflt U_conodeflt = returnUgn UfCoNoDefault
+ wlk_deflt (U_cobinddeflt v exp)
+ = wlkCoreBinder v `thenUgn` \ b ->
+ wlkCoreExpr exp `thenUgn` \ rhs ->
+ returnUgn (UfCoBindDefault b rhs)
+
+ U_colet b expr ->
+ wlk_bind b `thenUgn` \ bind ->
+ wlkCoreExpr expr `thenUgn` \ body ->
+ returnUgn (UfLet bind body)
+ where
+ wlk_bind (U_cononrec v expr)
+ = wlkCoreBinder v `thenUgn` \ b ->
+ wlkCoreExpr expr `thenUgn` \ rhs ->
+ returnUgn (UfCoNonRec b rhs)
+
+ wlk_bind (U_corec prs)
+ = wlkList rd_pair prs `thenUgn` \ pairs ->
+ returnUgn (UfCoRec pairs)
+ where
+ rd_pair pt
+ = rdU_coresyn pt `thenUgn` \ (U_corec_pair v expr) ->
+
+ wlkCoreBinder v `thenUgn` \ b ->
+ wlkCoreExpr expr `thenUgn` \ rhs ->
+ returnUgn (b, rhs)
+
+ U_coscc c expr ->
+ wlk_cc c `thenUgn` \ cc ->
+ wlkCoreExpr expr `thenUgn` \ body ->
+ returnUgn (UfSCC cc body)
where
- rd_pair ('F' : 'f' : xs)
- = BIND (rdCoreBinder xs) _TO_ (b, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (rhs, xs2) ->
- RETN ((b, rhs), xs2)
- BEND BEND
-
-rdCoreExpr ('F' : 'z' : xs)
- = BIND (rd_cc xs) _TO_ (cc, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (body, xs2) ->
- RETN (UfCoSCC cc body, xs2)
- BEND BEND
- where
- rd_cc ('F' : '?' : 'a' : xs)
- = BIND (rd_dupd xs) _TO_ (is_dupd, xs1) ->
- RETN (UfPreludeDictsCC is_dupd, xs1)
- BEND
-
- rd_cc ('F' : '?' : 'b' : xs)
- = BIND (rdString xs) _TO_ (m, xs1) ->
- BIND (rdString xs1) _TO_ (g, xs2) ->
- BIND (rd_dupd xs2) _TO_ (is_dupd, xs3) ->
- RETN (UfAllDictsCC m g is_dupd, xs3)
- BEND BEND BEND
-
- rd_cc ('F' : '?' : 'c' : xs)
- = BIND (rdString xs) _TO_ (n, xs1) ->
- BIND (rdString xs1) _TO_ (m, xs2) ->
- BIND (rdString xs2) _TO_ (g, xs3) ->
- BIND (rd_dupd xs3) _TO_ (is_dupd, xs4) ->
- BIND (rd_cafd xs4) _TO_ (is_cafd, xs5) ->
- RETN (UfUserCC n m g is_dupd is_cafd, xs5)
- BEND BEND BEND BEND BEND
-
- rd_cc ('F' : '?' : 'd' : xs)
- = BIND (rdCoreId xs) _TO_ (i, xs1) ->
- BIND (rdString xs1) _TO_ (m, xs2) ->
- BIND (rdString xs2) _TO_ (g, xs3) ->
- BIND (rd_dupd xs3) _TO_ (is_dupd, xs4) ->
- BIND (rd_cafd xs4) _TO_ (is_cafd, xs5) ->
- RETN (UfAutoCC i m g is_dupd is_cafd, xs5)
- BEND BEND BEND BEND BEND
-
- rd_cc ('F' : '?' : 'e' : xs)
- = BIND (rdCoreId xs) _TO_ (i, xs1) ->
- BIND (rdString xs1) _TO_ (m, xs2) ->
- BIND (rdString xs2) _TO_ (g, xs3) ->
- BIND (rd_dupd xs3) _TO_ (is_dupd, xs4) ->
- BIND (rd_cafd xs4) _TO_ (is_cafd, xs5) ->
- RETN (UfDictCC i m g is_dupd is_cafd, xs5)
- BEND BEND BEND BEND BEND
-
- ------
- rd_cafd ('F' : '?' : 'f' : xs) = RETN (False, xs)
- rd_cafd ('F' : '?' : 'g' : xs) = RETN (True, xs)
--- rd_cafd xs = panic ("rd_cafd:\n"++xs)
-
- rd_dupd ('F' : '?' : 'h' : xs) = RETN (False, xs)
- rd_dupd ('F' : '?' : 'i' : xs) = RETN (True, xs)
+ wlk_cc (U_co_preludedictscc dupd)
+ = wlk_dupd dupd `thenUgn` \ is_dupd ->
+ returnUgn (UfPreludeDictsCC is_dupd)
+
+ wlk_cc (U_co_alldictscc m g dupd)
+ = wlk_dupd dupd `thenUgn` \ is_dupd ->
+ returnUgn (UfAllDictsCC m g is_dupd)
+
+ wlk_cc (U_co_usercc n m g dupd cafd)
+ = wlk_dupd dupd `thenUgn` \ is_dupd ->
+ wlk_cafd cafd `thenUgn` \ is_cafd ->
+ returnUgn (UfUserCC n m g is_dupd is_cafd)
+
+ wlk_cc (U_co_autocc id m g dupd cafd)
+ = wlkCoreId id `thenUgn` \ i ->
+ wlk_dupd dupd `thenUgn` \ is_dupd ->
+ wlk_cafd cafd `thenUgn` \ is_cafd ->
+ returnUgn (UfAutoCC i m g is_dupd is_cafd)
+
+ wlk_cc (U_co_dictcc id m g dupd cafd)
+ = wlkCoreId id `thenUgn` \ i ->
+ wlk_dupd dupd `thenUgn` \ is_dupd ->
+ wlk_cafd cafd `thenUgn` \ is_cafd ->
+ returnUgn (UfDictCC i m g is_dupd is_cafd)
+
+ ------
+ wlk_cafd U_co_scc_noncaf = returnUgn False
+ wlk_cafd U_co_scc_caf = returnUgn True
+
+ wlk_dupd U_co_scc_nondupd = returnUgn False
+ wlk_dupd U_co_scc_dupd = returnUgn True
\end{code}
\begin{code}
-rdCoreBinder ('F' : 'a' : xs)
- = BIND (rdId xs) _TO_ (b, xs1) ->
- BIND (rdCoreType xs1) _TO_ (ty, xs2) ->
- RETN ((b, ty), xs2)
- BEND BEND
-
-rdCoreAtom ('F' : 'b' : xs)
- = BIND (rdBasicLit xs) _TO_ (lit, xs1) ->
- RETN (UfCoLitAtom lit, xs1)
- BEND
-
-rdCoreAtom ('F' : 'c' : xs)
- = BIND (rdCoreId xs) _TO_ (v, xs1) ->
- RETN (UfCoVarAtom v, xs1)
- BEND
-\end{code}
+type ProtoUfBinder = (ProtoName, PolyType ProtoName)
-\begin{code}
-rdCoreType :: String -> RETN_TYPE (ProtoNamePolyType, String)
-
-rdCoreType ('2' : 'C' : xs)
- = BIND (rdList rdId xs) _TO_ (tvs, xs1) ->
- BIND (rdMonoType xs1) _TO_ (ty, xs2) ->
- RETN (ForAllTy tvs ty, xs2)
- BEND BEND
-
-rdCoreType other
- = BIND (rdMonoType other) _TO_ (ty, xs1) ->
- RETN (UnoverloadedTy ty, xs1)
- BEND
+rdCoreBinder :: ParseTree -> UgnM ProtoUfBinder
+
+rdCoreBinder pt = rdU_coresyn pt `thenUgn` \ x -> wlkCoreBinder x
+
+wlkCoreBinder :: U_coresyn -> UgnM ProtoUfBinder
+
+wlkCoreBinder (U_cobinder b t)
+ = wlkCoreType t `thenUgn` \ ty ->
+ returnUgn (b, ty)
+
+rdCoreAtom pt
+ = rdU_coresyn pt `thenUgn` \ atom ->
+ case atom of
+ U_colit l ->
+ wlkBasicLit l `thenUgn` \ lit ->
+ returnUgn (UfCoLitAtom lit)
+
+ U_colocal var ->
+ wlkCoreId var `thenUgn` \ v ->
+ returnUgn (UfCoVarAtom v)
\end{code}
\begin{code}
-rdCoreTypeMaybe :: String -> RETN_TYPE(Maybe ProtoNamePolyType, String)
+rdCoreType :: ParseTree -> UgnM ProtoNamePolyType
+
+rdCoreType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkCoreType ttype
+
+wlkCoreType :: U_ttype -> UgnM ProtoNamePolyType
-rdCoreTypeMaybe ('2' : 'D' : xs) = RETN(Nothing, xs)
-rdCoreTypeMaybe ('2' : 'E' : xs)
- = BIND (rdCoreType xs) _TO_ (ty, xs1) ->
- RETN(Just ty, xs1)
- BEND
+wlkCoreType other
+ = panic "ReadPragmas:wlkCoreType:ToDo"
+{- LATER:
+wlkCoreType (U_uniforall ts t)
+ = wlkList rdU_???unkId ts `thenUgn` \ tvs ->
+ wlkMonoType t `thenUgn` \ ty ->
+ returnUgn (HsForAllTy tvs ty)
-rdMonoTypeMaybe ('2' : 'D' : xs) = RETN (Nothing, xs)
+wlkCoreType other
+ = wlkMonoType other `thenUgn` \ ty ->
+ returnUgn (UnoverloadedTy ty)
+-}
+\end{code}
-rdMonoTypeMaybe ('2' : 'E' : xs)
- = BIND (rdMonoType xs) _TO_ (mono_ty, xs1) ->
- RETN (Just mono_ty, xs1)
- BEND
+\begin{code}
+rdMonoTypeMaybe pt
+ = rdU_maybe pt `thenUgn` \ ty_maybe ->
+ wlkMaybe rdMonoType ty_maybe
\end{code}
\begin{code}
-rdCoreId :: String -> RETN_TYPE (UfId ProtoName, String)
-
-rdCoreId ('F' : '1' : xs)
- = BIND (rdIdString xs) _TO_ (v, xs1) ->
- RETN (BoringUfId (cvt_IdString v), xs1)
- BEND
-rdCoreId ('F' : '9' : xs)
- = BIND (rdIdString xs) _TO_ (mod, xs1) ->
- BIND (rdIdString xs1) _TO_ (nm, xs2) ->
- RETN (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm), xs2)
- BEND BEND
-rdCoreId ('F' : '2' : xs)
- = BIND (rdId xs) _TO_ (clas, xs1) ->
- BIND (rdId xs1) _TO_ (super_clas, xs2) ->
- RETN (SuperDictSelUfId clas super_clas, xs2)
- BEND BEND
-rdCoreId ('F' : '3' : xs)
- = BIND (rdId xs) _TO_ (clas, xs1) ->
- BIND (rdId xs1) _TO_ (method, xs2) ->
- RETN (ClassOpUfId clas method, xs2)
- BEND BEND
-rdCoreId ('F' : '4' : xs)
- = BIND (rdId xs) _TO_ (clas, xs1) ->
- BIND (rdId xs1) _TO_ (method, xs2) ->
- RETN (DefaultMethodUfId clas method, xs2)
- BEND BEND
-rdCoreId ('F' : '5' : xs)
- = BIND (rdId xs) _TO_ (clas, xs1) ->
- BIND (rdCoreType xs1) _TO_ (ty, xs2) ->
- RETN (DictFunUfId clas ty, xs2)
- BEND BEND
-rdCoreId ('F' : '6' : xs)
- = BIND (rdId xs) _TO_ (clas, xs1) ->
- BIND (rdId xs1) _TO_ (op, xs2) ->
- BIND (rdCoreType xs2) _TO_ (ty, xs3) ->
- RETN (ConstMethodUfId clas op ty, xs3)
- BEND BEND BEND
-rdCoreId ('F' : '7' : xs)
- = BIND (rdCoreId xs) _TO_ (unspec, xs1) ->
- BIND (rdList rdMonoTypeMaybe xs1) _TO_ (ty_maybes, xs2) ->
- RETN (SpecUfId unspec ty_maybes, xs2)
- BEND BEND
-rdCoreId ('F' : '8' : xs)
- = BIND (rdCoreId xs) _TO_ (unwrkr, xs1) ->
- RETN (WorkerUfId unwrkr, xs1)
- BEND
+wlkCoreId :: U_coresyn -> UgnM (UfId ProtoName)
+
+wlkCoreId (U_co_id v)
+ = returnUgn (BoringUfId (cvt_IdString v))
+
+wlkCoreId (U_co_orig_id mod nm)
+ = returnUgn (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm))
+
+wlkCoreId (U_co_sdselid clas super_clas)
+ = returnUgn (SuperDictSelUfId clas super_clas)
+
+wlkCoreId (U_co_classopid clas method)
+ = returnUgn (ClassOpUfId clas method)
+
+wlkCoreId (U_co_defmid clas method)
+ = returnUgn (DefaultMethodUfId clas method)
+wlkCoreId (U_co_dfunid clas t)
+ = wlkCoreType t `thenUgn` \ ty ->
+ returnUgn (DictFunUfId clas ty)
+
+wlkCoreId (U_co_constmid clas op t)
+ = wlkCoreType t `thenUgn` \ ty ->
+ returnUgn (ConstMethodUfId clas op ty)
+
+wlkCoreId (U_co_specid id tys)
+ = wlkCoreId id `thenUgn` \ unspec ->
+ wlkList rdMonoTypeMaybe tys `thenUgn` \ ty_maybes ->
+ returnUgn (SpecUfId unspec ty_maybes)
+
+wlkCoreId (U_co_wrkrid un)
+ = wlkCoreId un `thenUgn` \ unwrkr ->
+ returnUgn (WorkerUfId unwrkr)
+
+------------
cvt_IdString :: FAST_STRING -> ProtoName
cvt_IdString s
= if (_HEAD_ s /= '_') then
boring
else if (sub_s == SLIT("NIL_")) then
--- trace (show s++"/*1*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
Prel (WiredInVal nilDataCon)
--- )
else if (sub_s == SLIT("TUP_")) then
--- trace (show s++"/*2*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
Prel (WiredInVal (mkTupleCon arity))
--- )
else
--- trace (show s++"/*3*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
boring
--- )
where
boring = Unk s
sub_s = _SUBSTR_ s 1 4 -- chars 1--4 (0-origin)
\end{code}
\begin{code}
-rdBasicLit :: String -> RETN_TYPE (BasicLit, String)
+wlkBasicLit :: U_literal -> UgnM Literal
-rdBasicLit ('R' : xs)
- = BIND (rdString xs) _TO_ (n, xs1) ->
- BIND (rdString xs1) _TO_ (d, xs2) ->
- let
+wlkBasicLit (U_norepr n d)
+ = let
num = ((read (_UNPK_ n)) :: Integer)
den = ((read (_UNPK_ d)) :: Integer)
in
- RETN (NoRepRational (num % den), xs2)
- BEND BEND
-
-rdBasicLit ( tag : xs)
- = BIND (rdString xs) _TO_ (x, zs) ->
- let
- s = _UNPK_ x
-
- as_char = chr ((read s) :: Int)
- -- a char comes in as a number string
- -- representing its ASCII code
- as_integer = readInteger s
-#ifdef __GLASGOW_HASKELL__
- as_rational = _readRational s -- non-std
-#else
- as_rational = ((read s)::Rational)
-#endif
- as_double = ((read s) :: Double)
- in
- case tag of {
- 'H' -> RETN (mkMachInt as_integer, zs);
- 'J' -> RETN (MachDouble as_rational,zs);
- 'K' -> RETN (MachFloat as_rational,zs);
- 'P' -> RETN (MachChar as_char, zs);
- 'V' -> RETN (MachStr x, zs);
- 'Y' -> BIND (rdString zs) _TO_ (k, zs2) ->
- RETN (MachLitLit x (guessPrimKind k), zs2)
- BEND;
- 'I' -> RETN (NoRepInteger as_integer, zs);
- 's' -> RETN (NoRepStr x, zs)
- } BEND
+ returnUgn (NoRepRational (num % den))
+
+wlkBasicLit other
+ = returnUgn (
+ case other of
+ U_intprim s -> mkMachInt (as_integer s)
+ U_doubleprim s -> MachDouble (as_rational s)
+ U_floatprim s -> MachFloat (as_rational s)
+ U_charprim s -> MachChar (as_char s)
+ U_stringprim s -> MachStr (as_string s)
+
+ U_clitlit s k -> MachLitLit (as_string s) (guessPrimRep (_UNPK_ k))
+
+ U_norepi s -> NoRepInteger (as_integer s)
+ U_noreps s -> NoRepStr (as_string s)
+ )
+ where
+ as_char s = _HEAD_ s
+ as_integer s = readInteger (_UNPK_ s)
+ as_rational s = _readRational (_UNPK_ s) -- non-std
+ as_string s = s
\end{code}
projects / ghc-hetmet.git / blobdiff