Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

15 files changed, 155 insertions, 105 deletions

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 6b918dbc08..e244c0db65 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -273,7 +273,7 @@ data DataCon
 	--	dcExTyVars    = [x,y]
 	--	dcEqSpec      = [a~(x,y)]
 	--	dcOtherTheta  = [x~y, Ord x]	
-	--	dcOrigArgTys  = [a,List b]
+	--	dcOrigArgTys  = [x,y]
 	--	dcRepTyCon       = T
 
 	dcVanilla :: Bool,	-- True <=> This is a vanilla Haskell 98 data constructor
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 1291f6466a..dfa44ca274 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -1065,6 +1065,12 @@ doReturn exprs_code = do
   updfr_off <- getUpdFrameOff
   emit (mkReturnSimple dflags exprs updfr_off)
 
+mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
+mkReturnSimple dflags actuals updfr_off =
+  mkReturn dflags e actuals updfr_off
+  where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
+                             (gcWord dflags))
+
 doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
 doRawJump expr_code vols = do
   dflags <- getDynFlags
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index 1536794a70..7971b1de0f 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -12,7 +12,7 @@ module MkGraph
   , mkJump, mkJumpExtra, mkDirectJump, mkForeignJump, mkForeignJumpExtra
   , mkRawJump
   , mkCbranch, mkSwitch
-  , mkReturn, mkReturnSimple, mkComment, mkCallEntry, mkBranch
+  , mkReturn, mkComment, mkCallEntry, mkBranch
   , copyInOflow, copyOutOflow
   , noExtraStack
   , toCall, Transfer(..)
@@ -23,7 +23,6 @@ import BlockId
 import Cmm
 import CmmCallConv
 
-
 import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
 import DynFlags
 import FastString
@@ -241,11 +240,6 @@ mkReturn dflags e actuals updfr_off =
   lastWithArgs dflags Ret  Old NativeReturn actuals updfr_off $
     toCall e Nothing updfr_off 0
 
-mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
-mkReturnSimple dflags actuals updfr_off =
-  mkReturn dflags e actuals updfr_off
-  where e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)
-
 mkBranch        :: BlockId -> CmmAGraph
 mkBranch bid     = mkLast (CmmBranch bid)
 
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index 7612cd1a49..aef1e4f792 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -306,6 +306,11 @@ loadThreadState dflags tso stack = do
         -- SpLim = stack->stack + RESERVED_STACK_WORDS;
         mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
                                     (rESERVED_STACK_WORDS dflags)),
+        -- HpAlloc = 0;
+        --   HpAlloc is assumed to be set to non-zero only by a failed
+        --   a heap check, see HeapStackCheck.cmm:GC_GENERIC
+        mkAssign hpAlloc (zeroExpr dflags),
+
         openNursery dflags,
         -- and load the current cost centre stack from the TSO when profiling:
         if gopt Opt_SccProfilingOn dflags then
@@ -367,13 +372,14 @@ stgHp             = CmmReg hp
 stgCurrentTSO     = CmmReg currentTSO
 stgCurrentNursery = CmmReg currentNursery
 
-sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
+sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg
 sp                = CmmGlobal Sp
 spLim             = CmmGlobal SpLim
 hp                = CmmGlobal Hp
 hpLim             = CmmGlobal HpLim
 currentTSO        = CmmGlobal CurrentTSO
 currentNursery    = CmmGlobal CurrentNursery
+hpAlloc           = CmmGlobal HpAlloc
 
 -- -----------------------------------------------------------------------------
 -- For certain types passed to foreign calls, we adjust the actual
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index bf49a98a3b..49e943c0de 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -749,7 +749,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
                         -- In such case, we return a best approximation:
                         --  ignore the unpointed args, and recover the pointeds
                         -- This preserves laziness, and should be safe.
-		       traceTR (text "Nothing" <+> ppr dcname)
+		       traceTR (text "Not constructor" <+> ppr dcname)
                        let dflags = hsc_dflags hsc_env
                            tag = showPpr dflags dcname
                        vars     <- replicateM (length$ elems$ ptrs clos) 
