Hi Chickeneers,
yesterday I found that simply having a (use mailbox) in some code had a
huge impact (more than a factor of 3) at the performance of the
resulting executable. Without using the mailbox stuff at all.
Meanwhile I figured out that this has nothing at all to do with the
mailbox egg. But _all_ with the use of srfi-1.
But how is this possible?
Attached some test code. As I ran into it from mailbox I prepared a
stripped down version of it to play with. Towards the end of the file
there is a (use srfi-1) which makes all the difference.
So far I found (compiling the code with -O5 but similar things happen
with less aggressive optimization):
a) Using chicken 4.9.1 there is absolutely no difference. Using srfi-1
or not I get roughly 100 messages passed per ms on my machine. (But I
have to include the forced gc; see comment in the code.)
b) A slightly different version which avoids allocations in the queue
runs without the forced gc and yields about 160 ms^-1 on chicken 4.9.1
Again no difference whether or not I (use srfi-1) anywhere.
Now the interesting bits:
c) On master (built almost two weeks ago) I get - when (use srfi-1) is
included - about 180 ms^-1. Those ~5% faster sound about right to me.
d) Comment out the (use srfi-1) at line 163 and it goes down to about
_50_ per millisecond!
e) The same happens for the alternative, allocation free version (not
attached), which uses vectors instead of pairs.
Speculating: The code I wrote has nothing to do with the difference.
But I'm confused. Neither scheduler.scm nor srfi-18 seem to have any
dependency on srfi-1. Also srfi-1 seems not to overwrite any global
bindings.
Should we simply always (use srfi-1) if we also (use srfi-18). Looks
like a workaround, but not like the right thing to do.
How could I boil this down to the real reason?
Best
/Jörg
(declare
;;(unit mailbox)
;; requirements
(disable-interrupts)
;; promises
(strict-types)
(usual-integrations)
(no-procedure-checks-for-usual-bindings)
(inline)
(local)
(no-bound-checks)
(no-procedure-checks-for-usual-bindings)
(bound-to-procedure
##sys#schedule
##sys#current-exception-handler)
(always-bound
##sys#current-thread)
)
(module
mailbox3
(
make-mailbox
mailbox?
mailbox-empty?
mailbox-send!
mailbox-receive!
)
(import scheme extras srfi-18)
(import (except chicken add1 sub1))
(: mailbox? (* --> boolean : (struct <mailbox>)))
(define-record-type <mailbox>
(internal-make-mailbox condition head tail pred)
mailbox?
(condition %mailbox-condition)
(head %mailbox-head %mailbox-head-set!)
(tail %mailbox-tail %mailbox-tail-set!)
(pred mailbox-predicate))
(cond-expand
(never
(define-inline (mailbox-condition mb) (%mailbox-condition mb))
(define-inline (mailbox-head mb) (%mailbox-head mb))
(define-inline (mailbox-head-set! mb v) (%mailbox-head-set! mb v))
(define-inline (mailbox-tail mb) (%mailbox-tail mb))
(define-inline (mailbox-tail-set! mb v) (%mailbox-tail-set! mb v)))
(else
(define-inline (mailbox-condition mb) (##sys#slot mb 1))
(define-inline (mailbox-head mb) (##sys#slot mb 2))
(define-inline (mailbox-head-set! mb v) (##sys#setslot mb 2 v))
(define-inline (mailbox-tail mb) (##sys#slot mb 3))
(define-inline (mailbox-tail-set! mb v) (##sys#setslot mb 3 v))
))
(: make-mailbox (* --> (struct <mailbox>)))
(define (make-mailbox name)
(let ((x (cons #f '())))
(internal-make-mailbox
(make-condition-variable name) x x #f)))
(: mailbox-empty? ((struct <mailbox>) --> boolean))
(define (mailbox-empty? mb)
(null? (cdr (mailbox-head mb))))
(: mailbox-number-of-items ((struct <mailbox>) -> fixnum))
(define (mailbox-number-of-items mb)
(length (cdr (mailbox-head mb))))
(define-inline (%dequeue-message mb)
(mailbox-head-set! mb (##sys#slot #;cdr (mailbox-head mb) 1))
(##sys#slot #;car (mailbox-head mb) 0))
(: mailbox-send! ((struct <mailbox>) * -> undefined))
(define (mailbox-send! mailbox obj)
(let ((p (cons obj '())))
(##sys#setslot #;set-cdr! (mailbox-tail mailbox) 1 p)
(mailbox-tail-set! mailbox p))
#;(condition-variable-signal! (mailbox-condition mailbox))
(let ((x (mailbox-condition mailbox))) (if (thread? x) (thread-resume! x)))
)
(: mailbox-receive! ((struct <mailbox>) -> *))
(define (mailbox-receive! mailbox)
;;(dbg "receive-message! ~a ~a ~a" (current-thread) (mailbox-name mailbox) (##sys#slot (mailbox-condition mailbox) 2))
(let loop ()
(if (null? (##sys#slot (mailbox-head mailbox) 1))
(begin
(##sys#setslot mailbox 1 ##sys#current-thread)
(thread-suspend! ##sys#current-thread)
(##sys#setslot mailbox 1 #f)
(loop))
(let ((obj (%dequeue-message mailbox)))
obj))))
) ;; module mailbox
(module
test
(test-run)
(import scheme chicken srfi-18 extras)
(import mailbox3)
;;(include "bench.scm")
;;----------
(define mb (make-mailbox 'm0))
(define turns 1000000)
(define tw
(make-thread
(lambda ()
(do ((i 0 (add1 i)))
((= i turns))
(mailbox-send! mb i)
;; Must be active for my chicken 4.9.1 .
;; Otherwise will run into
;; "[panic] out of memory - heap full while resizing - execution terminated"
;;
;;(if (= (modulo i 1000) 999) (gc #t))
(thread-yield!)
))
'w))
(define tr
(make-thread
(lambda ()
(do ((i 0 (add1 i)))
((= i turns))
(mailbox-receive! mb)
(thread-yield!)
))
'r))
(define (test-run)
(thread-start! tr)
(define t0 (current-milliseconds))
(thread-start! tw)
(thread-join! tr)
(define t1 (current-milliseconds))
(format #t "~a message passings in ~a (~a per ms)\n " turns (- t1 t0) (/ turns (- t1 t0)))
)
;;----------
)
;; !!!!!!!!!!!!!!!!
;; THIS (use srfi-1) is the declaration which makes the effect.
;; Comment out and it runs for me at about
(use srfi-1)
(use srfi-18)
(use extras)
(import test)
(test-run)
_______________________________________________
Chicken-users mailing list
Chicken-users@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-users
