[project @ 2001-11-19 16:34:12 by simonpj]
[ghc-hetmet.git] / ghc / compiler / basicTypes / MkId.lhs
index a44e083..c112a2a 100644 (file)
@@ -22,7 +22,7 @@ module MkId (
 
        -- And some particular Ids; see below for why they are wired in
        wiredInIds,
-       unsafeCoerceId, realWorldPrimId,
+       unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId,
        eRROR_ID, eRROR_CSTRING_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID,
        rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID,
        nO_METHOD_BINDING_ERROR_ID, aBSENT_ERROR_ID, pAR_ERROR_ID
@@ -45,9 +45,9 @@ import TcType         ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
                          tcSplitFunTys, tcSplitForAllTys, mkPredTy
                        )
 import Module          ( Module )
-import CoreUtils       ( mkInlineMe )
+import CoreUtils       ( exprType )
 import CoreUnfold      ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
-import Literal         ( Literal(..) )
+import Literal         ( Literal(..), nullAddrLit )
 import TyCon           ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
                           tyConTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
 import Class           ( Class, classTyCon, classTyVars, classSelIds )
@@ -71,13 +71,13 @@ import Id           ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
                        )
 import IdInfo          ( IdInfo, noCafNoTyGenIdInfo,
                          setUnfoldingInfo, 
-                         setArityInfo, setSpecInfo,  setCgInfo,
-                         mkNewStrictnessInfo, setNewStrictnessInfo,
-                         GlobalIdDetails(..), CafInfo(..), CprInfo(..), 
-                         CgInfo(..), setCgArity
+                         setArityInfo, setSpecInfo, setCafInfo,
+                         newStrictnessFromOld, setAllStrictnessInfo,
+                         GlobalIdDetails(..), CafInfo(..), CprInfo(..)
                        )
 import NewDemand       ( mkStrictSig, strictSigResInfo, DmdResult(..),
-                         mkTopDmdType, topDmd, evalDmd, Demand(..), Keepity(..) )
+                         mkTopDmdType, topDmd, evalDmd, lazyDmd, 
+                         Demand(..), Demands(..) )
 import FieldLabel      ( mkFieldLabel, fieldLabelName, 
                          firstFieldLabelTag, allFieldLabelTags, fieldLabelType
                        )
@@ -87,6 +87,7 @@ import Unique         ( mkBuiltinUnique )
 import Maybes
 import PrelNames
 import Maybe            ( isJust )
+import Util             ( dropList, isSingleton )
 import Outputable
 import ListSetOps      ( assoc, assocMaybe )
 import UnicodeUtil      ( stringToUtf8 )
@@ -107,8 +108,8 @@ wiredInIds
        -- 
        -- [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-reporting functions that they have an 'open' 
+       -- result type. -- sof 1/99]
 
       aBSENT_ERROR_ID
     , eRROR_ID
@@ -121,9 +122,11 @@ wiredInIds
     , rEC_CON_ERROR_ID
     , rEC_UPD_ERROR_ID
 
-       -- These three can't be defined in Haskell
+       -- These can't be defined in Haskell, but they have
+       -- perfectly reasonable unfoldings in Core
     , realWorldPrimId
     , unsafeCoerceId
+    , nullAddrId
     , getTagId
     , seqId
     ]
@@ -143,9 +146,8 @@ mkDataConId work_name data_con
   = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
   where
     info = noCafNoTyGenIdInfo
-          `setCgArity`                 arity
           `setArityInfo`               arity
-          `setNewStrictnessInfo`       Just strict_sig
+          `setAllStrictnessInfo`       Just strict_sig
 
     arity      = dataConRepArity data_con
 
@@ -231,51 +233,59 @@ mkDataConWrapId data_con
     work_id = dataConId data_con
 
     info = noCafNoTyGenIdInfo
-          `setUnfoldingInfo`   mkTopUnfolding (mkInlineMe wrap_rhs)
-          `setCgArity`         arity
+          `setUnfoldingInfo`   wrap_unf
                -- The NoCaf-ness is set by noCafNoTyGenIdInfo
           `setArityInfo`       arity
                -- It's important to specify the arity, so that partial
                -- applications are treated as values
-          `setNewStrictnessInfo`       Just wrap_sig
+          `setAllStrictnessInfo`       Just wrap_sig
 
     wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty)
 
