Re-working of the breakpoint support

[ghc-hetmet.git] / compiler / basicTypes / MkId.lhs

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 4609959..67cf5e4 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -1,7 +1,7 @@
 %
 %

+% (c) The University of Glasgow 2006

 % (c) The AQUA Project, Glasgow University, 1998
 %
 % (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:
 
 This module contains definitions for the IdInfo for things that
 have a standard form, namely:

@@ -18,7 +18,7 @@ module MkId (
 
        mkDataConIds,
        mkRecordSelId, 
 
        mkDataConIds,
        mkRecordSelId, 

-       mkPrimOpId, mkFCallId,
+       mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,

 
        mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
         mkUnpackCase, mkProductBox,
 
        mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
         mkUnpackCase, mkProductBox,

@@ -38,69 +38,41 @@ module MkId (
 
 #include "HsVersions.h"
 
 
 #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, coreEqType,
-                          PredType(..),
-                         mkTopTvSubst, substTyVar )
-import TcGadt           ( gadtRefine, refineType, emptyRefinement )
-import HsBinds          ( ExprCoFn(..), isIdCoercion )
-import Coercion         ( mkSymCoercion, mkUnsafeCoercion, 
-                          splitNewTypeRepCo_maybe, isEqPred )
-import TcType          ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, 
-                         mkTyConApp, mkTyVarTys, mkClassPred, 
-                         mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, 
-                         isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
-                         tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
-                       )
-import CoreUtils       ( exprType, dataConInstPat )
-import CoreUnfold      ( mkTopUnfolding, mkCompulsoryUnfolding )
-import Literal         ( nullAddrLit, mkStringLit )
-import TyCon           ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
-                          tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon,
-                          newTyConCo, tyConArity )
-import Class           ( Class, classTyCon, classSelIds )
-import Var             ( Id, TyVar, Var, setIdType, mkCoVar, mkWildCoVar )
-import VarSet          ( isEmptyVarSet, subVarSet, varSetElems )
-import Name            ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..),
-                          mkSysTvName )
-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,
-                         dataConSig, dataConStrictMarks, dataConExStricts, 
-                         splitProductType, isVanillaDataCon, dataConFieldType,
-                         dataConInstOrigArgTys, deepSplitProductType
-                       )
-import Id              ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, 
-                         mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
-                         mkTemplateLocal, idName, mkWildId
-                       )
-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 CoreSyn

-import Unique          ( mkBuiltinUnique, mkPrimOpIdUnique )
+import Unique

 import Maybes
 import PrelNames
 import Maybes
 import PrelNames

-import Util             ( dropList, isSingleton )
+import BasicTypes       hiding ( SuccessFlag(..) )
+import Util

 import Outputable
 import FastString
 import Outputable
 import FastString

-import ListSetOps      ( assoc, minusList )
+import ListSetOps
+import Module

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

@@ -190,22 +162,48 @@ Notice that
   Making an explicit case expression allows the simplifier to eliminate
   it in the (common) case where the constructor arg is already evaluated.
 
   Making an explicit case expression allows the simplifier to eliminate
   it in the (common) case where the constructor arg is already evaluated.
 

