Re-working of the breakpoint support
[ghc-hetmet.git] / compiler / basicTypes / MkId.lhs
index 3f24a85..67cf5e4 100644 (file)
@@ -1,7 +1,7 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The AQUA Project, Glasgow University, 1998
 %
-\section[StdIdInfo]{Standard unfoldings}
 
 This module contains definitions for the IdInfo for things that
 have a standard form, namely:
@@ -18,7 +18,7 @@ module MkId (
 
        mkDataConIds,
        mkRecordSelId, 
-       mkPrimOpId, mkFCallId,
+       mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
 
        mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
         mkUnpackCase, mkProductBox,
@@ -38,71 +38,41 @@ module MkId (
 
 #include "HsVersions.h"
 
-
-import BasicTypes      ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
-import Rules           ( mkSpecInfo )
-import TysPrim         ( openAlphaTyVars, alphaTyVar, alphaTy, 
-                         realWorldStatePrimTy, addrPrimTy
-                       )
-import TysWiredIn      ( charTy, mkListTy )
-import PrelRules       ( primOpRules )
-import Type            ( TyThing(..), mkForAllTy, tyVarsOfTypes, 
-                         newTyConInstRhs, mkTopTvSubst, substTyVar, 
-                         substTys, zipTopTvSubst )
-import TcGadt           ( gadtRefine, refineType, emptyRefinement )
-import HsBinds          ( HsWrapper(..), isIdHsWrapper )
-import Coercion         ( mkSymCoercion, mkUnsafeCoercion, isEqPred )
-import TcType          ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, 
-                         mkTyConApp, mkTyVarTys, mkClassPred, isPredTy,
-                         mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, tcEqType,
-                         isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
-                         tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
-                       )
-import CoreUtils       ( exprType, dataConOrigInstPat, mkCoerce )
-import CoreUnfold      ( mkTopUnfolding, mkCompulsoryUnfolding )
-import Literal         ( nullAddrLit, mkStringLit )
-import TyCon           ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
-                         FieldLabel,
-                          tyConStupidTheta, isProductTyCon, isDataTyCon,
-                          isRecursiveTyCon, isFamInstTyCon,
-                          tyConFamInst_maybe, tyConFamilyCoercion_maybe,
-                          newTyConCo_maybe )
-import Class           ( Class, classTyCon, classSelIds )
-import Var             ( Id, TyVar, Var, setIdType )
-import VarSet          ( isEmptyVarSet, subVarSet, varSetElems )
-import Name            ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..))
-import OccName         ( mkOccNameFS, varName )
-import PrimOp          ( PrimOp, primOpSig, primOpOcc, primOpTag )
-import ForeignCall     ( ForeignCall )
-import DataCon         ( DataCon, DataConIds(..), dataConTyCon,
-                         dataConUnivTyVars, 
-                         dataConFieldLabels, dataConRepArity, dataConResTys,
-                         dataConRepArgTys, dataConRepType, dataConFullSig,
-                         dataConStrictMarks, dataConExStricts, 
-                         splitProductType, isVanillaDataCon, dataConFieldType,
-                         deepSplitProductType, 
-                       )
-import Id              ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, 
-                         mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
-                         mkTemplateLocal, idName
-                       )
-import IdInfo          ( IdInfo, noCafIdInfo,  setUnfoldingInfo, 
-                         setArityInfo, setSpecInfo, setCafInfo,
-                         setAllStrictnessInfo, vanillaIdInfo,
-                         GlobalIdDetails(..), CafInfo(..)
-                       )
-import NewDemand       ( mkStrictSig, DmdResult(..),
-                         mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR,
-                         Demand(..), Demands(..) )
-import DmdAnal         ( dmdAnalTopRhs )
+import Rules
+import TysPrim
+import TysWiredIn
+import PrelRules
+import Type
+import TcGadt
+import HsBinds
+import Coercion
+import TcType
+import CoreUtils
+import CoreUnfold
+import Literal
+import TyCon
+import Class
+import VarSet
+import Name
+import OccName
+import PrimOp
+import ForeignCall
+import DataCon
+import Id
+import Var              ( Var, TyVar)
+import IdInfo
+import NewDemand
+import DmdAnal
 import CoreSyn
-import Unique          ( mkBuiltinUnique, mkPrimOpIdUnique )
+import Unique
 import Maybes
 import PrelNames
-import Util             ( dropList, isSingleton )
+import BasicTypes       hiding ( SuccessFlag(..) )
+import Util
 import Outputable
 import FastString
-import ListSetOps      ( assoc, minusList )
+import ListSetOps
+import Module
 \end{code}             
 
 %************************************************************************
@@ -248,7 +218,7 @@ mkDataConIds wrap_name wkr_name data_con
                     -- arguments to the universals of the data constructor
                     -- (crucial when type checking interfaces)
     dict_tys       = mkPredTys theta
