[hoc-cvs] [hoc] r410 committed - Rework mechanics of calls to super so that meta-class objects...

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

Revision: 410
Author: wol...@gm...
Date: Thu Aug 20 17:27:38 2009
Log: Rework mechanics of calls to super so that meta-class objects
are never passed through the machinery in ID.hs.

See issue #18

http://code.google.com/p/hoc/source/detail?r=410

Modified:
  /trunk/hoc/HOC/HOC/Class.hs
  /trunk/hoc/HOC/HOC/DeclareClass.hs
  /trunk/hoc/HOC/HOC/Super.hs
  /trunk/hoc/HOC_cbits/MemoryManagement.m
  /trunk/hoc/HOC_cbits/Statistics.m

=======================================
--- /trunk/hoc/HOC/HOC/Class.hs	Sun Dec 21 13:42:00 2008
+++ /trunk/hoc/HOC/HOC/Class.hs	Thu Aug 20 17:27:38 2009
@@ -1,6 +1,6 @@
  {-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls,
               MultiParamTypeClasses, FunctionalDependencies,
-             TypeSynonymInstances #-}
+             TypeSynonymInstances, FlexibleContexts #-}
  module HOC.Class where

  import HOC.Base
@@ -23,22 +23,21 @@

  getClassByName name = withCString name c_getClassByName

-{-# NOINLINE unsafeGetClassObject #-} -- called from generated code, save  
space
+     -- called from generated code, save space:
+{-# NOINLINE unsafeGetClassObject #-}
  unsafeGetClassObject name = unsafePerformIO $
      getClassByName name >>= importImmortal

-
-unsafeGetMetaclassForClass :: Class a -> MetaClass a
+{-# NOINLINE unsafeGetRawClassObject #-}
+unsafeGetRawClassObject name = unsafePerformIO $
+    getClassByName name
+

  foreign import ccall unsafe "Class.h getClassForObject"
      c_getClassForObject :: Ptr ObjCObject -> IO (Ptr ObjCObject)

  getClassForObject obj = withExportedArgument obj c_getClassForObject

-{-# NOINLINE unsafeGetMetaclassForClass #-}
-unsafeGetMetaclassForClass obj = unsafePerformIO $
-    getClassForObject obj >>= importImmortal
-

  class (Object a, Object b) => ClassAndObject a b | a -> b, b -> a

@@ -47,3 +46,15 @@
  class Object cls => ClassObject cls
      where
          classObject :: cls
+
+class Object a => RawStaticClass a where
+    rawStaticClassForObject :: a -> Ptr ObjCObject
+
+instance RawStaticClass (ID a) => RawStaticClass (Class a) where
+    rawStaticClassForObject cls =
+        unsafePerformIO $
+            c_getClassForObject (rawStaticClassForObject $ objdummy cls)
+        where
+            objdummy :: Class a -> ID a
+            objdummy = undefined
+
=======================================
--- /trunk/hoc/HOC/HOC/DeclareClass.hs	Mon Aug 17 10:31:23 2009
+++ /trunk/hoc/HOC/HOC/DeclareClass.hs	Thu Aug 20 17:27:38 2009
@@ -6,6 +6,12 @@

  import HOC.TH

+import Debug.Trace
+
+import HOC.Arguments
+import Foreign.Ptr
+import System.IO.Unsafe
+
  declareClass :: String -> String -> Q [Dec]

  declareClass name super = sequence $ [
@@ -41,10 +47,6 @@
          valD (return $ VarP (mkName classObjectName))
              (normalB [| unsafeGetClassObject $(stringE name) |]) [],

-        -- $(metaClassObjectName) = unsafeGetMetaclassForClass  
$(classObjectName)
-        valD (return $ VarP (mkName metaClassObjectName))
-            (normalB [| unsafeGetMetaclassForClass $(varE (mkName  
classObjectName)) |]) [],
-
          -- $(superName) :: String
          sigD (mkName superName) [t| String |],

@@ -61,12 +63,13 @@
          --  where classObject = classObject
          instanceD (cxt []) (conT ''ClassObject `appT` metaClsType)
              [funD 'classObject [clause [] (normalB $ varE (mkName  
classObjectName)) []]],
-
-        -- instance ClassObject metaMetaCls
-        --  where classObject = unsafeGetMetaclassForClass classObject
-        --  {- metaclass object, to support super calls in class methods -}
-        instanceD (cxt []) (conT ''ClassObject `appT` metaMetaClsType)
-            [funD 'classObject [clause [] (normalB $ varE (mkName  
metaClassObjectName)) []]]
+
+        -- instance RawStaticClass (name ()) where
+        --  rawStaticClassForObject _ = unsafeGetRawClassObject "name"
+        instanceD (cxt []) (conT ''RawStaticClass `appT` clsType)
+            [funD 'rawStaticClassForObject [
+                clause [wildP] (normalB $
+                [| unsafeGetRawClassObject $(stringE name) |] ) []]]
      ]
      where
          phantomName = name ++ "_"