+[Wrappers for data instance tycons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the case of data instances, the wrapper also applies the coercion turning
+the representation type into the family instance type to cast the result of
+the wrapper.  For example, consider the declarations
+
+  data family Map k :: * -> *
+  data instance Map (a, b) v = MapPair (Map a (Pair b v))
+
+The tycon to which the datacon MapPair belongs gets a unique internal name of
+the form :R123Map, and we call it the representation tycon.  In contrast, Map
+is the family tycon (accessible via tyConFamInst_maybe).  The wrapper and work
+of MapPair get the types
+
+  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
+  $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
+
+which implies that the wrapper code will have to apply the coercion moving
+between representation and family type.  It is accessible via
+tyConFamilyCoercion_maybe and has kind
+
+  Co123Map a b v :: {Map (a, b) v :=: :R123Map a b v}
+
+This coercion is conditionally applied by wrapFamInstBody.

 
 \begin{code}
 mkDataConIds :: Name -> Name -> DataCon -> DataConIds
 mkDataConIds wrap_name wkr_name data_con
   | isNewTyCon tycon
 
 \begin{code}
 mkDataConIds :: Name -> Name -> DataCon -> DataConIds
 mkDataConIds wrap_name wkr_name data_con
   | isNewTyCon tycon

-  = NewDC nt_wrap_id
+  = DCIds Nothing nt_work_id                 -- Newtype, only has a worker

 
 

-  | any isMarkedStrict all_strict_marks                -- Algebraic, needs wrapper
-    || not (null eq_spec)
-  = AlgDC (Just alg_wrap_id) wrk_id
+  | any isMarkedStrict all_strict_marks             -- Algebraic, needs wrapper
+    || not (null eq_spec)                   -- NB: LoadIface.ifaceDeclSubBndrs
+    || isFamInstTyCon tycon                 --     depends on this test
+  = DCIds (Just alg_wrap_id) wrk_id

 
 

-  | otherwise                                  -- Algebraic, no wrapper
-  = AlgDC Nothing wrk_id
+  | otherwise                               -- Algebraic, no wrapper
+  = DCIds Nothing wrk_id

   where
   where

-    (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys) = dataConFullSig data_con
-    tycon = dataConTyCon data_con
+    (univ_tvs, ex_tvs, eq_spec, 
+     theta, orig_arg_tys)          = dataConFullSig data_con
+    tycon                          = dataConTyCon data_con

 
        ----------- Wrapper --------------
        -- We used to include the stupid theta in the wrapper's args
 
        ----------- Wrapper --------------
        -- We used to include the stupid theta in the wrapper's args

@@ -213,9 +211,23 @@ mkDataConIds wrap_name wkr_name data_con
        -- extra constraints where necessary.
     wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
     subst         = mkTopTvSubst eq_spec
        -- extra constraints where necessary.
     wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
     subst         = mkTopTvSubst eq_spec

+    famSubst      = ASSERT( length (tyConTyVars tycon  ) ==  
+                            length (mkTyVarTys univ_tvs)   )
+                    zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
+                    -- substitution mapping the type constructor's type
+                    -- arguments to the universals of the data constructor
+                    -- (crucial when type checking interfaces)

     dict_tys       = mkPredTys theta
     dict_tys       = mkPredTys theta

-    result_ty_args = map (substTyVar subst) univ_tvs
-    result_ty      = mkTyConApp tycon result_ty_args
+    result_ty_args = substTyVars subst univ_tvs
+    result_ty      = case tyConFamInst_maybe tycon of
+                        -- ordinary constructor
+                      Nothing            -> mkTyConApp tycon result_ty_args
+                        -- family instance constructor
+                      Just (familyTyCon, 
+                            instTys)     -> 
+                        mkTyConApp familyTyCon ( substTys subst 
+                                               . substTys famSubst 
+                                               $ instTys)

     wrap_ty        = mkForAllTys wrap_tvs $ mkFunTys dict_tys $
                     mkFunTys orig_arg_tys $ result_ty
        -- NB: watch out here if you allow user-written equality 
     wrap_ty        = mkForAllTys wrap_tvs $ mkFunTys dict_tys $
                     mkFunTys orig_arg_tys $ result_ty
        -- NB: watch out here if you allow user-written equality 

@@ -235,6 +247,7 @@ mkDataConIds wrap_name wkr_name data_con
                                                        -- even if arity = 0
 
     wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
                                                        -- 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)
        -- 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)

@@ -259,9 +272,9 @@ mkDataConIds wrap_name wkr_name data_con
        -- RetCPR is only true for products that are real data types;
        -- that is, not unboxed tuples or [non-recursive] newtypes
 
        -- RetCPR is only true for products that are real data types;
        -- that is, not unboxed tuples or [non-recursive] newtypes
 