@@ -758,7 +758,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
                                               | (i, tv) <- zip [0..] vars]
                        return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
           Just dc -> do
-            traceTR (text "Just" <+> ppr dc)
+            traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))
             subTtypes <- getDataConArgTys dc my_ty
             subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes
             return (Term my_ty (Right dc) a subTerms)
@@ -939,14 +939,16 @@ getDataConArgTys :: DataCon -> Type -> TR [Type]
 -- not be fully known.  Moreover, the arg types might involve existentials;
 -- if so, make up fresh RTTI type variables for them
 getDataConArgTys dc con_app_ty
-  = do { (_, ex_tys, _) <- instTyVars ex_tvs
+  = do { (_, ex_tys, ex_subst) <- instTyVars ex_tvs
        ; let UnaryRep rep_con_app_ty = repType con_app_ty
+       ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty))
        ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of
                        Just (tc, ty_args) | dataConTyCon dc == tc
 		       	   -> ASSERT( univ_tvs `equalLength` ty_args) 
                               return ty_args
- 		       _   -> do { (_, ty_args, subst) <- instTyVars univ_tvs
-		       	         ; let res_ty = substTy subst (dataConOrigResTy dc)
+ 		       _   -> do { (_, ty_args, univ_subst) <- instTyVars univ_tvs
+		       	         ; let res_ty = substTy ex_subst (substTy univ_subst (dataConOrigResTy dc))
+                                   -- See Note [Constructor arg types]
                                  ; addConstraint rep_con_app_ty res_ty
                                  ; return ty_args }
 		-- It is necessary to check dataConTyCon dc == tc
@@ -954,11 +956,38 @@ getDataConArgTys dc con_app_ty
       		-- newtype and tcSplitTyConApp has not removed it. In
       		-- that case, we happily give up and don't match
        ; let subst = zipTopTvSubst (univ_tvs ++ ex_tvs) (ty_args ++ ex_tys)
+       ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr ty_args $$ ppr subst))
        ; return (substTys subst (dataConRepArgTys dc)) }
   where
     univ_tvs = dataConUnivTyVars dc
     ex_tvs   = dataConExTyVars dc
 
+{- Note [Constructor arg types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider a GADT (cf Trac #7386)
+   data family D a b
+   data instance D [a] b where
+     MkT :: b -> D [a] (Maybe b)
+
+In getDataConArgTys
+* con_app_ty is the known type (from outside) of the constructor application, 
+  say D [Int] Bool
+
+* The data constructor MkT has a (representation) dataConTyCon = DList,
+  say where
+    data DList a b where
+      MkT :: b -> DList a (Maybe b)
+
+So the dataConTyCon of the data constructor, DList, differs from 
+the "outside" type, D. So we can't straightforwardly decompose the
+"outside" type, and we end up in the "_" branch of the case.
+
+Then we match the dataConOrigResTy of the data constructor against the
+outside type, hoping to get a substitution that tells how to instantiate
+the *representation* type constructor.   This looks a bit delicate to
+me, but it seems to work.
+-}
+
 -- Soundness checks
 --------------------
 {-
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index a75890f70a..3facc1e7e4 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -335,13 +335,17 @@ kickOutRewritable new_flav new_tv
                     --     constraints that mention type variables whose
                     --     kinds could contain this variable!
 
-    kick_out_eq inert_ct = kick_out_ct inert_ct && 
-                           not (ctFlavour inert_ct `canRewrite` new_flav)
-               -- If also the inert can rewrite the subst then there is no danger of 
-               -- occurs check errors sor keep it there. No need to rewrite the inert equality
-               -- (as we did in the past) because of point (8) of 
-               -- See Note [Detailed InertCans Invariants] 
-               -- and Note [Delicate equality kick-out]
+    kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs, cc_ev = ev })
+      =  (new_flav `canRewrite` inert_flav)  -- See Note [Delicate equality kick-out]
+      && (new_tv `elemVarSet` kind_vars ||              -- (1)
+          (not (inert_flav `canRewrite` new_flav) &&    -- (2)
+           new_tv `elemVarSet` (extendVarSet (tyVarsOfType rhs) tv)))
+      where
+        inert_flav = ctEvFlavour ev
+        kind_vars = tyVarsOfType (tyVarKind tv) `unionVarSet`
+                    tyVarsOfType (typeKind rhs)
+
+    kick_out_eq other_ct = pprPanic "kick_out_eq" (ppr other_ct)
 \end{code}
 
 Note [Kick out insolubles]
@@ -355,27 +359,34 @@ outer type constructors match.
 
 Note [Delicate equality kick-out]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
-Delicate:
-When kicking out rewritable constraints, it would be safe to simply
-kick out all rewritable equalities, but instead we only kick out those
-that, when rewritten, may result in occur-check errors. Example:
-
-          WorkItem =   [G] a ~ b
-          Inerts   = { [W] b ~ [a] }
-Now at this point the work item cannot be further rewritten by the
-inert (due to the weaker inert flavor). Instead the workitem can 
-rewrite the inert leading to potential occur check errors. So we must
-kick the inert out. On the other hand, if the inert flavor was as 
-powerful or more powerful than the workitem flavor, the work-item could 
-not have reached this stage (because it would have already been 
-rewritten by the inert).
-
-The coclusion is: we kick out the 'dangerous' equalities that may
-require recanonicalization (occurs checks) and the rest we keep 
-there in the inerts without further checks.
-
-In the past we used to rewrite-on-the-spot those equalities that we keep in,
-but this is no longer necessary see Note [Non-idempotent inert substitution].
+When adding an equality (a ~ xi), we kick out an inert type-variable 
+equality (b ~ phi) in two cases
+
+(1) If the new tyvar can rewrite the kind LHS or RHS of the inert
+    equality.  Example:
+    Work item: [W] k ~ *
+    Inert:     [W] (a:k) ~ ty        
+               [W] (b:*) ~ c :: k
+    We must kick out those blocked inerts so that we rewrite them
+    and can subsequently unify.
+
+(2) If the new tyvar can 
+          Work item:  [G] a ~ b
+          Inert:      [W] b ~ [a]
+    Now at this point the work item cannot be further rewritten by the
+    inert (due to the weaker inert flavor). But we can't add the work item
+    as-is because the inert set would then have a cyclic substitution, 
+    when rewriting a wanted type mentioning 'a'. So we must kick the inert out. 
+
+    We have to do this only if the inert *cannot* rewrite the work item;
+    it it can, then the work item will have been fully rewritten by the 
+    inert during canonicalisation.  So for example:
+         Work item: [W] a ~ Int
+         Inert:     [W] b ~ [a]
+    No need to kick out the inert, beause the inert substitution is not
+    necessarily idemopotent.  See Note [Non-idempotent inert substitution].
+
+See also point (8) of Note [Detailed InertCans Invariants] 
 
 \begin{code}
 data SPSolveResult = SPCantSolve
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index e6d2013ff2..4b2ea8fa94 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -915,7 +915,7 @@ built (in TcCanonical).
 
 In contrast, the type of the evidence *term* (ccev_evtm or ctev_evar) in
 the evidence may *not* be fully zonked; we are careful not to look at it
-during constraint solving.  Seee Note [Evidence field of CtEvidence]
+during constraint solving.  See Note [Evidence field of CtEvidence]
 
 \begin{code}
 mkNonCanonical :: CtLoc -> CtEvidence -> Ct
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 78fb0bf7e3..7541cd79f9 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -477,29 +477,34 @@ The InertCans represents a collection of constraints with the following properti
   
   7 Non-equality constraints are fully rewritten with respect to the equalities (CTyEqCan)
 
-  8 Equalities _do_not_ form an idempotent substitution but they are guarranteed to not have
-    any occurs errors. Additional notes: 
-
-       - The lack of idempotence of the inert substitution implies that we must make sure 
-         that when we rewrite a constraint we apply the substitution /recursively/ to the 
-         types involved. Currently the one AND ONLY way in the whole constraint solver 
-         that we rewrite types and constraints wrt to the inert substitution is 
-         TcCanonical/flattenTyVar.
-
-       - In the past we did try to have the inert substituion as idempotent as possible but
-         this would only be true for constraints of the same flavor, so in total the inert 
-         substitution could not be idempotent, due to flavor-related issued. 
-         Note [Non-idempotent inert substitution] explains what is going on. 
-
-       - Whenever a constraint ends up in the worklist we do recursively apply exhaustively
-         the inert substitution to it to check for occurs errors but if an equality is already
-         in the inert set and we can guarantee that adding a new equality will not cause the
-         first equality to have an occurs check then we do not rewrite the inert equality. 
-         This happens in TcInteract, rewriteInertEqsFromInertEq. 
+  8 Equalities _do_not_ form an idempotent substitution, but they are
+    guaranteed to not have any occurs errors. Additional notes: 
+
+       - The lack of idempotence of the inert substitution implies
+         that we must make sure that when we rewrite a constraint we
+         apply the substitution /recursively/ to the types
+         involved. Currently the one AND ONLY way in the whole
+         constraint solver that we rewrite types and constraints wrt
+         to the inert substitution is TcCanonical/flattenTyVar.
+
+       - In the past we did try to have the inert substitution as
+         idempotent as possible but this would only be true for
+         constraints of the same flavor, so in total the inert
+         substitution could not be idempotent, due to flavor-related
+         issued.  Note [Non-idempotent inert substitution] explains
+         what is going on.
+
+       - Whenever a constraint ends up in the worklist we do
+         recursively apply exhaustively the inert substitution to it
+         to check for occurs errors.  But if an equality is already in
+         the inert set and we can guarantee that adding a new equality
+         will not cause the first equality to have an occurs check
+         then we do not rewrite the inert equality.  This happens in
+         TcInteract, rewriteInertEqsFromInertEq.
          
-         See Note [Delicate equality kick-out] to see which inert equalities can safely stay
-         in the inert set and which must be kicked out to be rewritten and re-checked for 
-         occurs errors. 
+         See Note [Delicate equality kick-out] to see which inert
+         equalities can safely stay in the inert set and which must be
+         kicked out to be rewritten and re-checked for occurs errors.
 
   9 Given family or dictionary constraints don't mention touchable unification variables
 
@@ -1596,11 +1601,17 @@ Main purpose: create new evidence for new_pred;
                         Not                            Just new_evidence
 -}
 
--- If derived, don't even look at the coercion
--- NB: this allows us to sneak away with ``error'' thunks for 
--- coercions that come from derived ids (which don't exist!) 
-
 
+rewriteCtFlavor (CtDerived {}) new_pred _co
+  = -- If derived, don't even look at the coercion.
+    -- This is very important, DO NOT re-order the equations for
+    -- rewriteCtFlavor to put the isTcReflCo test first!  
+    -- Why?  Because for *Derived* constraints, c, the coercion, which 
+    -- was produced by flattening, may contain suspended calls to 
+    -- (ctEvTerm c), which fails for Derived constraints.
+    -- (Getting this wrong caused Trac #7384.)
+    newDerived new_pred
+        
 rewriteCtFlavor old_ev new_pred co
   | isTcReflCo co -- If just reflexivity then you may re-use the same variable
   = return (Just (if ctEvPred old_ev `eqType` new_pred
@@ -1612,9 +1623,6 @@ rewriteCtFlavor old_ev new_pred co
        -- However, if they *do* look the same, we'd prefer to stick with old_pred
        -- then retain the old type, so that error messages come out mentioning synonyms
 
-rewriteCtFlavor (CtDerived {}) new_pred _co
-  = newDerived new_pred
-        
 rewriteCtFlavor (CtGiven { ctev_evtm = old_tm }) new_pred co
   = do { new_ev <- newGivenEvVar new_pred new_tm  -- See Note [Bind new Givens immediately]
        ; return (Just new_ev) }
diff --git a/docs/users_guide/ghci.xml b/docs/users_guide/ghci.xml
index c59f4b3830..9e8ea2f0d1 100644
--- a/docs/users_guide/ghci.xml
+++ b/docs/users_guide/ghci.xml
@@ -662,7 +662,7 @@ Prelude>
       an attempt to distinguish it from the new <literal>T</literal>,
       which is displayed as simply <literal>T</literal>.</para>
 
-    <para>Class and type-family instance declarations are simply added to the list of available isntances, with one
+    <para>Class and type-family instance declarations are simply added to the list of available instances, with one
     exception. Since type-family instances are not permitted to overlap, but you might want to re-define one,
     a type-family instance <emphasis>replaces</emphasis> any earlier type instance with an identical left hand side.
     (See <xref linkend="type-families"/>.)</para>
diff --git a/includes/mkDerivedConstants.c b/includes/mkDerivedConstants.c
index 79242d9b41..7009a3fca8 100644
--- a/includes/mkDerivedConstants.c
+++ b/includes/mkDerivedConstants.c
@@ -631,7 +631,10 @@ main(int argc, char *argv[])
         closure_field(StgTVarWatchQueue, next_queue_entry);
         closure_field(StgTVarWatchQueue, prev_queue_entry);
 
+        closure_size(StgTVar);
         closure_field(StgTVar, current_value);
+        closure_field(StgTVar, first_watch_queue_entry);
+        closure_field(StgTVar, num_updates);
 
         closure_size(StgWeak);
         closure_field(StgWeak,link);
diff --git a/rts/Exception.cmm b/rts/Exception.cmm
index 3f1dc100be..2b633285dc 100644
--- a/rts/Exception.cmm
+++ b/rts/Exception.cmm
@@ -55,6 +55,9 @@ INFO_TABLE_RET(stg_unmaskAsyncExceptionszh_ret, RET_SMALL, W_ info_ptr)
 {
     CInt r;
 
+    P_ ret;
+    ret = R1;
+
     StgTSO_flags(CurrentTSO) = %lobits32(
       TO_W_(StgTSO_flags(CurrentTSO)) & ~(TSO_BLOCKEX|TSO_INTERRUPTIBLE));
 
@@ -68,18 +71,18 @@ INFO_TABLE_RET(stg_unmaskAsyncExceptionszh_ret, RET_SMALL, W_ info_ptr)
          * thread, which might result in the thread being killed.
          */
         Sp_adj(-2);
-        Sp(1) = R1;
+        Sp(1) = ret;
         Sp(0) = stg_ret_p_info;
         SAVE_THREAD_STATE();
-        (r) = ccall maybePerformBlockedException (MyCapability() "ptr", 
+        (r) = ccall maybePerformBlockedException (MyCapability() "ptr",
                                                       CurrentTSO "ptr");
-
         if (r != 0::CInt) {
             if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
                 jump stg_threadFinished [];
             } else {
                 LOAD_THREAD_STATE();
                 ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
+                R1 = ret;
                 jump %ENTRY_CODE(Sp(0)) [R1];
             }
         }
@@ -94,6 +97,7 @@ INFO_TABLE_RET(stg_unmaskAsyncExceptionszh_ret, RET_SMALL, W_ info_ptr)
     }
 
     Sp_adj(1);
+    R1 = ret;
     jump %ENTRY_CODE(Sp(0)) [R1];
 }
 
@@ -184,7 +188,10 @@ stg_unmaskAsyncExceptionszh /* explicit stack */
     W_ level;
 
     /* Args: R1 :: IO a */
-    STK_CHK_P (WDS(4), stg_unmaskAsyncExceptionszh, R1);
+    P_ io;
+    io = R1;
+
+    STK_CHK_P (WDS(4), stg_unmaskAsyncExceptionszh, io);
     /* 4 words: one for the unblock frame, 3 for setting up the
      * stack to call maybePerformBlockedException() below.
      */
@@ -222,11 +229,11 @@ stg_unmaskAsyncExceptionszh /* explicit stack */
              */
             Sp_adj(-3);
             Sp(2) = stg_ap_v_info;
-            Sp(1) = R1;
+            Sp(1) = io;
             Sp(0) = stg_enter_info;
 
             SAVE_THREAD_STATE();
-            (r) = ccall maybePerformBlockedException (MyCapability() "ptr", 
+            (r) = ccall maybePerformBlockedException (MyCapability() "ptr",
                                                       CurrentTSO "ptr");
 
             if (r != 0::CInt) {
@@ -235,6 +242,7 @@ stg_unmaskAsyncExceptionszh /* explicit stack */
 	        } else {
 	            LOAD_THREAD_STATE();
 	            ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
+                    R1 = io;
                     jump %ENTRY_CODE(Sp(0)) [R1];
 	        }
             } else {
@@ -246,6 +254,7 @@ stg_unmaskAsyncExceptionszh /* explicit stack */
     }
     TICK_UNKNOWN_CALL();
     TICK_SLOW_CALL_v();
+    R1 = io;
     jump stg_ap_v_fast [R1];
 }
 
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 6ff7dc0cf3..be8bc1572d 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -1062,8 +1062,15 @@ stg_newTVarzh (P_ init)
 {
     W_ tv;
 
-    MAYBE_GC_P (stg_newTVarzh, init);
-    ("ptr" tv) = ccall stmNewTVar(MyCapability() "ptr", init "ptr");
+    ALLOC_PRIM_P (SIZEOF_StgTVar, stg_newTVarzh, init);
+
+    tv = Hp - SIZEOF_StgTVar + WDS(1);
+    SET_HDR (tv, stg_TVAR_info, CCCS);
+
+    StgTVar_current_value(tv) = init;
+    StgTVar_first_watch_queue_entry(tv) = stg_END_STM_WATCH_QUEUE_closure;
+    StgTVar_num_updates(tv) = 0;
+
     return (tv);
 }
 
diff --git a/rts/STM.c b/rts/STM.c
index f8f56a2905..568a401f4d 100644
--- a/rts/STM.c
+++ b/rts/STM.c
@@ -1648,18 +1648,3 @@ void stmWriteTVar(Capability *cap,
 }
 
 /*......................................................................*/
-
-StgTVar *stmNewTVar(Capability *cap,
-                    StgClosure *new_value) {
-  StgTVar *result;
-  result = (StgTVar *)allocate(cap, sizeofW(StgTVar));
-  SET_HDR (result, &stg_TVAR_info, CCS_SYSTEM);
-  result -> current_value = new_value;
-  result -> first_watch_queue_entry = END_STM_WATCH_QUEUE;
-#if defined(THREADED_RTS)
-  result -> num_updates = 0;
-#endif
-  return result;
-}
-
-/*......................................................................*/
diff --git a/rts/STM.h b/rts/STM.h
index dd11bb8154..799cac3f84 100644
--- a/rts/STM.h
+++ b/rts/STM.h
@@ -183,14 +183,6 @@ StgBool stmReWait(Capability *cap, StgTSO *tso);
 
 /*----------------------------------------------------------------------
 
-   TVar management operations
-   --------------------------
-*/
-
-StgTVar *stmNewTVar(Capability *cap, StgClosure *new_value);
-
-/*----------------------------------------------------------------------
-
    Data access operations
    ----------------------
 */
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index ca278e952a..e727f4d903 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -239,7 +239,7 @@ usageHeader prog = substProg prog $
   "    Prints the highest registered version of a package.\n" ++
   "\n" ++
   "  $p check\n" ++
-  "    Check the consistency of package depenencies and list broken packages.\n" ++
+  "    Check the consistency of package dependencies and list broken packages.\n" ++
   "    Accepts the --simple-output flag.\n" ++
   "\n" ++
   "  $p describe {pkg}\n" ++