+    wrap_sig = mkStrictSig (mkTopDmdType arg_dmds res_info)
     res_info = strictSigResInfo (idNewStrictness work_id)
-    wrap_sig = mkStrictSig (mkTopDmdType (replicate arity topDmd) res_info)
+    arg_dmds = [Abs | d <- dict_args] ++ 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
-       -- But we are sloppy about the argument demands, because we expect 
-       -- to inline the constructor very vigorously.
-
-    wrap_rhs | isNewTyCon tycon
-            = ASSERT( null ex_tyvars && null ex_dict_args && length orig_arg_tys == 1 )
+       -- 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
+
+    wrap_unf | isNewTyCon tycon
+            = 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 $ mkLams dict_args $ Lam id_arg1 $ 
-               mkNewTypeBody tycon result_ty id_arg1
+               mkNewTypeBody tycon result_ty (Var id_arg1)
 
             | null dict_args && not (any isMarkedStrict strict_marks)
-            = Var work_id      -- The common case.  Not only is this efficient,
-                               -- but it also ensures that the wrapper is replaced
-                               -- by the worker even when there are no args.
-                               --              f (:) x
-                               -- becomes 
-                               --              f $w: x
-                               -- 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.)
+            = mkCompulsoryUnfolding (Var work_id)
+                       -- The common case.  Not only is this efficient,
+                       -- but it also ensures that the wrapper is replaced
+                       -- by the worker even when there are no args.
+                       --              f (:) x
+                       -- becomes 
+                       --              f $w: x
+                       -- 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.)
                --
                -- NB:  because of this special case, (map (:) ys) turns into
-               --      (map $w: ys), and thence into (map (\x xs. $w: x xs) ys)
-               --      in core-to-stg.  The top-level defn for (:) is never used.
+               --      (map $w: ys).  The top-level defn for (:) is never used.
                --      This is somewhat of a bore, but I'm currently leaving it 
                --      as is, so that there still is a top level curried (:) for
                --      the interpreter to call.
 
             | otherwise
-            = mkLams all_tyvars $ mkLams dict_args $ 
+            = mkTopUnfolding $ Note InlineMe $
+              mkLams all_tyvars $ mkLams dict_args $ 
               mkLams ex_dict_args $ mkLams id_args $
               foldr mk_case con_app 
                     (zip (ex_dict_args++id_args) strict_marks) i3 []
@@ -431,11 +441,10 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
        -- With all this unpackery it's not easy!
 
     info = noCafNoTyGenIdInfo
-          `setCgInfo`            CgInfo arity caf_info
+          `setCafInfo`           caf_info
           `setArityInfo`         arity
           `setUnfoldingInfo`     mkTopUnfolding rhs_w_str
