diff options
Diffstat (limited to 'ghc/compiler/stgSyn')
| -rw-r--r-- | ghc/compiler/stgSyn/CoreToStg.hi | 23 | ||||
| -rw-r--r-- | ghc/compiler/stgSyn/CoreToStg.lhs | 698 | ||||
| -rw-r--r-- | ghc/compiler/stgSyn/Jmakefile | 5 | ||||
| -rw-r--r-- | ghc/compiler/stgSyn/StgFuns.hi | 7 | ||||
| -rw-r--r-- | ghc/compiler/stgSyn/StgFuns.lhs | 93 | ||||
| -rw-r--r-- | ghc/compiler/stgSyn/StgLint.hi | 16 | ||||
| -rw-r--r-- | ghc/compiler/stgSyn/StgLint.lhs | 541 | ||||
| -rw-r--r-- | ghc/compiler/stgSyn/StgSyn.hi | 443 | ||||
| -rw-r--r-- | ghc/compiler/stgSyn/StgSyn.lhs | 882 | ||||
| -rw-r--r-- | ghc/compiler/stgSyn/root.lit | 9 |
10 files changed, 2717 insertions, 0 deletions
diff --git a/ghc/compiler/stgSyn/CoreToStg.hi b/ghc/compiler/stgSyn/CoreToStg.hi new file mode 100644 index 0000000000..2aace5e401 --- /dev/null +++ b/ghc/compiler/stgSyn/CoreToStg.hi @@ -0,0 +1,23 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CoreToStg where +import BasicLit(BasicLit) +import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import PrimOps(PrimOp) +import SplitUniq(SplitUniqSupply) +import StgSyn(StgAtom, StgBinderInfo, StgBinding, StgExpr, StgRhs, UpdateFlag) +import TyVar(TyVar) +import UniType(UniType) +import Unique(Unique) +data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data StgBinderInfo {-# GHC_PRAGMA NoStgBinderInfo | StgBinderInfo Bool Bool Bool Bool Bool #-} +data StgBinding a b {-# GHC_PRAGMA StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] #-} +data StgRhs a b {-# GHC_PRAGMA StgRhsClosure CostCentre StgBinderInfo [b] UpdateFlag [a] (StgExpr a b) | StgRhsCon CostCentre Id [StgAtom b] #-} +topCoreBindsToStg :: SplitUniqSupply -> [CoreBinding Id Id] -> [StgBinding Id Id] + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(ALA)S" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs new file mode 100644 index 0000000000..4b21fb3a2a --- /dev/null +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -0,0 +1,698 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%************************************************************************ +%* * +\section[CoreToStg]{Converting core syntax to STG syntax} +%* * +%************************************************************************ + +Convert a @CoreSyntax@ program to a @StgSyntax@ program. + + +\begin{code} +#include "HsVersions.h" + +module CoreToStg ( + topCoreBindsToStg, + + -- and to make the interface self-sufficient... + SplitUniqSupply, Id, CoreExpr, CoreBinding, StgBinding, + StgRhs, StgBinderInfo + ) where + +import PlainCore -- input +import AnnCoreSyn -- intermediate form on which all work is done +import StgSyn -- output +import SplitUniq +import Unique -- the UniqueSupply monadery used herein + +import AbsPrel ( unpackCStringId, stringTy, + integerTy, rationalTy, ratioDataCon, + PrimOp(..), -- For Int2IntegerOp etc + integerZeroId, integerPlusOneId, integerMinusOneId + IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) + +import AbsUniType ( isPrimType, isLeakFreeType, getUniDataTyCon ) +import Bag -- Bag operations +import BasicLit ( mkMachInt, BasicLit(..), PrimKind ) -- ToDo: its use is ugly... +import CostCentre ( noCostCentre, CostCentre ) +import Id ( mkSysLocal, getIdUniType, isBottomingId + IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed) + ) +import IdEnv +import Maybes ( Maybe(..), catMaybes ) +import Outputable ( isExported ) +import Pretty -- debugging only! +import SpecTyFuns ( mkSpecialisedCon ) +import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) +import Util +\end{code} + + + *************** OVERVIEW ********************* + + +The business of this pass is to convert Core to Stg. On the way: + +* We discard type lambdas and applications. In so doing we discard + "trivial" bindings such as + x = y t1 t2 + where t1, t2 are types + +* We make the representation of NoRep literals explicit, and + float their bindings to the top level + +* We do *not* pin on the correct free/live var info; that's done later. + Instead we use bOGUS_LVS and _FVS as a placeholder. + +* We convert case x of {...; x' -> ...x'...} + to + case x of {...; _ -> ...x... } + + See notes in SimplCase.lhs, near simplDefault for the reasoning here. + + +%************************************************************************ +%* * +\subsection[coreToStg-programs]{Converting a core program and core bindings} +%* * +%************************************************************************ + +Because we're going to come across ``boring'' bindings like +\tr{let x = /\ tyvars -> y in ...}, we want to keep a small +environment, so we can just replace all occurrences of \tr{x} +with \tr{y}. + +\begin{code} +type StgEnv = IdEnv PlainStgAtom +\end{code} + +No free/live variable information is pinned on in this pass; it's added +later. For this pass +we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders. + +\begin{code} +bOGUS_LVs :: PlainStgLiveVars +bOGUS_LVs = panic "bOGUS_LVs" + +bOGUS_FVs :: [Id] +bOGUS_FVs = panic "bOGUS_FVs" +\end{code} + +\begin{code} +topCoreBindsToStg :: SplitUniqSupply -- name supply + -> [PlainCoreBinding] -- input + -> [PlainStgBinding] -- output + +topCoreBindsToStg us core_binds + = case (initSUs us (binds_to_stg nullIdEnv core_binds)) of + (_, stuff) -> stuff + where + binds_to_stg :: StgEnv -> [PlainCoreBinding] -> SUniqSM [PlainStgBinding] + + binds_to_stg env [] = returnSUs [] + binds_to_stg env (b:bs) + = do_top_bind env b `thenSUs` \ (new_b, new_env, float_binds) -> + binds_to_stg new_env bs `thenSUs` \ new_bs -> + returnSUs (bagToList float_binds ++ -- Literals + new_b ++ + new_bs) + + do_top_bind env bind@(CoRec pairs) + = coreBindToStg env bind + + do_top_bind env bind@(CoNonRec var rhs) + = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds) -> + + case stg_binds of + [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] -> + -- Mega-special case; there's still a binding there + -- no fvs (of course), *no args*, "let" rhs + let + (extra_float_binds, rhs_body') = seek_liftable [] rhs_body + in + returnSUs (extra_float_binds ++ + [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')], + new_env, + float_binds) + + other -> returnSUs (stg_binds, new_env, float_binds) + + -------------------- + -- HACK: look for very simple, obviously-liftable bindings + -- that can come up to the top level; those that couldn't + -- 'cause they were big-lambda constrained in the Core world. + + seek_liftable :: [PlainStgBinding] -- accumulator... + -> PlainStgExpr -- look for top-lev liftables + -> ([PlainStgBinding], PlainStgExpr) -- result + + seek_liftable acc expr@(StgLet inner_bind body) + | is_liftable inner_bind + = seek_liftable (inner_bind : acc) body + + seek_liftable acc other_expr = (reverse acc, other_expr) -- Finished + + -------------------- + is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body)) + = not (null args) -- it's manifestly a function... + || isLeakFreeType [] (getIdUniType binder) + || is_whnf body + -- ToDo: use a decent manifestlyWHNF function for STG? + where + is_whnf (StgConApp _ _ _) = True + is_whnf (StgApp (StgVarAtom v) _ _) = isBottomingId v + is_whnf other = False + + is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)]) + = not (null args) -- it's manifestly a (recursive) function... + + is_liftable anything_else = False +\end{code} + +%************************************************************************ +%* * +\subsection[coreToStg-binds]{Converting bindings} +%* * +%************************************************************************ + +\begin{code} +coreBindToStg :: StgEnv + -> PlainCoreBinding + -> SUniqSM ([PlainStgBinding], -- Empty or singleton + StgEnv, -- New envt + Bag PlainStgBinding) -- Floats + +coreBindToStg env (CoNonRec binder rhs) + = coreRhsToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) -> + + let + -- Binds to return if RHS is trivial + triv_binds = if isExported binder then + [StgNonRec binder stg_rhs] -- Retain it + else + [] -- Discard it + in + case stg_rhs of + StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) -> + -- Trivial RHS, so augment envt, and ditch the binding + returnSUs (triv_binds, new_env, rhs_binds) + where + new_env = addOneToIdEnv env binder atom + + StgRhsCon cc con_id [] -> + -- Trivial RHS, so augment envt, and ditch the binding + returnSUs (triv_binds, new_env, rhs_binds) + where + new_env = addOneToIdEnv env binder (StgVarAtom con_id) + + other -> -- Non-trivial RHS, so don't augment envt + returnSUs ([StgNonRec binder stg_rhs], env, rhs_binds) + +coreBindToStg env (CoRec pairs) + = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND **** + -- (possibly ToDo) + let + (binders, rhss) = unzip pairs + in + mapAndUnzipSUs (coreRhsToStg env) rhss `thenSUs` \ (stg_rhss, rhs_binds) -> + returnSUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds) +\end{code} + + +%************************************************************************ +%* * +\subsection[coreToStg-rhss]{Converting right hand sides} +%* * +%************************************************************************ + +\begin{code} +coreRhsToStg :: StgEnv -> PlainCoreExpr -> SUniqSM (PlainStgRhs, Bag PlainStgBinding) + +coreRhsToStg env core_rhs + = coreExprToStg env core_rhs `thenSUs` \ (stg_expr, stg_binds) -> + + let stg_rhs = case stg_expr of + StgLet (StgNonRec var1 rhs) (StgApp (StgVarAtom var2) [] _) + | var1 == var2 -> rhs + -- This curious stuff is to unravel what a lambda turns into + -- We have to do it this way, rather than spot a lambda in the + -- incoming rhs + + StgConApp con args _ -> StgRhsCon noCostCentre con args + + other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?) + stgArgOcc -- safe + bOGUS_FVs + Updatable -- Be pessimistic + [] + stg_expr + in + returnSUs (stg_rhs, stg_binds) +\end{code} + + +%************************************************************************ +%* * +\subsection[coreToStg-lits]{Converting literals} +%* * +%************************************************************************ + +Literals: the NoRep kind need to be de-no-rep'd. +We always replace them with a simple variable, and float a suitable +binding out to the top level. + +If an Integer is small enough (Haskell implementations must support +Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@; +otherwise, wrap with @litString2Integer@. + +\begin{code} +tARGET_MIN_INT, tARGET_MAX_INT :: Integer +tARGET_MIN_INT = -536870912 +tARGET_MAX_INT = 536870912 + +litToStgAtom :: BasicLit -> SUniqSM (PlainStgAtom, Bag PlainStgBinding) + +litToStgAtom (NoRepStr s) + = newStgVar stringTy `thenSUs` \ var -> + let + rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) + stgArgOcc -- safe + bOGUS_FVs + Updatable -- OLD: ReEntrant (see note below) + [] -- No arguments + val + +-- We used not to update strings, so that they wouldn't clog up the heap, +-- but instead be unpacked each time. But on some programs that costs a lot +-- [eg hpg], so now we update them. + + val = StgApp (StgVarAtom unpackCStringId) + [StgLitAtom (MachStr s)] + bOGUS_LVs + in + returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs)) + +litToStgAtom (NoRepInteger i) + -- extremely convenient to look out for a few very common + -- Integer literals! + | i == 0 = returnSUs (StgVarAtom integerZeroId, emptyBag) + | i == 1 = returnSUs (StgVarAtom integerPlusOneId, emptyBag) + | i == (-1) = returnSUs (StgVarAtom integerMinusOneId, emptyBag) + + | otherwise + = newStgVar integerTy `thenSUs` \ var -> + let + rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) + stgArgOcc -- safe + bOGUS_FVs + Updatable -- Update an integer + [] -- No arguments + val + + val + | i > tARGET_MIN_INT && i < tARGET_MAX_INT + = -- Start from an Int + StgPrimApp Int2IntegerOp [StgLitAtom (mkMachInt i)] bOGUS_LVs + + | otherwise + = -- Start from a string + StgPrimApp Addr2IntegerOp [StgLitAtom (MachStr (_PK_ (show i)))] bOGUS_LVs + in + returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs)) + +litToStgAtom (NoRepRational r) + = litToStgAtom (NoRepInteger (numerator r)) `thenSUs` \ (num_atom, binds1) -> + litToStgAtom (NoRepInteger (denominator r)) `thenSUs` \ (denom_atom, binds2) -> + newStgVar rationalTy `thenSUs` \ var -> + let + rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?) + ratioDataCon -- Constructor + [num_atom, denom_atom] + in + returnSUs (StgVarAtom var, binds1 `unionBags` + binds2 `unionBags` + unitBag (StgNonRec var rhs)) + +litToStgAtom other_lit = returnSUs (StgLitAtom other_lit, emptyBag) +\end{code} + + +%************************************************************************ +%* * +\subsection[coreToStg-atoms{Converting atoms} +%* * +%************************************************************************ + +\begin{code} +coreAtomToStg :: StgEnv -> PlainCoreAtom -> SUniqSM (PlainStgAtom, Bag PlainStgBinding) + +coreAtomToStg env (CoVarAtom var) = returnSUs (stgLookup env var, emptyBag) +coreAtomToStg env (CoLitAtom lit) = litToStgAtom lit +\end{code} + +There's not anything interesting we can ASSERT about \tr{var} if it +isn't in the StgEnv. (WDP 94/06) +\begin{code} +stgLookup :: StgEnv -> Id -> PlainStgAtom + +stgLookup env var = case (lookupIdEnv env var) of + Nothing -> StgVarAtom var + Just atom -> atom +\end{code} + +%************************************************************************ +%* * +\subsection[coreToStg-exprs]{Converting core expressions} +%* * +%************************************************************************ + +\begin{code} +coreExprToStg :: StgEnv + -> PlainCoreExpr + -> SUniqSM (PlainStgExpr, -- Result + Bag PlainStgBinding) -- Float these to top level +\end{code} + +\begin{code} +coreExprToStg env (CoLit lit) + = litToStgAtom lit `thenSUs` \ (atom, binds) -> + returnSUs (StgApp atom [] bOGUS_LVs, binds) + +coreExprToStg env (CoVar var) + = returnSUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag) + +coreExprToStg env (CoCon con types args) + = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) -> + returnSUs (StgConApp spec_con stg_atoms bOGUS_LVs, unionManyBags stg_binds) + where + spec_con = mkSpecialisedCon con types + +coreExprToStg env (CoPrim op tys args) + = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) -> + returnSUs (StgPrimApp op stg_atoms bOGUS_LVs, unionManyBags stg_binds) +\end{code} + +%************************************************************************ +%* * +\subsubsection[coreToStg-type-stuff]{Type application and abstraction} +%* * +%************************************************************************ + +This type information dies in this Core-to-STG translation. + +\begin{code} +coreExprToStg env (CoTyLam tyvar expr) = coreExprToStg env expr +coreExprToStg env (CoTyApp expr ty) = coreExprToStg env expr +\end{code} + +%************************************************************************ +%* * +\subsubsection[coreToStg-lambdas]{Lambda abstractions} +%* * +%************************************************************************ + +\begin{code} +coreExprToStg env expr@(CoLam binders body) + = coreExprToStg env body `thenSUs` \ (stg_body, binds) -> + newStgVar (typeOfCoreExpr expr) `thenSUs` \ var -> + returnSUs (StgLet (StgNonRec var (StgRhsClosure noCostCentre + stgArgOcc + bOGUS_FVs + ReEntrant -- binders is non-empty + binders + stg_body)) + (StgApp (StgVarAtom var) [] bOGUS_LVs), + binds) +\end{code} + +%************************************************************************ +%* * +\subsubsection[coreToStg-applications]{Applications} +%* * +%************************************************************************ + +\begin{code} +coreExprToStg env expr@(CoApp _ _) + = -- Deal with the arguments + mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_args, arg_binds) -> + + -- Now deal with the function + case fun of + CoVar fun_id -> returnSUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, + unionManyBags arg_binds) + + other -> -- A non-variable applied to things; better let-bind it. + newStgVar (typeOfCoreExpr fun) `thenSUs` \ fun_id -> + coreExprToStg env fun `thenSUs` \ (stg_fun, fun_binds) -> + let + fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) + stgArgOcc + bOGUS_FVs + SingleEntry -- Only entered once + [] + stg_fun + in + returnSUs (StgLet (StgNonRec fun_id fun_rhs) + (StgApp (StgVarAtom fun_id) stg_args bOGUS_LVs), + unionManyBags arg_binds `unionBags` + fun_binds) + where + (fun,args) = collect_args expr [] + + -- Collect arguments, discarding type applications + collect_args (CoApp fun arg) args = collect_args fun (arg:args) + collect_args (CoTyApp e t) args = collect_args e args + collect_args fun args = (fun, args) +\end{code} + +%************************************************************************ +%* * +\subsubsection[coreToStg-cases]{Case expressions} +%* * +%************************************************************************ + +At this point, we *mangle* cases involving fork# and par# in the +discriminant. The original templates for these primops (see +@PrelVals.lhs@) constructed case expressions with boolean results +solely to fool the strictness analyzer, the simplifier, and anyone +else who might want to fool with the evaluation order. Now, we +believe that once the translation to STG code is performed, our +evaluation order is safe. Therefore, we convert expressions of the +form: + + case par# e of + True -> rhs + False -> parError# + +to + + case par# e of + _ -> rhs + +\begin{code} + +coreExprToStg env (CoCase discrim@(CoPrim op tys args) alts) + | funnyParallelOp op = + getSUnique `thenSUs` \ uniq -> + coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) -> + alts_to_stg alts `thenSUs` \ (stg_alts, alts_binds) -> + returnSUs ( + StgCase stg_discrim + bOGUS_LVs + bOGUS_LVs + uniq + stg_alts, + discrim_binds `unionBags` alts_binds + ) + where + funnyParallelOp SeqOp = True + funnyParallelOp ParOp = True + funnyParallelOp ForkOp = True + funnyParallelOp _ = False + + discrim_ty = typeOfCoreExpr discrim + + alts_to_stg (CoPrimAlts _ (CoBindDefault binder rhs)) + = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) -> + let + stg_deflt = StgBindDefault binder False stg_rhs + in + returnSUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds) + +-- OK, back to real life... + +coreExprToStg env (CoCase discrim alts) + = coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) -> + alts_to_stg discrim alts `thenSUs` \ (stg_alts, alts_binds) -> + getSUnique `thenSUs` \ uniq -> + returnSUs ( + StgCase stg_discrim + bOGUS_LVs + bOGUS_LVs + uniq + stg_alts, + discrim_binds `unionBags` alts_binds + ) + where + discrim_ty = typeOfCoreExpr discrim + (_, discrim_ty_args, _) = getUniDataTyCon discrim_ty + + alts_to_stg discrim (CoAlgAlts alts deflt) + = default_to_stg discrim deflt `thenSUs` \ (stg_deflt, deflt_binds) -> + mapAndUnzipSUs boxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) -> + returnSUs (StgAlgAlts discrim_ty stg_alts stg_deflt, + deflt_binds `unionBags` unionManyBags alts_binds) + where + boxed_alt_to_stg (con, bs, rhs) + = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) -> + returnSUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs), + rhs_binds) + where + spec_con = mkSpecialisedCon con discrim_ty_args + + alts_to_stg discrim (CoPrimAlts alts deflt) + = default_to_stg discrim deflt `thenSUs` \ (stg_deflt,deflt_binds) -> + mapAndUnzipSUs unboxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) -> + returnSUs (StgPrimAlts discrim_ty stg_alts stg_deflt, + deflt_binds `unionBags` unionManyBags alts_binds) + where + unboxed_alt_to_stg (lit, rhs) + = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) -> + returnSUs ((lit, stg_rhs), rhs_binds) + +#ifdef DPH + alts_to_stg (CoParAlgAlts tycon ctxt params alts deflt) + = default_to_stg deflt `thenSUs` \ stg_deflt -> + mapSUs boxed_alt_to_stg alts `thenSUs` \ stg_alts -> + returnSUs (StgParAlgAlts discrim_ty ctxt params stg_alts stg_deflt) + where + boxed_alt_to_stg (con, rhs) + = coreExprToStg env rhs `thenSUs` \ stg_rhs -> + returnSUs (con, stg_rhs) + + alts_to_stg (CoParPrimAlts tycon ctxt alts deflt) + = default_to_stg deflt `thenSUs` \ stg_deflt -> + mapSUs unboxed_alt_to_stg alts `thenSUs` \ stg_alts -> + returnSUs (StgParPrimAlts discrim_ty ctxt stg_alts stg_deflt) + where + unboxed_alt_to_stg (lit, rhs) + = coreExprToStg env rhs `thenSUs` \ stg_rhs -> + returnSUs (lit, stg_rhs) +#endif {- Data Parallel Haskell -} + + default_to_stg discrim CoNoDefault + = returnSUs (StgNoDefault, emptyBag) + + default_to_stg discrim (CoBindDefault binder rhs) + = coreExprToStg new_env rhs `thenSUs` \ (stg_rhs, rhs_binds) -> + returnSUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs, + rhs_binds) + where + + + -- We convert case x of {...; x' -> ...x'...} + -- to + -- case x of {...; _ -> ...x... } + -- + -- See notes in SimplCase.lhs, near simplDefault for the reasoning. + -- It's quite easily done: simply extend the environment to bind the + -- default binder to the scrutinee. + -- + new_env = case discrim of + CoVar v -> addOneToIdEnv env binder (StgVarAtom v) + other -> env +\end{code} + +%************************************************************************ +%* * +\subsubsection[coreToStg-let(rec)]{Let and letrec expressions} +%* * +%************************************************************************ + +\begin{code} +coreExprToStg env (CoLet bind body) + = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds1) -> + coreExprToStg new_env body `thenSUs` \ (stg_body, float_binds2) -> + returnSUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2) +\end{code} + + +%************************************************************************ +%* * +\subsubsection[coreToStg-scc]{SCC expressions} +%* * +%************************************************************************ + +Covert core @scc@ expression directly to STG @scc@ expression. +\begin{code} +coreExprToStg env (CoSCC cc expr) + = coreExprToStg env expr `thenSUs` \ (stg_expr, binds) -> + returnSUs (StgSCC (typeOfCoreExpr expr) cc stg_expr, binds) +\end{code} + +%************************************************************************ +%* * +\subsubsection[coreToStg-dataParallel]{Data Parallel expressions} +%* * +%************************************************************************ +\begin{code} +#ifdef DPH +coreExprToStg env (_, AnnCoParCon con ctxt types args) + = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) -> + returnSUs (mkStgLets (catMaybes stg_binds) + (StgParConApp con ctxt stg_atoms bOGUS_LVs)) + +coreExprToStg env (_,AnnCoParComm ctxt expr comm) + = coreExprToStg env expr `thenSUs` \ stg_expr -> + annComm_to_stg comm `thenSUs` \ (stg_comm,stg_binds) -> + returnSUs (mkStgLets (catMaybes stg_binds) + (StgParComm ctxt stg_expr stg_comm)) + )) + where + annComm_to_stg (AnnCoParSend args) + = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) -> + returnSUs (StgParSend stg_atoms,stg_binds) + + annComm_to_stg (AnnCoParFetch args) + = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) -> + returnSUs (StgParFetch stg_atoms,stg_binds) + + annComm_to_stg (AnnCoToPodized) + = returnSUs (StgToPodized,[]) + annComm_to_stg (AnnCoFromPodized) + = returnSUs (StgFromPodized,[]) +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +coreExprToStg env other = panic "coreExprToStg: it really failed here" +\end{code} + +%************************************************************************ +%* * +\subsection[coreToStg-misc]{Miscellaneous helping functions} +%* * +%************************************************************************ + +Utilities. + +Invent a fresh @Id@: +\begin{code} +newStgVar :: UniType -> SUniqSM Id +newStgVar ty + = getSUnique `thenSUs` \ uniq -> + returnSUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc) +\end{code} + +\begin{code} +mkStgLets :: [PlainStgBinding] + -> PlainStgExpr -- body of let + -> PlainStgExpr + +mkStgLets binds body = foldr StgLet body binds +\end{code} diff --git a/ghc/compiler/stgSyn/Jmakefile b/ghc/compiler/stgSyn/Jmakefile new file mode 100644 index 0000000000..32b8199f6a --- /dev/null +++ b/ghc/compiler/stgSyn/Jmakefile @@ -0,0 +1,5 @@ +/* this is a standalone Jmakefile; NOT part of ghc "make world" */ + +/*LIT2LATEX_OPTS=-ttgrind*/ + +LitDocRootTarget(root,lit) diff --git a/ghc/compiler/stgSyn/StgFuns.hi b/ghc/compiler/stgSyn/StgFuns.hi new file mode 100644 index 0000000000..83ce7be440 --- /dev/null +++ b/ghc/compiler/stgSyn/StgFuns.hi @@ -0,0 +1,7 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StgFuns where +import Id(Id) +import StgSyn(StgRhs) +mapStgBindeesRhs :: (Id -> Id) -> StgRhs Id Id -> StgRhs Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/stgSyn/StgFuns.lhs b/ghc/compiler/stgSyn/StgFuns.lhs new file mode 100644 index 0000000000..8dd3f877c2 --- /dev/null +++ b/ghc/compiler/stgSyn/StgFuns.lhs @@ -0,0 +1,93 @@ +x% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[StgFuns]{Utility functions for @STG@ programs} + +\begin{code} +#include "HsVersions.h" + +module StgFuns ( + mapStgBindeesRhs + ) where + +import StgSyn + +import UniqSet +import Unique + +import Util +\end{code} + +This utility function simply applies the given function to every +bindee in the program. + +\begin{code} +mapStgBindeesBind :: (Id -> Id) -> PlainStgBinding -> PlainStgBinding + +mapStgBindeesBind fn (StgNonRec b rhs) = StgNonRec b (mapStgBindeesRhs fn rhs) +mapStgBindeesBind fn (StgRec pairs) = StgRec [ (b, mapStgBindeesRhs fn r) | (b, r) <- pairs ] + +------------------ +mapStgBindeesRhs :: (Id -> Id) -> PlainStgRhs -> PlainStgRhs + +mapStgBindeesRhs fn (StgRhsClosure cc bi fvs u args expr) + = StgRhsClosure + cc bi + (map fn fvs) + u + (map fn args) + (mapStgBindeesExpr fn expr) + +mapStgBindeesRhs fn (StgRhsCon cc con atoms) + = StgRhsCon cc con (map (mapStgBindeesAtom fn) atoms) + +------------------ +mapStgBindeesExpr :: (Id -> Id) -> PlainStgExpr -> PlainStgExpr + +mapStgBindeesExpr fn (StgApp f args lvs) + = StgApp (mapStgBindeesAtom fn f) + (map (mapStgBindeesAtom fn) args) + (mapUniqSet fn lvs) + +mapStgBindeesExpr fn (StgConApp con atoms lvs) + = StgConApp con (map (mapStgBindeesAtom fn) atoms) (mapUniqSet fn lvs) + +mapStgBindeesExpr fn (StgPrimApp op atoms lvs) + = StgPrimApp op (map (mapStgBindeesAtom fn) atoms) (mapUniqSet fn lvs) + +mapStgBindeesExpr fn (StgLet bind expr) + = StgLet (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn expr) + +mapStgBindeesExpr fn (StgLetNoEscape lvs rhss_lvs bind body) + = StgLetNoEscape (mapUniqSet fn lvs) (mapUniqSet fn rhss_lvs) + (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn body) + +mapStgBindeesExpr fn (StgSCC ty label expr) + = StgSCC ty label (mapStgBindeesExpr fn expr) + +mapStgBindeesExpr fn (StgCase expr lvs1 lvs2 uniq alts) + = StgCase (mapStgBindeesExpr fn expr) + (mapUniqSet fn lvs1) + (mapUniqSet fn lvs2) + uniq + (mapStgBindeesAlts alts) + where + mapStgBindeesAlts (StgAlgAlts ty alts deflt) + = StgAlgAlts ty (map mapStgBindeesBoxed_alt alts) (mapStgBindeesDeflt deflt) + where + mapStgBindeesBoxed_alt (c,ps,use_mask,expr) = (c,ps,use_mask,mapStgBindeesExpr fn expr) + + mapStgBindeesAlts (StgPrimAlts ty alts deflt) + = StgPrimAlts ty (map mapStgBindeesunboxed_alt alts) (mapStgBindeesDeflt deflt) + where + mapStgBindeesunboxed_alt (l,expr) = (l,mapStgBindeesExpr fn expr) + + mapStgBindeesDeflt StgNoDefault = StgNoDefault + mapStgBindeesDeflt (StgBindDefault b used expr) = StgBindDefault b used (mapStgBindeesExpr fn expr) + +------------------ +mapStgBindeesAtom :: (Id -> Id) -> PlainStgAtom -> PlainStgAtom + +mapStgBindeesAtom fn a@(StgLitAtom _) = a +mapStgBindeesAtom fn a@(StgVarAtom id) = StgVarAtom (fn id) +\end{code} diff --git a/ghc/compiler/stgSyn/StgLint.hi b/ghc/compiler/stgSyn/StgLint.hi new file mode 100644 index 0000000000..0bf1754525 --- /dev/null +++ b/ghc/compiler/stgSyn/StgLint.hi @@ -0,0 +1,16 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StgLint where +import CmdLineOpts(GlobalSwitch) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Pretty(PprStyle) +import StgSyn(PlainStgBinding(..), StgBinding, StgRhs) +import UniType(UniType) +import Unique(Unique) +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type PlainStgBinding = StgBinding Id Id +data StgBinding a b {-# GHC_PRAGMA StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] #-} +lintStgBindings :: PprStyle -> [Char] -> [StgBinding Id Id] -> [StgBinding Id Id] + {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LLS" _N_ _N_ #-} + diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs new file mode 100644 index 0000000000..9f1e5ba651 --- /dev/null +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -0,0 +1,541 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[StgLint]{A ``lint'' pass to check for Stg correctness} + +\begin{code} +#include "HsVersions.h" + +module StgLint ( + lintStgBindings, + + PprStyle, StgBinding, PlainStgBinding(..), Id + ) where + +IMPORT_Trace + +import AbsPrel ( typeOfPrimOp, mkFunTy, PrimOp(..), PrimKind + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType +import Bag +import BasicLit ( typeOfBasicLit, BasicLit ) +import Id ( getIdUniType, isNullaryDataCon, isDataCon, + isBottomingId, + getInstantiatedDataConSig, Id + IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed) + ) +import Maybes +import Outputable +import Pretty +import SrcLoc ( SrcLoc ) +import StgSyn +import UniqSet +import Util + +infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_` +\end{code} + +Checks for + (a) *some* type errors + (b) locally-defined variables used but not defined + +%************************************************************************ +%* * +\subsection{``lint'' for various constructs} +%* * +%************************************************************************ + +@lintStgBindings@ is the top-level interface function. + +\begin{code} +lintStgBindings :: PprStyle -> String -> [PlainStgBinding] -> [PlainStgBinding] + +lintStgBindings sty whodunnit binds + = BSCC("StgLint") + case (initL (lint_binds binds)) of + Nothing -> binds + Just msg -> pprPanic "" (ppAboves [ + ppStr ("*** Stg Lint Errors: in "++whodunnit++" ***"), + msg sty, + ppStr "*** Offending Program ***", + ppAboves (map (pprPlainStgBinding sty) binds), + ppStr "*** End of Offense ***"]) + ESCC + where + lint_binds :: [PlainStgBinding] -> LintM () + + lint_binds [] = returnL () + lint_binds (bind:binds) + = lintStgBinds bind `thenL` \ binders -> + addInScopeVars binders ( + lint_binds binds + ) +\end{code} + + +\begin{code} +lintStgAtom :: PlainStgAtom -> LintM (Maybe UniType) + +lintStgAtom (StgLitAtom lit) = returnL (Just (typeOfBasicLit lit)) +lintStgAtom a@(StgVarAtom v) + = checkInScope v `thenL_` + returnL (Just (getIdUniType v)) +\end{code} + +\begin{code} +lintStgBinds :: PlainStgBinding -> LintM [Id] -- Returns the binders +lintStgBinds (StgNonRec binder rhs) + = lint_binds_help (binder,rhs) `thenL_` + returnL [binder] + +lintStgBinds (StgRec pairs) + = addInScopeVars binders ( + mapL lint_binds_help pairs `thenL_` + returnL binders + ) + where + binders = [b | (b,_) <- pairs] + +lint_binds_help (binder, rhs) + = addLoc (RhsOf binder) ( + -- Check the rhs + lintStgRhs rhs `thenL` \ maybe_rhs_ty -> + + -- Check match to RHS type + (case maybe_rhs_ty of + Nothing -> returnL () + Just rhs_ty -> checkTys (getIdUniType binder) + rhs_ty + (mkRhsMsg binder rhs_ty) + ) `thenL_` + + returnL () + ) +\end{code} + +\begin{code} +lintStgRhs :: PlainStgRhs -> LintM (Maybe UniType) + +lintStgRhs (StgRhsClosure _ _ _ _ binders expr) + = addLoc (LambdaBodyOf binders) ( + addInScopeVars binders ( + lintStgExpr expr `thenMaybeL` \ body_ty -> + returnL (Just (foldr (mkFunTy . getIdUniType) body_ty binders)) + )) + +lintStgRhs (StgRhsCon _ con args) + = mapMaybeL lintStgAtom args `thenL` \ maybe_arg_tys -> + case maybe_arg_tys of + Nothing -> returnL Nothing + Just arg_tys -> checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys) + where + con_ty = getIdUniType con +\end{code} + +\begin{code} +lintStgExpr :: PlainStgExpr -> LintM (Maybe UniType) -- Nothing if error found + +lintStgExpr e@(StgApp fun args _) + = lintStgAtom fun `thenMaybeL` \ fun_ty -> + mapMaybeL lintStgAtom args `thenL` \ maybe_arg_tys -> + case maybe_arg_tys of + Nothing -> returnL Nothing + Just arg_tys -> checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e) + +lintStgExpr e@(StgConApp con args _) + = mapMaybeL lintStgAtom args `thenL` \ maybe_arg_tys -> + case maybe_arg_tys of + Nothing -> returnL Nothing + Just arg_tys -> checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e) + where + con_ty = getIdUniType con + +lintStgExpr e@(StgPrimApp op args _) + = mapMaybeL lintStgAtom args `thenL` \ maybe_arg_tys -> + case maybe_arg_tys of + Nothing -> returnL Nothing + Just arg_tys -> checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e) + where + op_ty = typeOfPrimOp op + +lintStgExpr (StgLet binds body) + = lintStgBinds binds `thenL` \ binders -> + addLoc (BodyOfLetRec binders) ( + addInScopeVars binders ( + lintStgExpr body + )) + +lintStgExpr (StgLetNoEscape _ _ binds body) + = lintStgBinds binds `thenL` \ binders -> + addLoc (BodyOfLetRec binders) ( + addInScopeVars binders ( + lintStgExpr body + )) + +lintStgExpr (StgSCC _ _ expr) = lintStgExpr expr + +lintStgExpr e@(StgCase scrut _ _ _ alts) + = lintStgExpr scrut `thenMaybeL` \ _ -> + + -- Check that it is a data type + case getUniDataTyCon_maybe scrut_ty of + Nothing -> addErrL (mkCaseDataConMsg e) `thenL_` + returnL Nothing + Just (tycon, _, _) + -> lintStgAlts alts scrut_ty tycon + where + scrut_ty = get_ty alts + + get_ty (StgAlgAlts ty _ _) = ty + get_ty (StgPrimAlts ty _ _) = ty +\end{code} + +\begin{code} +lintStgAlts :: PlainStgCaseAlternatives + -> UniType -- Type of scrutinee + -> TyCon -- TyCon pinned on the case + -> LintM (Maybe UniType) -- Type of alternatives + +lintStgAlts alts scrut_ty case_tycon + = (case alts of + StgAlgAlts _ alg_alts deflt -> + chk_non_abstract_type case_tycon `thenL_` + mapL (lintAlgAlt scrut_ty) alg_alts `thenL` \ maybe_alt_tys -> + lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty -> + returnL (maybe_deflt_ty : maybe_alt_tys) + + StgPrimAlts _ prim_alts deflt -> + mapL (lintPrimAlt scrut_ty) prim_alts `thenL` \ maybe_alt_tys -> + lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty -> + returnL (maybe_deflt_ty : maybe_alt_tys) + ) `thenL` \ maybe_result_tys -> + -- Check the result types + case catMaybes (maybe_result_tys) of + [] -> returnL Nothing + + (first_ty:tys) -> mapL check tys `thenL_` + returnL (Just first_ty) + where + check ty = checkTys first_ty ty (mkCaseAltMsg alts) + where + chk_non_abstract_type tycon + = case (getTyConFamilySize tycon) of + Nothing -> addErrL (mkCaseAbstractMsg tycon) + Just _ -> returnL () -- that's cool + +lintAlgAlt scrut_ty (con, args, _, rhs) + = (case getUniDataTyCon_maybe scrut_ty of + Nothing -> + addErrL (mkAlgAltMsg1 scrut_ty) + Just (tycon, tys_applied, cons) -> + let + (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied + in + checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_` + checkL (length arg_tys == length args) (mkAlgAltMsg3 con args) + `thenL_` + mapL check (arg_tys `zipEqual` args) `thenL_` + returnL () + ) `thenL_` + addInScopeVars args ( + lintStgExpr rhs + ) + where + check (ty, arg) = checkTys ty (getIdUniType arg) (mkAlgAltMsg4 ty arg) + + -- elem: yes, the elem-list here can sometimes be long-ish, + -- but as it's use-once, probably not worth doing anything different + -- We give it its own copy, so it isn't overloaded. + elem _ [] = False + elem x (y:ys) = x==y || elem x ys + +lintPrimAlt scrut_ty alt@(lit,rhs) + = checkTys (typeOfBasicLit lit) scrut_ty (mkPrimAltMsg alt) `thenL_` + lintStgExpr rhs + +lintDeflt StgNoDefault scrut_ty = returnL Nothing +lintDeflt deflt@(StgBindDefault binder _ rhs) scrut_ty + = checkTys (getIdUniType binder) scrut_ty (mkDefltMsg deflt) `thenL_` + addInScopeVars [binder] ( + lintStgExpr rhs + ) +\end{code} + + +%************************************************************************ +%* * +\subsection[lint-monad]{The Lint monad} +%* * +%************************************************************************ + +\begin{code} +type LintM a = [LintLocInfo] -- Locations + -> UniqSet Id -- Local vars in scope + -> Bag ErrMsg -- Error messages so far + -> (a, Bag ErrMsg) -- Result and error messages (if any) + +type ErrMsg = PprStyle -> Pretty + +data LintLocInfo + = RhsOf Id -- The variable bound + | LambdaBodyOf [Id] -- The lambda-binder + | BodyOfLetRec [Id] -- One of the binders + +instance Outputable LintLocInfo where + ppr sty (RhsOf v) + = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"] + + ppr sty (LambdaBodyOf bs) + = ppBesides [ppr sty (getSrcLoc (head bs)), + ppStr ": [in body of lambda with binders ", pp_binders sty bs, ppStr "]"] + + ppr sty (BodyOfLetRec bs) + = ppBesides [ppr sty (getSrcLoc (head bs)), + ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"] + +pp_binders :: PprStyle -> [Id] -> Pretty +pp_binders sty bs + = ppInterleave ppComma (map pp_binder bs) + where + pp_binder b + = ppCat [ppr sty b, ppStr "::", ppr sty (getIdUniType b)] +\end{code} + +\begin{code} +initL :: LintM a -> Maybe ErrMsg +initL m + = case (m [] emptyUniqSet emptyBag) of { (_, errs) -> + if isEmptyBag errs then + Nothing + else + Just ( \ sty -> + ppAboves [ msg sty | msg <- bagToList errs ] + ) + } + +returnL :: a -> LintM a +returnL r loc scope errs = (r, errs) + +thenL :: LintM a -> (a -> LintM b) -> LintM b +thenL m k loc scope errs + = case m loc scope errs of + (r, errs') -> k r loc scope errs' + +thenL_ :: LintM a -> LintM b -> LintM b +thenL_ m k loc scope errs + = case m loc scope errs of + (_, errs') -> k loc scope errs' + +thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b) +thenMaybeL m k loc scope errs + = case m loc scope errs of + (Nothing, errs2) -> (Nothing, errs2) + (Just r, errs2) -> k r loc scope errs2 + +thenMaybeL_ :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b) +thenMaybeL_ m k loc scope errs + = case m loc scope errs of + (Nothing, errs2) -> (Nothing, errs2) + (Just _, errs2) -> k loc scope errs2 + +mapL :: (a -> LintM b) -> [a] -> LintM [b] +mapL f [] = returnL [] +mapL f (x:xs) + = f x `thenL` \ r -> + mapL f xs `thenL` \ rs -> + returnL (r:rs) + +mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b]) + -- Returns Nothing if anything fails +mapMaybeL f [] = returnL (Just []) +mapMaybeL f (x:xs) + = f x `thenMaybeL` \ r -> + mapMaybeL f xs `thenMaybeL` \ rs -> + returnL (Just (r:rs)) +\end{code} + +\begin{code} +checkL :: Bool -> ErrMsg -> LintM () +checkL True msg loc scope errs = ((), errs) +checkL False msg loc scope errs = ((), addErr errs msg loc) + +addErrL :: ErrMsg -> LintM () +addErrL msg loc scope errs = ((), addErr errs msg loc) + +addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg + +addErr errs_so_far msg locs + = errs_so_far `snocBag` ( \ sty -> + ppHang (ppr sty (head locs)) 4 (msg sty) + ) + +addLoc :: LintLocInfo -> LintM a -> LintM a +addLoc extra_loc m loc scope errs + = m (extra_loc:loc) scope errs + +addInScopeVars :: [Id] -> LintM a -> LintM a +addInScopeVars ids m loc scope errs + = -- We check if these "new" ids are already + -- in scope, i.e., we have *shadowing* going on. + -- For now, it's just a "trace"; we may make + -- a real error out of it... + let + new_set = mkUniqSet ids + + shadowed = scope `intersectUniqSets` new_set + in +-- After adding -fliberate-case, Simon decided he likes shadowed +-- names after all. WDP 94/07 +-- (if isEmptyUniqSet shadowed +-- then id +-- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) ( + m loc (scope `unionUniqSets` new_set) errs +-- ) +\end{code} + +\begin{code} +checkFunApp :: UniType -- The function type + -> [UniType] -- The arg type(s) + -> ErrMsg -- Error messgae + -> LintM (Maybe UniType) -- The result type + +checkFunApp fun_ty arg_tys msg loc scope errs + = cfa res_ty expected_arg_tys arg_tys + where + (_, expected_arg_tys, res_ty) = splitTypeWithDictsAsArgs fun_ty + + cfa res_ty expected [] -- Args have run out; that's fine + = (Just (glueTyArgs expected res_ty), errs) + + cfa res_ty [] arg_tys -- Expected arg tys ran out first; + -- first see if res_ty is a tyvar template; + -- otherwise, maybe res_ty is a + -- dictionary type which is actually a function? + | isTyVarTemplateTy res_ty + = (Just res_ty, errs) + | otherwise + = case splitTyArgs (unDictifyTy res_ty) of + ([], _) -> (Nothing, addErr errs msg loc) -- Too many args + (new_expected, new_res) -> cfa new_res new_expected arg_tys + + cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys) + = case (sleazy_cmp_ty expected_arg_ty arg_ty) of + EQ_ -> cfa res_ty expected_arg_tys arg_tys + _ -> (Nothing, addErr errs msg loc) -- Arg mis-match +\end{code} + +\begin{code} +checkInScope :: Id -> LintM () +checkInScope id loc scope errs + = if isLocallyDefined id && not (isDataCon id) && not (id `elementOfUniqSet` scope) then + ((), addErr errs (\ sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc) + else + ((), errs) + +checkTys :: UniType -> UniType -> ErrMsg -> LintM () +checkTys ty1 ty2 msg loc scope errs + = case (sleazy_cmp_ty ty1 ty2) of + EQ_ -> ((), errs) + other -> ((), addErr errs msg loc) +\end{code} + +\begin{code} +mkCaseAltMsg :: PlainStgCaseAlternatives -> ErrMsg +mkCaseAltMsg alts sty + = ppAbove (ppStr "In some case alternatives, type of alternatives not all same:") + -- LATER: (ppr sty alts) + (panic "mkCaseAltMsg") + +mkCaseDataConMsg :: PlainStgExpr -> ErrMsg +mkCaseDataConMsg expr sty + = ppAbove (ppStr "A case scrutinee not a type-constructor type:") + (pp_expr sty expr) + +mkCaseAbstractMsg :: TyCon -> ErrMsg +mkCaseAbstractMsg tycon sty + = ppAbove (ppStr "An algebraic case on an abstract type:") + (ppr sty tycon) + +mkDefltMsg :: PlainStgCaseDefault -> ErrMsg +mkDefltMsg deflt sty + = ppAbove (ppStr "Binder in default case of a case expression doesn't match type of scrutinee:") + --LATER: (ppr sty deflt) + (panic "mkDefltMsg") + +mkFunAppMsg :: UniType -> [UniType] -> PlainStgExpr -> ErrMsg +mkFunAppMsg fun_ty arg_tys expr sty + = ppAboves [ppStr "In a function application, function type doesn't match arg types:", + ppHang (ppStr "Function type:") 4 (ppr sty fun_ty), + ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys)), + ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] + +mkRhsConMsg :: UniType -> [UniType] -> ErrMsg +mkRhsConMsg fun_ty arg_tys sty + = ppAboves [ppStr "In a RHS constructor application, con type doesn't match arg types:", + ppHang (ppStr "Constructor type:") 4 (ppr sty fun_ty), + ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys))] + +mkUnappTyMsg :: Id -> UniType -> ErrMsg +mkUnappTyMsg var ty sty + = ppAboves [ppStr "Variable has a for-all type, but isn't applied to any types.", + ppBeside (ppStr "Var: ") (ppr sty var), + ppBeside (ppStr "Its type: ") (ppr sty ty)] + +mkAlgAltMsg1 :: UniType -> ErrMsg +mkAlgAltMsg1 ty sty + = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:") + (ppr sty ty) + +mkAlgAltMsg2 :: UniType -> Id -> ErrMsg +mkAlgAltMsg2 ty con sty + = ppAboves [ + ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", + ppr sty ty, + ppr sty con + ] + +mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg +mkAlgAltMsg3 con alts sty + = ppAboves [ + ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:", + ppr sty con, + ppr sty alts + ] + +mkAlgAltMsg4 :: UniType -> Id -> ErrMsg +mkAlgAltMsg4 ty arg sty + = ppAboves [ + ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:", + ppr sty ty, + ppr sty arg + ] + +mkPrimAltMsg :: (BasicLit, PlainStgExpr) -> ErrMsg +mkPrimAltMsg alt sty + = ppAbove (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:") + (ppr sty alt) + +mkRhsMsg :: Id -> UniType -> ErrMsg +mkRhsMsg binder ty sty + = ppAboves [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:", + ppr sty binder], + ppCat [ppStr "Binder's type:", ppr sty (getIdUniType binder)], + ppCat [ppStr "Rhs type:", ppr sty ty] + ] + +pp_expr :: PprStyle -> PlainStgExpr -> Pretty +pp_expr sty expr = ppr sty expr + +sleazy_cmp_ty ty1 ty2 + -- NB: probably severe overkill (WDP 95/04) + = case (splitTypeWithDictsAsArgs ty1) of { (_,tyargs1,tyres1) -> + case (splitTypeWithDictsAsArgs ty2) of { (_,tyargs2,tyres2) -> + let + ty11 = glueTyArgs tyargs1 tyres1 + ty22 = glueTyArgs tyargs2 tyres2 + in + cmpUniType False{-!!!NOT PROPERLY!!!-} ty11 ty22 + }} +\end{code} diff --git a/ghc/compiler/stgSyn/StgSyn.hi b/ghc/compiler/stgSyn/StgSyn.hi new file mode 100644 index 0000000000..31c584eeb5 --- /dev/null +++ b/ghc/compiler/stgSyn/StgSyn.hi @@ -0,0 +1,443 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StgSyn where +import Bag(Bag) +import BasicLit(BasicLit, isLitLitLit) +import CharSeq(CSeq) +import Class(Class, ClassOp, cmpClass) +import CmdLineOpts(GlobalSwitch) +import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC) +import HsBinds(Bind, Binds, Sig) +import HsExpr(ArithSeqInfo, Expr, Qual) +import HsLit(Literal) +import HsMatches(GRHS, GRHSsAndBinds, Match) +import HsPat(InPat) +import HsTypes(PolyType) +import Id(Id, IdDetails) +import IdEnv(IdEnv(..)) +import IdInfo(ArgUsageInfo, ArityInfo, DeforestInfo, DemandInfo, FBTypeInfo, IdInfo, SpecEnv, StrictnessInfo, UpdateInfo) +import Inst(Inst) +import InstEnv(InstTemplate) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, Provenance, ShortName) +import Outputable(ExportFlag, NamedThing(..), Outputable(..)) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SimplEnv(UnfoldingDetails) +import SrcLoc(SrcLoc) +import TyCon(TyCon, cmpTyCon) +import TyVar(TyVar, TyVarTemplate, cmpTyVar) +import TyVarEnv(TyVarEnv(..)) +import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType, cmpUniType) +import UniqFM(UniqFM) +import UniqSet(UniqSet(..)) +import Unique(Unique) +class NamedThing a where + getExportFlag :: a -> ExportFlag + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-} + isLocallyDefined :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-} + getOrigName :: a -> (_PackedString, _PackedString) + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-} + getOccurrenceName :: a -> _PackedString + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-} + getInformingModules :: a -> [_PackedString] + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-} + getSrcLoc :: a -> SrcLoc + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-} + getTheUnique :: a -> Unique + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-} + hasType :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-} + getType :: a -> UniType + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-} + fromPreludeCore :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-} +class Outputable a where + ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_ + {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-} +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-} +data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-} +data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-} +data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-} +data GRHS a b {-# GHC_PRAGMA GRHS (Expr a b) (Expr a b) SrcLoc | OtherwiseGRHS (Expr a b) SrcLoc #-} +data GRHSsAndBinds a b {-# GHC_PRAGMA GRHSsAndBindsIn [GRHS a b] (Binds a b) | GRHSsAndBindsOut [GRHS a b] (Binds a b) UniType #-} +data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type IdEnv a = UniqFM a +data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-} +data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-} +data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-} +type PlainStgAtom = StgAtom Id +type PlainStgBinding = StgBinding Id Id +type PlainStgCaseAlternatives = StgCaseAlternatives Id Id +type PlainStgCaseDefault = StgCaseDefault Id Id +type PlainStgExpr = StgExpr Id Id +type PlainStgLiveVars = UniqFM Id +type PlainStgProgram = [StgBinding Id Id] +type PlainStgRhs = StgRhs Id Id +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data PrimOp + {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data StgAtom a = StgVarAtom a | StgLitAtom BasicLit +data StgBinderInfo = NoStgBinderInfo | StgBinderInfo Bool Bool Bool Bool Bool +data StgBinding a b = StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] +data StgCaseAlternatives a b = StgAlgAlts UniType [(Id, [a], [Bool], StgExpr a b)] (StgCaseDefault a b) | StgPrimAlts UniType [(BasicLit, StgExpr a b)] (StgCaseDefault a b) +data StgCaseDefault a b = StgNoDefault | StgBindDefault a Bool (StgExpr a b) +data StgExpr a b = StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) +type StgLiveVars a = UniqFM a +data StgRhs a b = StgRhsClosure CostCentre StgBinderInfo [b] UpdateFlag [a] (StgExpr a b) | StgRhsCon CostCentre Id [StgAtom b] +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +type TyVarEnv a = UniqFM a +type SigmaType = UniType +type TauType = UniType +type ThetaType = [(Class, UniType)] +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSet a = UniqFM a +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data UpdateFlag = ReEntrant | Updatable | SingleEntry +isLitLitLit :: BasicLit -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 12 \ (u0 :: BasicLit) -> case u0 of { _ALG_ _ORIG_ BasicLit MachLitLit (u1 :: _PackedString) (u2 :: PrimKind) -> _!_ True [] []; (u3 :: BasicLit) -> _!_ False [] [] } _N_ #-} +cmpClass :: Class -> Class -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +cmpTyCon :: TyCon -> TyCon -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +cmpTyVar :: TyVar -> TyVar -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +cmpUniType :: Bool -> UniType -> UniType -> Int# + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-} +collectExportedStgBinders :: [StgBinding Id Id] -> [Id] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +getAtomKind :: StgAtom Id -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: StgAtom Id) -> case u0 of { _ALG_ _ORIG_ StgSyn StgVarAtom (u1 :: Id) -> _APP_ _ORIG_ Id getIdKind [ u1 ]; _ORIG_ StgSyn StgLitAtom (u2 :: BasicLit) -> _APP_ _ORIG_ BasicLit kindOfBasicLit [ u2 ]; _NO_DEFLT_ } _N_ #-} +isLitLitStgAtom :: StgAtom a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 5 _/\_ u0 -> \ (u1 :: StgAtom u0) -> case u1 of { _ALG_ _ORIG_ StgSyn StgVarAtom (u2 :: u0) -> _!_ False [] []; _ORIG_ StgSyn StgLitAtom (u3 :: BasicLit) -> _APP_ _ORIG_ BasicLit isLitLitLit [ u3 ]; _NO_DEFLT_ } _N_ #-} +pprPlainStgBinding :: PprStyle -> StgBinding Id Id -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +stgArgOcc :: StgBinderInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgArity :: StgRhs Id Id -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: StgRhs Id Id) -> case u0 of { _ALG_ _ORIG_ StgSyn StgRhsCon (u1 :: CostCentre) (u2 :: Id) (u3 :: [StgAtom Id]) -> _!_ I# [] [0#]; _ORIG_ StgSyn StgRhsClosure (u4 :: CostCentre) (u5 :: StgBinderInfo) (u6 :: [Id]) (u7 :: UpdateFlag) (u8 :: [Id]) (u9 :: StgExpr Id Id) -> _APP_ _TYAPP_ _ORIG_ PreludeList length { Id } [ u8 ]; _NO_DEFLT_ } _N_ #-} +stgFakeFunAppOcc :: StgBinderInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgNoUpdHeapOcc :: StgBinderInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgNormalOcc :: StgBinderInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgStdHeapOcc :: StgBinderInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgUnsatOcc :: StgBinderInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +instance Eq BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool)] [_CONSTM_ Eq (==) (BasicLit), _CONSTM_ Eq (/=) (BasicLit)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Class -> Class -> Bool), (Class -> Class -> Bool)] [_CONSTM_ Eq (==) (Class), _CONSTM_ Eq (/=) (Class)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ eqInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Eq (/=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Eq ClassOp + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool)] [_CONSTM_ Eq (==) (ClassOp), _CONSTM_ Eq (/=) (ClassOp)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Eq Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Id -> Id -> Bool), (Id -> Id -> Bool)] [_CONSTM_ Eq (==) (Id), _CONSTM_ Eq (/=) (Id)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool)] [_CONSTM_ Eq (==) (PrimKind), _CONSTM_ Eq (/=) (PrimKind)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Eq PrimOp + {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimOp -> PrimOp -> Bool), (PrimOp -> PrimOp -> Bool)] [_CONSTM_ Eq (==) (PrimOp), _CONSTM_ Eq (/=) (PrimOp)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: PrimOp) (u1 :: PrimOp) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u0 ] of { _PRIM_ (u2 :: Int#) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u1 ] of { _PRIM_ (u3 :: Int#) -> _#_ eqInt# [] [u2, u3] } } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Eq TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool)] [_CONSTM_ Eq (==) (TyCon), _CONSTM_ Eq (/=) (TyCon)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool)] [_CONSTM_ Eq (==) (TyVar), _CONSTM_ Eq (/=) (TyVar)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq TyVarTemplate + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool)] [_CONSTM_ Eq (==) (TyVarTemplate), _CONSTM_ Eq (/=) (TyVarTemplate)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq UniType + {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UniType -> UniType -> Bool), (UniType -> UniType -> Bool)] [_CONSTM_ Eq (==) (UniType), _CONSTM_ Eq (/=) (UniType)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Ord BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq BasicLit}}, (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> _CMP_TAG)] [_DFUN_ Eq (BasicLit), _CONSTM_ Ord (<) (BasicLit), _CONSTM_ Ord (<=) (BasicLit), _CONSTM_ Ord (>=) (BasicLit), _CONSTM_ Ord (>) (BasicLit), _CONSTM_ Ord max (BasicLit), _CONSTM_ Ord min (BasicLit), _CONSTM_ Ord _tagCmp (BasicLit)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Class}}, (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Class), (Class -> Class -> Class), (Class -> Class -> _CMP_TAG)] [_DFUN_ Eq (Class), _CONSTM_ Ord (<) (Class), _CONSTM_ Ord (<=) (Class), _CONSTM_ Ord (>=) (Class), _CONSTM_ Ord (>) (Class), _CONSTM_ Ord max (Class), _CONSTM_ Ord min (Class), _CONSTM_ Ord _tagCmp (Class)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ ltInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ leInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord ClassOp + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq ClassOp}}, (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> _CMP_TAG)] [_DFUN_ Eq (ClassOp), _CONSTM_ Ord (<) (ClassOp), _CONSTM_ Ord (<=) (ClassOp), _CONSTM_ Ord (>=) (ClassOp), _CONSTM_ Ord (>) (ClassOp), _CONSTM_ Ord max (ClassOp), _CONSTM_ Ord min (ClassOp), _CONSTM_ Ord _tagCmp (ClassOp)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ ltInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ leInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ geInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ geInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ gtInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ gtInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Ord Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Id}}, (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Id), (Id -> Id -> Id), (Id -> Id -> _CMP_TAG)] [_DFUN_ Eq (Id), _CONSTM_ Ord (<) (Id), _CONSTM_ Ord (<=) (Id), _CONSTM_ Ord (>=) (Id), _CONSTM_ Ord (>) (Id), _CONSTM_ Ord max (Id), _CONSTM_ Ord min (Id), _CONSTM_ Ord _tagCmp (Id)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq PrimKind}}, (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> _CMP_TAG)] [_DFUN_ Eq (PrimKind), _CONSTM_ Ord (<) (PrimKind), _CONSTM_ Ord (<=) (PrimKind), _CONSTM_ Ord (>=) (PrimKind), _CONSTM_ Ord (>) (PrimKind), _CONSTM_ Ord max (PrimKind), _CONSTM_ Ord min (PrimKind), _CONSTM_ Ord _tagCmp (PrimKind)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Ord TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyCon}}, (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> _CMP_TAG)] [_DFUN_ Eq (TyCon), _CONSTM_ Ord (<) (TyCon), _CONSTM_ Ord (<=) (TyCon), _CONSTM_ Ord (>=) (TyCon), _CONSTM_ Ord (>) (TyCon), _CONSTM_ Ord max (TyCon), _CONSTM_ Ord min (TyCon), _CONSTM_ Ord _tagCmp (TyCon)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVar}}, (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> _CMP_TAG)] [_DFUN_ Eq (TyVar), _CONSTM_ Ord (<) (TyVar), _CONSTM_ Ord (<=) (TyVar), _CONSTM_ Ord (>=) (TyVar), _CONSTM_ Ord (>) (TyVar), _CONSTM_ Ord max (TyVar), _CONSTM_ Ord min (TyVar), _CONSTM_ Ord _tagCmp (TyVar)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord TyVarTemplate + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVarTemplate}}, (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> TyVarTemplate), (TyVarTemplate -> TyVarTemplate -> TyVarTemplate), (TyVarTemplate -> TyVarTemplate -> _CMP_TAG)] [_DFUN_ Eq (TyVarTemplate), _CONSTM_ Ord (<) (TyVarTemplate), _CONSTM_ Ord (<=) (TyVarTemplate), _CONSTM_ Ord (>=) (TyVarTemplate), _CONSTM_ Ord (>) (TyVarTemplate), _CONSTM_ Ord max (TyVarTemplate), _CONSTM_ Ord min (TyVarTemplate), _CONSTM_ Ord _tagCmp (TyVarTemplate)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Class -> ExportFlag), (Class -> Bool), (Class -> (_PackedString, _PackedString)), (Class -> _PackedString), (Class -> [_PackedString]), (Class -> SrcLoc), (Class -> Unique), (Class -> Bool), (Class -> UniType), (Class -> Bool)] [_CONSTM_ NamedThing getExportFlag (Class), _CONSTM_ NamedThing isLocallyDefined (Class), _CONSTM_ NamedThing getOrigName (Class), _CONSTM_ NamedThing getOccurrenceName (Class), _CONSTM_ NamedThing getInformingModules (Class), _CONSTM_ NamedThing getSrcLoc (Class), _CONSTM_ NamedThing getTheUnique (Class), _CONSTM_ NamedThing hasType (Class), _CONSTM_ NamedThing getType (Class), _CONSTM_ NamedThing fromPreludeCore (Class)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAEAA)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ue; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(LLAAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [ub, uc]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(ALSAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAAAS)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ug; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Unique) } [ _NOREP_S_ "NamedThing.Class.getTheUnique", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Bool) } [ _NOREP_S_ "NamedThing.Class.hasType", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> UniType) } [ _NOREP_S_ "NamedThing.Class.getType", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing a => NamedThing (InPat a) + {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 1 _U_ 0 _N_ _N_ _N_ _N_ #-} +instance NamedThing Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Id -> ExportFlag), (Id -> Bool), (Id -> (_PackedString, _PackedString)), (Id -> _PackedString), (Id -> [_PackedString]), (Id -> SrcLoc), (Id -> Unique), (Id -> Bool), (Id -> UniType), (Id -> Bool)] [_CONSTM_ NamedThing getExportFlag (Id), _CONSTM_ NamedThing isLocallyDefined (Id), _CONSTM_ NamedThing getOrigName (Id), _CONSTM_ NamedThing getOccurrenceName (Id), _CONSTM_ NamedThing getInformingModules (Id), _CONSTM_ NamedThing getSrcLoc (Id), _CONSTM_ NamedThing getTheUnique (Id), _CONSTM_ NamedThing hasType (Id), _CONSTM_ NamedThing getType (Id), _CONSTM_ NamedThing fromPreludeCore (Id)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Id) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Id" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u1; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Id) -> _!_ True [] [] _N_, + getType = _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing FullName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(FullName -> ExportFlag), (FullName -> Bool), (FullName -> (_PackedString, _PackedString)), (FullName -> _PackedString), (FullName -> [_PackedString]), (FullName -> SrcLoc), (FullName -> Unique), (FullName -> Bool), (FullName -> UniType), (FullName -> Bool)] [_CONSTM_ NamedThing getExportFlag (FullName), _CONSTM_ NamedThing isLocallyDefined (FullName), _CONSTM_ NamedThing getOrigName (FullName), _CONSTM_ NamedThing getOccurrenceName (FullName), _CONSTM_ NamedThing getInformingModules (FullName), _CONSTM_ NamedThing getSrcLoc (FullName), _CONSTM_ NamedThing getTheUnique (FullName), _CONSTM_ NamedThing hasType (FullName), _CONSTM_ NamedThing getType (FullName), _CONSTM_ NamedThing fromPreludeCore (FullName)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAEAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u4; _NO_DEFLT_ } _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ThisModule -> _!_ True [] []; _ORIG_ NameTypes InventedInThisModule -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LLAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [u1, u2]; _NO_DEFLT_ } _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(ALSAAA)" {_A_ 2 _U_ 11 _N_ _N_ _F_ _IF_ARGS_ 0 2 XC 10 \ (u0 :: _PackedString) (u1 :: Provenance) -> case u1 of { _ALG_ _ORIG_ NameTypes OtherPrelude (u2 :: _PackedString) -> u2; _ORIG_ NameTypes OtherModule (u3 :: _PackedString) (u4 :: [_PackedString]) -> u3; (u5 :: Provenance) -> u0 } _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ExportedByPreludeCore -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_ #-} +instance NamedThing ShortName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(ShortName -> ExportFlag), (ShortName -> Bool), (ShortName -> (_PackedString, _PackedString)), (ShortName -> _PackedString), (ShortName -> [_PackedString]), (ShortName -> SrcLoc), (ShortName -> Unique), (ShortName -> Bool), (ShortName -> UniType), (ShortName -> Bool)] [_CONSTM_ NamedThing getExportFlag (ShortName), _CONSTM_ NamedThing isLocallyDefined (ShortName), _CONSTM_ NamedThing getOrigName (ShortName), _CONSTM_ NamedThing getOccurrenceName (ShortName), _CONSTM_ NamedThing getInformingModules (ShortName), _CONSTM_ NamedThing getSrcLoc (ShortName), _CONSTM_ NamedThing getTheUnique (ShortName), _CONSTM_ NamedThing hasType (ShortName), _CONSTM_ NamedThing getType (ShortName), _CONSTM_ NamedThing fromPreludeCore (ShortName)] _N_ + getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ _ORIG_ Outputable NotExported [] [] _N_, + isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ True [] [] _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(SA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: _PackedString) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u1; _NO_DEFLT_ } _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u2; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AA)" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> _!_ False [] []; _NO_DEFLT_ } _N_ #-} +instance NamedThing TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyCon -> ExportFlag), (TyCon -> Bool), (TyCon -> (_PackedString, _PackedString)), (TyCon -> _PackedString), (TyCon -> [_PackedString]), (TyCon -> SrcLoc), (TyCon -> Unique), (TyCon -> Bool), (TyCon -> UniType), (TyCon -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyCon), _CONSTM_ NamedThing isLocallyDefined (TyCon), _CONSTM_ NamedThing getOrigName (TyCon), _CONSTM_ NamedThing getOccurrenceName (TyCon), _CONSTM_ NamedThing getInformingModules (TyCon), _CONSTM_ NamedThing getSrcLoc (TyCon), _CONSTM_ NamedThing getTheUnique (TyCon), _CONSTM_ NamedThing hasType (TyCon), _CONSTM_ NamedThing getType (TyCon), _CONSTM_ NamedThing fromPreludeCore (TyCon)] _N_ + getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getTheUnique = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Unique } [ _NOREP_S_ "NamedThing.TyCon.getTheUnique" ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> Bool) } [ _NOREP_S_ "NamedThing.TyCon.hasType", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> UniType) } [ _NOREP_S_ "NamedThing.TyCon.getType", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +instance NamedThing TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVar -> ExportFlag), (TyVar -> Bool), (TyVar -> (_PackedString, _PackedString)), (TyVar -> _PackedString), (TyVar -> [_PackedString]), (TyVar -> SrcLoc), (TyVar -> Unique), (TyVar -> Bool), (TyVar -> UniType), (TyVar -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVar), _CONSTM_ NamedThing isLocallyDefined (TyVar), _CONSTM_ NamedThing getOrigName (TyVar), _CONSTM_ NamedThing getOccurrenceName (TyVar), _CONSTM_ NamedThing getInformingModules (TyVar), _CONSTM_ NamedThing getSrcLoc (TyVar), _CONSTM_ NamedThing getTheUnique (TyVar), _CONSTM_ NamedThing hasType (TyVar), _CONSTM_ NamedThing getType (TyVar), _CONSTM_ NamedThing fromPreludeCore (TyVar)] _N_ + getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ _ORIG_ Outputable NotExported [] [] _N_, + isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ True [] [] _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVar) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVar" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar UserTyVar (u1 :: Unique) (u2 :: ShortName) -> case u2 of { _ALG_ _ORIG_ NameTypes ShortName (u3 :: _PackedString) (u4 :: SrcLoc) -> u4; _NO_DEFLT_ }; (u5 :: TyVar) -> _ORIG_ SrcLoc mkUnknownSrcLoc } _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar PolySysTyVar (u1 :: Unique) -> u1; _ORIG_ TyVar PrimSysTyVar (u2 :: Unique) -> u2; _ORIG_ TyVar OpenSysTyVar (u3 :: Unique) -> u3; _ORIG_ TyVar UserTyVar (u4 :: Unique) (u5 :: ShortName) -> u4; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ False [] [] _N_ #-} +instance NamedThing TyVarTemplate + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVarTemplate -> ExportFlag), (TyVarTemplate -> Bool), (TyVarTemplate -> (_PackedString, _PackedString)), (TyVarTemplate -> _PackedString), (TyVarTemplate -> [_PackedString]), (TyVarTemplate -> SrcLoc), (TyVarTemplate -> Unique), (TyVarTemplate -> Bool), (TyVarTemplate -> UniType), (TyVarTemplate -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVarTemplate), _CONSTM_ NamedThing isLocallyDefined (TyVarTemplate), _CONSTM_ NamedThing getOrigName (TyVarTemplate), _CONSTM_ NamedThing getOccurrenceName (TyVarTemplate), _CONSTM_ NamedThing getInformingModules (TyVarTemplate), _CONSTM_ NamedThing getSrcLoc (TyVarTemplate), _CONSTM_ NamedThing getTheUnique (TyVarTemplate), _CONSTM_ NamedThing hasType (TyVarTemplate), _CONSTM_ NamedThing getType (TyVarTemplate), _CONSTM_ NamedThing fromPreludeCore (TyVarTemplate)] _N_ + getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ _ORIG_ Outputable NotExported [] [] _N_, + isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ True [] [] _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVarTemplate" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: TyVarTemplate) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u1 :: Unique) (u2 :: _PackedString) -> _ORIG_ SrcLoc mkUnknownSrcLoc; _ORIG_ TyVar UserTyVarTemplate (u3 :: Unique) (u4 :: ShortName) -> case u4 of { _ALG_ _ORIG_ NameTypes ShortName (u5 :: _PackedString) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: TyVarTemplate) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u1 :: Unique) (u2 :: _PackedString) -> u1; _ORIG_ TyVar UserTyVarTemplate (u3 :: Unique) (u4 :: ShortName) -> u3; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ patError# { (TyVarTemplate -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ patError# { (TyVarTemplate -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ False [] [] _N_ #-} +instance (Outputable a, Outputable b) => Outputable (a, b) + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-} +instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLU(LLL)" _N_ _N_ #-} +instance Outputable BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (BasicLit) _N_ + ppr = _A_ 0 _U_ 2122 _N_ _N_ _N_ _N_ #-} +instance Outputable Bool + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Bool) _N_ + ppr = _A_ 4 _U_ 0120 _N_ _S_ "AELA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Class) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(AU(LLLLAA)AAAAAAAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable ClassOp + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Binds a b) + {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Expr a b) + {-# GHC_PRAGMA _M_ HsExpr {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHS a b) + {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: GRHS u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr: GRHSs", u8, u9 ] _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHSsAndBinds a b) + {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: GRHSsAndBinds u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr:GRHSsAndBinds", u8, u9 ] _N_ #-} +instance Outputable a => Outputable (InPat a) + {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance Outputable FullName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (FullName) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LLLLAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable ShortName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (ShortName) _N_ + ppr = _A_ 4 _U_ 0120 _N_ _S_ "AU(LA)LA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (PrimKind) _N_ + ppr = _A_ 2 _U_ 0120 _N_ _S_ "AL" {_A_ 1 _U_ 120 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable PrimOp + {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ #-} +instance Outputable a => Outputable (StgAtom a) + {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 3 _U_ 2 _N_ _S_ "LLS" _F_ _IF_ARGS_ 1 3 XXC 8 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: StgAtom u0) -> case u3 of { _ALG_ _ORIG_ StgSyn StgVarAtom (u4 :: u0) -> _APP_ u1 [ u2, u4 ]; _ORIG_ StgSyn StgLitAtom (u5 :: BasicLit) -> _APP_ _CONSTM_ Outputable ppr (BasicLit) [ u2, u5 ]; _NO_DEFLT_ } _N_ #-} +instance (Outputable a, Outputable b, Ord b) => Outputable (StgBinding a b) + {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +instance (Outputable a, Outputable b, Ord b) => Outputable (StgExpr a b) + {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +instance (Outputable a, Outputable b, Ord b) => Outputable (StgRhs a b) + {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLS" _N_ _N_ #-} +instance Outputable UpdateFlag + {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (UpdateFlag) _N_ + ppr = _A_ 4 _U_ 0120 _N_ _S_ "ALLA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyCon) _N_ + ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVar) _N_ + ppr = _A_ 2 _U_ 1122 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable TyVarTemplate + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVarTemplate) _N_ + ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable UniType + {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ #-} +instance Outputable a => Outputable [a] + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 3 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Text Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_ + readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_, + showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs new file mode 100644 index 0000000000..577498d63d --- /dev/null +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -0,0 +1,882 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation} + +This data type represents programs just before code generation +(conversion to @AbstractC@): basically, what we have is a stylised +form of @CoreSyntax@, the style being one that happens to be ideally +suited to spineless tagless code generation. + +\begin{code} +#include "HsVersions.h" + +module StgSyn ( + StgAtom(..), + StgLiveVars(..), + + StgBinding(..), StgExpr(..), StgRhs(..), + StgCaseAlternatives(..), StgCaseDefault(..), +#ifdef DPH + StgParCommunicate(..), +#endif {- Data Parallel Haskell -} + + UpdateFlag(..), + + StgBinderInfo(..), + stgArgOcc, stgUnsatOcc, stgStdHeapOcc, stgNoUpdHeapOcc, + stgNormalOcc, stgFakeFunAppOcc, + combineStgBinderInfo, + + -- a set of synonyms for the most common (only :-) parameterisation + PlainStgAtom(..), PlainStgLiveVars(..), PlainStgProgram(..), + PlainStgBinding(..), PlainStgExpr(..), PlainStgRhs(..), + PlainStgCaseAlternatives(..), PlainStgCaseDefault(..), + + pprPlainStgBinding, +--UNUSED: fvsFromAtoms, + getAtomKind, + isLitLitStgAtom, + stgArity, + collectExportedStgBinders, + + -- and to make the interface self-sufficient... + Outputable(..), NamedThing(..), Pretty(..), + Unique, ExportFlag, SrcLoc, PprStyle, PrettyRep, + + BasicLit, Class, ClassOp, + + Binds, Expr, GRHS, GRHSsAndBinds, InPat, + + Id, IdInfo, Maybe, Name, FullName, ShortName, + PrimKind, PrimOp, CostCentre, TyCon, TyVar, + UniqSet(..), UniqFM, Bag, + TyVarTemplate, UniType, TauType(..), + ThetaType(..), SigmaType(..), + TyVarEnv(..), IdEnv(..) + + IF_ATTACK_PRAGMAS(COMMA isLitLitLit) + IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar COMMA cmpClass) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) where + +import AbsPrel ( getPrimOpResultInfo, PrimOpResultInfo(..), + PrimOp, PrimKind + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsSyn ( Binds, Expr, GRHS, GRHSsAndBinds, InPat ) +import AbsUniType +import BasicLit ( typeOfBasicLit, kindOfBasicLit, isLitLitLit, + BasicLit(..) -- (..) for pragmas + ) +import Id ( getIdUniType, getIdKind, toplevelishId, + isTopLevId, Id, IdInfo + ) +import Maybes ( Maybe(..), catMaybes ) +import Outputable +import Pretty +import PrimKind ( PrimKind ) +import CostCentre ( showCostCentre, CostCentre ) +import UniqSet +import Unique +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[StgBinding]{@StgBinding@} +%* * +%************************************************************************ + +As usual, expressions are interesting; other things are boring. Here +are the boring things [except note the @StgRhs@], parameterised with +respect to binder and bindee information (just as in @CoreSyntax@): +\begin{code} +data StgBinding binder bindee + = StgNonRec binder (StgRhs binder bindee) + | StgRec [(binder, StgRhs binder bindee)] +\end{code} + +An @StgProgram@ is just a list of @StgBindings@; the +properties/restrictions-on this list are the same as for a +@CoreProgram@ (a list of @CoreBindings@). +\begin{code} +--type StgProgram binder bindee = [StgBinding binder bindee] +\end{code} + +%************************************************************************ +%* * +\subsection[StgAtom]{@StgAtom@} +%* * +%************************************************************************ + +\begin{code} +data StgAtom bindee + = StgVarAtom bindee + | StgLitAtom BasicLit +\end{code} + +\begin{code} +getAtomKind (StgVarAtom local) = getIdKind local +getAtomKind (StgLitAtom lit) = kindOfBasicLit lit + +{- UNUSED happily +fvsFromAtoms :: [PlainStgAtom] -> (UniqSet Id) -- ToDo: this looks like a HACK to me (WDP) +fvsFromAtoms as = mkUniqSet [ id | (StgVarAtom id) <- as, not (toplevelishId id) ] +-} + +isLitLitStgAtom (StgLitAtom x) = isLitLitLit x +isLitLitStgAtom _ = False +\end{code} + +%************************************************************************ +%* * +\subsection[StgExpr]{STG expressions} +%* * +%************************************************************************ + +The @StgExpr@ data type is parameterised on binder and bindee info, as +before. + +%************************************************************************ +%* * +\subsubsection[StgExpr-application]{@StgExpr@ application} +%* * +%************************************************************************ + +An application is of a function to a list of atoms [not expressions]. +Operationally, we want to push the arguments on the stack and call the +function. (If the arguments were expressions, we would have to build +their closures first.) + +There is no constructor for a lone variable; it would appear as +@StgApp var [] _@. +\begin{code} +type StgLiveVars bindee = UniqSet bindee + +data StgExpr binder bindee + = StgApp + (StgAtom bindee) -- function + [StgAtom bindee] -- arguments + (StgLiveVars bindee) -- Live vars in continuation; ie not + -- including the function and args + + -- NB: a literal is: StgApp <lit-atom> [] ... +\end{code} + +%************************************************************************ +%* * +\subsubsection[StgExpr-apps]{@StgConApp@ and @StgPrimApp@---saturated applications} +%* * +%************************************************************************ + +There are two specialised forms of application, for +constructors and primitives. +\begin{code} + | StgConApp -- always saturated + Id -- data constructor + [StgAtom bindee] + (StgLiveVars bindee) -- Live vars in continuation; ie not + -- including the constr and args + + | StgPrimApp -- always saturated + PrimOp + [StgAtom bindee] + (StgLiveVars bindee) -- Live vars in continuation; ie not + -- including the op and args +\end{code} +These forms are to do ``inline versions,'' as it were. +An example might be: @f x = x:[]@. + +%************************************************************************ +%* * +\subsubsection[StgExpr-case]{@StgExpr@: case-expressions} +%* * +%************************************************************************ + +This has the same boxed/unboxed business as Core case expressions. +\begin{code} + | StgCase + (StgExpr binder bindee) + -- the thing to examine + + (StgLiveVars bindee) -- Live vars of whole case + -- expression; i.e., those which mustn't be + -- overwritten + + (StgLiveVars bindee) -- Live vars of RHSs; + -- i.e., those which must be saved before eval. + -- + -- note that an alt's constructor's + -- binder-variables are NOT counted in the + -- free vars for the alt's RHS + + Unique -- Occasionally needed to compile case + -- statements, as the uniq for a local + -- variable to hold the tag of a primop with + -- algebraic result + + (StgCaseAlternatives binder bindee) +\end{code} + +%************************************************************************ +%* * +\subsubsection[StgExpr-lets]{@StgExpr@: @let(rec)@-expressions} +%* * +%************************************************************************ + +The various forms of let(rec)-expression encode most of the +interesting things we want to do. +\begin{enumerate} +\item +\begin{verbatim} +let-closure x = [free-vars] expr [args] +in e +\end{verbatim} +is equivalent to +\begin{verbatim} +let x = (\free-vars -> \args -> expr) free-vars +\end{verbatim} +\tr{args} may be empty (and is for most closures). It isn't under +circumstances like this: +\begin{verbatim} +let x = (\y -> y+z) +\end{verbatim} +This gets mangled to +\begin{verbatim} +let-closure x = [z] [y] (y+z) +\end{verbatim} +The idea is that we compile code for @(y+z)@ in an environment in which +@z@ is bound to an offset from \tr{Node}, and @y@ is bound to an +offset from the stack pointer. + +(A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.) + +\item +\begin{verbatim} +let-constructor x = Constructor [args] +in e +\end{verbatim} + +(A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.) + +\item +Letrec-expressions are essentially the same deal as +let-closure/let-constructor, so we use a common structure and +distinguish between them with an @is_recursive@ boolean flag. + +\item +\begin{verbatim} +let-unboxed u = an arbitrary arithmetic expression in unboxed values +in e +\end{verbatim} +All the stuff on the RHS must be fully evaluated. No function calls either! + +(We've backed away from this toward case-expressions with +suitably-magical alts ...) + +\item +~[Advanced stuff here! Not to start with, but makes pattern matching +generate more efficient code.] + +\begin{verbatim} +let-escapes-not fail = expr +in e' +\end{verbatim} +Here the idea is that @e'@ guarantees not to put @fail@ in a data structure, +or pass it to another function. All @e'@ will ever do is tail-call @fail@. +Rather than build a closure for @fail@, all we need do is to record the stack +level at the moment of the @let-escapes-not@; then entering @fail@ is just +a matter of adjusting the stack pointer back down to that point and entering +the code for it. + +Another example: +\begin{verbatim} +f x y = let z = huge-expression in + if y==1 then z else + if y==2 then z else + 1 +\end{verbatim} + +(A let-escapes-not is an @StgLetNoEscape@.) + +\item +We may eventually want: +\begin{verbatim} +let-literal x = BasicLit +in e +\end{verbatim} + +(ToDo: is this obsolete?) +\end{enumerate} + +And so the code for let(rec)-things: +\begin{code} + | StgLet + (StgBinding binder bindee) -- right hand sides (see below) + (StgExpr binder bindee) -- body + + | StgLetNoEscape -- remember: ``advanced stuff'' + (StgLiveVars bindee) -- Live in the whole let-expression + -- Mustn't overwrite these stack slots + -- *Doesn't* include binders of the let(rec). + + (StgLiveVars bindee) -- Live in the right hand sides (only) + -- These are the ones which must be saved on + -- the stack if they aren't there already + -- *Does* include binders of the let(rec) if recursive. + + (StgBinding binder bindee) -- right hand sides (see below) + (StgExpr binder bindee) -- body +\end{code} + +%************************************************************************ +%* * +\subsubsection[StgExpr-scc]{@StgExpr@: @scc@ expressions} +%* * +%************************************************************************ + +Finally for @scc@ expressions we introduce a new STG construct. + +\begin{code} + | StgSCC + UniType -- the type of the body + CostCentre -- label of SCC expression + (StgExpr binder bindee) -- scc expression +\end{code} + +%************************************************************************ +%* * +\subsection[DataParallel]{Data parallel extensions to STG syntax} +%* * +%************************************************************************ + +\begin{code} +#ifdef DPH + | StgParConApp -- saturated parallel constructor + Id + Int -- What parallel context + [StgAtom bindee] + (StgLiveVars bindee) + + | StgParComm + Int + (StgExpr binder bindee) -- The thing we are communicating + (StgParCommunicate binder bindee) +#endif {- Data Parallel Haskell -} + -- end of StgExpr +\end{code} + +%************************************************************************ +%* * +\subsection[StgRhs]{STG right-hand sides} +%* * +%************************************************************************ + +Here's the rest of the interesting stuff for @StgLet@s; the first +flavour is for closures: +\begin{code} +data StgRhs binder bindee + = StgRhsClosure + CostCentre -- cost centre to be attached (default is CCC) + StgBinderInfo -- Info about how this binder is used (see below) + [bindee] -- non-global free vars; a list, rather than + -- a set, because order is important + UpdateFlag -- ReEntrant | Updatable | SingleEntry + [binder] -- arguments; if empty, then not a function; + -- as above, order is important + (StgExpr binder bindee) -- body +\end{code} +An example may be in order. Consider: +\begin{verbatim} +let t = \x -> \y -> ... x ... y ... p ... q in e +\end{verbatim} +Pulling out the free vars and stylising somewhat, we get the equivalent: +\begin{verbatim} +let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q +\end{verbatim} +Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are +offsets from @Node@ into the closure, and the code ptr for the closure +will be exactly that in parentheses above. + +The second flavour of right-hand-side is for constructors (simple but important): +\begin{code} + | StgRhsCon + CostCentre -- Cost centre to be attached (default is CCC). + -- Top-level (static) ones will end up with + -- DontCareCC, because we don't count static + -- data in heap profiles, and we don't set CCC + -- from static closure. + Id -- constructor + [StgAtom bindee] -- args +\end{code} + +Here's the @StgBinderInfo@ type, and its combining op: +\begin{code} +data StgBinderInfo + = NoStgBinderInfo + + | StgBinderInfo + Bool -- At least one occurrence as an argument + + Bool -- At least one occurrence in an unsaturated application + + Bool -- This thing (f) has at least occurrence of the form: + -- x = [..] \u [] -> f a b c + -- where the application is saturated + + Bool -- Ditto for non-updatable x. + + Bool -- At least one fake application occurrence, that is + -- an StgApp f args where args is an empty list + -- This is due to the fact that we do not have a + -- StgVar constructor. + -- Used by the lambda lifter. + -- True => "at least one unsat app" is True too + +stgArgOcc = StgBinderInfo True False False False False +stgUnsatOcc = StgBinderInfo False True False False False +stgStdHeapOcc = StgBinderInfo False False True False False +stgNoUpdHeapOcc = StgBinderInfo False False False True False +stgNormalOcc = StgBinderInfo False False False False False +-- [Andre] can't think of a good name for the last one. +stgFakeFunAppOcc = StgBinderInfo False True False False True + +combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo + +combineStgBinderInfo NoStgBinderInfo info2 = info2 +combineStgBinderInfo info1 NoStgBinderInfo = info1 +combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1) + (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2) + = StgBinderInfo (arg1 || arg2) + (unsat1 || unsat2) + (std_heap1 || std_heap2) + (upd_heap1 || upd_heap2) + (fkap1 || fkap2) +\end{code} + +%************************************************************************ +%* * +\subsection[Stg-case-alternatives]{STG case alternatives} +%* * +%************************************************************************ + +Just like in @CoreSyntax@ (except no type-world stuff). + +\begin{code} +data StgCaseAlternatives binder bindee + = StgAlgAlts UniType -- so we can find out things about constructor family + [(Id, -- alts: data constructor, + [binder], -- constructor's parameters, + [Bool], -- "use mask", same length as + -- parameters; a True in a + -- param's position if it is + -- used in the ... + StgExpr binder bindee)] -- ...right-hand side. + (StgCaseDefault binder bindee) + | StgPrimAlts UniType -- so we can find out things about constructor family + [(BasicLit, -- alts: unboxed literal, + StgExpr binder bindee)] -- rhs. + (StgCaseDefault binder bindee) +#ifdef DPH + | StgParAlgAlts + UniType + Int -- What context we are in + [binder] + [(Id,StgExpr binder bindee)] + (StgCaseDefault binder bindee) + | StgParPrimAlts UniType + Int -- What context we are in + [(BasicLit, -- alts: unboxed literal, + StgExpr binder bindee)] -- rhs. + (StgCaseDefault binder bindee) +#endif {- Data Parallel Haskell -} + +data StgCaseDefault binder bindee + = StgNoDefault -- small con family: all + -- constructor accounted for + | StgBindDefault binder -- form: var -> expr + Bool -- True <=> var is used in rhs + -- i.e., False <=> "_ -> expr" + (StgExpr binder bindee) +\end{code} + +%************************************************************************ +%* * +\subsection[Stg-parComummunicate]{Communication operations} +%* * +%************************************************************************ + +\begin{code} +#ifdef DPH +data StgParCommunicate binder bindee + = StgParSend + [StgAtom bindee] -- Sending PODs + + | StgParFetch + [StgAtom bindee] -- Fetching PODs + + | StgToPodized -- Convert a POD to the podized form + + | StgFromPodized -- Convert a POD from the podized form +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[PlainStg]{The Plain STG parameterisation} +%* * +%************************************************************************ + +This happens to be the only one we use at the moment. + +\begin{code} +type PlainStgProgram = [StgBinding Id Id] +type PlainStgBinding = StgBinding Id Id +type PlainStgAtom = StgAtom Id +type PlainStgLiveVars= UniqSet Id +type PlainStgExpr = StgExpr Id Id +type PlainStgRhs = StgRhs Id Id +type PlainStgCaseAlternatives = StgCaseAlternatives Id Id +type PlainStgCaseDefault = StgCaseDefault Id Id +\end{code} + +%************************************************************************ +%* * +\subsubsection[UpdateFlag-datatype]{@UpdateFlag@} +%* * +%************************************************************************ + +This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module. + +\begin{code} +data UpdateFlag = ReEntrant | Updatable | SingleEntry + +instance Outputable UpdateFlag where + ppr sty u + = ppChar (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' }) +\end{code} + +%************************************************************************ +%* * +\subsection[Stg-utility-functions]{Utility functions} +%* * +%************************************************************************ + + +For doing interfaces, we want the exported top-level Ids from the +final pre-codegen STG code, so as to be sure we have the +latest/greatest pragma info. + +\begin{code} +collectExportedStgBinders + :: [PlainStgBinding] -- input: PlainStgProgram + -> [Id] -- exported top-level Ids + +collectExportedStgBinders binds + = exported_from_here [] binds + where + exported_from_here es [] = es + + exported_from_here es ((StgNonRec b _) : binds) + = if not (isExported b) then + exported_from_here es binds + else + exported_from_here (b:es) binds + + exported_from_here es ((StgRec []) : binds) + = exported_from_here es binds + + exported_from_here es ((StgRec ((b, rhs) : pairs)) : binds) + = exported_from_here + es + (StgNonRec b rhs : (StgRec pairs : binds)) + -- OK, a total hack; laziness rules +\end{code} + +%************************************************************************ +%* * +\subsection[Stg-pretty-printing]{Pretty-printing} +%* * +%************************************************************************ + +Robin Popplestone asked for semi-colon separators on STG binds; here's +hoping he likes terminators instead... Ditto for case alternatives. + +\begin{code} +pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) => + PprStyle -> StgBinding bndr bdee -> Pretty + +pprStgBinding sty (StgNonRec binder rhs) + = ppHang (ppCat [ppr sty binder, ppEquals]) + 4 (ppBeside (ppr sty rhs) ppSemi) + +pprStgBinding sty (StgRec pairs) + = ppAboves ((ifPprDebug sty (ppStr "{- StgRec -}")) : + (map (ppr_bind sty) pairs)) + where + ppr_bind sty (binder, expr) + = ppHang (ppCat [ppr sty binder, ppEquals]) + 4 (ppBeside (ppr sty expr) ppSemi) + +pprPlainStgBinding :: PprStyle -> PlainStgBinding -> Pretty +pprPlainStgBinding sty b = pprStgBinding sty b +\end{code} + +\begin{code} +instance (Outputable bdee) => Outputable (StgAtom bdee) where + ppr = pprStgAtom + +instance (Outputable bndr, Outputable bdee, Ord bdee) + => Outputable (StgBinding bndr bdee) where + ppr = pprStgBinding + +instance (Outputable bndr, Outputable bdee, Ord bdee) + => Outputable (StgExpr bndr bdee) where + ppr = pprStgExpr + +{- OLD: +instance (Outputable bndr, Outputable bdee, Ord bdee) + => Outputable (StgCaseDefault bndr bdee) where + ppr sty deflt = panic "ppr:StgCaseDefault" +-} + +instance (Outputable bndr, Outputable bdee, Ord bdee) + => Outputable (StgRhs bndr bdee) where + ppr sty rhs = pprStgRhs sty rhs +\end{code} + +\begin{code} +pprStgAtom :: (Outputable bdee) => PprStyle -> StgAtom bdee -> Pretty + +pprStgAtom sty (StgVarAtom var) = ppr sty var +pprStgAtom sty (StgLitAtom lit) = ppr sty lit +\end{code} + +\begin{code} +pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) => + PprStyle -> StgExpr bndr bdee -> Pretty +-- special case +pprStgExpr sty (StgApp func [] lvs) + = ppBeside (ppr sty func) (pprStgLVs sty lvs) + +-- general case +pprStgExpr sty (StgApp func args lvs) + = ppHang (ppBeside (ppr sty func) (pprStgLVs sty lvs)) + 4 (ppSep (map (ppr sty) args)) +\end{code} + +\begin{code} +pprStgExpr sty (StgConApp con args lvs) + = ppBesides [ ppBeside (ppr sty con) (pprStgLVs sty lvs), + ppStr "! [", interppSP sty args, ppStr "]" ] + +pprStgExpr sty (StgPrimApp op args lvs) + = ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs, + ppStr " [", interppSP sty args, ppStr "]" ] +\end{code} + +\begin{code} +-- special case: let v = <very specific thing> +-- in +-- let ... +-- in +-- ... +-- +-- Very special! Suspicious! (SLPJ) + +pprStgExpr sty (StgLet (StgNonRec binder (StgRhsClosure cc bi free_vars upd_flag args rhs)) + expr@(StgLet _ _)) + = ppAbove + (ppHang (ppBesides [ppStr "let { ", ppr sty binder, ppStr " = ", + ppStr (showCostCentre sty True{-as string-} cc), + pp_binder_info sty bi, + ppStr " [", ifPprDebug sty (interppSP sty free_vars), ppStr "] \\", + ppr sty upd_flag, ppStr " [", + interppSP sty args, ppStr "]"]) + 8 (ppSep [ppCat [ppr sty rhs, ppStr "} in"]])) + (ppr sty expr) + +-- special case: let ... in let ... + +pprStgExpr sty (StgLet bind expr@(StgLet _ _)) + = ppAbove + (ppSep [ppHang (ppStr "let {") 2 (ppCat [pprStgBinding sty bind, ppStr "} in"])]) + (ppr sty expr) + +-- general case +pprStgExpr sty (StgLet bind expr) + = ppSep [ppHang (ppStr "let {") 2 (pprStgBinding sty bind), + ppHang (ppStr "} in ") 2 (ppr sty expr)] + +pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr) + = ppSep [ppHang (ppStr "let-no-escape {") + 2 (pprStgBinding sty bind), + ppHang (ppBeside (ppStr "} in ") + (ifPprDebug sty ( + ppNest 4 ( + ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole), + ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss), + ppStr "]"])))) + 2 (ppr sty expr)] +\end{code} + +\begin{code} +pprStgExpr sty (StgSCC ty cc expr) + = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)], + pprStgExpr sty expr ] +\end{code} + +\begin{code} +pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts) + = ppSep [ppSep [ppStr "case", + ppNest 4 (ppCat [pprStgExpr sty expr, + ifPprDebug sty (ppBeside (ppStr "::") (pp_ty alts))]), + ppStr "of {"], + ifPprDebug sty ( + ppNest 4 ( + ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole), + ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss), + ppStr "]; uniq: ", pprUnique uniq])), + ppNest 2 (ppr_alts sty alts), + ppStr "}"] + where + pp_ty (StgAlgAlts ty _ _) = ppr sty ty + pp_ty (StgPrimAlts ty _ _) = ppr sty ty + + ppr_alts sty (StgAlgAlts ty alts deflt) + = ppAboves [ ppAboves (map (ppr_bxd_alt sty) alts), + ppr_default sty deflt ] + where + ppr_bxd_alt sty (con, params, use_mask, expr) + = ppHang (ppCat [ppr_con sty con, interppSP sty params, ppStr "->"]) + 4 (ppBeside (ppr sty expr) ppSemi) + where + ppr_con sty con + = if isOpLexeme con + then ppBesides [ppLparen, ppr sty con, ppRparen] + else ppr sty con + + ppr_alts sty (StgPrimAlts ty alts deflt) + = ppAboves [ ppAboves (map (ppr_ubxd_alt sty) alts), + ppr_default sty deflt ] + where + ppr_ubxd_alt sty (lit, expr) + = ppHang (ppCat [ppr sty lit, ppStr "->"]) + 4 (ppBeside (ppr sty expr) ppSemi) + +#ifdef DPH + ppr_alts sty (StgParAlgAlts ty dim params alts deflt) + = ppAboves [ ppBeside (ppCat (map (ppr sty) params)) + (ppCat [ppStr "|" , ppr sty dim , ppStr "|"]), + ppAboves (map (ppr_bxd_alt sty) alts), + ppr_default sty deflt ] + where + ppr_bxd_alt sty (con, expr) + = ppHang (ppCat [ppStr "\\/", ppr_con sty con, ppStr "->"]) + 4 (ppr sty expr) + where + ppr_con sty con + = if isOpLexeme con + then ppBesides [ppLparen, ppr sty con, ppRparen] + else ppr sty con + + ppr_alts sty (StgParPrimAlts ty dim alts deflt) + = ppAboves [ ifPprShowAll sty (ppr sty ty), + ppCat [ppStr "|" , ppr sty dim , ppStr "|"], + ppAboves (map (ppr_ubxd_alt sty) alts), + ppr_default sty deflt ] + where + ppr_ubxd_alt sty (lit, expr) + = ppHang (ppCat [ppStr "\\/", ppr sty lit, ppStr "->"]) 4 (ppr sty expr) +#endif {- Data Parallel Haskell -} + + ppr_default sty StgNoDefault = ppNil + ppr_default sty (StgBindDefault binder used expr) + = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr) + where + pp_binder = if used then ppr sty binder else ppChar '_' +\end{code} + +\begin{code} +#ifdef DPH +pprStgExpr sty (StgParConApp con dim args lvs) + = ppBesides [ppr sty con, pprStgLVs sty lvs, ppStr "!<<" ,ppr sty dim , + ppStr ">> [", interppSP sty args, ppStr "]" ] + +pprStgExpr sty (StgParComm dim expr comm) + = ppSep [ppSep [ppStr "COMM ", + ppNest 2 (pprStgExpr sty expr),ppStr "{"], + ppNest 2 (ppr_comm sty comm), + ppStr "}"] + where + ppr_comm sty (StgParSend args) + = ppSep [ppStr "SEND [",interppSP sty args, ppStr "]" ] + ppr_comm sty (StgParFetch args) + = ppSep [ppStr "FETCH [",interppSP sty args, ppStr "]" ] + ppr_comm sty (StgToPodized) + = ppStr "ToPodized" + ppr_comm sty (StgFromPodized) + = ppStr "FromPodized" +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +-- pprStgLVs :: PprStyle -> StgLiveVars bindee -> Pretty + +pprStgLVs PprForUser lvs = ppNil + +pprStgLVs sty lvs + = if isEmptyUniqSet lvs then + ppNil + else + ppBesides [ppStr "{-lvs:", interpp'SP sty (uniqSetToList lvs), ppStr "-}"] +\end{code} + +\begin{code} +pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) => + PprStyle -> StgRhs bndr bdee -> Pretty + +-- special case +pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs)) + = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc), + pp_binder_info sty bi, + ppStr " [", ifPprDebug sty (ppr sty free_var), + ppStr "] \\", ppr sty upd_flag, ppStr " [] ", ppr sty func ] +-- general case +pprStgRhs sty (StgRhsClosure cc bi free_vars upd_flag args body) + = ppHang (ppBesides [ ppStr (showCostCentre sty True{-as String-} cc), + pp_binder_info sty bi, + ppStr " [", ifPprDebug sty (interppSP sty free_vars), + ppStr "] \\", ppr sty upd_flag, ppStr " [", interppSP sty args, ppStr "]"]) + 4 (ppr sty body) + +pprStgRhs sty (StgRhsCon cc con args) + = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc), + ppSP, ppr sty con, ppStr " [", interppSP sty args, ppStr "]" ] + +-------------- +pp_binder_info PprForUser _ = ppNil + +pp_binder_info sty NoStgBinderInfo = ppNil + +-- cases so boring that we print nothing +pp_binder_info sty (StgBinderInfo True b c d e) = ppNil + +-- general case +pp_binder_info sty (StgBinderInfo a b c d e) + = ppBesides [ppChar '(', ppInterleave ppComma (map pp_bool [a,b,c,d,e]), ppChar ')'] + where + pp_bool x = ppr (panic "pp_bool") x +\end{code} + +Collect @IdInfo@ stuff that is most easily just snaffled straight +from the STG bindings. + +\begin{code} +stgArity :: PlainStgRhs -> Int + +stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied +stgArity (StgRhsClosure _ _ _ _ args _ ) = length args +\end{code} diff --git a/ghc/compiler/stgSyn/root.lit b/ghc/compiler/stgSyn/root.lit new file mode 100644 index 0000000000..9842848fd9 --- /dev/null +++ b/ghc/compiler/stgSyn/root.lit @@ -0,0 +1,9 @@ +\documentstyle[11pt,literate,a4wide]{article} + +\begin{document} +\author{Simon and friends} +\title{STG Syntax} +\maketitle + +\input{StgSyn.lhs} +\end{document} |