[Help-smalltalk] [PATCH] CFunctionDescriptor minor refactoring

[Paolo Bonzini]

This patch improves the possibility for Smalltalk code to manage C 
function pointers.  It is now possible to create CFunctionDescriptors 
that are not attached to a function that the VM knows about, simply by 
passing a CObject to CFunctionDescriptor>>#for:returning:withArgs:.  The 
address however is reset to "nil" on image restart and it is up to the 
user to reinitialize it.  To aid in this, since CFunctionDescriptor 
subclasses cannot add instance variables, a subclass can add more info 
in the new "tag" instance variable of CFunctionDescriptor, which is 
unused by the VM.

Also to simplify this kind of task, I extracted parts of the pragma 
handling for <cCall:returning:args:> to constructor methods on 
CompiledMethod's class-side.

Parts of the C code could be deleted or simplified; I don't have much 
time to do that now.

Damien -- I think this backports safely to 3.0.2 if you don't have a 
copy of trunk available.

Paolo

2008-04-01  Paolo Bonzini  <address@hidden>

        * kernel/CFuncs.st: Change numFixedArgs to tag.  Add Smalltalk
        counterpart of classify_type_symbol.  Add setters.  Improve #printOn:.
        * kernel/CompildMeth.st: Extract creation of C call-out methods
        to new constructor methods on the class side.

        * libgst/cint.c: Don't use numFixedArgs instance variable of
        a CFunctionDescriptor.  Add classOOP parameters to _gst_make_descriptor.
        Return NULL if there is a problem instead of printing an error.
        * libgst/cint.h: Rename numFixedArgs field of gst_cfunc_descriptor
        to tagOOP.  Adjust prototype of _gst_make_descriptor.
        * libgst/dict.c Rename numFixedArgs variable to tag here too.
        * libgst/prims.def: Create subclasses of CFunctionDescriptor
        if VMpr_CFuncDescriptor_create is sent to a subclass.  Fail
        if _gst_make_descriptor returns NULL.
 
diff --git a/NEWS b/NEWS
index 5ef1438..925693b 100644
--- a/NEWS
+++ b/NEWS
@@ -33,6 +33,15 @@ o   If possible, the installation is made relocatable.  To 
this end,
     will be disabled and the program will look for its files only in
     the configured prefix.
 
+o   It is possible to create CFunctionDescriptors that are not attached
+    to a function that the VM knows about, simply by passing a CObject
+    to CFunctionDescriptor>>#for:returning:withArgs:.  The address
+    however is reset to "nil" on image restart and it is up to the
+    user to reinitialize it.  To aid in this, since CFunctionDescriptor
+    subclasses cannot add instance variables, a subclass can add
+    more info in the new "tag" instance variable of CFunctionDescriptor,
+    which is unused by the VM.
+
 o   The semantics of #on:do: were changed: executing off the end of an
     exception handler will always return from the associated #on:do:.
     Older versions of GNU Smalltalk either returned or resumed depending