-       ----------- Wrappers for newtypes --------------
-    nt_wrap_id   = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty nt_wrap_info
-    nt_wrap_info = noCafIdInfo         -- The NoCaf-ness is set by noCafIdInfo
+       ----------- Workers for newtypes --------------
+    nt_work_id   = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info
+    nt_work_info = noCafIdInfo         -- The NoCaf-ness is set by noCafIdInfo

                  `setArityInfo` 1      -- Arity 1
                  `setUnfoldingInfo`     newtype_unf
     newtype_unf  = ASSERT( isVanillaDataCon data_con &&
                  `setArityInfo` 1      -- Arity 1
                  `setUnfoldingInfo`     newtype_unf
     newtype_unf  = ASSERT( isVanillaDataCon data_con &&

@@ -305,10 +318,11 @@ mkDataConIds wrap_name wkr_name data_con
                    (zip (dict_args ++ id_args) all_strict_marks)
                    i3 []
 
                    (zip (dict_args ++ id_args) all_strict_marks)
                    i3 []
 

-    con_app i rep_ids = Var wrk_id `mkTyApps`  result_ty_args
-                                  `mkVarApps` ex_tvs
-                                  `mkTyApps`  map snd eq_spec
-                                  `mkVarApps` reverse rep_ids
+    con_app _ rep_ids = wrapFamInstBody tycon result_ty_args $
+                         Var wrk_id `mkTyApps`  result_ty_args
+                                    `mkVarApps` ex_tvs
+                                    `mkTyApps`  map snd eq_spec
+                                    `mkVarApps` reverse rep_ids

 
     (dict_args,i2) = mkLocals 1  dict_tys
     (id_args,i3)   = mkLocals i2 orig_arg_tys
 
     (dict_args,i2) = mkLocals 1  dict_tys
     (id_args,i3)   = mkLocals i2 orig_arg_tys

@@ -329,7 +343,7 @@ mkDataConIds wrap_name wkr_name data_con
                        Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
 
                MarkedUnboxed
                        Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
 
                MarkedUnboxed

-                  -> unboxProduct i (Var arg) (idType arg) the_body result_ty
+                  -> unboxProduct i (Var arg) (idType arg) the_body 

                       where
                         the_body i con_args = body i (reverse con_args ++ rep_args)
 
                       where
                         the_body i con_args = body i (reverse con_args ++ rep_args)
 

@@ -347,6 +361,18 @@ mAX_CPR_SIZE = 10
 mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
               where
                 n = length tys
 mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
               where
                 n = length tys

+
+-- If the type constructor is a representation type of a data instance, wrap
+-- the expression into a cast adjusting the expression type, which is an
+-- instance of the representation type, to the corresponding instance of the
+-- family instance type.
+--
+wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
+wrapFamInstBody tycon args result_expr
+  | Just co_con <- tyConFamilyCoercion_maybe tycon
+  = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
+  | otherwise
+  = result_expr

 \end{code}
 
 
 \end{code}
 
 

@@ -551,50 +577,37 @@ mkRecordSelId tycon field_label
        --      foo = /\a. \t:T. case t of { MkT f -> f a }
 
     mk_alt data_con 
        --      foo = /\a. \t:T. case t of { MkT f -> f a }
 
     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) rhs
+      =   ASSERT2( res_ty `tcEqType` field_ty, ppr data_con $$ ppr res_ty $$ ppr field_ty )
+         mkReboxingAlt rebox_uniqs data_con (ex_tvs ++ co_tvs ++ arg_vs) rhs

       where
       where

-       -- TODO: this is *not* right; Orig vs Rep tys
-       (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
-          = (ex_tvs ++ co_tvs ++ dict_vs, field_vs)
-
-        (ex_tvs, co_tvs, arg_vs) = dataConInstPat uniqs' data_con res_tys
-        (dict_vs, field_vs) = splitAt (length dc_theta) arg_vs
+           -- get pattern binders with types appropriately instantiated
+       arg_uniqs = map mkBuiltinUnique [arg_base..]
+        (ex_tvs, co_tvs, arg_vs) = dataConOrigInstPat arg_uniqs data_con res_tys

 
 

-       (_, pre_dc_theta, dc_arg_tys) = dataConSig data_con
-        dc_theta  = filter (not . isEqPred) pre_dc_theta
+       rebox_base  = arg_base + length ex_tvs + length co_tvs + length arg_vs
+       rebox_uniqs = map mkBuiltinUnique [rebox_base..]

 
 

-       arg_base' = arg_base + length dc_theta
+       -- data T :: *->* where T1 { fld :: Maybe b } -> T [b]
+       --      Hence T1 :: forall a b. (a=[b]) => b -> T a
+       -- fld :: forall b. T [b] -> Maybe b
+       -- fld = /\b.\(t:T[b]). case t of 
+       --              T1 b' (c : [b]=[b']) (x:Maybe b') 
+       --                      -> x `cast` Maybe (sym (right c))

 
 

-       unpack_base = arg_base' + length dc_arg_tys
-
-       uniq_list = map mkBuiltinUnique [unpack_base..]

 
 

+               -- Generate the refinement for b'=b, 
+               -- and apply to (Maybe b'), to get (Maybe b)

         Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
         Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs

-        (co_fn, _)      = refineType refinement (idType the_arg_id)
-
-        rhs = perform_co co_fn (Var the_arg_id)
-
-        perform_co (ExprCoFn co) expr = Cast expr co
-        perform_co id_co expr = ASSERT(isIdCoercion id_co) expr
-
-          -- split the uniq_list into two
-        uniqs  = takeHalf uniq_list
-        uniqs' = takeHalf (drop 1 uniq_list)
+       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)

 
 

-        takeHalf [] = []
-        takeHalf (h:_:t) = h:(takeHalf t)  
-        takeHalf (h:t) = [h]
-
-       the_arg_id  = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label
+       field_vs    = filter (not . isPredTy . idType) arg_vs 
+       the_arg_id  = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label

        field_lbls  = dataConFieldLabels data_con
 
        field_lbls  = dataConFieldLabels data_con
 

-    error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
+    error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_ty full_msg

     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id])
 
 -- unbox a product type...
     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id])
 
 -- unbox a product type...

