Menu
▾
▴
[hoc-cvs] [hoc] r402 committed - Merging ObjC2 branch to trunk (r380 and related changes)
|
From: <cod...@go...> - 2009-08-13 15:50:25
|
Revision: 402 Author: jam...@us... Date: Thu Aug 13 08:45:30 2009 Log: Merging ObjC2 branch to trunk (r380 and related changes) http://code.google.com/p/hoc/source/detail?r=402 Modified: / /trunk/hoc /trunk/hoc/HOC/HOC/ExportClass.hs /trunk/hoc/HOC/HOC/ID.hs /trunk/hoc/HOC/HOC/NewClass.hs /trunk/hoc/HOC_cbits/MemoryManagement.h /trunk/hoc/HOC_cbits/MemoryManagement.m /trunk/hoc/InterfaceGenerator2/Output.hs ======================================= --- /trunk/hoc/HOC/HOC/ExportClass.hs Sun Dec 21 13:42:00 2008 +++ /trunk/hoc/HOC/HOC/ExportClass.hs Thu Aug 13 08:45:30 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) ) ======================================= --- /trunk/hoc/HOC/HOC/ID.hs Sat Nov 1 04:27:26 2008 +++ /trunk/hoc/HOC/HOC/ID.hs Thu Aug 13 08:45:30 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 @@ -58,6 +64,13 @@ -- don't we love globals? This needs -fno-cse to be truely safe. 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 @@ -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,54 +168,52 @@ 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 - sptr <- getHaskellPart p - mbHaskellObj <- - if castStablePtrToPtr sptr /= nullPtr - then do - wptr <- deRefStablePtr sptr - deRefWeak wptr - else - return Nothing - case mbHaskellObj of - -- if the HSO already exists, we're done! - Just haskellObj -> return $ ID haskellObj - -- notice that the finalizer definition requires new_sptr - Nothing -> mdo {- it's much more pratical than fixM -} - haskellData <- makeNewHaskellData p - let haskellObj = HSO p (fromMaybe [] haskellData) - finalizer | isJust haskellData = Just $ finalizeHaskellID p new_sptr - | 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 + | otherwise = do + (haskellObj, retain) <- withObjectMapLock "importArgument'" $ do + mbHaskellObj <- lookupHSO p + case mbHaskellObj of + -- if the HSO already exists, we're done! + Just haskellObj -> return (haskellObj, False) + -- otherwise create one and (outside the lock) retain p + Nothing -> do + haskellObj <- makeNewHSO immortal p + return (haskellObj, True) + when retain (retainObject p) + return (ID haskellObj) + +lookupHSO p = do + sptr <- getHaskellPart p + if castStablePtrToPtr sptr /= nullPtr + then do + wptr <- deRefStablePtr sptr + deRefWeak wptr + else + return Nothing + +-- notice that wptr's finalizer definition requires new_sptr, which +-- cannot be created till after the wptr; +-- so we use 'mdo' (it's much more pratical than fixM) +makeNewHSO immortal p = mdo + haskellData <- makeNewHaskellData p + dPutWords ["got haskell data", show haskellData] + let haskellObj = HSO p (fromMaybe [] haskellData) + 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) + return 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 +223,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 - - 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_retain self super = do + dPutWords ["haskellObject_retain", show self, show super] + retainSuper self super + dPutStrLn "retained super" + + 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 - - when (refCount == 0) $ do +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 (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 ======================================= --- /trunk/hoc/HOC/HOC/NewClass.hs Sun Dec 21 13:42:00 2008 +++ /trunk/hoc/HOC/HOC/NewClass.hs Thu Aug 13 08:45:30 2009 @@ -101,14 +101,14 @@ releaseCif = getCifForSelector (undefined :: ID () -> IO ()) getHaskellDataSelector = getSelectorForName "__getHaskellData__" -getHaskellDataCif = getCifForSelector (undefined :: Class () -> ID () -> IO (ID ())) +getHaskellDataCif = getCifForSelector (undefined :: ID () -> IO (ID ())) -- actually -> IO (Ptr ()) ... -setHaskellRetainMethod methodList idx = - setMethodInList methodList idx retainSelector "@@:" retainCif haskellObject_retain_IMP - -setHaskellReleaseMethod methodList idx = - setMethodInList methodList idx releaseSelector "v@:" releaseCif haskellObject_release_IMP +setHaskellRetainMethod methodList idx super = + setMethodInList methodList idx retainSelector "@@:" retainCif (haskellObject_retain_IMP super) + +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) ======================================= --- /trunk/hoc/HOC_cbits/MemoryManagement.h Tue Sep 9 00:05:17 2008 +++ /trunk/hoc/HOC_cbits/MemoryManagement.h Thu Aug 13 08:45:30 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); ======================================= --- /trunk/hoc/HOC_cbits/MemoryManagement.m Tue Sep 9 00:05:17 2008 +++ /trunk/hoc/HOC_cbits/MemoryManagement.m Thu Aug 13 08:45:30 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,10 +74,60 @@ 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) { ======================================= --- /trunk/hoc/InterfaceGenerator2/Output.hs Tue Aug 11 10:37:55 2009 +++ /trunk/hoc/InterfaceGenerator2/Output.hs Thu Aug 13 08:45:30 2009 @@ -66,7 +66,8 @@ <+> textBS (eHaskellName e) <> text "MetaClass") pprHsBoot entityPile modName entities - = text "module" <+> textBS modName <+> text "where" $+$ + = text "{-# OPTIONS -fglasgow-exts #-}" $+$ + text "module" <+> textBS modName <+> text "where" $+$ text "import HOC" $+$ vcat imports $+$ vcat classes @@ -84,7 +85,9 @@ <+> parens (textBS name <> char '_' <+> char 'a') $+$ text "type" <+> textBS name <> text "MetaClass" <+> char 'a' <+> equals <+> text (maybe "MetaClass" ( (++ "MetaClass") . BS.unpack . eHaskellName ) mbSuper) - <+> parens (textBS name <> char '_' <+> char 'a') + <+> parens (textBS name <> char '_' <+> char 'a') $+$ + text "instance" <+> text "ClassObject" <+> parens (textBS name <> text "Class" <+> text "()") $+$ + text "_" <> textBS name <+> text "::" <+> textBS name <> text "Class" <+> text "()" | (name, mbSuper) <- classes0 ] |
