swizard (swizard) wrote,
swizard
swizard

Хамелеончеги

В инете есть весьма популярный хуеизмеритель для языков программирования, на который любит ориентироваться школота: http://shootout.alioth.debian.org

Собственно что — для задачи chameneos-redux там отсутствует милый нашему сердцу Lisp SBCL, поэтому я кой-что набросал.


;; The Computer Language Benchmarks Game
;;   http://shootout.alioth.debian.org/
;;
;;   contributed by Alexey Voznyuk
;;

(defpackage #:chameneos-redux
  (:use :cl))

(in-package :chameneos-redux)

;;
;; Game DSL compiler
;;

(defmacro defun/fast (name typed-args &body body)
  `(defun ,name ,(mapcar #'first typed-args)
     (declare (optimize (speed 3) (safety 0) (debug 0))
              ,@(loop :for (arg type) :in typed-args
                   :collect `(type ,type ,arg)))
     ,@body))

(defmacro declare-colors-map (&rest transformations)
  `(progn
     (defun/fast complement-color ((color-a symbol) (color-b symbol))
       (cond
         ,@(loop
              :for (test-a kw-plus test-b kw-arrow test-result) :in transformations
              :do (assert (and (eq kw-plus '+) (eq kw-arrow '->)))
              :collect `((and (eq color-a ',test-a) (eq color-b ',test-b))
                         ',test-result))
         (t (error "Invalid colors combinations"))))
     (defun/fast print-colors ()
       (format t "~{~{~a + ~a -> ~a~%~}~}~%"
               (list ,@(loop
                          :for (test-a kw-plus test-b) :in transformations
                          :collect `(list ,(string-downcase (string test-a))
                                          ,(string-downcase (string test-b))
                                          (string-downcase
                                           (string (complement-color ',test-a
                                                                     ',test-b))))))))))

(defun/fast spell-number ((number fixnum))
  (with-output-to-string (result-string)
    (loop
       :for char :across (the simple-string (format nil "~a" number))
       :do (format result-string " ~r" (- (char-code char) (char-code #\0))))))

(defmacro with-threads-pool ((thread-maker &rest colors) &body body)
  `(let (threads)
     (declare (type list threads))
     (unwind-protect
          (progn ,@(loop
                      :for color :in colors
                      :for thread-index :from 0
                      :collect `(push (sb-thread:make-thread
                                       (,thread-maker ,thread-index ',color)
                                       :name ,(format nil "chameneos-worker-~a-~a"
                                                      thread-index
                                                      (string-downcase (string color))))
                                      threads))
                 ,@body)
       (loop
          :for thread :in threads
          :do (sb-thread:join-thread thread)))
     nil))

(defmacro spin-wait (condition)
  `(loop
      :repeat 16384
      :do (when ,condition
            (return))
      :finally (loop :until ,condition :do (sb-thread:thread-yield))))

#+x86-64
(defstruct atomic
  (counter 0 :type (unsigned-byte 64)))
#+x86
(defstruct atomic
  (counter 0 :type (unsigned-byte 32)))

(defmacro defgame (game-name (count &rest colors))
  (let* ((colors-count (length colors))
         (colors-type `(integer 0 ,colors-count)))
    `(defun/fast ,game-name ((,count fixnum))
       (format t ,(format nil "~{ ~a~}~~%"
                          (loop :for color :in colors
                             :collect (string-downcase (string color)))))
       (let ((meet-counts (make-array ,colors-count
                                      :element-type 'fixnum :initial-element 0))
             (same-counts (make-array ,colors-count
                                      :element-type 'fixnum :initial-element 0))
             (action-cas (list #'identity))
             (counter (make-atomic)))
         (declare (type (simple-array fixnum (,colors-count)) meet-counts same-counts)
                  (type cons action-cas)
                  (type atomic counter))
         (labels ((incf-counter ()
                    (sb-ext:atomic-incf (atomic-counter counter)))
                  (in-progress ()
                     (< (the fixnum (atomic-counter counter)) ,count))
                  (color-worker (id color)
                    (declare (type ,colors-type id) (type symbol color))
                    (lambda ()
                      (let ((meet-wait nil))
                        (declare (type boolean meet-wait))
                        (labels ((clear-meet-wait ()
                                   (setf meet-wait t))
                                 (promise (second-color)
                                   (setf color (complement-color color second-color))
                                   (values id color #'clear-meet-wait)))
                          (loop
                             :while (in-progress)
                             :do (let ((action (car action-cas)))
                                   (declare (type function action))
                                   (if (eq action #'identity)
                                       (when (eq (sb-ext:compare-and-swap (car action-cas)
                                                                          action
                                                                          #'promise)
                                                 action)
                                         (spin-wait (or (not (in-progress)) meet-wait))
                                         (setf meet-wait nil))
                                       (when (eq (sb-ext:compare-and-swap (car action-cas)
                                                                          action
                                                                          #'identity)
                                                 action)
                                         (multiple-value-bind (second-id
                                                               second-color
                                                               break-spin-wait)
                                             (funcall action color)
                                           (declare (type ,colors-type second-id)
                                                    (type symbol second-color)
                                                    (type function break-spin-wait))
                                           (setf color second-color)
                                           (when (in-progress)
                                             (when (= id second-id)
                                               (incf (elt same-counts id))
                                               (incf (elt same-counts second-id)))
                                             (incf (elt meet-counts id))
                                             (incf (elt meet-counts second-id))
                                             (incf-counter))
                                           (funcall break-spin-wait)))))))))))
           (with-threads-pool (color-worker ,@colors)
             nil)
           (loop
              :for i :from 0 :below ,colors-count
              :summing (elt meet-counts i) :into total :of-type fixnum
              :do (format t "~a~a~%" (elt meet-counts i) (spell-number (elt same-counts i)))
              :finally (format t "~a~%~%" (spell-number total))))))))

;;
;; Game contents
;;

(progn
  (declare-colors-map 
   (blue + blue -> blue)
   (blue + red -> yellow)
   (blue + yellow -> red)
   (red + blue -> yellow)
   (red + red -> red)
   (red + yellow -> blue)
   (yellow + blue -> red)
   (yellow + red -> blue)
   (yellow + yellow -> yellow))
    
  (defgame game-a (count blue red yellow))
  (defgame game-b (count blue red yellow red yellow blue red yellow red blue))

  (defun main (&optional force-count)
    (let* ((args (cdr sb-ext:*posix-argv*))
           (count (or force-count (if args (parse-integer (car args)) 600))))
      (print-colors)
      (game-a count)
      (game-b count))))



Код я вроде закоммитил, но там что-то не очень понятно с процедурой аппрува и тд, пока разбираемся.

Просьба заключается вот в чем: код-ревью, протестировать перфоманс (time (main 6000000)), и какие-нибудь ценные советы, как превзойти java-версию. У меня с ней личные счеты :)

Специфика задачи в том, что процессы по ходу дела почти не выполняют никакой работы, но активно взаимодействуют друг с другом. Я уже вроде сделал все от меня зависящее: свел синхронизацию места встречи к одному Compare-And-Swap, вычистил остальные блокировки, сделал ожидание первого хамелеона хитрым спином. Другие очевидные оптимизации, за счет который программа-победитель работает меньше секунды заключаются в том, чтобы руками рассадить потоки по процессорам и аккуратно разложить данные по кэш-линиям. Как это сделать в sbcl я чето ума не приложу, возможно, что и никак :)

Но это ладно, основное, что меня бесит — это как java ухитряется отрабатывать задачу за ~5 секунд на моей машине, при том, что в джава-коде всех этих ухищрений нет! Там synchronized(this) (насколько я понимаю, это мьютекс) для места встречи и спин-ожидание первого хамелеона. Мой код с более легковесной синхронизацией работает ~7.4 сек. Что за непотребное волшебство творит jre?!
Tags: chameneos-redux, code, common lisp, java, lisp, question, shootout
Subscribe
  • 157 comments
Previous
← Ctrl ← Alt
Next
Ctrl → Alt →
  • 157 comments
Previous
← Ctrl ← Alt
Next
Ctrl → Alt →

Comments for this post were locked by the author