#:g1

CLでsrfi-46

Posted 2012-05-26 07:49:00 GMT

CLでsrfi、今回は、srfi-46の「Basic Syntax-rules Extensions」です。
syntax-rulesのellipsisの拡張で、繰り返しの記法が拡張されているのと、ユーザー定義のものが利用できるようになっています。

動作

(define-syntax fake-begin
  (syntax-rules ()
    ((fake-begin ?body *** ?tail)
     (srfi-46.internal::let* ((ignored ?body) ***) ?tail))))

(fake-begin (princ "hello,") (write-char #\space) (princ "world!") (terpri))

;==> (FUNCALL (LAMBDA (#:_IGNORED_48) (FUNCALL (LAMBDA (#:_IGNORED_49) (FUNCALL (LAMBDA (#:_IGNORED_50) (FUNCALL (LAMBDA () (TERPRI)))) (PRINC "world!"))) (WRITE-CHAR #\ ))) (PRINC "hello,")) ;>> hello, world! ;>> ;=> NIL

;;; Examples of the user-specified ellipsis token extension

;;; Utility macro for CPS macros (define-syntax apply-syntactic-continuation (syntax-rules () ((apply-syntactic-continuation (?k ?env ***) . ?args) (?k ?env *** . ?args))))

;;; Generates a list of temporaries, for example to implement LETREC ;;; (see below), and 'returns' it by CPS. (define-syntax generate-temporaries (syntax-rules () ((generate-temporaries ?origs ?k) (letrec-syntax ((aux (syntax-rules %%% () ;; We use a trick here: pass the continuation again ;; to AUX in case it contains ellipsis. If we stuck ;; it right into AUX's template, AUX would process the ;; ellipsis in ?K as ellipsis for something in the AUX ;; macro. ((aux ?temps () ?k*) (apply-syntactic-continuation ?k* ?temps)) ;; Be careful about the ellipsis! ((aux (?temp %%%) (?x ?more %%%) ?k*) (aux (?temp %%% new-temp) (?more %%%) ?k*))))) (aux () ?origs ?k)))))

(define-syntax test-letrec (syntax-rules () ((letrec ((?var ?init) ***) ?body1 ?body2 ***) (let-syntax ((k (syntax-rules %%% () ;; Use the same trick as with the continuations in ;; GENERATE-TEMPORARIES. Be careful about the ellipsis! ((k ((?var* ?init*) %%%) (?body1* ?body2* %%%) ;; Here are the actual arguments to the continuation ;; -- the previous bits of the pattern were just the ;; 'environment' of the continuation --: (?temp %%%)) (rnrs:let ((?var* '#:|unspecific|) ; Get an 'unspecific' value. %%%) (rnrs:let ((?temp ?init*) %%%) (rnrs:set! ?var* ?temp) %%% (rnrs:let () ?body1* ?body2* %%%))))))) (generate-temporaries (?var ***) ;; Pass K the environment. GENERATE-TEMPORARIES will add the ;; temporary variable list argument. (k ((?var ?init) ***) (?body1 ?body2 ***)))))))

(test-letrec ((fib (lambda (n) (if (< n 2) (funcall fib1 n) (+ (funcall fib (- n 1)) (funcall fib (- n 2)) )))) (fib1 (lambda (x) x)) ) (funcall fib 10) ) ;==> (FUNCALL (LAMBDA (#:_FIB_50 #:_FIB1_51) (FUNCALL (LAMBDA (#:_NEW-TEMP_52 #:_NEW-TEMP_53) (PROGN (SETQ #:_FIB_50 #:_NEW-TEMP_52) (SETQ #:_FIB1_51 #:_NEW-TEMP_53) (FUNCALL (LAMBDA () (FUNCALL #:_FIB_50 10))))) (LAMBDA (N) (IF (< N 2) (FUNCALL #:_FIB1_51 N) (+ (FUNCALL #:_FIB_50 (- N 1)) (FUNCALL #:_FIB_50 (- N 2))))) (LAMBDA (X) X))) '#:|unspecific| '#:|unspecific|) ;=> 55

(let-syntax ((foo (syntax-rules %%%0 () ((_ a %%%0) (let-syntax ((bar (syntax-rules %%%1 () ((_ b %%%1) (list :bar-expanded b %%%1 a %%%0))))) (bar :b1 :b2)))))) (foo 1 2 3)) ;=> (:BAR-EXPANDED :B1 :B2 1 2 3)

;;; This example demonstrates the hygienic renaming of the ellipsis ;;; identifiers.

(let-syntax ((f (syntax-rules () ((f ?e) (let-syntax ((g (syntax-rules %%% () ((g (??x ?e) (??y %%%)) '((??x) ?e (??y) %%%) )))) (g (1 2) (3 4)) ))))) (f %%%) ) ;=> ((1) 2 (3) (4))

移植について

ややこしそうなので移植は無理かなと思っていましたが、思いの外すんなり移植できました。
ただCLで動かす場合、展開されるシンボルがどのパッケージに属しているかで動きが変ってくるので、この辺りを調整する必要がありそうです。

CLでsrfi-57

Posted 2012-05-24 14:04:00 GMT

CLでsrfi、今回は、srfi-57の「Records」です。
srfi-9に継承の機能と総称関数的なものを加えたようなものです

動作

(define-record-type  point (make-point x y) point?
  (x get-x set-x!)
  (y get-y set-y!))

(define-record-scheme <point nil <point? (x <point.x) (y <point.y))

(define-record-scheme <color nil <color? (hue <color.hue))

(define-record-type (point <point) make-point point? (x point.x) (y point.y))

(define-record-type (color <color) make-color)

(define-record-type (color-point <color <point) (make-color-point x y hue) color-point? (info color-point.info))

(defparameter *p* (point (x 1) (y 2)))

(point.x (record-update *p* point (x 7))) ;=> 7

(point.x *p*) ;=> 1

(defparameter *cp* (color-point (hue 'blue) (x 1) (y 2)))

(show (record-update *cp* <point (x 7))) ;=> (COLOR-POINT (INFO srfi-57.INTERNAL::<UNDEFINED>) (HUE BLUE) (X 7) (Y 2))

(show *cp*) ;=> (COLOR-POINT (INFO srfi-57.INTERNAL::<UNDEFINED>) (HUE BLUE) (X 1) (Y 2))

移植について

マクロがえらいややこしいのですが、関数定義とマクロ展開のタイミングがか移植したものでは噛み合っておらず、謎の挙動をしたりします。
ややこしすぎるので気が向いたら直してみたいです。
総称関数的なものを導入するsrfiはいまいち微妙な気がしています…。

多値のスタックでFORTHの真似事

Posted 2012-05-19 13:09:00 GMT

gforthのチュートリアルをちょっとやってみてforthも面白いなと思ったのですが、CLでスタックといえば多値が身近じゃないか、ということで、遊んでみました。
ポーランドと逆ポーランドを行ったり来たりで混乱しますが、引数の扱いをもうちょっとすっきりさせて、曖昧さを無くせれば、括弧を省略してひっくりかえして書けるかもしれません。

;;; multiple-value-callが長いので #[]と省略して書く
(set-dispatch-macro-character #\# #\[
                              (lambda (s c a)
                                (declare (cl:ignore a c))
                                (destructuring-bind (fn . args)
                                                    (read-delimited-list #\] s t)
                                  `(multiple-value-call
                                     #',fn
                                     ,@args))))

(defun drop (&rest args) (declare (dynamic-extent args)) (values-list (cdr args)))

#[drop 1 2 3 4 5] ;=> 2 ; 3 ; 4 ; 5

(defun nip (&rest args) (declare (dynamic-extent args)) (multiple-value-call #'values (car args) (values-list (cddr args))))

#[nip 1 2 3 4 5] ;=> 1 ; 3 ; 4 ; 5

(defun swap (x y &rest args) (declare (dynamic-extent args)) (multiple-value-call #'values y x (values-list args)))

#[swap 1 2 3 4 5] ;=> 2 ; 1 ; 3 ; 4 ; 5

(defun over (&rest args) (declare (dynamic-extent args)) (multiple-value-call #'values (second args) (values-list args)))

#[over 1 2 3 4 5] ;=> 2 ; 1 ; 2 ; 3 ; 4 ; 5

(defun tuck (x y &rest args) (declare (dynamic-extent args)) (multiple-value-call #'values x y x (values-list args)))

#[tuck 1 2 3 4 5] ;=> 1 ; 2 ; 1 ; 3 ; 4 ; 5

(defun vmod (x y &rest args) (declare (dynamic-extent args)) (multiple-value-call #'values (cl:rem y x) (values-list args)))

#[vmod 7 4 :a :b :c] ;=> 3 ; :A ; :B ; :C

(defun dup (&rest args) (declare (dynamic-extent args)) (multiple-value-call #'values (first args) (values-list args)))

#[dup 1 2 3 4 5] ;=> 1 ; 1 ; 2 ; 3 ; 4 ; 5

(defun 0= (x &rest args) (declare (dynamic-extent args)) (multiple-value-call #'values (if (zerop x) -1 0) (values-list args)))

#[0= 0 1 2 3 5] ;=> -1 ; 1 ; 2 ; 3 ; 5

(defun until (mvfn &rest args) (declare (dynamic-extent args)) (labels ((*until (&rest args) (declare (dynamic-extent args)) (multiple-value-call (lambda (true? &rest args) (if (= -1 true?) (values-list args) (multiple-value-call #'*until (values-list args)))) (apply mvfn args)))) (apply #'*until args)))

#[until (lambda (cnt &rest args) #[dup #[values (1- cnt) (values-list args)]]) 5 :a :b :c] ;=> -1 ; :A ; :B ; :C

;; : gcd ( u1 u2 ) ;; begin ;; tuck mod ;; dup 0= ;; until ;; drop ;

(defun my-gcd (x y &rest args) (declare (dynamic-extent args)) #[drop #[until (lambda (x y) #[0= #[dup #[vmod #[tuck x y]]]]) x y] (values-list args)])

(multiple-value-call #'my-gcd 1029 1071 :a :b :c) ;=> 21 ; :A ; :B ; :C

マルチスレッドのタスク実行ライブラリでお勧めのものを教えてください

Posted 2012-05-14 14:57:59 GMT

(defpackage :parallel
  (:use)
  (:export :dotimes
           :cpu-cores)
  (:shadow :dotimes))

(defun parallel:cpu-cores () #+linux (with-open-file (in "/proc/cpuinfo") (cl:loop :for line := (read-line in nil) :while line :when (search "cpu cores" line) :return (values (parse-integer line :start (1+ (position #\: line)))))) #-linux :not-implemented)

(define-compiler-macro parallel:cpu-cores () `,(parallel:cpu-cores))

(defmacro parallel:dotimes ((var count &optional result) &body body) (sb-int:with-unique-names (cores start end ths s e task/core rem ans dotask block abortp result/abort win) `(let* ((,cores (parallel:cpu-cores)) (,start 0) (,end 0) (,ths (make-list ,cores)) (,result/abort ',win)) (declare (fixnum ,start ,end ,cores) (list ,ths) ) (multiple-value-bind (,task/core ,rem) (floor ,count ,cores) (declare (fixnum ,task/core ,rem)) (unwind-protect (flet ((,dotask (,s ,e) (declare (fixnum ,s ,e)) (let* ((,abortp ',abortp) (,ans (block nil (loop :named ,block :for ,var :of-type fixnum :from ,s :below ,e :do (let ((,var ,var)) ,@body) :finally (setq ,abortp nil) (return-from ,block ,var))))) (if (eq ',abortp ,abortp) (setq ,result/abort ,ans) ,ans)))) (incf ,end (+ ,task/core ,rem)) ;; first thread (setf (car ,ths) (sb-thread:make-thread #',dotask :arguments (list 0 ,end)) ) (setq ,start ,end) (incf ,end ,task/core) ;; rest threads (map-into (cdr ,ths) (lambda () (prog1 (sb-thread:make-thread #',dotask :arguments (list ,start ,end)) (incf ,start ,task/core) (incf ,end ,task/core) )))) ;; clean-up (mapc #'sb-thread:join-thread ,ths)) ;; result-form (if (eq ',win ,result/abort) (let ((,var ,count)) (declare (ignorable ,var)) ,result) ,result/abort)))))

  • 実行

(declaim ((simple-array fixnum (65536)) *a*))
(defparameter *a*
  (make-array 65536 :element-type 'fixnum :initial-element 1) )

(parallel:dotimes (i 65536 (reduce #'+ *a*)) ; (and (= (random 100) 55) (return :abort!)) (setf (cl:aref *a* i) (fib 15))) ;⇒ 39976960 #|------------------------------------------------------------| Evaluation took: 1.978 seconds of real time 3.676230 seconds of total run time (3.672230 user, 0.004000 system) 185.84% CPU 4,734,659,880 processor cycles 2,131,408 bytes consed

Intel(R) Core(TM)2 Duo CPU P8600 @ 2.40GHz |------------------------------------------------------------|#

(dotimes (i 65536 (reduce #'+ *a*)) ; (and (= (random 100) 55) (return :abort!)) (setf (cl:aref *a* i) (fib 15))) ;⇒ 39976960 #|------------------------------------------------------------| Evaluation took: 3.641 seconds of real time 3.644228 seconds of total run time (3.644228 user, 0.000000 system) 100.08% CPU 8,715,282,210 processor cycles 2,280,224 bytes consed

Intel(R) Core(TM)2 Duo CPU P8600 @ 2.40GHz |------------------------------------------------------------|#

こんな感じで、通常の書き方と同じ感じ書いたら自動でパラレルになるような、C#でいう、System.Threading.Tasks的なライブラリでお勧めのものを教えてください


HTML generated by 3bmd in LispWorks 7.0.0

CLでsrfi-99

Posted 2012-04-27 10:12:00 GMT

CLでsrfi、今回は、srfi-99の「ERR5RS Records」です。
R6RSで、構造体が導入されましたが、本srfiは、srfi-9との互換性も考慮されていてR5RSでも使えるような提案です。

動作

(define-record-type foo
                    t
                    t
  a)

(define-record-type (bar foo) (mkbar a b) bar-p b (c))

(defvar *foo* (make-foo 8))

(foo? *foo*) ;=> T (defvar *bar* (mkbar 1 2))

(bar-p *bar*) ;=> T (foo? *bar*) ;=> T (bar-c *bar*) ;=> NIL (bar-c-set! *bar* 100)

(bar-c *bar*) ;=> 100

移植について

イントロスペクションの機能が色々あるので、これはCLOSで作るべきかなと思いましたが、適当にdefstructで作ってしまいました。 その所為で、make-rtdがまともに機能しません…。
無名structure-classから、structure-objectが生成できるような処理系なら簡単に作れるかもしれませんが、やはり、CLOSで作るべきだったか…。

CLでsrfi-44

Posted 2012-04-19 05:09:00 GMT

CLでsrfi、今回は、srfi-44の「Collections」です。
コレクションのライブラリです。

動作

(collection= #'=
             '(1 2 3 4)
             '(1.0 2.0 3.0 4.0))
;=>  T

(bag= #'=
      (bag 1 2 3 4)
      (bag 1 2 3 4 4 3 2 1))
;=>  T

移植について

オブジェクト指向の枠組みとしては、Tiny-Closを利用するのですが、CLOSを使うことにしました。
とはいえ、srfi-44の設計が一つの関数名に集約される訳ではなく、list-foo、bag-foo、collection-fooという風にコレクションごとに作成しつつcollection-fooはディスパッチする、というもののようなので、拡張性があるような無いようなというところで、結果として800を越す関数が定義されることになっています。
一応参照実装にあるテストは全部通しましたが、全然完成している気がしないので穴が沢山ある気がします…。 ■

fooとfoo!の共通化

Posted 2012-04-12 03:38:00 GMT

(foo obj) ≡ (foo! (copy obj)) という風に破壊的なものと、非破壊的な2種類の関数を作る必要がある場合にどうにかしてすっきり書きたい。
マクロでも良いんだけど…。

LISP日記 2012-04-11

Posted 2012-04-10 15:41:00 GMT

どうもTwitterに垂れ流してしまうだけで、ブログに記録するのを怠ってしまう。すっかり放置

分かったこと

  • なし

やってみたこと

  • silicon graphicsのoriginのページを眺めていて、ループの交換について書いてあったので面白そうなので試してみた。
    この内容では、最内周で細かいループは非効率ということなんだけども、CLで書いたら逆になってしまった。
    テストは、2x40x2000という配列甲と、2000x40x2という配列乙を用意して、それぞれに対して、大>小というループのネストと、小<大というネストで計測というもの
    結果としては、配列の構成に沿った感じでループを構成するのが速く、(2 40 2000)という配列なら、(2times (40times (2000times ...)))が良いらしい
    配列の構成に沿っているならば、件の記事のように小<大のネストが速そうだけど、それも逆転しているっぽい。結局のところ配列のアロケーションに沿っているかどうかが決め手っぽいので、配列のアロケーションを探ってみたいところ。
    -=--=--=--=--=--=--=--=--=--=--=--=--=--=--=-
    << win. (a: 7395246 b: 8827002)
    >> win. (c: 9134298 d: 6816960)
    fastest: d: 6816960
    -=--=--=--=--=--=--=--=--=--=--=--=--=--=--=-
    << win. (a: 7276086 b: 8413470)
    >> win. (c: 8830314 d: 7155954)
    fastest: d: 7155954
    -=--=--=--=--=--=--=--=--=--=--=--=--=--=--=-
    << win. (a: 7293582 b: 9383508)
    >> win. (c: 8984358 d: 6809112)
    fastest: d: 6809112
    -=--=--=--=--=--=--=--=--=--=--=--=--=--=--=-
    << win. (a: 7270200 b: 8493120)
    >> win. (c: 9550044 d: 6958116)
    fastest: d: 6958116
    -=--=--=--=--=--=--=--=--=--=--=--=--=--=--=-
    << win. (a: 7240338 b: 8668962)
    >> win. (c: 8813808 d: 6798636)
    fastest: d: 6798636
    -=--=--=--=--=--=--=--=--=--=--=--=--=--=--=-
    << win. (a: 7304724 b: 8697600)
    >> win. (c: 8827794 d: 6806916)
    fastest: d: 6806916
    -=--=--=--=--=--=--=--=--=--=--=--=--=--=--=-
    << win. (a: 7350750 b: 9680652)
    >> win. (c: 9296424 d: 6768864)
    fastest: d: 6768864
    -=--=--=--=--=--=--=--=--=--=--=--=--=--=--=-
    << win. (a: 7426278 b: 11157102)
    >> win. (c: 10433988 d: 7675218)
    fastest: a: 7426278
    -=--=--=--=--=--=--=--=--=--=--=--=--=--=--=-
    << win. (a: 7338636 b: 9024228)
    >> win. (c: 10986840 d: 6877530)
    fastest: d: 6877530
    -=--=--=--=--=--=--=--=--=--=--=--=--=--=--=-
    << win. (a: 7852032 b: 11772378)
    >> win. (c: 10818918 d: 6832872)
    fastest: d: 6832872

やりたいこと

  • なし

思ったこと

  • なし

CLでsrfi-21

Posted 2012-03-31 13:31:00 GMT

CLでsrfi、今回は、srfi-21の「Real-time Multithreading support」です。
srfi 18にスレッドの優先度等のオプションを付けたようなsrfiです。

動作

(let ((th (make-thread (lambda () (sleep 2) :end)
                       "sleep 2")))
  (thread-base-priority-set! th 10)
  (thread-priority-boost-set! th 3)
  (thread-quantum-set! th 0.1)
  (thread-start! th)
  (list (thread-name th)
        (thread-base-priority th)
        (thread-priority-boost th)
        (thread-quantum th)
        (thread-join! th)))
;=>  ("sleep 2" 10 3 0.1 :END)

移植について

いまいち良く分からなかったので、srfi-18のスレッドの構造体に優先度のスロットetcを付けただけです…。 ■

CLでsrfi-18

Posted 2012-03-29 08:34:00 GMT

CLでsrfi、今回は、srfi-18の「Multithreading support」です。
マルチスレッド関係を規定するsrfiです。

動作

(defun make-empty-mailbox ()
  (let ((mutex (make-mutex))
        (put-condvar (make-condition-variable))
        (get-condvar (make-condition-variable))
        (full? nil)
        (cell nil) )
    (labels ((put! (obj)
               (mutex-lock! mutex)
               (if full?
                   (progn
                     (mutex-unlock! mutex put-condvar)
                     (put! obj) )
                   (progn
                     (setq cell obj)
                     (setq full? 'T)
                     (condition-variable-signal! get-condvar)
                     (mutex-unlock! mutex) )))
             (get! ()
               (mutex-lock! mutex)
               (if (not full?)
                   (progn
                     (mutex-unlock! mutex get-condvar)
                     (get!) )
                   (let ((result cell))
                     (setq cell nil) ; avoid space leaks
                     (setq full? nil)
                     (condition-variable-signal! put-condvar)
                     (mutex-unlock! mutex) ))))
      (lambda (msg)
        (case msg
          ((put!) #'put!)
          ((get!) #'get!)
          (otherwise (error "unknown message")) )))))

(defun mailbox-put! (m obj) (funcall (funcall m 'put!) obj)) (defun mailbox-get! (m) (funcall (funcall m 'get!)))

;;; test (let ((th (make-thread (lambda () (handler-case (sb-ext:with-timeout 2 (let ((mb (make-empty-mailbox))) (mailbox-put! mb 'foo) (mailbox-get! mb) (mailbox-put! mb 'bar) t )) (sb-ext:timeout () nil) )) "mailbox" ))) (thread-start! th) (thread-join! th) ) ;=> T

移植について

結構低レイヤーなので厳しいです。
適当にSBCLで該当する機能がある範囲で似せる、という感じでお茶を濁しています。 ■

Older entries (1476 remaining)