Handle HValues slightly nicer
authorIan Lynagh <igloo@earth.li>
Mon, 3 Oct 2011 10:03:36 +0000 (11:03 +0100)
committerIan Lynagh <igloo@earth.li>
Mon, 3 Oct 2011 10:06:01 +0000 (11:06 +0100)
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.

compiler/codeGen/CgPrimOp.hs
compiler/codeGen/StgCmmPrim.hs
compiler/ghci/ByteCodeLink.lhs
compiler/prelude/TysPrim.lhs
compiler/prelude/primops.txt.pp
utils/genprimopcode/Main.hs

index 25d63d8..e8f75b5 100644 (file)
@@ -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))
index 103929c..4ce830a 100644 (file)
@@ -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))
index f9be113..603accd 100644 (file)
@@ -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)
index 64f413d..3f54172 100644 (file)
@@ -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
 
index 8cad832..09d2dd3 100644 (file)
@@ -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
 
index ddae677..df6c46b 100644 (file)
@@ -621,6 +621,7 @@ ppTyVar "o" = "openAlphaTyVar"
 ppTyVar _   = error "Unknown type var"
 
 ppType :: Ty -> String
+ppType (TyApp "Any"         []) = "anyTy"
 ppType (TyApp "Bool"        []) = "boolTy"
 
 ppType (TyApp "Int#"        []) = "intPrimTy"