add thread support

Author: evilbinary

packages/cffi/cffi.ss

@@ -48,9 +48,9 @@
    cffi-alloc
    cffi-free
    cffi-log
-
+   cffi-thread
    )
-  (import  (scheme) (utils libutil) (utils macro) )
+  (import  (scheme) (utils libutil) (utils macro) (thread scm-ffi) )
 
   (define FFI_DEFAULT_ABI  2)
 
@@ -84,9 +84,13 @@
 
 
   (define cffi-enable-log #f)
+  (define cffi-enable-thread (threaded?))
   (define (cffi-log t)
-    (set! cffi-enable-log t)
-    )
+    (set! cffi-enable-log t))
+  
+  (define (cffi-thread t)
+    (set! cffi-enable-thread t))
+  
 
 
   (define lib-name
@@ -116,7 +120,7 @@
   ;;(define $ffi-free (lambda (addr)
   ;;(display (format "addr=~x\n" addr))))
 
-  
+
   (define (ffi-cif-alloc $ffi-alloc-list)
     (let ((m ($ffi-cif-alloc)))
       (set! $ffi-alloc-list(append! $ffi-alloc-list (list m) ))
@@ -250,6 +254,7 @@
 
 
 
+  
   (define ffi-dlsym (foreign-procedure "ffi_dlsym" (void*  string) void*))
   (define ffi-dlopen (foreign-procedure "ffi_dlopen" (string int ) void*))
   (define ffi-dlerror (foreign-procedure "ffi_dlerror" ( ) string ))
@@ -332,8 +337,6 @@
 	    ))
       )
     )
-
-
 
   ;;(name1 name2 name3)
   ;;(type1 type2 type3)
@@ -714,6 +717,10 @@
 
     )
 
+
+ 
+  
+
   ;;ffi call
   (define (cffi-call sym arg-type ret-type args )    
     (if cffi-enable-log
@@ -739,23 +746,30 @@
       ;;(display (format "ffi-prep-cif len=~a  cret-type=~a carg-type=~a\n" (length arg-type) cret-type carg-type) )
       ;;(display (test-float cif FFI_DEFAULT_ABI  cret-type carg-type cargs) )
       ;;init cif
+     
       (if (= FFI_OK (ffi-prep-cif cif FFI_DEFAULT_ABI (length arg-type) cret-type carg-type ) )
 	  (begin
 	    ;;(printf "fptr=~a \n" fptr)
 	    (if (> fptr 0)
-		(begin 
+		(begin
+		  (if cffi-enable-thread
+		      (deactivate-thread))
 		  ;;(display (format "ffi-call cret=~x cargs=~x\n" cret cargs ))
-		  (ffi-call cif fptr cret cargs)  
+		  (ffi-call cif fptr cret cargs)
+		  (if cffi-enable-thread
+		      (activate-thread))
 		  )
 		(display (format "cannot find symbol ~a\n" sym ))
                 ))
 	  (error 'cffi (format "ffi-prep-cif return error\n"))
 	  )
+   
       ;;(display (format "cret=~x\n" cret))
       (if (procedure? call-ret)
 	  (set! ret-val (call-ret cret))
 	  )
       (ffi-free-all alloc-list)
+      
       (if cffi-enable-log
 	  (display (format "ffi-call ret=~x\n" ret-val)))
       ret-val

packages/thread/scm-ffi.ss

@@ -0,0 +1,49 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;作者:evilbinary on 2017-06-10 23:49:57.
+;;邮箱:rootdebug@163.com
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(library (thread scm-ffi) 
+  (export 
+   activate-thread
+   deactivate-thread
+   slock-object
+   sunlock-object
+  )
+
+ (import (scheme) (utils libutil) )
+
+ (define lib-name
+  (case (machine-type)
+   ((arm32le) "libscm.so")
+   ((a6nt i3nt ta6nt ti3nt) "libscm.dll")
+   ((a6osx i3osx ta6osx ti3osx)  "libscm.so")
+   ((a6le i3le ta6le ti3le) "libscm.so")))
+ (define lib (load-lib  lib-name ))
+
+ ;; (def-function activate-thread "Sactivate_thread"
+ ;;   (void) int)
+
+ ;;  (def-function deactivate-thread "Sdeactivate_thread"
+ ;;   (void) void)
+
+
+    (define activate-thread
+      (foreign-procedure "Sactivate_thread"
+			 () int))
+
+    (define deactivate-thread
+      (foreign-procedure "Sdeactivate_thread"
+			 () void))
+  
+    (define slock-object
+      (foreign-procedure "Slock_object"
+			 () void))
+
+    (define sunlock-object
+      (foreign-procedure"Sunlock_object"
+			() void))
+
+
+  
+  
+ )