Shadowing pattern identifier (macro bug)

I've been adding SRFIs, 57, 61, 87 and 99, to Sagittarius these days (means I just lost short term goal...). And found the bug (resolved). The bug was one of the longest lasting ones since I've re-written the macro expander. So it might be useful to share for someone who wants to write one macro expander from scratch.

The bug was about renaming pattern identifier. Well, more precisely, not renaming pattern identifier. On Sagittarius, pattern identifiers are preserved means they aren't renamed when syntax-case is compiled. I don't remember why I needed to do this (should've written some comment but at that moment it was as clear as day, of course not anymore...) but if I change to rename it, then test cases, or even test itself, would run. Now, the bug was relating this non-renamed pattern identifier. You can see the issue but I also write the reproducible code here:
(import (rnrs))

(define-syntax foo
  (lambda (x)
    (define (derive-it k s)
      (let loop ((r '()) (s s))
        (syntax-case s ()
          (() (datum->syntax k r))
          (((f a b) rest ...)
           (loop (cons #'(f a b) (cons #'(f a b) r)) #'(rest ...))))))
    (syntax-case x ()
      ((k (foo . bar) ...)
       (with-syntax ((((foo a b) ...)
                      (derive-it #'k #'((foo . bar) ...))))
         #''((foo a b)  ...))))))

(foo (f a b)) ;; -> shoulr return ((foo a b) (foo a b))
The problem is macro expander picked up not only foo of with-syntax but also foo of syntax-case. And bound input forms of these variables don't have the same length so macro expander signaled an error.

There would be 2 solution for this bug.
  1. Rename pattern identifier (not even an option for me since it requires tacking macro expander again...)
  2. Consider shadowing of pattern identifiers.
with-syntax binds pattern identifiers and hides the same identifiers outside of the expression. So it can be considered creating a scope like let or so. Then taking only the top most binding (bound variables are like in environment, so I call it top) wouldn't be a problem, would it? So I took the easy path (#2).

If it's just like this, probably I wouldn't write a blog post. The actual reason why is that how I found this bug. The bug was buried for a long time. I would say it's from the beginning (so ancient) but could also say since 0.5.0 (2 years). It's because the style of writing macros. I usually don't use the same name for pattern identifiers especially if ellipsis is involved. This is easier to debug. Now, when I was porting SRFI-57, I've noticed reference implementation was considerably slow. I think it's because the implementation uses macro generation macro generation macro generation... so on macro (not sure how much macro would be generated though). Unfortunately, Sagittarius' macro expander isn't so fast. Then I've found syntax-case implementation on discussion archive. It was written for MzScheme but not so difficult to port for R6RS. Then faced the bug.

Initially, I've thought this was implementation bug because the syntax-case used at that moment could be different. So I've tested with other implementations and it worked. The error message said pretty close where it happened and dumped most of the information I needed, but just I couldn't see it in first glance. Maybe I don't want to see the fact that there's still macro related bugs...

What I want to say or put a note here is that bugs are found when you step out from your usual way. It'd be there, if I didn't port SRFI-57.It's worth to take a different way to do it.


syntax-case ポコ・ア・ポコ

syntax-caseを解説した日本語の文章というのは極端に少ないらしい。実際Googleで「syntax-case は」(日本語のみを検索する方法を知らないw)と検索しても、(オランダからだからかもしれないが)日本語の解説ページは自分が書いたものが一番上にヒットする。ここは一つ知ったかぶりをしてもう一つ検索結果を汚してもいいだろうと思ったので、syntax-caseの使い方を解説することにした(ここまで前置き)。想定読者はマクロはしってるけどSchemeのマクロはよく分からないという人としている。つまりsyntax-rulesを知らなくてもよい。ただ、マクロ自体は解説しないので、マクロとはなんぞやという疑問はこの記事を読んでも解決しないのであしからず。


(import (except (rnrs) when))

(define-syntax when
  (lambda (x)
    (syntax-case x ()
      ((_ test body1 body* ...)
       #'(if test
             (begin body1 body* ...))))))

(when 'a 'b) ;; -> b
(when #f #f) ;; -> unspecified
(when #f)    ;; -> &syntax

(define-syntax when
  (lambda (x) ;; <- define-syntaxが受け取る手続きが受け取る引数が構文オブジェクト
    (syntax-case x #| <- 第一引数:構文オブジェクト |# () #| >- 第二引数:リテラルリスト |#
      ;; パターンと出力式のリスト
      ;; (パターン 出力式)
      ;; もしくは
      ;; (パターン フェンダー 出力式) [フェンダーについては後述参照]
      ((_ test body1 body* ...)
       #'(if test
             (begin body1 body* ...))))))
(syntax (if test (begin body1 body* ...)))

ヒント: unlessの展開形は(if (not test) (begin body1 body* ...)) のようになるはずである。


*1: コード上に現れるシンボルのこと。ここではクオートされたシンボルと区別するためにこう呼ぶ
(e e* ...)
(1 2 3) ;; OK (これ以上でももちろんよい)
(1)     ;; OK
()      ;; NG
(e* ...)
((e1* ...) e2* ...)
((1 2 3) 4 5 6) ;; OK
(() 4 5 6)      ;; OK
(())            ;; OK
()              ;; NG

(a . d)
(1 . 2) ;; OK
(1 2 3) ;; OK (1 2 3) = (1 . (2 . (3 . ())))
(1)     ;; OK
()      ;; NG
((a . d) ...)
((1 . 2))         ;; OK
(1 2 3)           ;; NG
((1 . 2) (3 . 4)) ;; OK
()                ;; OK

  • 識別子
  • 定数 (文字、文字列、数値及びバイトベクタ)
  • (<パターン> ...)
  • (<パターン> <パターン> ... . <パターン>)
  • (<パターン> ... <パターン> <ellipsis> <パターン> ...)
  • (<パターン> ... <パターン> <ellipsis> <パターン> ... . <パターン>)
  • #(<パターン> ...)
  • #(<パターン> ... <パターン> <ellipsis> <パターン> ...)



出力式は基本的に構文オブジェクトを返す必要がある。大事なことなので二度目である。構文オブジェクトの生成にはsyntax (#')構文とquasisyntax (#`)構文の2種類ある。quasisyntaxquasiquotesyntax版だと思えばよい。使い方は(あれば)次回やることにする(もしくはこちらを参照:Yet Another Syntax-case Explanation )。

(_ test body1 body* ...)
#'(if test (begin body1 body* ...)
(when (zero? a) (display a) (newline) (do-with-a a))
_     = when
test  = (zero? a)
body1 = (display a)
body* = ((newline) (do-with-a a))
*2: 要らない入力に名前を付けたくない場合に重宝する

(if (zero? a) (begin (zero? a) (display a) (newline) (do-with-a a)))


(define-syntax when
  (lambda (x)
    (syntax-case x ()
      ((_ test body1 body* ...)
       (and (boolean? #'test) #'test) ;; testが#tであれば、if式は要らない
       #'(begin body1 body* ...))
      ((_ test body1 body* ...)
       #'(if test
             (begin body1 body* ...))))))




肉体改造部 第三週


  • 体重: 73.7kg (-0.4kg)
  • 体脂肪率: 24.0% (+0.1%)
  • 筋肉率:42.4% (+0.1%)



Dynamic compilation 2

Almost a year ago, I've wrote a post about compiling Scheme code to C. (See: Dynamic compilation (failure)) In the article, I've conclude that Sagittarius' VM is turned like crazy so ordinal C code wasn't match at all or something like that. After a year, I've noticed that there's a possibility that the compiler eliminated the expression and the VM just did some loop.

I'm not totally sure since when I've add code elimination and right now I don't have the version 0.6.2 (I think that's the version I've used) in my environment. So this might be totally bogus. Anyway, back then I used the following code:
(define (fact n)
  (let loop ((m 1) (r 1))
    (if (= m n)
        (* m r)
        (loop (+ m 1) (* m r)))))

(time (dotimes (i 10000) (fact 1000)))
Now, the fact can be marked as transparent or no side effect because it seems it doesn't have any side effect nor consicing. Let me check.
(procedure-transparent? fact)
;; -> #t
The procedure-transparent? is an internal procedure which is used by the compiler to eliminate dead code. So possibility is very high now. OK, let's check the VM instructions of the expression.
(disasm (lambda () (dotimes (i 10000) (fact 1000))))
;; size: 15
;;    0: CONSTI_PUSH(10000)
;;    1: CONSTI_PUSH(0)
;;    2: LREF_PUSH(1)
;;    3: LREF(0)
;;    4: BNGE 2
;;    6: RET
;;    7: LREF_PUSH(0)
;;    8: LREF(1)
;;    9: ADDI(1)
;;   10: PUSH
;;   11: SHIFTJ(2 0)
;;   12: JUMP -11
;;   14: RET
Bingo! There is no procedure call!

Now, I might have some hope to turn up the VM. So prepare the shared object which provides fact. The C code is the following:
#include <sagittarius.h>
#include <sagittarius/extend.h>

static SgObject fact(SgObject *SG_FP, int SG_ARGC, void *data_)
  SgObject m = SG_MAKE_INT(1), r = SG_MAKE_INT(1);
  SgObject n = SG_FP[0];

  while (TRUE) {
    if (Sg_NumEq(m, SG_FP[0])) {
      return Sg_Mul(m, r);
    } else {
      SgObject t1 = Sg_Add(m, SG_MAKE_INT(1));
      SgObject t2 = Sg_Mul(m, r);
      m = t1;
      r = t2;
  return SG_UNDEF;  /* dummy */

static SG_DEFINE_SUBR(fact__STUB, 1, 0, fact, SG_FALSE, NULL);

  SgLibrary *lib = Sg_FindLibrary(SG_INTERN("(fact)"), TRUE);
  Sg_InsertBinding(lib, SG_INTERN("fact"), &fact__STUB);
gcc -lsagittarius fact.c -shared -o fact.so -fPIC -O3
Now, benchmark. I've added set! to prevent the compiler optimisation.
(load-dynamic-library "fact")
(import (time) (sagittarius control) (fact))

(define dummy)

;; Load C implementation first
(print fact)
(time (dotimes (i 10000) (set! dummy (fact 1000))))

;; Scheme implementation
(define (fact n)
  (let loop ((m 1) (r 1))
    (if (= m n)
        (* m r)
        (loop (+ m 1) (* m r)))))

(print fact)
(time (dotimes (i 10000) (set! dummy (fact 1000))))
#<subr fact 1:0>

;;  (dotimes (i 10000) (set! dummy (fact 1000)))
;;  6.604181 real    14.084392 user    0.174243 sys
#<closure fact 1:0>

;;  (dotimes (i 10000) (set! dummy (fact 1000)))
;;  6.698120 real    14.32880 user    0.132117 sys
Well, almost the same. C version is slightly faster. This is, I believe, because it doesn't have VM dispatch. But this is more or less error range.

Even if this had siginificant improvement, I still need to resolve loads of things to native shared object from Scheme code. Such as:
  • Mapping of Scheme procedure and C function
  • Calling Scheme procedure from C
  • Error handling especially unbound variables
  • C compiler detection
  • Etc. (macro, location so on)
In my experience, calling Scheme procedure from C is really slow and it's not call/cc friendly. There's a way to avoid some overhead, such as using CPS, however it'd be still the same or even slower then just running on VM (this is really proven by previous experience, unfortunately). On possible good future would be less consicing similar with the one mentioned unboxing in guile -- wingolog. Though, as long as I need to use CPS, it would most likely no more than trivial improvement.

It seems there's no easy way out for performance improvement. Maybe it's time to give up looking for this path.


肉体改造部 第一週

  • 体重: 74.1kg (-0.6kg)
  • 体脂肪率: 23.9% (-0.4%)
  • 筋肉率: 42.3% (+ 0.1%)


FFI improvements

I wish I could live only in Scheme world when I'm writing Scheme code. The world is not really kind to me so I often need to write C binding with FFI library.

Currently I'm aiming to write a very simple IDE for Windows using the FFI library. Personally, I use Emacs but it's rather not friendly if I'd just say 'install Emacs' for newbies. It might be better to have very first step IDE bundled especially for Windows users. (POSIX like OS users? They aren't really newbie more or less :P)

Writing it using Win32 API basically means bunch of FFI calls or emulating C structure. The latter part is crucial. I need to do load of things what C compiler does, such as byte padding, offset calculation, etc. I think I've done most of them however there were (yet are...) still more to do. One of the missing features was bit field.

I don't remember exactly why I put this aside for such a long time. Most likely I just didn't need it, though. Now it's time to implement (yes I needed it). So define-c-struct can now take bit-field clause like this:
(define-c-struct foo
  (bit-field unsigned-short (a 4) (b 4) (c 4) (d 4)))
Unlike actual C compilers, the bit-clause must have less than or equal to the specified C type. If it overflowed (not sure if I can call it overflow, though), then &assertion is raised. I know this is sometimes very inconvenient and I've already faced the inconvenience. It's more pain in the ass to do like C compilers do than restricting because I don't have the specification of C. So I wasn't sure how I can increase the storage size (well it's guessable).

The bit-field clause can also take endianness like this:
;; big endian
(define-c-struct foo-b
  (bit-field (unsigned-short big) (a 4) (b 4) (c 4) (d 4)))

;; little endian
(define-c-struct foo-l
  (bit-field (unsigned-short little) (a 4) (b 4) (c 4) (d 4)))
This might be convenient if you want to write like this:
;; use big endian structure
(let ((p (allocate-c-struct foo-b))
  (pointer-set-c-uint16! p #x1234)
  (list (foo-a-ref p) (foo-b-ref p) (foo-c-ref p) (foo-d-ref p)))
;; -> (1 2 3 4)

;; use little endian structure
(let ((p (allocate-c-struct foo-l))
  (pointer-set-c-uint16! p #x1234)
  (list (foo-a-ref p) (foo-b-ref p) (foo-c-ref p) (foo-d-ref p)))
;; -> (4 3 2 1)
I haven't tested on real big endian environment, so not sure if the actual pointer values are correct. (Feeling like something is wrong since pointer-set-c-uint16! sets the given value with little endian on my enviromnet. So I need to get big endian environment...)

I've also noticed that it's annoying to define pointer type each time. Say a C function has like this signature:
int foo (const char *s, int *i);
Now, I want to write FFI binding for this. It'd look like this:
(define so (open-shared-library "foo.so"))
;; Can you remember what the second argument's type is after 3 months?
(define foo (c-function so int foo (char* void*)))
I don't like to convert all pointer type except char and wchar_t to void* because of my short memory. So I often do like this:
(define-c-typedef int (* int*))
(define foo (c-function so int foo (char* int*)))
Better, at least I can see what kind of pointer type foo requires. But writing typedef each time is rather annoying. So I changed to accept (type *) style type specifier. Now we can write above like this:
;; char* is predefined so doesn't matter to change, though
(define foo (c-function so int foo ((char *) (int *))))
It's just matter of style how you write it. I thought it's convenient especially if C function requires pointer of structure.

It's not really big changes (or rather trivial) but I believe these small changes would make it better.




(define (foo a b c) (+ a b c))

(foo 1) ;; -> (lambda (b c) (+ 1 b c)) ;; ≶ 1 is given by caller
(let ((foo1 (foo 1))
  ;; foo1 = (lambda (b) (lambda (c) (+ 1 b c)))
  ((foo1 2) 3))
(import (rnrs))

(define-syntax lambda-partial-applicable
  (syntax-rules ()
    ((_ "case" () (arity ...) ((args body) ...) fun)
     (case-lambda (args body) ...))
    ((_ "case" (a arg ...) (arity ...) ((args body) ...) fun)
     (lambda-partial-applicable "case" 
                                (arg ...)
                                (arity ... a)
                                ((args body) ... ((arity ... a) (fun a)))
                                (fun a)))
    ((_ "partial" (arg ...) body)
     (let ((fun body))
       (lambda-partial-applicable "case" (arg ...) () ((() fun)) fun)))

    ((_ "curry" () (arg ...) body)
     (lambda-partial-applicable "partial" (arg ...) body))
    ((_ "curry" (a arg ...) (back ...)  body)
     (lambda-partial-applicable "curry" (arg ...) (a back ...)
                                (lambda (a) body)))

    ((_ "reverse" () (arg ...) (body ...))
     (lambda-partial-applicable "curry" (arg ...) () (begin body ...)))
    ((_ "reverse" (a rest ...) (arg ...) (body ...))
     (lambda-partial-applicable "reverse" (rest ...) (a arg ...) (body ...)))

    ((_ (args ...) body ...)
     (lambda-partial-applicable "reverse" (args ...) () (body ...)))))

(define-syntax define-partial-applicable
  (syntax-rules ()
    ((_ (name args ...) body ...)
     (define name (lambda-partial-applicable (args ...) body ...)))))
(define (print . args) (for-each display args) (newline))
(define-partial-applicable (foo a b) (+ a b))

(let ((&2+ (foo 2)))
   (&2+ 3))
;; -> 5

(define-partial-applicable (bar a b c) (+ a b c))

(bar 2 3 4)
;; -> 9

(let* ((&2+ (bar 2))
       (&2+3+ (&2+ 3)))
  (&2+3+ 4))
;; -> 9





  • 小麦粉 300g
  • 牛乳 250ml
  • ドライイースト 7g
  • 砂糖 1tbsp (15g)
  • 卵 1個
  • 上記の材料を混ぜる
    • しっかり混ぜると、出来上がりがもちもちする
    • 軽く混ぜるとさくっとする
  • 生地を1時間寝かせる(2倍程度に膨らむまで待つ)
  • 油(材料外)を180度に熱する
  •  スプーン(大)を二つ使って一口大程度の生地を掬い上げ、丸めてから揚げる。
    • イーストが入っているので膨らむ
    • あまり大きくするとできあがりが巨大になるので注意
  • 焦げないように注意しつつ、全体的にこんがり揚げる。
  • 竹串をさして何も付かなければ出来上がり



肉体改造部 入部


  • 体重:74.7kg
  • 体脂肪率:24.3% (俺の1/4は脂肪でできている・・・)
  • 筋肉率:42.2% (どれくらい正確なのかは知らん)


  • 腕立て 合計50回程度(潰れるまで)
  • 腹筋 適当に15分くらい
  • スクワット 合計100回くらい
  • その他適当