@@ -608,32 +621,32 @@ mkRecordSelId tycon field_label
 -- If we have e = MkT (MkS (PairInt 0 1)) and some body expecting a list of
 -- ids, we get (modulo int passing)
 --
 -- If we have e = MkT (MkS (PairInt 0 1)) and some body expecting a list of
 -- ids, we get (modulo int passing)
 --

---   case (e `cast` (sym CoT)) `cast` (sym CoS) of
+--   case (e `cast` CoT) `cast` CoS of

 --     PairInt a b -> body [a,b]
 --
 -- The Ints passed around are just for creating fresh locals
 --     PairInt a b -> body [a,b]
 --
 -- The Ints passed around are just for creating fresh locals

-unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> Type -> CoreExpr
-unboxProduct i arg arg_ty body res_ty
+unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> CoreExpr
+unboxProduct i arg arg_ty body

   = result
   where 
   = result
   where 

-    result = mkUnpackCase the_id arg arg_ty con_args boxing_con rhs
-    (tycon, tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty
+    result = mkUnpackCase the_id arg con_args boxing_con rhs
+    (_tycon, _tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty

     ([the_id], i') = mkLocals i [arg_ty]
     (con_args, i'') = mkLocals i' tys
     rhs = body i'' con_args
 
     ([the_id], i') = mkLocals i [arg_ty]
     (con_args, i'') = mkLocals i' tys
     rhs = body i'' con_args
 

-mkUnpackCase ::  Id -> CoreExpr -> Type -> [Id] -> DataCon -> CoreExpr -> CoreExpr
+mkUnpackCase ::  Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr

 -- (mkUnpackCase x e args Con body)
 --     returns
 -- case (e `cast` ...) of bndr { Con args -> body }
 -- 
 -- the type of the bndr passed in is irrelevent
 -- (mkUnpackCase x e args Con body)
 --     returns
 -- case (e `cast` ...) of bndr { Con args -> body }
 -- 
 -- the type of the bndr passed in is irrelevent

-mkUnpackCase bndr arg arg_ty unpk_args boxing_con body
+mkUnpackCase bndr arg unpk_args boxing_con body

   = Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)]
   where
   (cast_arg, bndr_ty) = go (idType bndr) arg
   go ty arg 
   = Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)]
   where
   (cast_arg, bndr_ty) = go (idType bndr) arg
   go ty arg 

-    | res@(tycon, tycon_args, _, _)  <- splitProductType "mkUnpackCase" ty
+    | (tycon, tycon_args, _, _)  <- splitProductType "mkUnpackCase" ty

     , isNewTyCon tycon && not (isRecursiveTyCon tycon)
     = go (newTyConInstRhs tycon tycon_args) 
          (unwrapNewTypeBody tycon tycon_args arg)
     , isNewTyCon tycon && not (isRecursiveTyCon tycon)
     = go (newTyConInstRhs tycon tycon_args) 
          (unwrapNewTypeBody tycon tycon_args arg)

@@ -647,7 +660,7 @@ reboxProduct :: [Unique]     -- uniques to create new local binders
                  [Id])       -- Ids being boxed into product
 reboxProduct us ty
   = let 
                  [Id])       -- Ids being boxed into product
 reboxProduct us ty
   = let 