-    result_ty_args = map (substTyVar subst) univ_tvs
+    result_ty_args = substTyVars subst univ_tvs
     result_ty      = case tyConFamInst_maybe tycon of
                         -- ordinary constructor
                       Nothing            -> mkTyConApp tycon result_ty_args
@@ -277,6 +247,7 @@ mkDataConIds wrap_name wkr_name data_con
                                                        -- even if arity = 0
 
     wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
+       --      Note [Data-con worker strictness]
        -- 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)
@@ -402,16 +373,6 @@ wrapFamInstBody tycon args result_expr
   = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
   | otherwise
   = result_expr
-
--- Apply the coercion in the opposite direction.
---
-unwrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
-unwrapFamInstBody tycon args result_expr
-  | Just co_con <- tyConFamilyCoercion_maybe tycon
-  = mkCoerce (mkTyConApp co_con args) result_expr
-  | otherwise
-  = result_expr
-
 \end{code}
 
 
@@ -633,14 +594,14 @@ mkRecordSelId tycon field_label
        --              T1 b' (c : [b]=[b']) (x:Maybe b') 
        --                      -> x `cast` Maybe (sym (right c))
 
-        Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
-        (co_fn, res_ty) = refineType refinement (idType the_arg_id)
+
                -- Generate the refinement for b'=b, 
                -- and apply to (Maybe b'), to get (Maybe b)
-
-        rhs = case co_fn of
-               WpCo co -> Cast (Var the_arg_id) co
-               id_co       -> ASSERT(isIdHsWrapper id_co) Var the_arg_id
+        Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
+       the_arg_id_ty = idType the_arg_id
+        (rhs, res_ty) = case refineType refinement the_arg_id_ty of
+                         Just (co, res_ty) -> (Cast (Var the_arg_id) co, res_ty)
+                         Nothing           -> (Var the_arg_id, the_arg_id_ty)
 
        field_vs    = filter (not . isPredTy . idType) arg_vs 
        the_arg_id  = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label
@@ -905,7 +866,7 @@ mkPrimOpId prim_op
     ty   = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
     name = mkWiredInName gHC_PRIM (primOpOcc prim_op) 
                         (mkPrimOpIdUnique (primOpTag prim_op))
-                        Nothing (AnId id) UserSyntax
+                        (AnId id) UserSyntax
     id   = mkGlobalId (PrimOpId prim_op) name ty info
                
     info = noCafIdInfo
@@ -943,6 +904,29 @@ mkFCallId uniq fcall ty
     (arg_tys, _) = tcSplitFunTys tau
     arity       = length arg_tys
     strict_sig   = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
+
+-- Tick boxes and breakpoints are both represented as TickBoxOpIds,
+-- except for the type:
+--
+--    a plain HPC tick box has type (State# RealWorld)
+--    a breakpoint Id has type forall a.a
+--
+-- The breakpoint Id will be applied to a list of arbitrary free variables,
+-- which is why it needs a polymorphic type.
+
+mkTickBoxOpId :: Unique -> Module -> TickBoxId -> Id
+mkTickBoxOpId uniq mod ix = mkTickBox' uniq mod ix realWorldStatePrimTy
+
+mkBreakPointOpId :: Unique -> Module -> TickBoxId -> Id
+mkBreakPointOpId uniq mod ix = mkTickBox' uniq mod ix ty
+ where ty = mkSigmaTy [openAlphaTyVar] [] openAlphaTy
+
+mkTickBox' uniq mod ix ty = mkGlobalId (TickBoxOpId tickbox) name ty info    
+  where
+    tickbox = TickBox mod ix
+    occ_str = showSDoc (braces (ppr tickbox))
+    name    = mkTickBoxOpName uniq occ_str
+    info    = noCafIdInfo
 \end{code}
 
 
@@ -1044,7 +1028,7 @@ another gun with which to shoot yourself in the foot.
 
 \begin{code}
 mkWiredInIdName mod fs uniq id
- = mkWiredInName mod (mkOccNameFS varName fs) uniq Nothing (AnId id) UserSyntax
+ = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax
 
 unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
 nullAddrName     = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#")    nullAddrIdKey      nullAddrId
@@ -1077,8 +1061,7 @@ unsafeCoerceId
                      (mkFunTy openAlphaTy openBetaTy)
     [x] = mkTemplateLocals [openAlphaTy]
     rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
---       Note (Coerce openBetaTy openAlphaTy) (Var x)
-         Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy)
+          Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy)
 
 -- nullAddr# :: Addr#
 -- The reason is is here is because we don't provide 
@@ -1236,9 +1219,5 @@ pc_bottoming_Id name ty
 
     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}