diff --git a/kernel/CFuncs.st b/kernel/CFuncs.st
index 991fb75..f8a7eed 100644
--- a/kernel/CFuncs.st
+++ b/kernel/CFuncs.st
@@ -33,7 +33,7 @@
 
 
 Object subclass: CFunctionDescriptor [
-    | cFunction cFunctionName returnType numFixedArgs |
+    | cFunction cFunctionName returnType tag |
     
     <shape: #pointer>
     <category: 'Language-C interface'>
@@ -42,12 +42,52 @@ about C functions that can be called from within Smalltalk, 
such as number
 and type of parameters.  This information is used by the C callout mechanism
 to perform the actual call-out to C routines.'>
 
-    CFunctionDescriptor class >> for: funcNameString returning: 
returnTypeSymbol withArgs: argsArray [
-       "Private - Answer a CFunctionDescriptor"
+    CFunctionDescriptor class >> mapType: aSymbol [
+       "Private - Map a Smalltalk symbols representing a C type to an integer."
+
+       <category: 'private - instance creation'>
+       aSymbol isSymbol ifFalse: [
+           SystemExceptions.WrongClass signalOn: aSymbol mustBe: Symbol ].
+
+       ^(#(#char #uchar #short #ushort #long #ulong #float #double
+           #string #smalltalk #int #uint #longDouble #unknown #stringOut
+           #symbol #byteArray #byteArrayOut #boolean #void #variadic
+           #variadicSmalltalk #cObject #cObjectPtr #self #selfSmalltalk
+           #wchar #wstring #wstringOut #symbolOut)
+               indexOf: aSymbol
+               ifAbsent: [ self error: 'invalid C argument type ', aSymbol 
storeString ]) - 1
+    ]
+
+    CFunctionDescriptor class >> mapReturnType: aSymbolOrType [
+       "We cannot use polymorphism here or we crash the VM..."
+
+       <category: 'private - instance creation'>
+       aSymbolOrType isSymbol ifTrue: [ ^self mapType: aSymbolOrType ].
+       (aSymbolOrType isKindOf: CType) ifTrue: [ ^aSymbolOrType ].
+        SystemExceptions.WrongClass signalOn: aSymbolOrType
+            mustBe: #(#{Symbol} #{CType})  
+    ]
+
+    CFunctionDescriptor class >> for: funcNameOrAddress returning: 
returnTypeSymbol withArgs: argsArray [
+       "Answer a CFunctionDescriptor with the given function name, return type
+        and arguments.  If funcNameOrAddress is a String, GNU Smalltalk will 
try
+        to relink it at the next startup.  If it is a CObject, the address will
+        be reset to nil upon image save (and it's the user's task to figure out
+        a why to reinitialize it!)"
 
        <category: 'instance creation'>
+       | result |
        <primitive: VMpr_CFuncDescriptor_create>
-       ^self primitiveFailed
+
+       "As a side effect, this returns a nice error message."
+       result := self new: argsArray size.
+       result returnType: (self mapReturnType: returnTypeSymbol).
+       argsArray keysAndValuesDo: [ :i :each | 
+           result at: i put: (self mapType: each) ].
+
+       funcNameOrAddress isString ifTrue: [ self primitiveFailed ].
+       result address: funcNameOrAddress.
+       ^result
     ]
 
     CFunctionDescriptor class >> addressOf: function [
@@ -96,6 +136,27 @@ to perform the actual call-out to C routines.'>
        ^cFunctionName
     ]
 
+    returnType: anInteger [
+       <category: 'private - instance creation'>
+        returnType := anInteger
+    ]
+
+    tag [
+       "Answer an arbitrary object that can be used to store extra information
+        (subclasses cannot add more instance variables)."
+
+       <category: 'accessing'>
+        ^tag
+    ]
+    
+    tag: anObject [
+       "Set the receiver's tag, an arbitrary object that can be used to store
+        extra information (subclasses cannot add more instance variables)."
+
+       <category: 'private - instance creation'>
+        tag := anObject
+    ]
+    
     isValid [
        "Answer whether the function represented by the receiver is actually
         a registered one"
@@ -114,11 +175,15 @@ to perform the actual call-out to C routines.'>
        <category: 'printing'>
        aStream
            print: self class;
-           nextPut: $(;
-           nextPutAll: self name;
-           nextPutAll: ' @ ';
-           nextPutAll: (self address address printStringRadix: 16);
-           nextPut: $)
+           nextPut: $(.
+
+       self name isNil ifFalse: [ aStream nextPutAll: self name ].
+       self address isNil ifFalse: [
+           self name isNil ifFalse: [ aStream nextPutAll: ' @ ' ].
+           aStream nextPutAll: (self address address printStringRadix: 16)
+       ].
+
+       aStream nextPut: $)
     ]
 
     asyncCall [
diff --git a/kernel/CompildMeth.st b/kernel/CompildMeth.st
index 211dc23..284d81b 100644
--- a/kernel/CompildMeth.st
+++ b/kernel/CompildMeth.st
@@ -91,6 +91,71 @@ instances.'>
            header: (6 bitShift: 27) + args literals: #()
     ]
 
+    CompiledMethod class >> cCall: func returning: returnType args: argsArray 
+       numArgs: numArgs attributes: attributesArray [
+       "Return a CompiledMethod corresponding to a #cCall:returning:args:
+       pragma with the given arguments."
+       <category: 'c call-outs'>
+       | descr literals bytecodes returnCType |
+       (CFunctionDescriptor isFunction: func) 
+           ifFalse: [^'C function not defined '].
+
+       returnCType := (returnType isSymbol or: [returnType isKindOf: CType]) 
+                   ifTrue: [returnType]
+                   ifFalse: [CType from: returnType].
+       descr := CFunctionDescriptor 
+                   for: func
+                   returning: returnCType
+                   withArgs: argsArray.
+
+       "One of these:
+        descr callInto: nil. ^self
+        ^(descr callInto: ValueHolder now) value
+        ^(descr callInto: ValueHolder now) value narrow"
+       returnType == #void 
+           ifTrue: 
+               [literals := {descr}.
+               bytecodes := #[179 1 45 0 30 34 66 0]]
+           ifFalse: 
+               [literals := {descr.  #{ValueHolder}}.
+               bytecodes := (returnCType isKindOf: CType) 
+                           ifTrue: [#[179 1 34 1 30 84 30 34 22 0 30 35 51 0]]
+                           ifFalse: [#[179 1 34 1 30 84 30 34 22 0 51 0]]].
+       ^self
+           literals: literals
+           numArgs: numArgs
+           numTemps: 0
+           attributes: attributesArray
+           bytecodes: bytecodes
+           depth: numArgs + 4
+    ]
+
+    CompiledMethod class >> asyncCCall: func args: argsArray 
+       numArgs: numArgs attributes: attributesArray [
+       "Return a CompiledMethod corresponding to a #asyncCCall:args:
+       pragma with the given arguments."
+
+       <category: 'c call-outs'>
+       | descr literals bytecodes |
+       (CFunctionDescriptor isFunction: func) 
+           ifFalse: [^'C function not defined '].
+       descr := CFunctionDescriptor 
+                   for: func
+                   returning: #void
+                   withArgs: argsArray.
+
+       "descr asyncCall. ^self"
+       literals := {descr.  #asyncCall}.
+       bytecodes := #[179 1 65 1 66 0].
+       ^self 
+           literals: literals
+           numArgs: numArgs
+           numTemps: 0
+           attributes: attributesArray
+           bytecodes: bytecodes
+           depth: numArgs + 3.
+    ]
+
     CompiledMethod class >> stripSourceCode [
        "Remove all the references to method source code from the system"
 
@@ -649,40 +714,14 @@ instances.'>
 
     rewriteAsCCall: func returning: returnType args: argsArray [
        <category: 'c call-outs'>
-       | descr literals bytecodes newMethod returnCType |
+       | newMethod |
        self isValidCCall ifFalse: [^'C call-out not empty'].
-       (CFunctionDescriptor isFunction: func) 
-           ifFalse: [^'C function not defined '].
-       returnCType := (returnType isSymbol or: [returnType isKindOf: CType]) 
-                   ifTrue: [returnType]
-                   ifFalse: [CType from: returnType].
-       descr := CFunctionDescriptor 
-                   for: func
-                   returning: returnCType
-                   withArgs: argsArray.
-
-       "One of these:
-        descr callInto: nil. ^self
-        ^(descr callInto: ValueHolder now) value
-        ^(descr callInto: ValueHolder now) value narrow"
-       returnType == #void 
-           ifTrue: 
-               [literals := {descr}.
-               bytecodes := #[179 1 45 0 30 34 66 0]]
-           ifFalse: 
-               [literals := 
-                       {descr.
-                       #{ValueHolder}}.
-               bytecodes := (returnCType isKindOf: CType) 
-                           ifTrue: [#[179 1 34 1 30 84 30 34 22 0 30 35 51 0]]
-                           ifFalse: [#[179 1 34 1 30 84 30 34 22 0 51 0]]].
-       newMethod := CompiledMethod 
-                   literals: literals
-                   numArgs: self numArgs
-                   numTemps: self numTemps
-                   attributes: self attributes
-                   bytecodes: bytecodes
-                   depth: self numArgs + 4.
+       newMethod := CompiledMethod
+           cCall: func
+           returning: returnType
+           args: argsArray
+           numArgs: self numArgs
+           attributes: self attributes.
        newMethod descriptor: self descriptor.
        self become: newMethod.
        ^nil
@@ -690,27 +729,13 @@ instances.'>
 
     rewriteAsAsyncCCall: func args: argsArray [
        <category: 'c call-outs'>
-       | descr literals bytecodes newMethod |
+       | newMethod |
        self isValidCCall ifFalse: [^'C call-out not empty'].
-       (CFunctionDescriptor isFunction: func) 
-           ifFalse: [^'C function not defined '].
-       descr := CFunctionDescriptor 
-                   for: func
-                   returning: #void
-                   withArgs: argsArray.
-
-       "descr asyncCall. ^self"
-       literals := 
-               {descr.
-               #asyncCall}.
-       bytecodes := #[179 1 65 1 66 0].
-       newMethod := CompiledMethod 
-                   literals: literals
-                   numArgs: self numArgs
-                   numTemps: self numTemps
-                   attributes: self attributes
-                   bytecodes: bytecodes
-                   depth: self numArgs + 3.
+       newMethod := CompiledMethod
+           asyncCCall: func
+           args: argsArray
+           numArgs: self numArgs
+           attributes: self attributes.
        newMethod descriptor: self descriptor.
        self become: newMethod.
        ^nil
diff --git a/libgst/cint.c b/libgst/cint.c
index 1ad6e5a..2f7bfc0 100644
--- a/libgst/cint.c
+++ b/libgst/cint.c
@@ -675,7 +675,7 @@ _gst_invoke_croutine (OOP cFuncOOP,
   if (!c_func_cur)
     return (NULL);
 
-  fixedArgs = TO_INT (desc->numFixedArgs);
+  fixedArgs = NUM_INDEXABLE_FIELDS (cFuncOOP);
   totalArgs = 0;
   for (si = i = 0; i < fixedArgs; i++)
     {
@@ -1218,7 +1218,8 @@ bad_type (OOP class_oop,
 
 
 OOP
-_gst_make_descriptor (OOP funcNameOOP,
+_gst_make_descriptor (OOP classOOP,
+                     OOP funcNameOOP,
                      OOP returnTypeOOP,
                      OOP argsOOP)
 {
@@ -1247,23 +1248,34 @@ _gst_make_descriptor (OOP funcNameOOP,
   INC_ADD_OOP (cFunction);
 
   cFunctionName = _gst_string_new (funcName);
+  xfree (funcName);
   INC_ADD_OOP (cFunctionName);
 
-  desc = (gst_cfunc_descriptor)
-    new_instance_with (_gst_c_func_descriptor_class, numArgs,
-                      &descOOP);
+  desc = (gst_cfunc_descriptor) new_instance_with (classOOP, numArgs, 
&descOOP);
 
   desc->cFunction = cFunction;
   desc->cFunctionName = cFunctionName;
-  desc->numFixedArgs = FROM_INT (numArgs);
+  desc->tagOOP = _gst_nil_oop;
   desc->returnType = classify_type_symbol (returnTypeOOP, true);
+  if (desc->returnType == _gst_nil_oop)
+    goto error;
+
   for (i = 1; i <= numArgs; i++)
-    desc->argTypes[i - 1] =
-      classify_type_symbol (ARRAY_AT (argsOOP, i), false);
+    {
+      OOP type;
+      type = desc->argTypes[i - 1] =
+        classify_type_symbol (ARRAY_AT (argsOOP, i), false);
+      if (type == _gst_nil_oop)
+       goto error;
+    }
 
-  xfree (funcName);
   INC_RESTORE_POINTER (incPtr);
   return (descOOP);
+
+ error:
+  INC_RESTORE_POINTER (incPtr);
+  return (NULL);
+
 }
 
 OOP
@@ -1271,8 +1283,6 @@ classify_type_symbol (OOP symbolOOP,
                      mst_Boolean isReturn)
 {
   const symbol_type_map *sp;
-  char *symbolName;
-
   for (sp = type_map; sp->symbol != NULL; sp++)
     {
       if (*sp->symbol == symbolOOP)
@@ -1285,14 +1295,7 @@ classify_type_symbol (OOP symbolOOP,
        return (symbolOOP);     /* this is the type we want! */
     }
 
-  symbolName = _gst_to_cstring (symbolOOP);    /* yeah, yeah...but
-                                                  they have the same
-                                                  representation! */
-  _gst_errorf ("Unknown data type symbol: %s", symbolName);
-
-  xfree (symbolName);
-
-  return (FROM_INT (CDATA_UNKNOWN));
+  return _gst_nil_oop;
 }
 
 void
diff --git a/libgst/cint.h b/libgst/cint.h
index 7dfa1fd..09bed43 100644
--- a/libgst/cint.h
+++ b/libgst/cint.h
@@ -113,12 +113,8 @@ typedef struct gst_cfunc_descriptor
                                    addr */ 
   OOP cFunctionName;            /* Name of C function in mapping table */
   OOP returnType;               /* Smalltalk return type */
-  OOP numFixedArgs;             /* number of real arguments passed from
-                                   smalltalk (excluding "self" parameters
-                                   which are synthetically added when 
-                                   calling the C function).  */
-  OOP argTypes[1];              /* variable length, really numFixedArgs
-                                   long */
+  OOP tagOOP;
+  OOP argTypes[1];              /* variable length.  */
 }
  *gst_cfunc_descriptor;
 
@@ -146,13 +142,14 @@ extern void _gst_define_cfunc (const char *funcName, PTR 
funcAddr)
 extern void _gst_init_cfuncs (void) 
   ATTRIBUTE_HIDDEN;
 
-/* Makes a C based descriptor for a callout method.  Returns a
-   gst_cfunc_descriptor object which holds onto the descriptor.  This
-   descriptor is subsequently used when the called out function
-   FUNCNAMEOOP (a Smalltalk String) is invoked. RETURNOOP is a Symbol
-   or CType which indicates the return type and ARGSOOP is a Smalltalk
-   Array containing the argument types (as Symbols).  */
-extern OOP _gst_make_descriptor (OOP funcNameOOP,
+/* Makes a CFunctionDescriptor (the actual class is in CLASSOOP) for a
+   callout method.  Returns a gst_cfunc_descriptor object which holds onto
+   the descriptor.  This descriptor is subsequently used when the called
+   out function FUNCNAMEOOP (a Smalltalk String) is invoked. RETURNOOP
+   is a Symbol or CType which indicates the return type and ARGSOOP is
+   a Smalltalk Array containing the argument types (as Symbols).  */
+extern OOP _gst_make_descriptor (OOP classOOP,
+                                OOP funcNameOOP,
                                 OOP returnTypeOOP,
                                 OOP argsOOP) 
   ATTRIBUTE_HIDDEN;
diff --git a/libgst/dict.c b/libgst/dict.c
index 6600b1b..cc0c7b1 100644
--- a/libgst/dict.c
+++ b/libgst/dict.c
@@ -717,7 +717,7 @@ static const class_definition class_info[] = {
   {&_gst_c_func_descriptor_class, &_gst_object_class,
    ISP_POINTER, true, 4,
    "CFunctionDescriptor",
-   "cFunction cFunctionName returnType numFixedArgs",
+   "cFunction cFunctionName returnType tag",
    NULL, NULL },
 
   {&_gst_memory_class, &_gst_object_class,
diff --git a/libgst/prims.def b/libgst/prims.def
index 714c028..ce9aca8 100644
--- a/libgst/prims.def
+++ b/libgst/prims.def
@@ -5017,6 +5017,7 @@ primitive VMpr_CFuncDescriptor_create [succeed,fail]
   oop4 = STACK_AT (0);
   oop3 = STACK_AT (1);
   oop2 = STACK_AT (2);
+  oop1 = STACK_AT (3);
 
   if (IS_CLASS (oop2, _gst_string_class)
       && (IS_CLASS (oop3, _gst_symbol_class)
@@ -5024,13 +5025,16 @@ primitive VMpr_CFuncDescriptor_create [succeed,fail]
       && (IS_CLASS (oop4, _gst_array_class)
          || IS_CLASS (oop4, _gst_undefined_object_class)))
     {
-      OOP cFuncDescrOOP = _gst_make_descriptor (oop2, oop3, oop4);
-      POP_N_OOPS (3);
-      SET_STACKTOP (cFuncDescrOOP);
-      PRIM_SUCCEEDED;
+      OOP cFuncDescrOOP = _gst_make_descriptor (oop1, oop2, oop3, oop4);
+      if (cFuncDescrOOP)
+       {
+         POP_N_OOPS (3);
+         SET_STACKTOP (cFuncDescrOOP);
+         PRIM_SUCCEEDED;
+       }
     }
-  else
-    PRIM_FAILED;
+
+  PRIM_FAILED;
 }
 
 /* Object snapshot: aString */