[project @ 2003-02-18 15:54:02 by simonpj]
[ghc-hetmet.git] / ghc / compiler / basicTypes / MkId.lhs
index 1c6b5d0..8be5844 100644 (file)
@@ -13,82 +13,133 @@ have a standard form, namely:
 
 \begin{code}
 module MkId (
 
 \begin{code}
 module MkId (
-       mkSpecPragmaId, mkWorkerId,
-
        mkDictFunId, mkDefaultMethodId,
        mkDictFunId, mkDefaultMethodId,
-       mkMethodSelId, mkSuperDictSelId, 
+       mkDictSelId, 
+
+       mkDataConWorkId, mkDataConWrapId,
+       mkRecordSelId, 
+       mkPrimOpId, mkFCallId,
+
+       mkReboxingAlt, mkNewTypeBody,
+
+       -- And some particular Ids; see below for why they are wired in
+       wiredInIds, ghcPrimIds,
+       unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
+       lazyId, lazyIdUnfolding, lazyIdKey,
 
 
-       mkDataConId,
-       mkRecordSelId,
-       mkNewTySelId,
-       mkPrimitiveId
+       mkRuntimeErrorApp,
+       rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
+       nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
+       pAT_ERROR_ID
     ) where
 
 #include "HsVersions.h"
 
     ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} CoreUnfold ( mkUnfolding )
 
 
-import TysWiredIn      ( boolTy )
-import Type            ( Type, ThetaType,
-                         mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy,
-                         isUnLiftedType, substTopTheta,
-                         splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
-                         splitFunTys, splitForAllTys
+import BasicTypes      ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
+import TysPrim         ( openAlphaTyVars, alphaTyVar, alphaTy, betaTyVar, betaTy,
+                         intPrimTy, realWorldStatePrimTy, addrPrimTy
                        )
                        )
-import TyCon           ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
-import Class           ( Class, classBigSig, classTyCon )
-import Var             ( Id, TyVar, VarDetails(..), mkId )
-import VarEnv          ( zipVarEnv )
-import Const           ( Con(..) )
-import Name            ( mkDerivedName, mkWiredInIdName, 
-                         mkWorkerOcc, mkSuperDictSelOcc,
-                         Name, NamedThing(..),
+import TysWiredIn      ( charTy, mkListTy )
+import PrelRules       ( primOpRules )
+import Rules           ( addRule )
+import TcType          ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
+                         mkTyVarTys, mkClassPred, tcEqPred,
+                         mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, 
+                         isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
+                         tcSplitFunTys, tcSplitForAllTys, mkPredTy
                        )
                        )
-import PrimOp          ( PrimOp, primOpType, primOpOcc, primOpUniq )
-import DataCon         ( DataCon, dataConStrictMarks, dataConFieldLabels, 
-                         dataConArgTys, dataConSig
+import CoreUtils       ( exprType )
+import CoreUnfold      ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
+import Literal         ( Literal(..), nullAddrLit )
+import TyCon           ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
+                          tyConTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
+import Class           ( Class, classTyCon, classTyVars, classSelIds )
+import Var             ( Id, TyVar, Var )
+import VarSet          ( isEmptyVarSet )
+import Name            ( mkFCallName, Name )
+import PrimOp          ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
+import ForeignCall     ( ForeignCall )
+import DataCon         ( DataCon, 
+                         dataConFieldLabels, dataConRepArity, dataConTyCon,
+                         dataConArgTys, dataConRepType, 
+                         dataConOrigArgTys,
+                          dataConTheta,
+                         dataConSig, dataConStrictMarks, dataConWorkId,
+                         splitProductType
                        )
                        )
-import Id              ( idType,
-                         mkUserLocal, mkVanillaId, mkTemplateLocals,
-                         setInlinePragma
+import Id              ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, mkLocalId,
+                         mkTemplateLocals, mkTemplateLocalsNum, setIdLocalExported,
+                         mkTemplateLocal, idNewStrictness, idName
                        )
                        )
-import IdInfo          ( noIdInfo,
-                         exactArity, setUnfoldingInfo, 
-                         setArityInfo, setInlinePragInfo,
-                         InlinePragInfo(..), IdInfo
+import IdInfo          ( IdInfo, noCafIdInfo, hasCafIdInfo,
+                         setUnfoldingInfo, 
+                         setArityInfo, setSpecInfo, setCafInfo,
+                         setAllStrictnessInfo,
+                         GlobalIdDetails(..), CafInfo(..)
                        )
                        )
-import FieldLabel      ( FieldLabel, FieldLabelTag, mkFieldLabel, fieldLabelName, 
-                         firstFieldLabelTag, allFieldLabelTags
+import NewDemand       ( mkStrictSig, strictSigResInfo, DmdResult(..),
+                         mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR,
+                         Demand(..), Demands(..) )
+import FieldLabel      ( mkFieldLabel, fieldLabelName, 
+                         firstFieldLabelTag, allFieldLabelTags, fieldLabelType
                        )
                        )
+import DmdAnal         ( dmdAnalTopRhs )
 import CoreSyn
 import CoreSyn
-import PrelVals                ( rEC_SEL_ERROR_ID )
-import PrelMods                ( pREL_GHC )
+import Unique          ( mkBuiltinUnique )
 import Maybes
 import Maybes
-import BasicTypes      ( Arity, StrictnessMark(..) )
-import Unique          ( Unique )
+import PrelNames
 import Maybe            ( isJust )
 import Maybe            ( isJust )
+import Util             ( dropList, isSingleton )
 import Outputable
 import Outputable
-import Util            ( assoc )
-import List            ( nub )
+import FastString
+import ListSetOps      ( assoc, assocMaybe )
+import UnicodeUtil      ( stringToUtf8 )
+import List            ( nubBy )
 \end{code}             
 
 \end{code}             
 
-
 %************************************************************************
 %*                                                                     *
 %************************************************************************
 %*                                                                     *
-\subsection{Easy ones}
+\subsection{Wired in Ids}
 %*                                                                     *
 %************************************************************************
 
 \begin{code}
 %*                                                                     *
 %************************************************************************
 
 \begin{code}
