Handle HValues slightly nicer

We now have addrToAny# rather than addrToHValue#, and both addrToAny#
and mkApUpd0# return "Any" rather than "a". This makes it a little
easier to see what's going on, and fixes a warning in ByteCodeLink.

5 files changed, 19 insertions, 17 deletions

diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs
index 25d63d8002..e8f75b5dfe 100644
--- a/compiler/codeGen/CgPrimOp.hs
+++ b/compiler/codeGen/CgPrimOp.hs
@@ -203,7 +203,7 @@ emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2] _
    = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2]))
 
 --  #define addrToHValuezh(r,a) r=(P_)a
-emitPrimOp [res] AddrToHValueOp [arg] _
+emitPrimOp [res] AddrToAnyOp [arg] _
    = stmtC (CmmAssign (CmmLocal res) arg)
 
 --  #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 103929c3b7..4ce830a4ee 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -269,7 +269,7 @@ emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2]
    = emit (mkAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2]))
 
 --  #define addrToHValuezh(r,a) r=(P_)a
-emitPrimOp [res] AddrToHValueOp [arg]
+emitPrimOp [res] AddrToAnyOp [arg]
    = emit (mkAssign (CmmLocal res) arg)
 
 --  #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs
index f9be1131d2..603accd189 100644
--- a/compiler/ghci/ByteCodeLink.lhs
+++ b/compiler/ghci/ByteCodeLink.lhs
@@ -8,8 +8,7 @@ ByteCodeLink: Bytecode assembler and linker
 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
 
 module ByteCodeLink (
-        HValue(..), -- We don't want to export the constructor, but
-                    -- we get a warning that it's unsed if we don't
+        HValue,
         ClosureEnv, emptyClosureEnv, extendClosureEnv,
         linkBCO, lookupStaticPtr, lookupName
        ,lookupIE
@@ -95,8 +94,8 @@ linkBCO ie ce ul_bco
         --       non-zero arity BCOs in an AP thunk.
         --
         if (unlinkedBCOArity ul_bco > 0)
-           then return (unsafeCoerce# bco#)
-           else case mkApUpd0# bco# of { (# final_bco #) -> return final_bco }
+           then return (HValue (unsafeCoerce# bco#))
+           else case mkApUpd0# bco# of { (# final_bco #) -> return (HValue final_bco) }
 
 
 linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
@@ -146,9 +145,9 @@ mkPtrsArray ie ce n_ptrs ptrs = do
         BCO bco# <- linkBCO' ie ce ul_bco
         writeArrayBCO marr i bco#
     fill (BCOPtrBreakInfo brkInfo) i =
-        unsafeWrite marr i (unsafeCoerce# brkInfo)
+        unsafeWrite marr i (HValue (unsafeCoerce# brkInfo))
     fill (BCOPtrArray brkArray) i =
-        unsafeWrite marr i (unsafeCoerce# brkArray)
+        unsafeWrite marr i (HValue (unsafeCoerce# brkArray))
   zipWithM_ fill ptrs [0..]
   unsafeFreeze marr
 
@@ -206,8 +205,8 @@ lookupPrimOp primop
    = do let sym_to_find = primopToCLabel primop "closure"
         m <- lookupSymbol sym_to_find
         case m of
-           Just (Ptr addr) -> case addrToHValue# addr of
-                                 (# hval #) -> return hval
+           Just (Ptr addr) -> case addrToAny# addr of
+                                 (# a #) -> return (HValue a)
            Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
 
 lookupName :: ClosureEnv -> Name -> IO HValue
@@ -219,8 +218,8 @@ lookupName ce nm
               do let sym_to_find = nameToCLabel nm "closure"
                  m <- lookupSymbol sym_to_find
                  case m of
-                    Just (Ptr addr) -> case addrToHValue# addr of
-                                          (# hval #) -> return hval
+                    Just (Ptr addr) -> case addrToAny# addr of
+                                          (# a #) -> return (HValue a)
                     Nothing         -> linkFail "ByteCodeLink.lookupCE" sym_to_find
 
 lookupIE :: ItblEnv -> Name -> IO (Ptr a)
diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index 64f413d2ff..3f54172ecf 100644
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -67,7 +67,7 @@ module TysPrim(
         eqPrimTyCon,            -- ty1 ~# ty2
 
 	-- * Any
-	anyTyCon, anyTyConOfKind, anyTypeOfKind
+	anyTy, anyTyCon, anyTyConOfKind, anyTypeOfKind
   ) where
 
 #include "HsVersions.h"
@@ -671,6 +671,9 @@ This commit uses
 anyTyConName :: Name
 anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon
 
+anyTy :: Type
+anyTy = mkTyConTy anyTyCon
+
 anyTyCon :: TyCon
 anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep
 
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 8cad832350..09d2dd3361 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -1761,14 +1761,14 @@ section "Bytecode operations"
 primtype BCO#
    {Primitive bytecode type.}
 
-primop   AddrToHValueOp "addrToHValue#" GenPrimOp
-   Addr# -> (# a #)
-   {Convert an {\tt Addr\#} to a followable type.}
+primop   AddrToAnyOp "addrToAny#" GenPrimOp
+   Addr# -> (# Any #)
+   {Convert an {\tt Addr\#} to a followable Any type.}
    with
    code_size = 0
 
 primop   MkApUpd0_Op "mkApUpd0#" GenPrimOp
-   BCO# -> (# a #)
+   BCO# -> (# Any #)
    with
    out_of_line = True