[hoc-cvs] [hoc commit] r380 - branches/objc2/hoc/HOC/HOC branches/objc2/hoc/HOC_cbits

[<cod...@go...>]

Author: jam...@us...
Date: Fri Jan  9 16:57:06 2009
New Revision: 380

Modified:
    /   (props changed)
    branches/objc2/hoc/HOC/HOC/ExportClass.hs
    branches/objc2/hoc/HOC/HOC/ID.hs
    branches/objc2/hoc/HOC/HOC/NewClass.hs
    branches/objc2/hoc/HOC_cbits/MemoryManagement.h
    branches/objc2/hoc/HOC_cbits/MemoryManagement.m

Log:
(objc2 branch) Rewrote retain/release to call superclass's implementations.


Modified: branches/objc2/hoc/HOC/HOC/ExportClass.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/ExportClass.hs	(original)
+++ branches/objc2/hoc/HOC/HOC/ExportClass.hs	Fri Jan  9 16:57:06 2009
@@ -130,8 +130,8 @@
                  ivars <- makeDefaultIvarList
                  imethods <- makeMethodList (nIMethods+3)
                  cmethods <- makeMethodList nCMethods
-                setHaskellRetainMethod imethods 0
-                setHaskellReleaseMethod imethods 1
+                setHaskellRetainMethod  imethods 0 super
+                setHaskellReleaseMethod imethods 1 super
                  setHaskellDataMethod imethods 2 super (
                          Just ($(typedInitIvars) >>= return . toDyn)
                      )

Modified: branches/objc2/hoc/HOC/HOC/ID.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/ID.hs	(original)
+++ branches/objc2/hoc/HOC/HOC/ID.hs	Fri Jan  9 16:57:06 2009
@@ -8,7 +8,7 @@

  import Control.Concurrent.MVar
  import Control.Exception(evaluate,assert)
-import Control.Monad(when)
+import Control.Monad(when, join)
  import System.IO.Unsafe(unsafePerformIO)
  import System.Mem.Weak
  import Foreign.Ptr
@@ -21,6 +21,12 @@

  data ID a = ID HSO | Nil

+dPutStrLn = if {--} False --} True
+    then putStrLn
+    else const $ return ()
+
+dPutWords = dPutStrLn . unwords
+
  nil = Nil

  castObject (ID a) = ID a