-mkSpecPragmaId occ uniq ty loc
-  = mkUserLocal occ uniq ty loc `setInlinePragma` IAmASpecPragmaId
-       -- Maybe a SysLocal?  But then we'd lose the location
-
-mkDefaultMethodId dm_name rec_c ty
-  = mkVanillaId dm_name ty
-
-mkWorkerId uniq unwrkr ty
-  = mkVanillaId (mkDerivedName mkWorkerOcc (getName unwrkr) uniq) ty
+wiredInIds
+  = [  -- These error-y things are wired in because we don't yet have
+       -- a way to express in an interface file that the result type variable
+       -- is 'open'; that is can be unified with an unboxed type
+       -- 
+       -- [The interface file format now carry such information, but there's
+       -- no way yet of expressing at the definition site for these 
+       -- error-reporting functions that they have an 'open' 
+       -- result type. -- sof 1/99]
+
+    eRROR_ID,  -- This one isn't used anywhere else in the compiler
+               -- But we still need it in wiredInIds so that when GHC
+               -- compiles a program that mentions 'error' we don't
+               -- import its type from the interface file; we just get
+               -- the Id defined here.  Which has an 'open-tyvar' type.
+
+    rUNTIME_ERROR_ID,
+    iRREFUT_PAT_ERROR_ID,
+    nON_EXHAUSTIVE_GUARDS_ERROR_ID,
+    nO_METHOD_BINDING_ERROR_ID,
+    pAT_ERROR_ID,
+    rEC_CON_ERROR_ID,
+
+    lazyId
+    ] ++ ghcPrimIds
+
+-- These Ids are exported from GHC.Prim
+ghcPrimIds
+  = [  -- These can't be defined in Haskell, but they have
+       -- perfectly reasonable unfoldings in Core
+    realWorldPrimId,
+    unsafeCoerceId,
+    nullAddrId,
+    seqId
+    ]
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -98,19 +149,60 @@ mkWorkerId uniq unwrkr ty
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}
-mkDataConId :: DataCon -> Id
-mkDataConId data_con
-  = mkId (getName data_con)
-        id_ty
-        (ConstantId (DataCon data_con))
-        (dataConInfo data_con)
+mkDataConWorkId :: Name -> DataCon -> Id
+       -- Makes the *worker* for the data constructor; that is, the function
+       -- that takes the reprsentation arguments and builds the constructor.
+mkDataConWorkId wkr_name data_con
+  = mkGlobalId (DataConWorkId data_con) wkr_name
+              (dataConRepType data_con) info
   where
   where
-    (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con
-    id_ty = mkSigmaTy (tyvars ++ ex_tyvars) 
-                     (theta ++ ex_theta)
-                     (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)))
+    info = noCafIdInfo
+          `setArityInfo`               arity
+          `setAllStrictnessInfo`       Just strict_sig
+
+    arity      = dataConRepArity data_con
+    strict_sig = mkStrictSig (mkTopDmdType (replicate arity topDmd) cpr_info)
+       -- Notice that we do *not* say the worker is strict
+       -- even if the data constructor is declared strict
+       --      e.g.    data T = MkT !(Int,Int)
+       -- Why?  Because the *wrapper* is strict (and its unfolding has case
+       -- expresssions that do the evals) but the *worker* itself is not.
+       -- If we pretend it is strict then when we see
+       --      case x of y -> $wMkT y
+       -- the simplifier thinks that y is "sure to be evaluated" (because
+       -- $wMkT is strict) and drops the case.  No, $wMkT is not strict.
+       --
+       -- When the simplifer sees a pattern 
+       --      case e of MkT x -> ...
+       -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
+       -- but that's fine... dataConRepStrictness comes from the data con
+       -- not from the worker Id.
+
+    tycon = dataConTyCon data_con
+    cpr_info | isProductTyCon tycon && 
+              isDataTyCon tycon    &&
+              arity > 0            &&
+              arity <= mAX_CPR_SIZE    = retCPR
+            | otherwise                = TopRes
+       -- RetCPR is only true for products that are real data types;
+       -- that is, not unboxed tuples or [non-recursive] newtypes
+
+mAX_CPR_SIZE :: Arity
+mAX_CPR_SIZE = 10
+-- We do not treat very big tuples as CPR-ish:
+--     a) for a start we get into trouble because there aren't 
+--        "enough" unboxed tuple types (a tiresome restriction, 
+--        but hard to fix), 
+--     b) more importantly, big unboxed tuples get returned mainly
+--        on the stack, and are often then allocated in the heap
+--        by the caller.  So doing CPR for them may in fact make
+--        things worse.
 \end{code}
 
 \end{code}
 
+The wrapper for a constructor is an ordinary top-level binding that evaluates
+any strict args, unboxes any args that are going to be flattened, and calls
+the worker.
+
 We're going to build a constructor that looks like:
 
        data (Data a, C b) =>  T a b = T1 !a !Int b
 We're going to build a constructor that looks like:
 
        data (Data a, C b) =>  T a b = T1 !a !Int b
@@ -130,53 +222,128 @@ Notice that
 * We have to check that we can construct Data dictionaries for
   the types a and Int.  Once we've done that we can throw d1 away too.
 
 * We have to check that we can construct Data dictionaries for
   the types a and Int.  Once we've done that we can throw d1 away too.
 
-* We use (case p of ...) to evaluate p, rather than "seq" because
+* We use (case p of q -> ...) to evaluate p, rather than "seq" because
   all that matters is that the arguments are evaluated.  "seq" is 
   very careful to preserve evaluation order, which we don't need
   to be here.
 
   all that matters is that the arguments are evaluated.  "seq" is 
   very careful to preserve evaluation order, which we don't need
   to be here.
 
+  You might think that we could simply give constructors some strictness
+  info, like PrimOps, and let CoreToStg do the let-to-case transformation.
+  But we don't do that because in the case of primops and functions strictness
+  is a *property* not a *requirement*.  In the case of constructors we need to
+  do something active to evaluate the argument.
+
+  Making an explicit case expression allows the simplifier to eliminate
+  it in the (common) case where the constructor arg is already evaluated.
+
 \begin{code}
 \begin{code}
