Skip to content

Commit 36615ad

Browse files
evilbinaryevilbinary
committed
cffi thread support
1 parent 52f6152 commit 36615ad

1 file changed

Lines changed: 38 additions & 36 deletions

File tree

‎packages/cffi/cffi.ss‎

Lines changed: 38 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -88,7 +88,6 @@
8888
(set! cffi-enable-log t)
8989
)
9090

91-
(define $ffi-alloc-list '() )
9291

9392
(define lib-name
9493
(case (machine-type)
@@ -118,33 +117,33 @@
118117
;;(display (format "addr=~x\n" addr))))
119118

120119

121-
(define (ffi-cif-alloc)
120+
(define (ffi-cif-alloc $ffi-alloc-list)
122121
(let ((m ($ffi-cif-alloc)))
123122
(set! $ffi-alloc-list(append! $ffi-alloc-list (list m) ))
124123
m
125124
)
126125
)
127-
(define (ffi-types-alloc size)
126+
(define (ffi-types-alloc $ffi-alloc-list size)
128127
(let ((m ($ffi-types-alloc size)))
129128
(set! $ffi-alloc-list(append! $ffi-alloc-list (list m) ))
130129
m
131130
)
132131
)
133-
(define (ffi-values-alloc size)
132+
(define (ffi-values-alloc $ffi-alloc-list size)
134133
(let ((m ($ffi-values-alloc size)))
135134
(set! $ffi-alloc-list(append! $ffi-alloc-list (list m) ))
136135
m
137136
)
138137
)
139-
(define (ffi-alloc size)
138+
(define (ffi-alloc $ffi-alloc-list size)
140139
(let ((m ($ffi-alloc size)))
141140
;;(display (format "$ffi-alloc addr=~x\n" m))
142141
(set! $ffi-alloc-list(append! $ffi-alloc-list (list m) ))
143142
m
144143
)
145144
)
146145

147-
(define (ffi-free-all)
146+
(define (ffi-free-all $ffi-alloc-list)
148147
;;(display (format "ffi-free-all=~a\n" (length $ffi-alloc-list)))
149148
(let loop ((l $ffi-alloc-list))
150149
(if (pair? l)
@@ -155,6 +154,7 @@
155154
)
156155
)
157156
)
157+
;;(lock-object $ffi-alloc-list)
158158
(set! $ffi-alloc-list '() )
159159
)
160160

@@ -448,7 +448,7 @@
448448
(let loop ((h handlers))
449449
(if (pair? h)
450450
(let ((sym (ffi-dlsym (car h) name)))
451-
(printf " sym=~a handler=~a name=~a\n" sym (car h ) name)
451+
;;(printf " sym=~a handler=~a name=~a\n" sym (car h ) name)
452452
(if (= sym 0)
453453
(loop (cdr h))
454454
sym))
@@ -522,14 +522,14 @@
522522
#t
523523
)
524524
;;
525-
(define (create-carg-type arg-type)
525+
(define (create-carg-type alloc-list arg-type )
526526
;;(display (format "creat-carg-type arg-type=~a len=~a \n" arg-type (length arg-type) ))
527-
(let ((carg-type (ffi-types-alloc (length arg-type) )))
527+
(let ((carg-type (ffi-types-alloc alloc-list (length arg-type) )))
528528
(let loop ((type arg-type) (i 0))
529529
(if (pair? type)
530530
(begin
531531
;;(display (format " type=~a index=~a \n" (car type) i ))
532-
(ffi-types-set carg-type i (create-cret-type (car type)) )
532+
(ffi-types-set carg-type i (create-cret-type alloc-list (car type)) )
533533

534534
(loop (cdr type) (+ i 1) )
535535
)
@@ -539,18 +539,19 @@
539539
carg-type
540540
)
541541
)
542+
542543

543-
(define (process-struct ret-type)
544+
(define (process-struct alloc-list ret-type)
544545
(let ((ret-struct-val '())
545546
(typelist '() )
546547
(typeelement '() )
547548
(alloc 0)
548549
)
549-
(set! alloc (ffi-alloc (+ 64 16 16 64)))
550+
(set! alloc (ffi-alloc alloc-list (+ 64 16 16 64)))
550551
(set! ret-struct-val ((top-level-value
551552
(string->symbol (format "make-~a" ret-type ) )) ))
552553
(set! typelist (struct-ref ret-struct-val 0) )
553-
(set! typeelement (ffi-alloc (* 64 (+ (length typelist ) 1) ) ))
554+
(set! typeelement (ffi-alloc alloc-list (* 64 (+ (length typelist ) 1) ) ))
554555
(ffi-init-struct alloc 0 0 FFI_TYPE_STRUCT typeelement)
555556
(let loop ((type typelist) (i 0))
556557
(if (pair? type)
@@ -571,7 +572,7 @@
571572
[(string ) (ffi-types-set typeelement i ffi-type-pointer ) ]
572573
[else
573574
;;(display (format " ###$$$else type=~a\n" (car type) ) )
574-
(ffi-types-set typeelement i (process-struct (car type) ) )
575+
(ffi-types-set typeelement i (process-struct alloc-list (car type) ) )
575576
]
576577
)
577578
(loop (cdr type) (+ i 1) )
@@ -584,7 +585,7 @@
584585

585586
)
586587

587-
(define (create-cret-type ret-type)
588+
(define (create-cret-type alloc-list ret-type)
588589
(let ((alloc 0) (ret-struct-val 0) (typeelement 0) (typelist '() ) )
589590
(case ret-type
590591
[(short ) ffi-type-sint16]
@@ -599,11 +600,11 @@
599600
[(void) ffi-type-void ]
600601
[else
601602
;;(display (format " $$$else type=~a\n" ret-type) )
602-
(process-struct ret-type )
603+
(process-struct alloc-list ret-type )
603604
]
604605
)))
605606

606-
(define (create-cret ret-type)
607+
(define (create-cret alloc-list ret-type)
607608
;;(display (format "ret-type-size=~a\n" (cffi-size ret-type) ))
608609
(let ( (ret-fun (lambda (x) x) )
609610
(ret-type-s ret-type )
@@ -630,14 +631,14 @@
630631
)
631632
]
632633
) )
633-
(list (ffi-alloc (cffi-size ret-type-s) ) ret-fun )
634+
(list (ffi-alloc alloc-list (cffi-size ret-type-s) ) ret-fun )
634635

635636
)
636637
)
637638

638-
(define (create-cargs arg-type args carg-type)
639+
(define (create-cargs alloc-list arg-type args carg-type)
639640
;;(display (format "creat-cargs args=~a len=~a carg-type=~a\n" args (length args) carg-type))
640-
(let ((cargs (ffi-values-alloc (length args)))
641+
(let ((cargs (ffi-values-alloc alloc-list (length args)))
641642
(alloc 0)
642643
)
643644
(let loop ((arg args) (type arg-type) (i 0))
@@ -646,31 +647,31 @@
646647
;;(display (format " type=~a value=~a index=~a \n" (car type) (car arg) i ))
647648
(case (car type)
648649
[(ushort)
649-
(set! alloc (ffi-alloc 16) )
650+
(set! alloc (ffi-alloc alloc-list 16) )
650651
(ffi-set-ushort alloc (car arg) )
651652
(ffi-values-set cargs i alloc) ]
652653
[(short)
653-
(set! alloc (ffi-alloc 16) )
654+
(set! alloc (ffi-alloc alloc-list 16) )
654655
(ffi-set-short alloc (car arg) )
655656
(ffi-values-set cargs i alloc) ]
656657
[(uint)
657-
(set! alloc (ffi-alloc 32) )
658+
(set! alloc (ffi-alloc alloc-list 32) )
658659
(ffi-set-uint alloc (car arg) )
659660
(ffi-values-set cargs i alloc) ]
660661
[(int)
661-
(set! alloc (ffi-alloc 32) )
662+
(set! alloc (ffi-alloc alloc-list 32) )
662663
(ffi-set-int alloc (car arg) )
663664
(ffi-values-set cargs i alloc) ]
664665
[(int64 long)
665-
(set! alloc (ffi-alloc 64) )
666+
(set! alloc (ffi-alloc alloc-list 64) )
666667
(ffi-set-long alloc (car arg))
667668
(ffi-values-set cargs i alloc) ]
668669
[(float)
669-
(set! alloc (ffi-alloc 32) )
670+
(set! alloc (ffi-alloc alloc-list 32) )
670671
(ffi-set-float alloc (+ 0.0 (car arg) ))
671672
(ffi-values-set cargs i alloc) ]
672673
[(double)
673-
(set! alloc (ffi-alloc 64) )
674+
(set! alloc (ffi-alloc alloc-list 64) )
674675
(ffi-set-double alloc (+ 0.0 (car arg)))
675676
(ffi-values-set cargs i alloc) ]
676677
[(void)
@@ -680,14 +681,14 @@
680681
1
681682
]
682683
[(string )
683-
(set! alloc (ffi-alloc 64) )
684+
(set! alloc (ffi-alloc alloc-list 64) )
684685
(if (number? (car arg))
685686
(ffi-set-pointer alloc (car arg))
686687
(ffi-set-string alloc (car arg))
687688
)
688689
(ffi-values-set cargs i alloc) ]
689690
[(void* )
690-
(set! alloc (ffi-alloc 64) )
691+
(set! alloc (ffi-alloc alloc-list 64) )
691692
(if (string? (car arg))
692693
(ffi-set-string alloc (car arg))
693694
(ffi-set-pointer alloc (car arg)))
@@ -696,7 +697,7 @@
696697
(ffi-values-set cargs i alloc) ]
697698
[else
698699
;(display (format " %%%else type=~a size=~a \n" (car type) (cffi-size (struct-ref (car arg) 1) ) ) )
699-
(set! alloc (ffi-alloc (cffi-size (struct-ref (car arg) 1) )) )
700+
(set! alloc (ffi-alloc alloc-list (cffi-size (struct-ref (car arg) 1) )) )
700701
(lisp2struct (car arg) alloc)
701702
(ffi-values-set cargs i alloc)
702703
]
@@ -719,13 +720,14 @@
719720
(begin
720721
(display "\n")(display (format "cffi-call ~a arg-type=~a ret-type=~a args=~a \n" sym arg-type ret-type args) ) ) )
721722
(let* (
722-
(carg-type (create-carg-type arg-type) )
723-
(cret-type (create-cret-type ret-type) )
724-
(cargs (create-cargs arg-type args carg-type) )
723+
(alloc-list '())
724+
(carg-type (create-carg-type alloc-list arg-type) )
725+
(cret-type (create-cret-type alloc-list ret-type) )
726+
(cargs (create-cargs alloc-list arg-type args carg-type) )
725727

726-
(cret-info (create-cret ret-type) )
728+
(cret-info (create-cret alloc-list ret-type) )
727729
(cret '() )
728-
(cif (ffi-cif-alloc) )
730+
(cif (ffi-cif-alloc alloc-list) )
729731
(fptr (cffi-sym sym ))
730732
(call-ret '() )
731733
(ret-val '() )
@@ -753,7 +755,7 @@
753755
(if (procedure? call-ret)
754756
(set! ret-val (call-ret cret))
755757
)
756-
(ffi-free-all)
758+
(ffi-free-all alloc-list)
757759
(if cffi-enable-log
758760
(display (format "ffi-call ret=~x\n" ret-val)))
759761
ret-val

0 commit comments

Comments
 (0)