-          `setNewStrictnessInfo` Just strict_sig
-       -- Unfolding and strictness added by dmdAnalTopId
+          `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
@@ -464,15 +473,23 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
              mkLams dict_ids $ mkLams field_dict_ids $
              Lam data_id     $ sel_body
 
-    sel_body | isNewTyCon tycon = mkNewTypeBody tycon field_tau data_id
+    sel_body | isNewTyCon tycon = mkNewTypeBody tycon field_tau (mk_result data_id)
             | otherwise        = Case (Var data_id) data_id (default_alt ++ the_alts)
 
+    mk_result result_id = mkVarApps (mkVarApps (Var result_id) 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 (DataAlt data_con, real_args, mkLets binds body)
                  where
-                   body               = mkVarApps (mkVarApps (Var the_arg_id) field_tyvars) field_dict_ids
+                   body               = mk_result the_arg_id
                    strict_marks       = dataConStrictMarks data_con
                    (binds, real_args) = rebuildConArgs arg_ids strict_marks
                                                        (map mkBuiltinUnique [unpack_base..])
@@ -531,7 +548,7 @@ rebuildConArgs (arg:args) (str:stricts) us
                 = splitProductType "rebuildConArgs" arg_ty
 
        unpacked_args  = zipWith (mkSysLocal SLIT("rb")) us con_arg_tys
-       (binds, args') = rebuildConArgs args stricts (drop (length con_arg_tys) us)
+       (binds, args') = rebuildConArgs 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')
@@ -569,10 +586,9 @@ mkDictSelId name clas
     tag       = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name
 
     info      = noCafNoTyGenIdInfo
-               `setCgArity`            1
                `setArityInfo`          1
                `setUnfoldingInfo`      mkTopUnfolding rhs
-               `setNewStrictnessInfo`  Just strict_sig
+               `setAllStrictnessInfo`  Just strict_sig
 
        -- We no longer use 'must-inline' on record selectors.  They'll
        -- inline like crazy if they scrutinise a constructor
@@ -582,9 +598,9 @@ mkDictSelId name clas
        -- 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 = Eval
-           | otherwise        = Seq Drop [ if the_arg_id == id then Eval else Abs
-                                         | id <- arg_ids ]
+    arg_dmd | isNewTyCon tycon = evalDmd
+           | otherwise        = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
+                                           | id <- arg_ids ])
 
     tyvars  = classTyVars clas
 
@@ -598,16 +614,18 @@ mkDictSelId name clas
     (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
 
     rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $ 
-                            mkNewTypeBody tycon (head arg_tys) dict_id
+                            mkNewTypeBody tycon (head arg_tys) (Var dict_id)
        | otherwise        = mkLams tyvars $ Lam dict_id $
                             Case (Var dict_id) dict_id
                                  [(DataAlt data_con, arg_ids, Var the_arg_id)]
 
-mkNewTypeBody tycon result_ty result_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 (idType result_id)) (Var result_id)
+  = Note (Coerce result_ty (exprType result_expr)) result_expr
   | otherwise                  -- Normal case
-  = Var result_id
+  = result_expr
 \end{code}
 
 
@@ -629,9 +647,8 @@ mkPrimOpId prim_op
                
     info = noCafNoTyGenIdInfo
           `setSpecInfo`        rules
-          `setCgArity`         arity
           `setArityInfo`       arity
-          `setNewStrictnessInfo`       Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo)
+          `setAllStrictnessInfo`       Just (newStrictnessFromOld name arity strict_info NoCPRInfo)
        -- Until we modify the primop generation code
 
     rules = foldl (addRule id) emptyCoreRules (primOpRules prim_op)
@@ -660,9 +677,8 @@ mkFCallId uniq fcall ty
     name = mkFCallName uniq occ_str
 
     info = noCafNoTyGenIdInfo
-          `setCgArity`                 arity
           `setArityInfo`               arity
-          `setNewStrictnessInfo`       Just strict_sig
+          `setAllStrictnessInfo`       Just strict_sig
 
     (_, tau)    = tcSplitForAllTys ty
     (arg_tys, _) = tcSplitFunTys tau
@@ -757,7 +773,7 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta
 These Ids can't be defined in Haskell.  They could be defined in 
 unfoldings in PrelGHC.hi-boot, but we'd have to ensure that they
 were definitely, definitely inlined, because there is no curried
-identifier for them.  Thats what mkCompulsoryUnfolding does.
+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.
 
@@ -770,6 +786,7 @@ 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 unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
   where
@@ -782,6 +799,15 @@ unsafeCoerceId
     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 nullAddrIdKey pREL_GHC SLIT("nullAddr#") addrPrimTy info
+  where
+    info = noCafNoTyGenIdInfo `setUnfoldingInfo` 
+          mkCompulsoryUnfolding (Lit nullAddrLit)
+
 seqId
   = pcMiscPrelId seqIdKey pREL_GHC SLIT("seq") ty info
   where
@@ -815,6 +841,13 @@ dataToTagId = mkPrimOpId DataToTagOp
 @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 realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
@@ -824,6 +857,9 @@ realWorldPrimId     -- :: State# RealWorld
        -- 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 SLIT("void") voidArgIdKey realWorldStatePrimTy
 \end{code}
 
 
@@ -902,10 +938,8 @@ pcMiscPrelId key mod str ty info
 pc_bottoming_Id key mod name ty
  = pcMiscPrelId key mod name ty bottoming_info
  where
-    
-    arity         = 1
     strict_sig    = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
-    bottoming_info = noCafNoTyGenIdInfo `setNewStrictnessInfo` Just strict_sig
+    bottoming_info = noCafNoTyGenIdInfo `setAllStrictnessInfo` Just strict_sig
        -- these "bottom" out, no matter what their arguments
 
 generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy