projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2006-01-06 16:30:17 by simonmar]
[ghc-hetmet.git] / ghc / compiler / basicTypes / MkId.lhs
diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index dcd057d..9d93a67 100644 (file)
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -37,37 +37,37 @@ module MkId (
 
 
 import BasicTypes      ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
 
 
 import BasicTypes      ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
+import Rules           ( mkSpecInfo )
 import TysPrim         ( openAlphaTyVars, alphaTyVar, alphaTy, 
                          realWorldStatePrimTy, addrPrimTy
                        )
 import TysWiredIn      ( charTy, mkListTy )
 import PrelRules       ( primOpRules )
 import TysPrim         ( openAlphaTyVars, alphaTyVar, alphaTy, 
                          realWorldStatePrimTy, addrPrimTy
                        )
 import TysWiredIn      ( charTy, mkListTy )
 import PrelRules       ( primOpRules )
-import Rules           ( addRule )
-import Type            ( TyThing(..) )
-import TcType          ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
-                         mkTyVarTys, mkClassPred, tcEqPred,
+import Type            ( TyThing(..), mkForAllTy, tyVarsOfTypes )
+import TcType          ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, 
+                         mkTyConApp, mkTyVarTys, mkClassPred, 
                          mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, 
                          isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
                          mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, 
                          isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
-                         tcSplitFunTys, tcSplitForAllTys, mkPredTy
+                         tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
                        )
 import CoreUtils       ( exprType )
                        )
 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 CoreUnfold      ( mkTopUnfolding, mkCompulsoryUnfolding )
+import Literal         ( nullAddrLit, mkStringLit )
+import TyCon           ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
+                          tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
+import Class           ( Class, classTyCon, classSelIds )
 import Var             ( Id, TyVar, Var )
 import Var             ( Id, TyVar, Var )
-import VarSet          ( isEmptyVarSet )
+import VarSet          ( isEmptyVarSet, subVarSet, varSetElems )
 import Name            ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) )
 import Name            ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) )
-import OccName         ( mkOccFS, varName )
+import OccName         ( mkOccNameFS, varName )
 import PrimOp          ( PrimOp, primOpSig, primOpOcc, primOpTag )
 import ForeignCall     ( ForeignCall )
 import PrimOp          ( PrimOp, primOpSig, primOpOcc, primOpTag )
 import ForeignCall     ( ForeignCall )
-import DataCon         ( DataCon, DataConIds(..),
-                         dataConFieldLabels, dataConRepArity, 
-                         dataConArgTys, dataConRepType, 
-                         dataConOrigArgTys, dataConTheta,
+import DataCon         ( DataCon, DataConIds(..), dataConTyVars,
+                         dataConFieldLabels, dataConRepArity, dataConResTys,
+                         dataConRepArgTys, dataConRepType, 
                          dataConSig, dataConStrictMarks, dataConExStricts, 
                          dataConSig, dataConStrictMarks, dataConExStricts, 
-                         splitProductType
+                         splitProductType, isVanillaDataCon, dataConFieldType,
+                         dataConInstOrigArgTys
                        )
 import Id              ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, 
                          mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
                        )
 import Id              ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, 
                          mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
@@ -81,21 +81,15 @@ import IdInfo               ( IdInfo, noCafIdInfo,  setUnfoldingInfo,
 import NewDemand       ( mkStrictSig, DmdResult(..),
                          mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR,
                          Demand(..), Demands(..) )
 import NewDemand       ( mkStrictSig, DmdResult(..),
                          mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR,
                          Demand(..), Demands(..) )
-import FieldLabel      ( fieldLabelName, firstFieldLabelTag, 
-                         allFieldLabelTags, fieldLabelType
-                       )
 import DmdAnal         ( dmdAnalTopRhs )
 import CoreSyn
 import Unique          ( mkBuiltinUnique, mkPrimOpIdUnique )
 import Maybes
 import PrelNames
 import DmdAnal         ( dmdAnalTopRhs )
 import CoreSyn
 import Unique          ( mkBuiltinUnique, mkPrimOpIdUnique )
 import Maybes
 import PrelNames
-import Maybe            ( isJust )
 import Util             ( dropList, isSingleton )
 import Outputable
 import FastString
 import Util             ( dropList, isSingleton )
 import Outputable
 import FastString
-import ListSetOps      ( assoc, assocMaybe )
-import UnicodeUtil      ( stringToUtf8 )
-import List            ( nubBy )
+import ListSetOps      ( assoc )
 \end{code}             
 
 %************************************************************************
 \end{code}             
 
 %************************************************************************
@@ -200,14 +194,13 @@ mkDataConIds wrap_name wkr_name data_con
   | otherwise                                  -- Algebraic, no wrapper
   = AlgDC Nothing wrk_id
   where
   | otherwise                                  -- Algebraic, no wrapper
   = AlgDC Nothing wrk_id
   where
-    (tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
-    all_tyvars = tyvars ++ ex_tyvars
+    (tyvars, theta, orig_arg_tys, tycon, res_tys) = dataConSig data_con
 
 
-    ex_dict_tys  = mkPredTys ex_theta
-    all_arg_tys  = ex_dict_tys ++ orig_arg_tys
-    result_ty    = mkTyConApp tycon (mkTyVarTys tyvars)
+    dict_tys    = mkPredTys theta
+    all_arg_tys = dict_tys ++ orig_arg_tys
+    result_ty   = mkTyConApp tycon res_tys
 
 
-    wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty)
+    wrap_ty = mkForAllTys 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.
        -- 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.
@@ -220,6 +213,8 @@ mkDataConIds wrap_name wkr_name data_con
     wkr_info  = noCafIdInfo
                `setArityInfo`          wkr_arity
                `setAllStrictnessInfo`  Just wkr_sig
     wkr_info  = noCafIdInfo
                `setArityInfo`          wkr_arity
                `setAllStrictnessInfo`  Just wkr_sig
+               `setUnfoldingInfo`      evaldUnfolding  -- Record that it's evaluated,
+                                                       -- even if arity = 0
 
     wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
        -- Notice that we do *not* say the worker is strict
 
     wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
        -- Notice that we do *not* say the worker is strict
@@ -230,7 +225,7 @@ mkDataConIds wrap_name wkr_name data_con
        -- 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
        -- 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.
+       --  $wMkT is strict) and drops the case.  No, $wMkT is not strict.
        --
        -- When the simplifer sees a pattern 
        --      case e of MkT x -> ...
        --
        -- When the simplifer sees a pattern 
        --      case e of MkT x -> ...
@@ -251,8 +246,8 @@ mkDataConIds wrap_name wkr_name data_con
     nt_wrap_info = noCafIdInfo         -- The NoCaf-ness is set by noCafIdInfo
                  `setArityInfo` 1      -- Arity 1
                  `setUnfoldingInfo`     newtype_unf
     nt_wrap_info = noCafIdInfo         -- The NoCaf-ness is set by noCafIdInfo
                  `setArityInfo` 1      -- Arity 1
                  `setUnfoldingInfo`     newtype_unf
-    newtype_unf  = ASSERT( null ex_tyvars && null ex_theta && 
-                         isSingleton orig_arg_tys )
+    newtype_unf  = ASSERT( isVanillaDataCon data_con &&
+                          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 $
                   -- No existentials on a newtype, but it can have a context
                   -- e.g.      newtype Eq a => T a = MkT (...)
                   mkTopUnfolding $ Note InlineMe $
@@ -285,18 +280,18 @@ mkDataConIds wrap_name wkr_name data_con
        -- we want to see that w is strict in its two arguments
 
     alg_unf = mkTopUnfolding $ Note InlineMe $
        -- we want to see that w is strict in its two arguments
 
     alg_unf = mkTopUnfolding $ Note InlineMe $
-             mkLams all_tyvars $ 
-             mkLams ex_dict_args $ mkLams id_args $
+             mkLams tyvars $ 
+             mkLams dict_args $ mkLams id_args $
              foldr mk_case con_app 
              foldr mk_case con_app 
-                   (zip (ex_dict_args ++ id_args) all_strict_marks)
+                   (zip (dict_args ++ id_args) all_strict_marks)
                    i3 []
 
     con_app i rep_ids = mkApps (Var wrk_id)
                    i3 []
 
     con_app i rep_ids = mkApps (Var wrk_id)
-                              (map varToCoreExpr (all_tyvars ++ reverse rep_ids))
+                              (map varToCoreExpr (tyvars ++ reverse rep_ids))
 
 
-    (ex_dict_args,i2)  = mkLocals 1  ex_dict_tys
-    (id_args,i3)       = mkLocals i2 orig_arg_tys
-    alg_arity         = i3-1
+    (dict_args,i2) = mkLocals 1  dict_tys
+    (id_args,i3)   = mkLocals i2 orig_arg_tys
+    alg_arity     = i3-1
 
     mk_case 
           :: (Id, StrictnessMark)      -- Arg, strictness
 
     mk_case 
           :: (Id, StrictnessMark)      -- Arg, strictness
@@ -310,13 +305,15 @@ mkDataConIds wrap_name wkr_name data_con
                MarkedStrict 
                   | isUnLiftedType (idType arg) -> body i (arg:rep_args)
                   | otherwise ->
                MarkedStrict 
                   | isUnLiftedType (idType arg) -> body i (arg:rep_args)
                   | otherwise ->
-                       Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
+                       Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
 
                MarkedUnboxed
                   -> case splitProductType "do_unbox" (idType arg) of
                           (tycon, tycon_args, con, tys) ->
 
                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))]
+                                  Case (Var arg) arg result_ty  
+                                       [(DataAlt con, 
+                                         con_args,
+                                         body i' (reverse con_args ++ rep_args))]
                              where 
                                (con_args, i') = mkLocals i tys
 
                              where 
                                (con_args, i') = mkLocals i tys
 
@@ -381,38 +378,84 @@ Similarly for (recursive) newtypes
        unN :: forall b. N -> b -> b
        unN = /\b -> \n:N -> (coerce (forall a. a->a) n)
 
        unN :: forall b. N -> b -> b
        unN = /\b -> \n:N -> (coerce (forall a. a->a) n)
 
+
+Note [Naughty record selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A "naughty" field is one for which we can't define a record 
+selector, because an existential type variable would escape.  For example:
+       data T = forall a. MkT { x,y::a }
+We obviously can't define      
+       x (MkT v _) = v
+Nevertheless we *do* put a RecordSelId into the type environment
+so that if the user tries to use 'x' as a selector we can bleat
+helpfully, rather than saying unhelpfully that 'x' is not in scope.
+Hence the sel_naughty flag, to identify record selcectors that don't really exist.
+
+In general, a field is naughty if its type mentions a type variable that
+isn't in the result type of the constructor.
+
+For GADTs, we require that all constructors with a common field 'f' have the same
+result type (modulo alpha conversion).  [Checked in TcTyClsDecls.checkValidTyCon]
+E.g. 
+       data T where
+         T1 { f :: a } :: T [a]
+         T2 { f :: a, y :: b  } :: T [a]
+and now the selector takes that type as its argument:
+       f :: forall a. T [a] -> a
+       f t = case t of
+               T1 { f = v } -> v
+               T2 { f = v } -> v
+Note the forall'd tyvars of the selector are just the free tyvars
+of the result type; there may be other tyvars in the constructor's
+type (e.g. 'b' in T2).
+
 \begin{code}
 \begin{code}
+
+-- XXX - autrijus -
+-- Plan: 1. Determine naughtiness by comparing field type vs result type
+--       2. Install naughty ones with selector_ty of type _|_ and fill in mzero for info
+--       3. If it's not naughty, do the normal plan.
+
+mkRecordSelId :: TyCon -> FieldLabel -> Id
 mkRecordSelId tycon field_label
        -- Assumes that all fields with the same field label have the same type
 mkRecordSelId tycon field_label
        -- Assumes that all fields with the same field label have the same type
-  = sel_id
+  | is_naughty = naughty_id
+  | otherwise  = sel_id
   where
   where
-    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
+    is_naughty = not (tyVarsOfType field_ty `subVarSet` tyvar_set)
+    sel_id_details = RecordSelId tycon field_label is_naughty
+
+    -- Escapist case here for naughty construcotrs
+    -- We give it no IdInfo, and a type of forall a.a (never looked at)
+    naughty_id = mkGlobalId sel_id_details field_label forall_a_a noCafIdInfo
+    forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
+
+    -- Normal case starts here
+    sel_id = mkGlobalId sel_id_details field_label selector_ty info
+    data_cons                = tyConDataCons tycon     
+    data_cons_w_field = filter has_field data_cons     -- Can't be empty!
+    has_field con     = field_label `elem` dataConFieldLabels con
+
+    con1       = head data_cons_w_field
+    res_tys    = dataConResTys con1
+    tyvar_set  = tyVarsOfTypes res_tys
+    tyvars     = varSetElems tyvar_set
+    data_ty    = mkTyConApp tycon res_tys
+    field_ty   = dataConFieldType con1 field_label
+    
+       -- *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
        -- 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 
+       -- BuildTyCl.mkDataConStupidTheta).  So we need to find all the data cons 
        -- involved in the pattern match and take the union of their constraints.
        -- 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
+    stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field)
+    n_stupid_dicts  = length stupid_dict_tys
 
     (field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
 
     (field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
-    field_dict_tys                      = map mkPredTy field_theta
+    field_dict_tys                      = mkPredTys 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
     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
@@ -431,10 +474,10 @@ mkRecordSelId tycon field_label
 
     selector_ty :: Type
     selector_ty  = mkForAllTys tyvars $ mkForAllTys field_tyvars $
 
     selector_ty :: Type
     selector_ty  = mkForAllTys tyvars $ mkForAllTys field_tyvars $
-                  mkFunTys dict_tys  $  mkFunTys field_dict_tys $
+                  mkFunTys stupid_dict_tys  $  mkFunTys field_dict_tys $
                   mkFunTy data_ty field_tau
       
                   mkFunTy data_ty field_tau
       
-    arity = 1 + n_dict_tys + n_field_dict_tys
+    arity = 1 + n_stupid_dicts + n_field_dict_tys
 
     (strict_sig, rhs_w_str) = dmdAnalTopRhs sel_rhs
        -- Use the demand analyser to work out strictness.
 
     (strict_sig, rhs_w_str) = dmdAnalTopRhs sel_rhs
        -- Use the demand analyser to work out strictness.
@@ -447,21 +490,22 @@ mkRecordSelId tycon field_label
           `setAllStrictnessInfo` Just strict_sig
 
        -- Allocate Ids.  We do it a funny way round because field_dict_tys is
           `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
+       -- almost always empty.  Also note that we use max_dict_tys
        -- 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!
        -- 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
+    stupid_dict_ids  = mkTemplateLocalsNum 1 stupid_dict_tys
+    max_stupid_dicts = length (tyConStupidTheta tycon)
+    field_dict_base  = max_stupid_dicts + 1
+    field_dict_ids   = mkTemplateLocalsNum field_dict_base field_dict_tys
+    dict_id_base     = field_dict_base + n_field_dict_tys
+    data_id         = mkTemplateLocal dict_id_base data_ty
+    arg_base        = dict_id_base + 1
+
+    the_alts :: [CoreAlt]
+    the_alts   = map mk_alt data_cons_w_field  -- Already sorted by data-con
+    no_default = length data_cons == length data_cons_w_field  -- No default needed
 
 
-    no_default = all isJust alts       -- No default needed
     default_alt | no_default = []
                | otherwise  = [(DEFAULT, [], error_expr)]
 
     default_alt | no_default = []
                | otherwise  = [(DEFAULT, [], error_expr)]
 
@@ -470,11 +514,11 @@ mkRecordSelId tycon field_label
                | otherwise  = MayHaveCafRefs
 
     sel_rhs = mkLams tyvars   $ mkLams field_tyvars $ 
                | otherwise  = MayHaveCafRefs
 
     sel_rhs = mkLams tyvars   $ mkLams field_tyvars $ 
-             mkLams dict_ids $ mkLams field_dict_ids $
+             mkLams stupid_dict_ids $ mkLams field_dict_ids $
              Lam data_id     $ sel_body
 
     sel_body | isNewTyCon tycon = mk_result (mkNewTypeBody tycon field_ty (Var data_id))
              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)
+            | otherwise        = Case (Var data_id) data_id field_tau (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 
 
     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 
@@ -484,23 +528,28 @@ mkRecordSelId tycon field_label
        --      foo :: forall a. T -> a -> a
        --      foo = /\a. \t:T. case t of { MkT f -> f 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
-                       -- Records can't be existential, so no existential tyvars or dicts
-
-           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
+    mk_alt data_con 
+      =        -- In the non-vanilla case, the pattern must bind type variables and
+               -- the context stuff; hence the arg_prefix binding below
+         mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids)
+                       (mk_result (Var the_arg_id))
+      where
+       (arg_prefix, arg_ids)
+          | isVanillaDataCon data_con          -- Instantiate from commmon base
+          = ([], mkTemplateLocalsNum arg_base (dataConInstOrigArgTys data_con res_tys))
+          | otherwise          -- The case pattern binds type variables, which are used
+                               -- in the types of the arguments of the pattern
+          = (dc_tyvars ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta),
+             mkTemplateLocalsNum arg_base' dc_arg_tys)
+
+       (dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con
+       arg_base' = arg_base + length dc_theta
+
+       unpack_base = arg_base' + length dc_arg_tys
+       uniqs = map mkBuiltinUnique [unpack_base..]
+
+       the_arg_id  = assoc "mkRecordSelId:mk_alt" (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]) 
 
     error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id]) 
@@ -522,7 +571,7 @@ mkRecordSelId tycon field_label
 mkReboxingAlt
   :: [Unique]                  -- Uniques for the new Ids
   -> DataCon
 mkReboxingAlt
   :: [Unique]                  -- Uniques for the new Ids
   -> DataCon
-  -> [Var]                     -- Source-level args
+  -> [Var]                     -- Source-level args, including existential dicts
   -> CoreExpr                  -- RHS
   -> CoreAlt
 
   -> CoreExpr                  -- RHS
   -> CoreAlt
 
@@ -602,8 +651,6 @@ mkDictSelId name clas
        -- But it's type must expose the representation of the dictionary
        -- to gat (say)         C a -> (a -> a)
 
        -- But it's type must expose the representation of the dictionary
        -- to gat (say)         C a -> (a -> a)
 
-    tag  = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name
-
     info = noCafIdInfo
                `setArityInfo`          1
                `setUnfoldingInfo`      mkTopUnfolding rhs
     info = noCafIdInfo
                `setArityInfo`          1
                `setUnfoldingInfo`      mkTopUnfolding rhs
@@ -621,21 +668,19 @@ mkDictSelId name clas
            | otherwise        = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
                                            | id <- arg_ids ])
 
            | 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
-    tyvar_tys  = mkTyVarTys tyvars
-    arg_tys    = dataConArgTys data_con tyvar_tys
-    the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
+    tyvars     = dataConTyVars data_con
+    arg_tys    = dataConRepArgTys data_con
+    the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name
 
 
-    pred             = mkClassPred clas tyvar_tys
+    pred             = mkClassPred clas (mkTyVarTys tyvars)
     (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
 
     rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $ 
                             mkNewTypeBody tycon (head arg_tys) (Var dict_id)
        | otherwise        = mkLams tyvars $ Lam dict_id $
     (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
 
     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
+                            Case (Var dict_id) dict_id (idType the_arg_id)
                                  [(DataAlt data_con, arg_ids, Var the_arg_id)]
 
 mkNewTypeBody tycon result_ty result_expr
                                  [(DataAlt data_con, arg_ids, Var the_arg_id)]
 
 mkNewTypeBody tycon result_ty result_expr
@@ -667,13 +712,10 @@ mkPrimOpId prim_op
     id   = mkGlobalId (PrimOpId prim_op) name ty info
                
     info = noCafIdInfo
     id   = mkGlobalId (PrimOpId prim_op) name ty info
                
     info = noCafIdInfo
-          `setSpecInfo`        rules
-          `setArityInfo`       arity
+          `setSpecInfo`          mkSpecInfo (primOpRules prim_op name)
+          `setArityInfo`         arity
           `setAllStrictnessInfo` Just strict_sig
 
           `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
 -- 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
@@ -719,11 +761,9 @@ 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).
 
 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. 
+We build them as LocalIds, but with External Names.  This ensures that
+they are taken to account by free-variable finding and dependency
+analysis (e.g. CoreFVs.exprFreeVars).
 
 Why shouldn't they be bound as GlobalIds?  Because, in particular, if
 they are globals, the specialiser floats dict uses above their defns,
 
 Why shouldn't they be bound as GlobalIds?  Because, in particular, if
 they are globals, the specialiser floats dict uses above their defns,
@@ -736,7 +776,7 @@ 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.
 
 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 
+BUT make sure they are *exported* LocalIds (mkExportedLocalId) so 
 that they aren't discarded by the occurrence analyser.
 
 \begin{code}
 that they aren't discarded by the occurrence analyser.
 
 \begin{code}
@@ -760,7 +800,7 @@ mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
 
     (class_tyvars, sc_theta, _, _) = classBigSig clas
     not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
 
     (class_tyvars, sc_theta, _, _) = classBigSig clas
     not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
-    sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
+    sc_theta' = substClasses (zipTopTvSubst 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
     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
@@ -807,7 +847,7 @@ another gun with which to shoot yourself in the foot.
 
 \begin{code}
 mkWiredInIdName mod fs uniq id
 
 \begin{code}
 mkWiredInIdName mod fs uniq id
- = mkWiredInName mod (mkOccFS varName fs) uniq Nothing (AnId id) UserSyntax
+ = mkWiredInName mod (mkOccNameFS varName fs) uniq Nothing (AnId id) UserSyntax
 
 unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
 nullAddrName     = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#")    nullAddrIdKey      nullAddrId
 
 unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
 nullAddrName     = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#")    nullAddrIdKey      nullAddrId
@@ -860,7 +900,8 @@ seqId
     ty  = mkForAllTys [alphaTyVar,openBetaTyVar]
                      (mkFunTy alphaTy (mkFunTy openBetaTy openBetaTy))
     [x,y] = mkTemplateLocals [alphaTy, openBetaTy]
     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)])
+-- gaw 2004
+    rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(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
 
 -- lazy :: forall a?. a? -> a?  (i.e. works for unboxed types too)
 -- Used to lazify pseq:                pseq a b = a `seq` lazy b
@@ -893,8 +934,8 @@ This comes up in strictness analysis
 \begin{code}
 realWorldPrimId        -- :: State# RealWorld
   = pcMiscPrelId realWorldName realWorldStatePrimTy
 \begin{code}
 realWorldPrimId        -- :: State# RealWorld
   = pcMiscPrelId realWorldName realWorldStatePrimTy
-                (noCafIdInfo `setUnfoldingInfo` mkOtherCon [])
-       -- The mkOtherCon makes it look that realWorld# is evaluated
+                (noCafIdInfo `setUnfoldingInfo` evaldUnfolding)
+       -- The evaldUnfolding 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
        -- which in turn makes Simplify.interestingArg return True,
        -- which in turn makes INLINE things applied to realWorld# likely
        -- to be inlined
@@ -936,7 +977,7 @@ mkRuntimeErrorApp
 mkRuntimeErrorApp err_id res_ty err_msg 
   = mkApps (Var err_id) [Type res_ty, err_string]
   where
 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)))
+    err_string = Lit (mkStringLit err_msg)
 
 rEC_SEL_ERROR_ID               = mkRuntimeErrorId recSelErrorName
 rUNTIME_ERROR_ID               = mkRuntimeErrorId runtimeErrorName
 
 rEC_SEL_ERROR_ID               = mkRuntimeErrorId recSelErrorName
 rUNTIME_ERROR_ID               = mkRuntimeErrorId runtimeErrorName
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)