-       (tycon, tycon_args, pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty
+       (_tycon, _tycon_args, _pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty

  
         us' = dropList con_arg_tys us
 
  
         us' = dropList con_arg_tys us
 

@@ -662,7 +675,7 @@ mkProductBox :: [Id] -> Type -> CoreExpr
 mkProductBox arg_ids ty 
   = result_expr
   where 
 mkProductBox arg_ids ty 
   = result_expr
   where 

-    (tycon, tycon_args, pack_con, con_arg_tys) = splitProductType "mkProductBox" ty
+    (tycon, tycon_args, pack_con, _con_arg_tys) = splitProductType "mkProductBox" ty

 
     result_expr
       | isNewTyCon tycon && not (isRecursiveTyCon tycon) 
 
     result_expr
       | isNewTyCon tycon && not (isRecursiveTyCon tycon) 

@@ -705,7 +718,7 @@ mkReboxingAlt us con args rhs
   where
     stricts = dataConExStricts con ++ dataConStrictMarks con
 
   where
     stricts = dataConExStricts con ++ dataConStrictMarks con
 

-    go [] stricts us = ([], [])
+    go [] _stricts _us = ([], [])

 
        -- Type variable case
     go (arg:args) stricts us 
 
        -- Type variable case
     go (arg:args) stricts us 

@@ -798,26 +811,39 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 -- The wrapper for the data constructor for a newtype looks like this:
 --     newtype T a = MkT (a,Int)
 --     MkT :: forall a. (a,Int) -> T a
 -- The wrapper for the data constructor for a newtype looks like this:
 --     newtype T a = MkT (a,Int)
 --     MkT :: forall a. (a,Int) -> T a

---     MkT = /\a. \(x:(a,Int)). x `cast` CoT a
+--     MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a)

 -- where CoT is the coercion TyCon assoicated with the newtype
 --
 -- The call (wrapNewTypeBody T [a] e) returns the
 -- body of the wrapper, namely
 -- where CoT is the coercion TyCon assoicated with the newtype
 --
 -- The call (wrapNewTypeBody T [a] e) returns the
 -- body of the wrapper, namely

---     e `cast` CoT [a]
+--     e `cast` (CoT [a])

 --
 -- If a coercion constructor is prodivided in the newtype, then we use
 -- it, otherwise the wrap/unwrap are both no-ops 
 --
 --
 -- If a coercion constructor is prodivided in the newtype, then we use
 -- it, otherwise the wrap/unwrap are both no-ops 
 --

+-- If the we are dealing with a newtype instance, we have a second coercion
+-- identifying the family instance with the constructor of the newtype
+-- instance.  This coercion is applied in any case (ie, composed with the
+-- coercion constructor of the newtype or applied by itself).
+--

 wrapNewTypeBody tycon args result_expr
 wrapNewTypeBody tycon args result_expr

-  | Just co_con <- newTyConCo tycon
-  = Cast result_expr (mkTyConApp co_con args)
-  | otherwise
-  = result_expr
+  = wrapFamInstBody tycon args inner
+  where
+    inner
+      | Just co_con <- newTyConCo_maybe tycon
+      = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
+      | otherwise
+      = result_expr

 
 

+-- When unwrapping, we do *not* apply any family coercion, because this will
+-- be done via a CoPat by the type checker.  We have to do it this way as
+-- computing the right type arguments for the coercion requires more than just
+-- a spliting operation (cf, TcPat.tcConPat).
+--

 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapNewTypeBody tycon args result_expr
 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapNewTypeBody tycon args result_expr

-  | Just co_con <- newTyConCo tycon
-  = Cast result_expr (mkSymCoercion (mkTyConApp co_con args))
+  | Just co_con <- newTyConCo_maybe tycon
+  = mkCoerce (mkTyConApp co_con args) result_expr

   | otherwise
   = result_expr
 
   | otherwise
   = result_expr
 

@@ -840,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))
     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
     id   = mkGlobalId (PrimOpId prim_op) name ty info
                
     info = noCafIdInfo

@@ -878,6 +904,29 @@ mkFCallId uniq fcall ty
     (arg_tys, _) = tcSplitFunTys tau
     arity       = length arg_tys
     strict_sig   = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
     (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}
 
 
 \end{code}
 
 

@@ -979,7 +1028,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 (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
 
 unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
 nullAddrName     = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#")    nullAddrIdKey      nullAddrId

@@ -1012,8 +1061,7 @@ unsafeCoerceId
                      (mkFunTy openAlphaTy openBetaTy)
     [x] = mkTemplateLocals [openAlphaTy]
     rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
                      (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 
 
 -- nullAddr# :: Addr#
 -- The reason is is here is because we don't provide 

@@ -1171,9 +1219,5 @@ pc_bottoming_Id name ty
 
     strict_sig    = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
        -- These "bottom" out, no matter what their arguments
 
     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}
 
 \end{code}