-dataConInfo :: DataCon -> IdInfo
-
-dataConInfo data_con
-  = setInlinePragInfo IMustBeINLINEd $
-               -- Always inline constructors; we won't create a binding for them
-    setArityInfo (exactArity (length locals)) $
-    setUnfoldingInfo unfolding $
-    noIdInfo
+mkDataConWrapId :: Name -> DataCon -> Maybe Id
+-- Only make a wrapper Id if necessary
+
+mkDataConWrapId wrap_name data_con
+  | is_newtype || any isMarkedStrict strict_marks
+  =    -- We need a wrapper function
+    Just (mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty info)
+
+  | otherwise
+  = Nothing    -- The common case, where there is no point in 
+               -- having a wrapper function.  Not only is this efficient,
+               -- but it also ensures that the wrapper is replaced
+               -- by the worker (becuase it *is* the wroker)
+               -- even when there are no args. E.g. in
+               --              f (:) x
+               -- the (:) *is* the worker.
+               -- This is really important in rule matching,
+               -- (We could match on the wrappers,
+               -- but that makes it less likely that rules will match
+               -- when we bring bits of unfoldings together.)
   where
   where
-        unfolding = mkUnfolding con_rhs
-
-       (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con
-       all_tyvars   = tyvars ++ ex_tyvars
-
-       dict_tys     = [mkDictTy clas tys | (clas,tys) <- theta]
-       ex_dict_tys  = [mkDictTy clas tys | (clas,tys) <- ex_theta]
-       n_dicts      = length dict_tys
-       result_ty    = mkTyConApp tycon (mkTyVarTys tyvars)
-
-       locals        = mkTemplateLocals (dict_tys ++ ex_dict_tys ++ arg_tys)
-       data_args     = drop n_dicts locals
-       (data_arg1:_) = data_args               -- Used for newtype only
-       strict_marks  = dataConStrictMarks data_con
-       strict_args   = [arg | (arg,MarkedStrict) <- data_args `zip` strict_marks]
-               -- NB: we can't call mkTemplateLocals twice, because it
-               -- always starts from the same unique.
-
-       con_app | isNewTyCon tycon 
-               = ASSERT( length arg_tys == 1)
-                 Note (Coerce result_ty (head arg_tys)) (Var data_arg1)
-               | otherwise
-               = mkConApp data_con (map Type (mkTyVarTys all_tyvars) ++ map Var data_args)
-
-       con_rhs = mkLams all_tyvars $ mkLams locals $
-                 foldr mk_case con_app strict_args
-
-       mk_case arg body | isUnLiftedType (idType arg)
-                        = body                 -- "!" on unboxed arg does nothing
-                        | otherwise
-                        = Case (Var arg) arg [(DEFAULT,[],body)]
-                               -- This case shadows "arg" but that's fine
+    (tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
+    is_newtype = isNewTyCon tycon
+    all_tyvars = tyvars ++ ex_tyvars
+    work_id    = dataConWorkId data_con
+
+    common_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo
+                 `setArityInfo` arity
+               -- It's important to specify the arity, so that partial
+               -- applications are treated as values
+
+    info | is_newtype = common_info `setUnfoldingInfo` newtype_unf
+        | otherwise  = common_info `setUnfoldingInfo` data_unf
+                                   `setAllStrictnessInfo` Just wrap_sig
+
+    wrap_sig = mkStrictSig (mkTopDmdType arg_dmds res_info)
+    res_info = strictSigResInfo (idNewStrictness work_id)
+    arg_dmds = map mk_dmd strict_marks
+    mk_dmd str | isMarkedStrict str = evalDmd
+              | otherwise          = lazyDmd
+       -- The Cpr info can be important inside INLINE rhss, where the
+       -- wrapper constructor isn't inlined.
+       -- And the argument strictness can be important too; we
+       -- may not inline a contructor when it is partially applied.
+       -- For example:
+       --      data W = C !Int !Int !Int
+       --      ...(let w = C x in ...(w p q)...)...
+       -- we want to see that w is strict in its two arguments
+
+    newtype_unf = ASSERT( null ex_tyvars && null ex_dict_args && 
+                         isSingleton orig_arg_tys )
+                 -- No existentials on a newtype, but it can have a context
+                 -- e.g.       newtype Eq a => T a = MkT (...)
+                 mkTopUnfolding $ Note InlineMe $
+                 mkLams tyvars $ Lam id_arg1 $ 
+                 mkNewTypeBody tycon result_ty (Var id_arg1)
+
+    data_unf = mkTopUnfolding $ Note InlineMe $
+              mkLams all_tyvars $ 
+              mkLams ex_dict_args $ mkLams id_args $
+              foldr mk_case con_app 
+                    (zip (ex_dict_args++id_args) strict_marks) i3 []
+
+    con_app i rep_ids = mkApps (Var work_id)
+                              (map varToCoreExpr (all_tyvars ++ reverse rep_ids))
+
+    ex_dict_tys  = mkPredTys ex_theta
+    all_arg_tys  = ex_dict_tys ++ orig_arg_tys
+    result_ty    = mkTyConApp tycon (mkTyVarTys tyvars)
+
+    wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty)
+       -- We used to include the stupid theta in the wrapper's args
+       -- but now we don't.  Instead the type checker just injects these
+       -- extra constraints where necessary.
+
+    mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
+                  where
+                    n = length tys
+
+    (ex_dict_args,i2)  = mkLocals 1  ex_dict_tys
+    (id_args,i3)       = mkLocals i2 orig_arg_tys
+    arity             = i3-1
+    (id_arg1:_)   = id_args            -- Used for newtype only
+
+    strict_marks  = dataConStrictMarks data_con
+
+    mk_case 
+          :: (Id, StrictnessMark)      -- Arg, strictness
+          -> (Int -> [Id] -> CoreExpr) -- Body
+          -> Int                       -- Next rep arg id
+          -> [Id]                      -- Rep args so far, reversed
+          -> CoreExpr
+    mk_case (arg,strict) body i rep_args
+         = case strict of
+               NotMarkedStrict -> body i (arg:rep_args)
+               MarkedStrict 
+                  | isUnLiftedType (idType arg) -> body i (arg:rep_args)
+                  | otherwise ->
+                       Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
+
+               MarkedUnboxed
+                  -> case splitProductType "do_unbox" (idType arg) of
+                          (tycon, tycon_args, con, tys) ->
+                                  Case (Var arg) arg [(DataAlt con, con_args,
+                                       body i' (reverse con_args ++ rep_args))]
+                             where 
+                               (con_args, i') = mkLocals i tys
 \end{code}
 
 
 \end{code}
 
 
@@ -197,82 +364,217 @@ We're going to build a record selector unfolding that looks like this:
                                    T2 ... x ... -> x
                                    other        -> error "..."
 
                                    T2 ... x ... -> x
                                    other        -> error "..."
 
-\begin{code}
-mkRecordSelId field_label selector_ty
-  = ASSERT( null theta && isDataTyCon tycon )
-    sel_id
-  where
-    sel_id = mkId (fieldLabelName field_label) selector_ty
-                 (RecordSelId field_label) info
-
-    info = exactArity 1        `setArityInfo` (
-          unfolding    `setUnfoldingInfo`
-          noIdInfo)
-       -- ToDo: consider adding further IdInfo
+Similarly for newtypes
 
 
-    unfolding = mkUnfolding sel_rhs
+       newtype N a = MkN { unN :: a->a }
 
 
-    (tyvars, theta, tau)  = splitSigmaTy selector_ty
-    (data_ty,rhs_ty)      = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
-                                       -- tau is of form (T a b c -> field-type)
-    (tycon, _, data_cons) = splitAlgTyConApp data_ty
-    tyvar_tys            = mkTyVarTys tyvars
+       unN :: N a -> a -> a
+       unN n = coerce (a->a) n
        
        
-    [data_id] = mkTemplateLocals [data_ty]
-    alts      = map mk_maybe_alt data_cons
-    the_alts  = catMaybes alts
-    default_alt | all isJust alts = [] -- No default needed
-               | otherwise       = [(DEFAULT, [], error_expr)]
+We need to take a little care if the field has a polymorphic type:
 
 
-    sel_rhs   = mkLams tyvars $ Lam data_id $
-               Case (Var data_id) data_id (the_alts ++ default_alt)
+       data R = R { f :: forall a. a->a }
 
 
-    mk_maybe_alt data_con 
-         = case maybe_the_arg_id of
-               Nothing         -> Nothing
-               Just the_arg_id -> Just (DataCon data_con, arg_ids, Var the_arg_id)
-         where
-           arg_ids          = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
-                                   -- The first one will shadow data_id, but who cares
-           field_lbls       = dataConFieldLabels data_con
-           maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
-
-    error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type rhs_ty, mkStringLit full_msg]
-    full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id]) 
-\end{code}
+Then we want
 
 
+       f :: forall a. R -> a -> a
+       f = /\ a \ r = case r of
+                         R f -> f a
 
 
-%************************************************************************
-%*                                                                     *
-\subsection{Newtype field selectors}
-%*                                                                     *
-%************************************************************************
+(not f :: R -> forall a. a->a, which gives the type inference mechanism 
+problems at call sites)
+
+Similarly for (recursive) newtypes
 
 
-Possibly overkill to do it this way:
+       newtype N = MkN { unN :: forall a. a->a }
+
+       unN :: forall b. N -> b -> b
+       unN = /\b -> \n:N -> (coerce (forall a. a->a) n)
 
 \begin{code}
 
 \begin{code}
-mkNewTySelId field_label selector_ty = sel_id
+mkRecordSelId tycon field_label
+       -- Assumes that all fields with the same field label have the same type
+       --
+       -- Annoyingly, we have to pass in the unpackCString# Id, because
+       -- we can't conjure it up out of thin air
+  = sel_id
   where
   where
-    sel_id = mkId (fieldLabelName field_label) selector_ty
-                 (RecordSelId field_label) info
+    sel_id     = mkGlobalId (RecordSelId field_label) (fieldLabelName field_label) selector_ty info
+    field_ty   = fieldLabelType field_label
+    data_cons  = tyConDataCons tycon
+    tyvars     = tyConTyVars tycon     -- These scope over the types in 
+                                       -- the FieldLabels of constructors of this type
+    data_ty   = mkTyConApp tycon tyvar_tys
+    tyvar_tys = mkTyVarTys tyvars
+
+       -- Very tiresomely, the selectors are (unnecessarily!) overloaded over
+       -- just the dictionaries in the types of the constructors that contain
+       -- the relevant field.  [The Report says that pattern matching on a
+       -- constructor gives the same constraints as applying it.]  Urgh.  
+       --
+       -- However, not all data cons have all constraints (because of
+       -- TcTyDecls.thinContext).  So we need to find all the data cons 
+       -- involved in the pattern match and take the union of their constraints.
+       --
+       -- NB: this code relies on the fact that DataCons are quantified over
+       -- the identical type variables as their parent TyCon
+    tycon_theta         = tyConTheta tycon     -- The context on the data decl
+                                       --   eg data (Eq a, Ord b) => T a b = ...
+    needed_preds = [pred | (DataAlt dc, _, _) <- the_alts, pred <- dataConTheta dc]
+    dict_tys     = map mkPredTy (nubBy tcEqPred needed_preds)
+    n_dict_tys   = length dict_tys
+
+    (field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
+    field_dict_tys                      = map mkPredTy field_theta
+    n_field_dict_tys                    = length field_dict_tys
+       -- If the field has a universally quantified type we have to 
+       -- be a bit careful.  Suppose we have
+       --      data R = R { op :: forall a. Foo a => a -> a }
+       -- Then we can't give op the type
+       --      op :: R -> forall a. Foo a => a -> a
+       -- because the typechecker doesn't understand foralls to the
+       -- right of an arrow.  The "right" type to give it is
+       --      op :: forall a. Foo a => R -> a -> a
+       -- But then we must generate the right unfolding too:
+       --      op = /\a -> \dfoo -> \ r ->
+       --           case r of
+       --              R op -> op a dfoo
+       -- Note that this is exactly the type we'd infer from a user defn
+       --      op (R op) = op
+
+    selector_ty :: Type
+    selector_ty  = mkForAllTys tyvars $ mkForAllTys field_tyvars $
+                  mkFunTys dict_tys  $  mkFunTys field_dict_tys $
+                  mkFunTy data_ty field_tau
+      
+    arity = 1 + n_dict_tys + n_field_dict_tys
+
+    (strict_sig, rhs_w_str) = dmdAnalTopRhs sel_rhs
+       -- Use the demand analyser to work out strictness.
+       -- With all this unpackery it's not easy!
+
+    info = noCafIdInfo
+          `setCafInfo`           caf_info
+          `setArityInfo`         arity
+          `setUnfoldingInfo`     mkTopUnfolding rhs_w_str
+          `setAllStrictnessInfo` Just strict_sig
+
+       -- Allocate Ids.  We do it a funny way round because field_dict_tys is
+       -- almost always empty.  Also note that we use length_tycon_theta
+       -- rather than n_dict_tys, because the latter gives an infinite loop:
+       -- n_dict tys depends on the_alts, which depens on arg_ids, which depends
+       -- on arity, which depends on n_dict tys.  Sigh!  Mega sigh!
+    field_dict_base    = length tycon_theta + 1
+    dict_id_base       = field_dict_base + n_field_dict_tys
+    field_base        = dict_id_base + 1
+    dict_ids          = mkTemplateLocalsNum  1               dict_tys
+    field_dict_ids     = mkTemplateLocalsNum  field_dict_base field_dict_tys
+    data_id           = mkTemplateLocal      dict_id_base    data_ty
+
+    alts      = map mk_maybe_alt data_cons
+    the_alts  = catMaybes alts
 
 
-    info = exactArity 1        `setArityInfo` (
-          unfolding    `setUnfoldingInfo`
-          noIdInfo)
-       -- ToDo: consider adding further IdInfo
+    no_default = all isJust alts       -- No default needed
+    default_alt | no_default = []
+               | otherwise  = [(DEFAULT, [], error_expr)]
 
 
-    unfolding = mkUnfolding sel_rhs
+       -- The default branch may have CAF refs, because it calls recSelError etc.
+    caf_info    | no_default = NoCafRefs
+               | otherwise  = MayHaveCafRefs
 
 
-    (tyvars, theta, tau)  = splitSigmaTy selector_ty
-    (data_ty,rhs_ty)      = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
-                                       -- tau is of form (T a b c -> field-type)
-    (tycon, _, data_cons) = splitAlgTyConApp data_ty
-    tyvar_tys            = mkTyVarTys tyvars
-       
-    [data_id] = mkTemplateLocals [data_ty]
-    sel_rhs   = mkLams tyvars $ Lam data_id $
-               Note (Coerce rhs_ty data_ty) (Var data_id)
+    sel_rhs = mkLams tyvars   $ mkLams field_tyvars $ 
+             mkLams dict_ids $ mkLams field_dict_ids $
+             Lam data_id     $ sel_body
+
+    sel_body | isNewTyCon tycon = mk_result (mkNewTypeBody tycon field_ty (Var data_id))
+            | otherwise        = Case (Var data_id) data_id (default_alt ++ the_alts)
+
+    mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids
+       -- We pull the field lambdas to the top, so we need to 
+       -- apply them in the body.  For example:
+       --      data T = MkT { foo :: forall a. a->a }
+       --
+       --      foo :: forall a. T -> a -> a
+       --      foo = /\a. \t:T. case t of { MkT f -> f a }
 
 
+    mk_maybe_alt data_con 
+       = case maybe_the_arg_id of
+               Nothing         -> Nothing
+               Just the_arg_id -> Just (mkReboxingAlt uniqs data_con arg_ids body)
+                               where
+                                  body = mk_result (Var the_arg_id)
+       where
+            arg_ids = mkTemplateLocalsNum field_base (dataConOrigArgTys data_con)
+                       -- No need to instantiate; same tyvars in datacon as tycon
+
+           unpack_base = field_base + length arg_ids
+           uniqs = map mkBuiltinUnique [unpack_base..]
+
+                               -- arity+1 avoids all shadowing
+           maybe_the_arg_id  = assocMaybe (field_lbls `zip` arg_ids) field_label
+           field_lbls        = dataConFieldLabels data_con
+
+    error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
+    full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id]) 
+
+
+-- (mkReboxingAlt us con xs rhs) basically constructs the case
+-- alternative (con, xs, rhs)
+-- but it does the reboxing necessary to construct the *source* 
+-- arguments, xs, from the representation arguments ys.
+-- For example:
+--     data T = MkT !(Int,Int) Bool
+--
+-- mkReboxingAlt MkT [x,b] r 
+--     = (DataAlt MkT, [y::Int,z::Int,b], let x = (y,z) in r)
+--
+-- mkDataAlt should really be in DataCon, but it can't because
+-- it manipulates CoreSyn.
+
+mkReboxingAlt
+  :: [Unique]                  -- Uniques for the new Ids
+  -> DataCon
+  -> [Var]                     -- Source-level args
+  -> CoreExpr                  -- RHS
+  -> CoreAlt
+
+mkReboxingAlt us con args rhs
+  | not (any isMarkedUnboxed stricts)
+  = (DataAlt con, args, rhs)
+
+  | otherwise
+  = let
+       (binds, args') = go args stricts us
+    in
+    (DataAlt con, args', mkLets binds rhs)
+
+  where
+    stricts = dataConStrictMarks con
+
+    go [] stricts us = ([], [])
+
+       -- Type variable case
+    go (arg:args) stricts us 
+      | isTyVar arg
+      = let (binds, args') = go args stricts us
+       in  (binds, arg:args')
+
+       -- Term variable case
+    go (arg:args) (str:stricts) us
+      | isMarkedUnboxed str
+      = let
+         (_, tycon_args, pack_con, con_arg_tys)
+                = splitProductType "mkReboxingAlt" (idType arg)
+
+         unpacked_args  = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
+         (binds, args') = go args stricts (dropList con_arg_tys us)
+         con_app        = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
+       in
+       (NonRec arg con_app : binds, unpacked_args ++ args')
+
+      | otherwise
+      = let (binds, args') = go args stricts us
+        in  (binds, arg:args')
 \end{code}
 
 
 \end{code}
 
 
@@ -282,45 +584,59 @@ mkNewTySelId field_label selector_ty = sel_id
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 
-\begin{code}
-mkSuperDictSelId :: Unique -> Class -> FieldLabelTag -> Type -> Id
-       -- The FieldLabelTag says which superclass is selected
-       -- So, for 
-       --      class (C a, C b) => Foo a b where ...
-       -- we get superclass selectors
-       --      Foo_sc1, Foo_sc2
-
-mkSuperDictSelId uniq clas index ty
-  = mkDictSelId name clas ty
-  where
-    name   = mkDerivedName (mkSuperDictSelOcc index) (getName clas) uniq
+Selecting a field for a dictionary.  If there is just one field, then
+there's nothing to do.  
 
 
-       -- For method selectors the clean thing to do is
-       -- to give the method selector the same name as the class op itself.
-mkMethodSelId name clas ty
-  = mkDictSelId name clas ty
-\end{code}
+Dictionary selectors may get nested forall-types.  Thus:
 
 
-Selecting a field for a dictionary.  If there is just one field, then
-there's nothing to do.
+       class Foo a where
+         op :: forall b. Ord b => a -> b -> b
 
 
-\begin{code}
-mkDictSelId name clas ty
-  = sel_id
-  where
-    sel_id    = mkId name ty (RecordSelId field_lbl) info
-    field_lbl = mkFieldLabel name ty tag
-    tag       = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id
+Then the top-level type for op is
 
 
-    info      = setInlinePragInfo IMustBeINLINEd $
-               setUnfoldingInfo  unfolding noIdInfo
-       -- The always-inline thing means we don't need any other IdInfo
-       -- We need "Must" inline because we don't create any bindigs for
-       -- the selectors.
+       op :: forall a. Foo a => 
+             forall b. Ord b => 
+             a -> b -> b
 
 
-    unfolding = mkUnfolding rhs
+This is unlike ordinary record selectors, which have all the for-alls
+at the outside.  When dealing with classes it's very convenient to
+recover the original type signature from the class op selector.
 
 
-    (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
+ToDo: unify with mkRecordSelId?
+
+\begin{code}
+mkDictSelId :: Name -> Class -> Id
+mkDictSelId name clas
+  = mkGlobalId (RecordSelId field_lbl) name sel_ty info
+  where
+    sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
+       -- We can't just say (exprType rhs), because that would give a type
+       --      C a -> C a
+       -- for a single-op class (after all, the selector is the identity)
+       -- But it's type must expose the representation of the dictionary
+       -- to gat (say)         C a -> (a -> a)
+
+    field_lbl = mkFieldLabel name tycon sel_ty tag
+    tag       = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name
+
+    info      = noCafIdInfo
+               `setArityInfo`          1
+               `setUnfoldingInfo`      mkTopUnfolding rhs
+               `setAllStrictnessInfo`  Just strict_sig
+
+       -- We no longer use 'must-inline' on record selectors.  They'll
+       -- inline like crazy if they scrutinise a constructor
+
+       -- The strictness signature is of the form U(AAAVAAAA) -> T
+       -- where the V depends on which item we are selecting
+       -- It's worth giving one, so that absence info etc is generated
+       -- even if the selector isn't inlined
+    strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
+    arg_dmd | isNewTyCon tycon = evalDmd
+           | otherwise        = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
+                                           | id <- arg_ids ])
+
+    tyvars  = classTyVars clas
 
     tycon      = classTyCon clas
     [data_con] = tyConDataCons tycon
 
     tycon      = classTyCon clas
     [data_con] = tyConDataCons tycon
@@ -328,14 +644,22 @@ mkDictSelId name clas ty
     arg_tys    = dataConArgTys data_con tyvar_tys
     the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
 
     arg_tys    = dataConArgTys data_con tyvar_tys
     the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
 
-    dict_ty    = mkDictTy clas tyvar_tys
-    (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
+    pred             = mkClassPred clas tyvar_tys
+    (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
 
 
-    rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
-                            Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
+    rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $ 
+                            mkNewTypeBody tycon (head arg_tys) (Var dict_id)
        | otherwise        = mkLams tyvars $ Lam dict_id $
                             Case (Var dict_id) dict_id
        | otherwise        = mkLams tyvars $ Lam dict_id $
                             Case (Var dict_id) dict_id
-                                 [(DataCon data_con, arg_ids, Var the_arg_id)]
+                                 [(DataAlt data_con, arg_ids, Var the_arg_id)]
+
+mkNewTypeBody tycon result_ty result_expr
+       -- Adds a coerce where necessary
+       -- Used for both wrapping and unwrapping
+  | isRecursiveTyCon tycon     -- Recursive case; use a coerce
+  = Note (Coerce result_ty (exprType result_expr)) result_expr
+  | otherwise                  -- Normal case
+  = result_expr
 \end{code}
 
 
 \end{code}
 
 
@@ -345,70 +669,118 @@ mkDictSelId name clas ty
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 
-
 \begin{code}
 \begin{code}
-mkPrimitiveId :: PrimOp -> Id
-mkPrimitiveId prim_op 
+mkPrimOpId :: PrimOp -> Id
+mkPrimOpId prim_op 
   = id
   where
   = id
   where
-    occ_name = primOpOcc  prim_op
-    key             = primOpUniq prim_op
-    ty      = primOpType prim_op
-    name    = mkWiredInIdName key pREL_GHC occ_name id
-    id      = mkId name ty (ConstantId (PrimOp prim_op)) info
+    (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
+    ty   = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
+    name = mkPrimOpIdName prim_op
+    id   = mkGlobalId (PrimOpId prim_op) name ty info
                
                
-    info = setUnfoldingInfo unfolding $
-          setInlinePragInfo IMustBeINLINEd $
-               -- The pragma @IMustBeINLINEd@ says that this Id absolutely 
-               -- must be inlined.  It's only used for primitives, 
-               -- because we don't want to make a closure for each of them.
-          noIdInfo
-
-    unfolding = mkUnfolding rhs
-
-    (tyvars, tau) = splitForAllTys ty
-    (arg_tys, _)  = splitFunTys tau
+    info = noCafIdInfo
+          `setSpecInfo`        rules
+          `setArityInfo`       arity
+          `setAllStrictnessInfo` Just strict_sig
+
+    rules = foldl (addRule id) emptyCoreRules (primOpRules prim_op)
+
+
+-- For each ccall we manufacture a separate CCallOpId, giving it
+-- a fresh unique, a type that is correct for this particular ccall,
+-- and a CCall structure that gives the correct details about calling
+-- convention etc.  
+--
+-- The *name* of this Id is a local name whose OccName gives the full
+-- details of the ccall, type and all.  This means that the interface 
+-- file reader can reconstruct a suitable Id
+
+mkFCallId :: Unique -> ForeignCall -> Type -> Id
+mkFCallId uniq fcall ty
+  = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
+       -- A CCallOpId should have no free type variables; 
+       -- when doing substitutions won't substitute over it
+    mkGlobalId (FCallId fcall) name ty info
+  where
+    occ_str = showSDoc (braces (ppr fcall <+> ppr ty))
+       -- The "occurrence name" of a ccall is the full info about the
+       -- ccall; it is encoded, but may have embedded spaces etc!
 
 
-    args = mkTemplateLocals arg_tys
-    rhs =  mkLams tyvars $ mkLams args $
-          mkPrimApp prim_op (map Type (mkTyVarTys tyvars) ++ map Var args)
-\end{code}
+    name = mkFCallName uniq occ_str
 
 
-\end{code}
+    info = noCafIdInfo
+          `setArityInfo`               arity
+          `setAllStrictnessInfo`       Just strict_sig
 
 
-\begin{code}
-dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
-monadic_fun_ty ty = ty `mkFunTy` ty
-compare_fun_ty ty = mkFunTys [ty, ty] boolTy
+    (_, tau)    = tcSplitForAllTys ty
+    (arg_tys, _) = tcSplitFunTys tau
+    arity       = length arg_tys
+    strict_sig   = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
 \end{code}
 
 
 %************************************************************************
 %*                                                                     *
 \end{code}
 
 
 %************************************************************************
 %*                                                                     *
-\subsection{DictFuns}
+\subsection{DictFuns and default methods}
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 
+Important notes about dict funs and default methods
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Dict funs and default methods are *not* ImplicitIds.  Their definition
+involves user-written code, so we can't figure out their strictness etc
+based on fixed info, as we can for constructors and record selectors (say).
+
+We build them as GlobalIds, but when in the module where they are
+bound, we turn the Id at the *binding site* into an exported LocalId.
+This ensures that they are taken to account by free-variable finding
+and dependency analysis (e.g. CoreFVs.exprFreeVars).   The simplifier
+will propagate the LocalId to all occurrence sites. 
+
+Why shouldn't they be bound as GlobalIds?  Because, in particular, if
+they are globals, the specialiser floats dict uses above their defns,
+which prevents good simplifications happening.  Also the strictness
+analyser treats a occurrence of a GlobalId as imported and assumes it
+contains strictness in its IdInfo, which isn't true if the thing is
+bound in the same module as the occurrence.
+
+It's OK for dfuns to be LocalIds, because we form the instance-env to
+pass on to the next module (md_insts) in CoreTidy, afer tidying
+and globalising the top-level Ids.
+
+BUT make sure they are *exported* LocalIds (setIdLocalExported) so 
+that they aren't discarded by the occurrence analyser.
+
 \begin{code}
 \begin{code}
+mkDefaultMethodId dm_name ty 
+  = setIdLocalExported (mkLocalId dm_name ty)
+
 mkDictFunId :: Name            -- Name to use for the dict fun;
 mkDictFunId :: Name            -- Name to use for the dict fun;
-           -> Class 
            -> [TyVar]
            -> [TyVar]
-           -> [Type]
            -> ThetaType
            -> ThetaType
+           -> Class 
+           -> [Type]
            -> Id
 
            -> Id
 
-mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
-  = mkVanillaId dfun_name dfun_ty
+mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
+  = setIdLocalExported (mkLocalId dfun_name dfun_ty)
   where
   where
-    (class_tyvars, sc_theta, _, _, _) = classBigSig clas
-    sc_theta' = substTopTheta (zipVarEnv class_tyvars inst_tys) sc_theta
+    dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
 
 
+{-  1 dec 99: disable the Mark Jones optimisation for the sake
+    of compatibility with Hugs.
+    See `types/InstEnv' for a discussion related to this.
+
+    (class_tyvars, sc_theta, _, _) = classBigSig clas
+    not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
+    sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
     dfun_theta = case inst_decl_theta of
                   []    -> []  -- If inst_decl_theta is empty, then we don't
                                -- want to have any dict arguments, so that we can
                                -- expose the constant methods.
 
     dfun_theta = case inst_decl_theta of
                   []    -> []  -- If inst_decl_theta is empty, then we don't
                                -- want to have any dict arguments, so that we can
                                -- expose the constant methods.
 
-                  other -> nub (inst_decl_theta ++ sc_theta')
+                  other -> nub (inst_decl_theta ++ filter not_const sc_theta')
                                -- Otherwise we pass the superclass dictionaries to
                                -- the dictionary function; the Mark Jones optimisation.
                                --
                                -- Otherwise we pass the superclass dictionaries to
                                -- the dictionary function; the Mark Jones optimisation.
                                --
@@ -417,6 +789,204 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
                                --   instance Monad m => MonadT (EnvT env) m where ...
                                -- Here, the inst_decl_theta has (Monad m); but so
                                -- does the sc_theta'!
                                --   instance Monad m => MonadT (EnvT env) m where ...
                                -- Here, the inst_decl_theta has (Monad m); but so
                                -- does the sc_theta'!
+                               --
+                               -- NOTE the "not_const".  I got caught by this one too:
+                               --   class Foo a => Baz a b where ...
+                               --   instance Wob b => Baz T b where..
+                               -- Now sc_theta' has Foo T
+-}
+\end{code}
 
 
-    dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
+
+%************************************************************************
+%*                                                                     *
+\subsection{Un-definable}
+%*                                                                     *
+%************************************************************************
+
+These Ids can't be defined in Haskell.  They could be defined in
+unfoldings in the wired-in GHC.Prim interface file, but we'd have to
+ensure that they were definitely, definitely inlined, because there is
+no curried identifier for them.  That's what mkCompulsoryUnfolding
+does.  If we had a way to get a compulsory unfolding from an interface
+file, we could do that, but we don't right now.
+
+unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
+just gets expanded into a type coercion wherever it occurs.  Hence we
+add it as a built-in Id with an unfolding here.
+
+The type variables we use here are "open" type variables: this means
+they can unify with both unlifted and lifted types.  Hence we provide
+another gun with which to shoot yourself in the foot.
+
+\begin{code}
+-- unsafeCoerce# :: forall a b. a -> b
+unsafeCoerceId
+  = pcMiscPrelId unsafeCoerceName ty info
+  where
+    info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+          
+
+    ty  = mkForAllTys [openAlphaTyVar,openBetaTyVar]
+                     (mkFunTy openAlphaTy openBetaTy)
+    [x] = mkTemplateLocals [openAlphaTy]
+    rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
+         Note (Coerce openBetaTy openAlphaTy) (Var x)
+
+-- nullAddr# :: Addr#
+-- The reason is is here is because we don't provide 
+-- a way to write this literal in Haskell.
+nullAddrId 
+  = pcMiscPrelId nullAddrName addrPrimTy info
+  where
+    info = noCafIdInfo `setUnfoldingInfo` 
+          mkCompulsoryUnfolding (Lit nullAddrLit)
+
+seqId
+  = pcMiscPrelId seqName ty info
+  where
+    info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+          
+
+    ty  = mkForAllTys [alphaTyVar,openBetaTyVar]
+                     (mkFunTy alphaTy (mkFunTy openBetaTy openBetaTy))
+    [x,y] = mkTemplateLocals [alphaTy, openBetaTy]
+    rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x [(DEFAULT, [], Var y)])
+
+-- lazy :: forall a?. a? -> a?  (i.e. works for unboxed types too)
+-- Used to lazify pseq:                pseq a b = a `seq` lazy b
+-- No unfolding: it gets "inlined" by the worker/wrapper pass
+-- Also, no strictness: by being a built-in Id, it overrides all
+-- the info in PrelBase.hi.  This is important, because the strictness
+-- analyser will spot it as strict!
+lazyId
+  = pcMiscPrelId lazyIdName ty info
+  where
+    info = noCafIdInfo
+    ty  = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
+
+lazyIdUnfolding :: CoreExpr    -- Used to expand LazyOp after strictness anal
+lazyIdUnfolding = mkLams [openAlphaTyVar,x] (Var x)
+               where
+                 [x] = mkTemplateLocals [openAlphaTy]
+\end{code}
+
+@realWorld#@ used to be a magic literal, \tr{void#}.  If things get
+nasty as-is, change it back to a literal (@Literal@).
+
+voidArgId is a Local Id used simply as an argument in functions
+where we just want an arg to avoid having a thunk of unlifted type.
+E.g.
+       x = \ void :: State# RealWorld -> (# p, q #)
+
+This comes up in strictness analysis
+
+\begin{code}
+realWorldPrimId        -- :: State# RealWorld
+  = pcMiscPrelId realWorldName realWorldStatePrimTy
+                (noCafIdInfo `setUnfoldingInfo` mkOtherCon [])
+       -- The mkOtherCon makes it look that realWorld# is evaluated
+       -- which in turn makes Simplify.interestingArg return True,
+       -- which in turn makes INLINE things applied to realWorld# likely
+       -- to be inlined
+
+voidArgId      -- :: State# RealWorld
+  = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy
 \end{code}
 \end{code}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection[PrelVals-error-related]{@error@ and friends; @trace@}
+%*                                                                     *
+%************************************************************************
+
+GHC randomly injects these into the code.
+
+@patError@ is just a version of @error@ for pattern-matching
+failures.  It knows various ``codes'' which expand to longer
+strings---this saves space!
+
+@absentErr@ is a thing we put in for ``absent'' arguments.  They jolly
+well shouldn't be yanked on, but if one is, then you will get a
+friendly message from @absentErr@ (rather than a totally random
+crash).
+
+@parError@ is a special version of @error@ which the compiler does
+not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@
+templates, but we don't ever expect to generate code for it.
+
+\begin{code}
+mkRuntimeErrorApp 
+       :: Id           -- Should be of type (forall a. Addr# -> a)
+                       --      where Addr# points to a UTF8 encoded string
+       -> Type         -- The type to instantiate 'a'
+       -> String       -- The string to print
+       -> CoreExpr
+
+mkRuntimeErrorApp err_id res_ty err_msg 
+  = mkApps (Var err_id) [Type res_ty, err_string]
+  where
+    err_string = Lit (MachStr (mkFastString (stringToUtf8 err_msg)))
+
+rEC_SEL_ERROR_ID               = mkRuntimeErrorId recSelErrorName
+rUNTIME_ERROR_ID               = mkRuntimeErrorId runtimeErrorName
+iRREFUT_PAT_ERROR_ID           = mkRuntimeErrorId irrefutPatErrorName
+rEC_CON_ERROR_ID               = mkRuntimeErrorId recConErrorName
+nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
+pAT_ERROR_ID                   = mkRuntimeErrorId patErrorName
+nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId noMethodBindingErrorName
+
+-- The runtime error Ids take a UTF8-encoded string as argument
+mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
+runtimeErrorTy               = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
+\end{code}
+
+\begin{code}
+eRROR_ID = pc_bottoming_Id errorName errorTy
+
+errorTy  :: Type
+errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
+    -- Notice the openAlphaTyVar.  It says that "error" can be applied
+    -- to unboxed as well as boxed types.  This is OK because it never
+    -- returns, so the return type is irrelevant.
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{Utilities}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+pcMiscPrelId :: Name -> Type -> IdInfo -> Id
+pcMiscPrelId name ty info
+  = mkVanillaGlobal name ty info
+    -- We lie and say the thing is imported; otherwise, we get into
+    -- a mess with dependency analysis; e.g., core2stg may heave in
+    -- random calls to GHCbase.unpackPS__.  If GHCbase is the module
+    -- being compiled, then it's just a matter of luck if the definition
+    -- will be in "the right place" to be in scope.
+
+pc_bottoming_Id name ty
+ = pcMiscPrelId name ty bottoming_info
+ where
+    bottoming_info = hasCafIdInfo `setAllStrictnessInfo` Just strict_sig
+       -- Do *not* mark them as NoCafRefs, because they can indeed have
+       -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,
+       -- which has some CAFs
+       -- In due course we may arrange that these error-y things are
+       -- regarded by the GC as permanently live, in which case we
+       -- can give them NoCaf info.  As it is, any function that calls
+       -- any pc_bottoming_Id will itself have CafRefs, which bloats
+       -- SRTs.
+
+    strict_sig    = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
+       -- These "bottom" out, no matter what their arguments
+
+(openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
+openAlphaTy  = mkTyVarTy openAlphaTyVar
+openBetaTy   = mkTyVarTy openBetaTyVar
+\end{code}
+