[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 50e981b..9d93a67 100644 (file)
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -37,36 +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 Type            ( TyThing(..), mkForAllTy, tyVarsOfTypes )

 import TcType          ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, 
 import TcType          ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, 

-                         mkTyConApp, mkTyVarTys, mkClassPred, tcEqPred,
+                         mkTyConApp, mkTyVarTys, mkClassPred, 

                          mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, 
                          isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
                          mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, 
                          isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,

-                         tcSplitFunTys, tcSplitForAllTys
+                         tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta

                        )
 import CoreUtils       ( exprType )
 import CoreUnfold      ( mkTopUnfolding, mkCompulsoryUnfolding )
 import Literal         ( nullAddrLit, mkStringLit )
                        )
 import CoreUtils       ( exprType )
 import CoreUnfold      ( mkTopUnfolding, mkCompulsoryUnfolding )
 import Literal         ( nullAddrLit, mkStringLit )

-import TyCon           ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
+import TyCon           ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,

                           tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
 import Class           ( Class, classTyCon, classSelIds )
 import Var             ( Id, TyVar, Var )
                           tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
 import Class           ( Class, classTyCon, classSelIds )
 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 DataCon         ( DataCon, DataConIds(..), dataConTyVars,
 import PrimOp          ( PrimOp, primOpSig, primOpOcc, primOpTag )
 import ForeignCall     ( ForeignCall )
 import DataCon         ( DataCon, DataConIds(..), dataConTyVars,

-                         dataConFieldLabels, dataConRepArity, 
-                         dataConRepArgTys, dataConRepType, dataConStupidTheta, 
+                         dataConFieldLabels, dataConRepArity, dataConResTys,
+                         dataConRepArgTys, dataConRepType, 

                          dataConSig, dataConStrictMarks, dataConExStricts, 
                          dataConSig, dataConStrictMarks, dataConExStricts, 

-                         splitProductType, isVanillaDataCon
+                         splitProductType, isVanillaDataCon, dataConFieldType,
+                         dataConInstOrigArgTys

                        )
 import Id              ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, 
                          mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
                        )
 import Id              ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, 
                          mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,

@@ -88,8 +89,7 @@ import PrelNames
 import Util             ( dropList, isSingleton )
 import Outputable
 import FastString
 import Util             ( dropList, isSingleton )
 import Outputable
 import FastString

-import ListSetOps      ( assoc, assocMaybe )
-import List            ( nubBy )
+import ListSetOps      ( assoc )

 \end{code}             
 
 %************************************************************************
 \end{code}             
 
 %************************************************************************

@@ -225,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 -> ...

@@ -378,32 +378,81 @@ 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}

-mkRecordSelId tycon field_label field_ty
+
+-- 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
        -- 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 tycon field_label) field_label selector_ty info
-    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
-    needed_preds = [pred | (DataAlt dc, _, _) <- the_alts, pred <- dataConStupidTheta dc]
-    dict_tys     = mkPredTys (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_dict_tys                      = mkPredTys field_theta
 
     (field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
     field_dict_tys                      = mkPredTys field_theta

@@ -425,10 +474,10 @@ mkRecordSelId tycon field_label field_ty
 
     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.

@@ -445,18 +494,18 @@ mkRecordSelId tycon field_label field_ty
        -- 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!

-    dict_ids       = mkTemplateLocalsNum  1               dict_tys
-    max_dict_tys    = length (tyConStupidTheta tycon)
-    field_dict_base = max_dict_tys + 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
-
-    alts      = map mk_maybe_alt data_cons
-    the_alts  = catMaybes alts         -- Already sorted by data-con
-
-    no_default = all isJust alts       -- No default needed
+    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
+

     default_alt | no_default = []
                | otherwise  = [(DEFAULT, [], error_expr)]
 
     default_alt | no_default = []
                | otherwise  = [(DEFAULT, [], error_expr)]
 

@@ -465,7 +514,7 @@ mkRecordSelId tycon field_label field_ty
                | 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))

@@ -479,30 +528,28 @@ mkRecordSelId tycon field_label field_ty
        --      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 
-       = ASSERT( dc_tyvars == tyvars )
-               -- The only non-vanilla case we allow is when we have an existential
-               -- context that binds no type variables, thus
-               --      data T a = (?v::Int) => MkT a
-               -- In the non-vanilla case, the pattern must bind type variables and
+    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
                -- the context stuff; hence the arg_prefix binding below

-
-         case maybe_the_arg_id of
-               Nothing         -> Nothing
-               Just the_arg_id -> Just (mkReboxingAlt uniqs data_con (arg_prefix ++ arg_src_ids) $
-                                        mk_result (Var the_arg_id))
-       where
-           (dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con
-           arg_src_ids = mkTemplateLocalsNum arg_base dc_arg_tys
-           arg_base'   = arg_base + length arg_src_ids
-           arg_prefix  | isVanillaDataCon data_con = []
-                       | otherwise = tyvars ++ mkTemplateLocalsNum arg_base' (mkPredTys dc_theta)
-
-           unpack_base = arg_base' + length dc_theta
-           uniqs = map mkBuiltinUnique [unpack_base..]
-
-           maybe_the_arg_id  = assocMaybe (field_lbls `zip` arg_src_ids) field_label
-           field_lbls        = dataConFieldLabels data_con
+         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]) 

@@ -665,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

@@ -717,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,

@@ -805,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