@@ -59,6 +65,13 @@
  objectMapLock = unsafePerformIO $ newMVar ()
  {-# NOINLINE objectMapLock #-}

+withObjectMapLock taker action = do
+    dPutWords [">", "withObjectMapLock", taker]
+    res <- withMVar objectMapLock $ \_ -> action
+    dPutWords ["<", "withObjectMapLock", taker]
+    return res
+
+
  -- given a pointer to an ObjCObject, return a stablePtr to a Weak  
reference to
  -- a HSO
  foreign import ccall unsafe "ObjectMap.h getHaskellPart"
@@ -91,13 +104,21 @@
      getRetainedHaskellPart :: Ptr ObjCObject -> IO (StablePtr HSO)
  foreign import ccall unsafe "RetainedHaskellPart.h setRetainedHaskellPart"
      setRetainedHaskellPart :: Ptr ObjCObject -> StablePtr HSO -> IO ()
-
-foreign import ccall unsafe "NSObjectReferenceCount.h  
NSIncrementExtraRefCount"
-    nsIncrementExtraRefCount :: Ptr ObjCObject -> IO ()
-foreign import ccall unsafe "NSObjectReferenceCount.h  
NSDecrementExtraRefCountWasZero"
-    nsDecrementExtraRefCountWasZero :: Ptr ObjCObject -> IO CChar{-BOOL-}
-foreign import ccall unsafe "NSObjectReferenceCount.h NSExtraRefCount"
-    nsExtraRefCount :: Ptr ObjCObject -> IO CUInt
+replaceRetainedHaskellPart :: Ptr ObjCObject -> StablePtr HSO -> IO ()
+replaceRetainedHaskellPart self newHSO = do
+    dPutWords ["replaceRetainedHaskellPart", show self, show  
(castStablePtrToPtr newHSO)]
+    oldHSO <- getRetainedHaskellPart self
+    when (oldHSO /= newHSO) $ do
+        when (castStablePtrToPtr oldHSO /= nullPtr) $ do
+            freeStablePtr oldHSO
+        setRetainedHaskellPart self newHSO
+
+foreign import ccall "MemoryManagement.h retainSuper"
+    retainSuper :: Ptr ObjCObject -> Ptr ObjCObject -> IO ()
+foreign import ccall "MemoryManagement.h releaseSuper"
+    releaseSuper :: Ptr ObjCObject -> Ptr ObjCObject -> IO ()
+foreign import ccall unsafe "MemoryManagement.h retainCount"
+    retainCount :: Ptr ObjCObject -> IO CUInt

  -- Since finalizers are executed in arbitrary threads, we must
  -- ensure that we establish an autoreleasepool for the duration
@@ -147,11 +168,13 @@

  importImmortal = importArgument' True

--- this is where the mogic happens.
+-- this is where the magic happens.
  importArgument' immortal p
      | p == nullPtr = return Nil
-    -- objectMapLock is a global, thanks to unsafePerformIO
-    | otherwise = withMVar objectMapLock $ \_ -> do
+    -- do what needs to be done in the lock, return what
+    -- needs to be done outside the lock (specifically,
+    -- the retain needs to be done outside the lock).
+    | otherwise = join $ withObjectMapLock "importArgument'" $ do
          sptr <- getHaskellPart p
          mbHaskellObj <-
              if castStablePtrToPtr sptr /= nullPtr
@@ -162,39 +185,31 @@
                      return Nothing
          case mbHaskellObj of
              -- if the HSO already exists, we're done!
-            Just haskellObj -> return $ ID haskellObj
+            Just haskellObj -> return $ return $ ID haskellObj
              -- notice that the finalizer definition requires new_sptr
              Nothing -> mdo  {- it's much more pratical than fixM -}
                  haskellData <- makeNewHaskellData p
+                dPutWords ["got haskell data", show haskellData]
                  let haskellObj = HSO p (fromMaybe [] haskellData)
-                    finalizer | isJust haskellData = Just $  
finalizeHaskellID p new_sptr
-                              | immortal = Nothing
+                    finalizer | immortal = Nothing
                                | otherwise = Just $ finalizeID p new_sptr
                  wptr <- mkWeakPtr haskellObj finalizer
                  new_sptr <- newStablePtr wptr
                  setHaskellPart p new_sptr (if immortal then 1 else 0)

-                case haskellData of
-                    Just _ -> haskellObject_retain p
-                    Nothing -> retainObject p
-
-                return $ ID haskellObj
+                return $ do
+                    -- retain the object, but do it outside the
+                    -- lock because the retain IMP may need the lock.
+                    retainObject p
+                    return $ ID haskellObj

  finalizeID :: Ptr ObjCObject -> StablePtr (Weak HSO) -> IO ()
  finalizeID cObj sptr = do
-    withMVar objectMapLock $ \_ -> removeHaskellPart cObj sptr
+    withObjectMapLock "finalizeID" $ removeHaskellPart cObj sptr
+
      releaseObjectWithPool cObj
      freeStablePtr sptr

-finalizeHaskellID :: Ptr ObjCObject -> StablePtr (Weak HSO) -> IO ()
-finalizeHaskellID cObj sptr = do
-    withMVar objectMapLock $ \_ -> removeHaskellPart cObj sptr
-    extraRefs <- nsExtraRefCount cObj
-    -- putStrLn "destroy haskelll object"
-    assert (extraRefs == 0) (deallocObjectWithPool cObj)
-    freeStablePtr sptr
-
---
  makeNewHaskellData p = do
      stable <- getNewHaskellData p
      if (castStablePtrToPtr stable == nullPtr)
@@ -204,77 +219,74 @@
              freeStablePtr stable
              return (Just dat)

-haskellObject_retain_IMP :: FFICif -> Ptr () -> Ptr (Ptr ()) -> IO (Ptr  
ObjCObject)
-haskellObject_retain_IMP cif ret args = do
+haskellObject_retain_IMP :: Ptr ObjCObject -> FFICif -> Ptr () -> Ptr (Ptr  
()) -> IO (Ptr ObjCObject)
+haskellObject_retain_IMP super cif ret args = do
      selfPtr <- peekElemOff args 0
      self <- peek (castPtr selfPtr) :: IO (Ptr ObjCObject)
      poke (castPtr ret) self     -- retain returns self
-    -- putStrLn "retain haskell object_IMP"
-    withMVar objectMapLock $ \_ -> haskellObject_retain self
+    dPutWords ["haskellObject_retain_IMP", show super, "<FFICif>", show  
ret, show args]
+    haskellObject_retain self super
      return nullPtr  -- no exception

-haskellObject_retain self = do
-    -- putStrLn "retain haskell object"
-    nsIncrementExtraRefCount self
+haskellObject_retain self super = do
+    dPutWords ["haskellObject_retain", show self, show super]
+    retainSuper self super
+    dPutStrLn "retained super"

-    stablePtrToHaskellSelf <- getRetainedHaskellPart self
-    when (castStablePtrToPtr stablePtrToHaskellSelf == nullPtr) $ do
-        stableWeakPtrToHaskellSelf <- getHaskellPart self
-        when (castStablePtrToPtr stableWeakPtrToHaskellSelf /= nullPtr) $  
do
-            weakPtrToHaskellSelf <- deRefStablePtr  
stableWeakPtrToHaskellSelf
-            mbHaskellSelf <- deRefWeak weakPtrToHaskellSelf
-            case mbHaskellSelf of
-                Just haskellSelf -> do
-                    stablePtrToHaskellSelf <- newStablePtr haskellSelf
-                    setRetainedHaskellPart self stablePtrToHaskellSelf
-                Nothing ->
-                    -- The weak pointer will only be dealloced when there  
are
-                    -- no known references from ObjC and no references  
from Haskell.
-                    -- So if we get here, it's not my bug (hopefully).
-                    -- When an object is exported (returned or passed as a  
parameter)
-                    -- from Haskell, it is retained and autoreleased, so  
passing an
-                    -- object from Haskell to Objective C and immediately  
forgetting
-                    -- the reference (before ObjC has a chance to retain  
it) is safe.
-
-                    error "Error: Retaining Haskell Object that has  
already been released"
+    withObjectMapLock "haskellObject_retain" $ do
+        stablePtrToHaskellSelf <- getRetainedHaskellPart self
+        when (castStablePtrToPtr stablePtrToHaskellSelf == nullPtr) $ do
+            stableWeakPtrToHaskellSelf <- getHaskellPart self
+            when (castStablePtrToPtr stableWeakPtrToHaskellSelf /=  
nullPtr) $ do
+                weakPtrToHaskellSelf <- deRefStablePtr  
stableWeakPtrToHaskellSelf
+                mbHaskellSelf <- deRefWeak weakPtrToHaskellSelf
+                case mbHaskellSelf of
+                    Just haskellSelf -> do
+                        stablePtrToHaskellSelf <- newStablePtr haskellSelf
+                        setRetainedHaskellPart self stablePtrToHaskellSelf
+                    Nothing ->
+                        -- The weak pointer will only be dealloced when  
there are
+                        -- no known references from ObjC and no references  
from Haskell.
+                        -- So if we get here, it's not my bug (hopefully).
+                        -- When an object is exported (returned or passed  
as a parameter)
+                        -- from Haskell, it is retained and autoreleased,  
so passing an
+                        -- object from Haskell to Objective C and  
immediately forgetting
+                        -- the reference (before ObjC has a chance to  
retain it) is safe.
+
+                        error "Error: Retaining Haskell Object that has  
already been released"


-haskellObject_release_IMP :: FFICif -> Ptr () -> Ptr (Ptr ()) -> IO (Ptr  
ObjCObject)
-haskellObject_release_IMP cif ret args = do
+haskellObject_release_IMP :: Ptr ObjCObject -> FFICif -> Ptr () -> Ptr  
(Ptr ()) -> IO (Ptr ObjCObject)
+haskellObject_release_IMP super cif ret args = do
      selfPtr <- peekElemOff args 0
      self <- peek (castPtr selfPtr) :: IO (Ptr ObjCObject)
-    -- putStrLn "release haskell object_IMP"
-    withMVar objectMapLock $ \_ -> haskellObject_release self
+    dPutWords ["haskellObject_release_IMP", show super, "<FFICif>", show  
ret, show args]
+    haskellObject_release super self
      return nullPtr  -- no exception

-haskellObject_release self = do
-    -- putStrLn "release haskell object"
-    wasZero <- nsDecrementExtraRefCountWasZero self
-        -- nobody else should call NSDecrementExtraRefCountWasZero anyway,
-        -- and we're protected from ourselves by the objectMapLock
-        -- ==> no race condition here
-    refCount <- nsExtraRefCount self
+haskellObject_release super self = do
+    dPutWords ["haskellObject_release", show super, show self]
+    retainCount+1 <- retainCount self
+        -- retainCount+1 because we want to know the retainCount after we
+        -- release; if it's about to become zero, then we won't be
+        -- able to call retainCount on self after the call to releaseSuper.
+    releaseSuper self super
+        -- retainCount should now contain the current retain count.

-    when (refCount == 0) $ do
+    when (retainCount == 1) $ withObjectMapLock "haskellObject_release" $  
do
          -- no extra references
          -- Only the reference from the Haskell part remains,
          -- which means we do no longer want to have a stable pointer
          -- (if we have one, that is)
-        stablePtrToHaskellSelf <- getRetainedHaskellPart self
-        when (castStablePtrToPtr stablePtrToHaskellSelf /= nullPtr) $ do
-            freeStablePtr stablePtrToHaskellSelf
-            setRetainedHaskellPart self (castPtrToStablePtr nullPtr)
-
-    when (wasZero /= 0) $ do
-        deallocObject self
+        replaceRetainedHaskellPart self (castPtrToStablePtr nullPtr)

  -- this is the implementation of the __getHaskellData__ selector.
  getHaskellData_IMP :: Ptr ObjCObject -> Maybe (IO Dynamic)
                      -> FFICif -> Ptr () -> Ptr (Ptr ()) -> IO (Ptr  
ObjCObject)
  getHaskellData_IMP super mbDat cif ret args = do
-    -- putStrLn "__getHaskellData__"
      selfPtr <- peekElemOff args 0
      self <- peek (castPtr selfPtr) :: IO (Ptr ObjCObject)
+    dPutWords ["__getHaskellData__", show self, show super]
      superDataStable <- getNewHaskellDataForClass self super
      superData <- if castStablePtrToPtr superDataStable == nullPtr
          then do

Modified: branches/objc2/hoc/HOC/HOC/NewClass.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/NewClass.hs	(original)
+++ branches/objc2/hoc/HOC/HOC/NewClass.hs	Fri Jan  9 16:57:06 2009
@@ -95,20 +95,20 @@
      return list

  retainSelector = getSelectorForName "retain"
-retainCif = getCifForSelector (undefined :: ID () -> IO (ID ()))
+retainCif = getCifForSelector (undefined :: Class () -> ID () -> IO (ID  
()))

  releaseSelector = getSelectorForName "release"
-releaseCif = getCifForSelector (undefined :: ID () -> IO ())
+releaseCif = getCifForSelector (undefined :: Class () -> ID () -> IO ())

  getHaskellDataSelector = getSelectorForName "__getHaskellData__"
  getHaskellDataCif = getCifForSelector (undefined :: Class () -> ID () ->  
IO (ID ()))
                                                  -- actually  -> IO (Ptr  
()) ...

-setHaskellRetainMethod methodList idx =
-    setMethodInList methodList idx retainSelector "@@:" retainCif  
haskellObject_retain_IMP
+setHaskellRetainMethod methodList idx super =
+    setMethodInList methodList idx retainSelector "@@:" retainCif  
(haskellObject_retain_IMP super)

-setHaskellReleaseMethod methodList idx =
-    setMethodInList methodList idx releaseSelector "v@:" releaseCif  
haskellObject_release_IMP
+setHaskellReleaseMethod methodList idx super =
+    setMethodInList methodList idx releaseSelector "v@:" releaseCif  
(haskellObject_release_IMP super)

  setHaskellDataMethod methodList idx super mbDat =
      setMethodInList methodList idx getHaskellDataSelector "^v@:#"  
getHaskellDataCif (getHaskellData_IMP super mbDat)

Modified: branches/objc2/hoc/HOC_cbits/MemoryManagement.h
==============================================================================
--- branches/objc2/hoc/HOC_cbits/MemoryManagement.h	(original)
+++ branches/objc2/hoc/HOC_cbits/MemoryManagement.h	Fri Jan  9 16:57:06 2009
@@ -8,6 +8,11 @@

  void retainObject(id obj);
  void releaseObject(id obj);
+
+void retainSuper(id obj, Class cls);
+void releaseSuper(id obj, Class cls);
+unsigned int retainCount(id obj);
+
  void deallocObject(id obj);

  void autoreleaseObject(id obj);

Modified: branches/objc2/hoc/HOC_cbits/MemoryManagement.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/MemoryManagement.m	(original)
+++ branches/objc2/hoc/HOC_cbits/MemoryManagement.m	Fri Jan  9 16:57:06 2009
@@ -1,3 +1,11 @@
+#ifdef GNUSTEP
+#include <objc/objc-api.h>
+#else
+#include <objc/objc-runtime.h>
+#endif
+
+#include <stdlib.h>
+
  #include "MemoryManagement.h"

  #define DO_LOG 0
@@ -44,6 +52,7 @@

  static SEL selRetain = 0;
  static SEL selRelease = 0;
+static SEL selRetainCount = 0;
  static SEL selDealloc = 0;
  static SEL selAutorelease = 0;
  static SEL selAlloc = 0;
@@ -55,7 +64,7 @@
      if(!selRetain)
          selRetain = getSelectorForName("retain");
  #if DO_LOG
-    printf("retain %p, %p\n",obj,obj->class_pointer);
+    printf("retain %p, %p\n",obj,obj->isa);
  #endif
      objc_msgSend(obj,selRetain);
  }
@@ -65,9 +74,59 @@
      if(!selRelease)
          selRelease = getSelectorForName("release");
  #if DO_LOG
-    printf("release %p, %p\n",obj,obj->class_pointer);
+    printf("release %p, %p\n",obj,obj->isa);
  #endif
      objc_msgSend(obj,selRelease);
+}
+
+void retainSuper(id obj, Class cls)
+{
+    if(!selRetain)
+        selRetain = getSelectorForName("retain");
+
+#if DO_LOG
+    printf("retain super %p, %p\n",obj,cls);
+#endif
+
+    struct objc_super * super = calloc(1, sizeof(struct objc_super));
+
+    super->receiver = obj;
+    super->super_class = cls;
+
+    objc_msgSendSuper(super, selRetain);
+}
+
+void releaseSuper(id obj, Class cls)
+{
+    if(!selRelease)
+        selRelease = getSelectorForName("release");
+
+#if DO_LOG
+    printf("release super %p, %p\n",obj,cls);
+#endif
+
+    struct objc_super * super = calloc(1, sizeof(struct objc_super));
+
+    super->receiver = obj;
+    super->super_class = cls;
+
+    objc_msgSendSuper(super, selRelease);
+}
+
+unsigned int retainCount(id obj) {
+    unsigned int rc;
+
+#if DO_LOG
+    printf("retainCount %p = ",obj);
+#endif
+    if(!selRetainCount)
+        selRetainCount = getSelectorForName("retainCount");
+
+    rc = (unsigned int) objc_msgSend(obj,selRetainCount);
+#if DO_LOG
+    printf("%d\n",rc);
+#endif
+    return rc;
  }

  void deallocObject(id obj)