@@ -78,7 +81,7 @@
          superMetaMetaClassName | super == "ID" = "MetaClass"
                                 | otherwise = super ++ "MetaClass"
          classObjectName = "_" ++ name
-        metaClassObjectName = "_" ++ metaClassName
+
          superName = "super_" ++ name

          metaMetaClsType = conT (mkName metaMetaClassName) `appT` [t| () |]
=======================================
--- /trunk/hoc/HOC/HOC/Super.hs	Wed Dec 10 06:52:25 2008
+++ /trunk/hoc/HOC/HOC/Super.hs	Thu Aug 20 17:27:38 2009
@@ -25,7 +25,7 @@
  -- super, which is sufficient to define a class hierarchy.
  class SuperClass sub super | sub -> super

-data SuperTarget a = SuperTarget a (Class ())
+data SuperTarget a = SuperTarget a (Ptr ObjCObject)

  class Super sub super | sub -> super where
      super :: sub -> super
@@ -43,7 +43,6 @@
          => ObjCArgument (SuperTarget a) (Ptr ObjCObject) where

      withExportedArgument (SuperTarget obj cls) action =
-        withExportedArgument cls $ \cls ->
          withExportedArgument obj $ \p ->
          withExportedSuper p cls action

@@ -55,19 +54,14 @@
  castSuper :: SuperClass (ID sub) (ID super) => ID sub -> ID super
  castSuper = castObject

-staticSuperclassForObject ::
-    ( SuperClass (ID sub) (ID super)
-    , ClassObject (Class super)
-    ) => ID sub -> Class super
-staticSuperclassForObject obj = classObject
-
  instance (Object (ID sub), Object (ID super), SuperClass (ID sub) (ID  
super),
-          ClassObject (Class super))
+          RawStaticClass (ID super))
      => Super (ID sub) (SuperTarget (ID super)) where
-    super obj = SuperTarget (castSuper obj) (castObject  
(staticSuperclassForObject obj))
+    super obj = SuperTarget (castSuper obj)
+                    (rawStaticClassForObject (castSuper obj))

  instance MessageTarget a => MessageTarget (SuperTarget a) where
-    isNil (SuperTarget x cls) = isNil x || isNil cls
+    isNil (SuperTarget x cls) = isNil x || cls == nullPtr

      sendMessageWithRetval _ = superSendMessageWithRetval
      sendMessageWithoutRetval _ = superSendMessageWithoutRetval
=======================================
--- /trunk/hoc/HOC_cbits/MemoryManagement.m	Mon Aug 17 15:41:10 2009
+++ /trunk/hoc/HOC_cbits/MemoryManagement.m	Thu Aug 20 17:27:38 2009
@@ -65,8 +65,9 @@
      if(!selRetain)
          selRetain = getSelectorForName("retain");
  #if DO_LOG
-    printf("retain %p, %p\n",obj,obj->isa);
+    printf("retain %p, %p\n",obj,getClassForObject(obj));
  #endif
+
      objc_msgSend(obj,selRetain);
  }

@@ -75,8 +76,9 @@
      if(!selRelease)
          selRelease = getSelectorForName("release");
  #if DO_LOG
-    printf("release %p, %p\n",obj,obj->isa);
+    printf("release %p, %p\n",obj,getClassForObject(obj));
  #endif
+
      objc_msgSend(obj,selRelease);
  }

=======================================
--- /trunk/hoc/HOC_cbits/Statistics.m	Tue Feb 13 09:11:04 2007
+++ /trunk/hoc/HOC_cbits/Statistics.m	Thu Aug 20 17:27:38 2009
@@ -37,7 +37,7 @@
      obj = *(id*)  args[0];
      sel = *(SEL*) args[1];

-   // printf("recordHOCEvent %d\n", what);
+    //printf("recordHOCEvent %d %p %s\n", what, obj, sel_get_name(sel));

  #ifdef DO_TIMINGS
      static uint64_t saved;