Named let performance

When I was playing around with Sagittarius compiler, I've found that some of named let expression was compiled to (looks) slow code. Following piece of code is one of them;
(lambda (pred lst)
  (let loop ((lst lst))
    (cond ((null? lst) '())
          ((pred (car lst)) (loop (cdr lst)))
          (else (cons (car lst) (loop (cdr lst)))))))
You can see this type of code anywhere (although it's not tail recursive so I don't like it). And you would expect this not to have any performance issue other than stack consumption because of the recursive call.

Now, I was also thinking like that however things are bit worse. The compiled code describes everything;
;; size: 3
;;    0: CLOSURE #<code-builder #f (2 0 0)>
;;   size: 13
;;      0: UNDEF
;;      1: PUSH
;;      2: BOX(0) !!!! IMPLICIT BOXING !!!!
;;      3: LREF_PUSH(0)
;;      4: LREF_PUSH(2)
;;      5: CLOSURE #<code-builder loop (1 0 2)> !!!! CLOSURE CREATION !!!!
;;     size: 26
;;        0: LREF(0)
;;        1: BNNULL 3                  ; ((null? lst) '())
;;        3: CONST_RET ()
;;        5: FRAME 4
;;        7: LREF_CAR_PUSH(0)
;;        8: FREF(1)
;;        9: CALL(1)
;;       10: TEST 6                    ; ((pred (car lst)) (loop (cdr l ...
;;       12: LREF_CDR_PUSH(0)
;;       13: FREF(0)
;;       14: UNBOX
;;       15: LOCAL_TAIL_CALL(1)
;;       16: RET
;;       17: LREF_CAR_PUSH(0)
;;       18: FRAME 5
;;       20: LREF_CDR_PUSH(0)
;;       21: FREF(0)
;;       22: UNBOX
;;       23: LOCAL_CALL(1)
;;       24: CONS
;;       25: RET
;;      7: LSET(2)
;;      8: LREF_PUSH(1)
;;      9: LREF(2)
;;     10: UNBOX
;;     11: LOCAL_TAIL_CALL(1)
;;     12: RET
;;    2: RET
I've put comments where it causes performance issue.

The first one, implicit boxing, is because the loop is transformed to letrec and it needs to refer loop itself inside of it. The second one is creating a procedure each time the top procedure (I haven't named it though) is called because it has a free variable pred inside. Sounds reasonable? No, it doesn't at all to me now. If you write a piece of code with named let, then you would expect the calling named procedure would be compiled to just a jump. However this is compiled to a procedure call. Well, on the other hand this is not a tail recursive call so you wouldn't expect to be a jump though. Actually if the code was tail recursive then compiler would compile it to a simple jump without implicit boxing and creating a closure.

Now, then should users always be careful or adjust their code how compiler compiles to maximumised performance instructions? My answer is yes and no. In above case, I expect at least compiler should emit non implicit boxing code. In general, compiler should be smart enough to emit good quality code. Then problem is how? ... that's something I need to think, though.



(LISP Library 365参加エントリ)

SRFI-17は一般化したset!です。発案者はKawaの製作者Per Bothner氏ですね。(他のSRFIでも既にGuileやらLarcenyやらの製作者が出ていたのですが、文量の水増しです。)

(set! (car a) 'b) ;; -> (set-car! a 'b)
(set! (cdr a) 'c) ;; -> (set-cdr! a 'b)

(set! (vector-ref v 0) 'a) ;; -> (vector-set! v 0 'a)
(set! (proc args ...) value) 
 ;; -> ((setter proc) args ... value)
例えば、Gaucheでは(set! (car a) 'b))はSRFIのように展開されますが、Sagittariusはset-car!が直接呼ばれるようにコンパイルされます(それがいいかどうかは別の問題ですが)。他の処理系は調べてません。


I have gotten no support for my proposal. While the srfi process allows for srfis that are controversal and don't have consensus, at this stage it seems kind of pointless to pursue it. I have no particular desire to push for something most people dislike, at least in this context. So if anybody out there thinks the generalized set! is a good idea, now is the time to speak up.
この投稿が投げられる前にあったMatthias Felleisen氏が投げた投稿から始まる議論(罵り合い?)がなかなか面白いです。個人的には便利なSRFIだと思っているのですが、Scheme的ではないかもしれませんね。



How to emulate pthread_cond_wait with SRFI-18

I was implementing multi thread queue like Gauche has but in pure Scheme with SRFI-18. Then I've got confused how to wait condition variable. If it's POSIX then you can use pthread_cond_wait. However it's SRFI-18 and it doesn't provide a procedure to wait condition variable directly. Well, in the end there are some example code which explains how to do it but at that moment I couldn't figure it out. So there may be some people who also have the same issue as me. (It's basically because of my lack of knowledge of multi threading and, well, if there aren't at least this could be my memo to remember...)

The answer was a combination of mutex-unlock! and mutex-lock!. I was always thinking that pthread_cond_wait or similar procedure is the only way to wait for a condition variable. I skipped reading this section (and caused my confusion...)
NOTE: mutex-unlock! is related to the "wait" operation on condition variables available in other thread systems. The main difference is that "wait" automatically locks mutex just after the thread is unblocked. This operation is not performed by mutex-unlock! and so must be done by an explicit call to mutex-lock!. This has the advantages that a different timeout and exception handler can be specified on the mutex-lock! and mutex-unlock! and the location of all the mutex operations is clearly apparent. A typical use with a condition variable is:
(I don't complain this is very confusing but don't you think?) So what I needed to do is instead of searching something that specifically says condition-wait! or something, I needed to use mutex-unlock! and mutex-lock!. Following piece of code is more concrete example;
(import (rnrs) (srfi :18))

(define-record-type (<foo> make-foo foo?)
  (fields (immutable mutex foo-mutex)
          (immutable cv    foo-cv)
          (mutable   count foo-count foo-count-set!))
  (protocol (lambda (p)
              (lambda ()
                (p (make-mutex)

;; Utilities for above foo record
(define-syntax lock-foo!
  (syntax-rules ()
    ((_ foo) (mutex-lock! (foo-mutex foo)))))
(define-syntax unlock-foo!
  (syntax-rules ()
    ((_ foo) (mutex-unlock! (foo-mutex foo)))))
(define (with-locking-foo foo thunk)
      (lambda () (lock-foo! foo))
      (lambda () (unlock-foo! foo))))

(define-syntax wait-cv
  (syntax-rules ()
    ((_ foo)
     (let ((r (mutex-unlock! (foo-mutex foo) (foo-cv foo))))
       (display "unlocked! with cv") (newline)
       ;; mutex is not locked so lock it if you need it.
       (mutex-lock! (foo-mutex foo))

(define-syntax notify-foo
  (syntax-rules ()
    ((_ foo)
     (condition-variable-broadcast! (foo-cv foo)))))

(let ()
  (define foo (make-foo))

  (define (producer)
    ;; increment count
    (with-locking-foo foo
     (lambda ()
       (display "Increment count!") (newline)
       (foo-count-set! foo 1)
       (notify-foo foo))))

  (define (consumer)
    ;; wait until the count is one
    (with-locking-foo foo 
     (lambda ()
       (let loop ()
         (cond ((zero? (foo-count foo))
                (display "It's zero need to wait!") (newline)
                (if (wait-cv foo)
                    (error #f "something went wrong")))
               (else (foo-count foo)))))))

  (let ((ct (thread-start! (make-thread consumer)))
        (pt (make-thread producer)))
    ;; consumer is waiting but make sure
    (thread-sleep! 10)
    ;; let producer increment
    (thread-start! pt)
    (thread-join! pt)
    (display (thread-join! ct)) (newline)))

It's zero need to wait!
Increment count!
unlocked! with cv
This just tries to emulate pthread_cond_wait using mutex-unlock! and mutex-lock!. The wait-cv is the emulation macro. notify-foo assumes that given foo
's mutex is locked. It took couple of hours to figure out this simple thing for me...
I haven't met any case that this mutex model is convenient but if this how it is I need to get used to it. (though, my case was just the name confusion...)



(LISP Library 365参加エントリ)


;; because it's very famous I've become a bit lazy
;; so just a bit of taste...
(define foo
    ((c key) (foo c key #f))
    ((c key default) (ref c key default))))
(define (foo c key . rest)
  (let ((default (if (null? rest) #f (car rest))))
    (ref c key default)))
(define foo
  (lambda args
    (let ((l (length args)))
      (if (= l (length '(c key)))
          (apply (lambda (c key) (foo c key #f)) args)
          (if (= l (length '(c key default)))
              (apply (lambda (c key default) (ref c key default)) args)
              (error #f "Wrong number of arguments to CASE-LAMBDA"))))))
これだと多少手間が減る程度の恩恵しかありません。(もちろん処理系によっては引数のパックとapplyが異常なまでに安い処理系もあるかもしれませんが・・・) また、コンパイル時に手続きの呼び出しを行わない処理系だと、lengthの呼び出しが定義された分だけ呼び出されるので精神衛生上あまり好ましくありません。



今回はSRFI-16を紹介しました。RnRS準拠でもっと効率のいい実装があるよ!という方がいらしたらご一報くださいm(_ _)m