9

我想告诉 sbcl，以下函数只会使用结果适合 fixnum 的 fixnum 值调用：

(defun layer (x y z n)
  (+ (* 2 (+ (* x y) (* y z) (* x z)))
     (* 4 (+ x y z n -2) (1- n))))

我的第一次尝试是做

(defun layer (x y z n)
  (declare (fixnum x y z n))
  (the fixnum
    (+ (* 2 (+ (* x y) (* y z) (* x z)))
       (* 4 (+ x y z n -2) (1- n))))

但是该返回类型声明并不能保证所有中间结果也将是 fixnums，正如我通过查看 sbcl 生成的非常有用的编译注释发现的那样。所以我这样做了：

(defmacro fixnum+ (&rest args)
  (reduce
    (lambda (x y) `(the fixnum (+ ,x ,y)))
    args))

(defmacro fixnum* (&rest args)
  (reduce
    (lambda (x y) `(the fixnum (* ,x ,y)))
    args))

(defun layer (x y z n)
  (declare (fixnum x y z n))
  (fixnum+ (fixnum* 2 (fixnum+ (fixnum* x y) (fixnum* y z) (fixnum* x z)))
     (fixnum* 4 (fixnum+ x y z n -2) (the fixnum (1- n)))))

这工作得很好。我的问题是：有没有更简单、更惯用的方法来做到这一点？

例如，也许我可以重新声明 +、-、*、1- 的类型来承诺 fixnum 结果？（我知道这通常是个坏主意，但我可能想在某些程序中这样做。） CHICKEN 方案(declare (fixnum-arithmetic))可以满足我的要求：它（不安全地）假设所有对 fixnums 的算术运算的结果都是 fixnums。

4

4 回答 4

11

您可以使用FTYPE声明函数的类型。

例子：

(defun foo (a b)
  (declare (ftype (function (&rest fixnum) fixnum) + * 1-)
           (type fixnum a b)
           (inline + * 1-)
           (optimize (speed 3) (safety 0) (debug 0) (space 0)))
  (+ a (* a (1- b))))

这有什么区别吗？

于 2013-07-24T16:43:52.660 回答
7

在他的《ANSI Common Lisp》一书中，Paul Graham 展示了宏with-type，它将表达式及其所有子表达式包装在the表单中，同时确保给定两个以上参数的运算符得到正确处理。

例如(with-type fixnum (+ 1 2 3))将扩展为表格

(the fixnum (+ (the fixnum (+ (the fixnum 1) (the fixnum 2))) 
               (the fixnum 3))

带有辅助函数的宏代码是

(defmacro with-type (type expr)
  `(the ,type ,(if (atom expr) 
                   expr
                   (expand-call type (binarize expr)))))

(defun expand-call (type expr)
  `(,(car expr) ,@(mapcar #'(lambda (a) 
                              `(with-type ,type ,a))
                          (cdr expr))))

(defun binarize (expr)
  (if (and (nthcdr 3 expr)
           (member (car expr) '(+ - * /)))
      (destructuring-bind (op a1 a2 . rest) expr
        (binarize `(,op (,op ,a1 ,a2) ,@rest)))
      expr))

本书代码的链接位于http://www.paulgraham.com/acl.html

代码中的一条注释指出“此代码为 Paul Graham 1995 年版权所有，但任何想要使用它的人都可以自由使用。”

于 2013-07-24T18:07:30.493 回答
2

尝试这个：

(defun layer (x y z n)
  (declare (optimize speed) (fixnum x y z n))
  (logand most-positive-fixnum
          (+ (* 2 (+ (* x y) (* y z) (* x z)))
             (* 4 (+ x y z n -2) (1- n)))))

请参阅SBCL 用户手册，第 6.3 节模数运算。

编辑：

如评论中所述，此功能需要 SBCL-1.1.9（或更高版本）。此外，通过内联子例程，可以再节省约 40% 的时间：

;;; From: https://gist.github.com/oantolin/6073417
(declaim (optimize (speed 3) (safety 0)))

(defmacro with-type (type expr)
  (if (atom expr)
      expr
      (let ((op (car expr)))
        (reduce
         (lambda (x y)
           `(the ,type
                 (,op ,@(if x (list x) '())
                      (with-type ,type ,y))))
         (cdr expr)
         :initial-value nil))))
 
(defun layer (x y z n)
  (declare (fixnum x y z n))
  (with-type fixnum
    (+ (* 2 (+ (* x y) (* y z) (* x z)))
       (* 4 (+ x y z n -2) (1- n)))))

(defun cubes (n)
  (declare (fixnum n))
  (let ((count (make-array (+ n 1) :element-type 'fixnum)))
    (loop for x of-type fixnum from 1 while (<= (layer x x x 1) n) do
      (loop for y of-type fixnum from x while (<= (layer x y y 1) n) do
        (loop for z of-type fixnum from y while (<= (layer x y z 1) n) do
          (loop for k of-type fixnum from 1 while (<= (layer x y z k) n) do
            (incf (elt count (layer x y z k)))))))
    count))

(defun first-time (x)
  (declare (fixnum x))
  (loop for n of-type fixnum = 1000 then (* 2 n)
        for k = (position x (cubes n))
        until k
        finally (return k)))

;;; With modarith and inlining
(defun first-time/inline (x)
  (declare (fixnum x))
  (labels
      ((layer (x y z n)
         (logand #.(1- (ash 1 (integer-length most-positive-fixnum)))
                 (+ (* 2 (+ (* x y) (* y z) (* x z)))
                    (* 4 (+ x y z n -2) (1- n)))))
       (cubes (n)
         (let ((count (make-array (+ n 1) :element-type 'fixnum)))
           (loop for x of-type fixnum from 1 while (<= (layer x x x 1) n) do
             (loop for y of-type fixnum from x while (<= (layer x y y 1) n) do
               (loop for z of-type fixnum from y while (<= (layer x y z 1) n) do
                 (loop for k of-type fixnum from 1 while (<= (layer x y z k) n)
                       do (incf (elt count (layer x y z k)))))))
           count)))
    (declare (inline layer cubes))
    (loop for n of-type fixnum = 1000 then (* 2 n)
          thereis (position x (cubes n)))))

#+(or) 
(progn
  (time (print (first-time 1000)))
  (time (print (first-time/inline 1000))))

;; 18522 
;; Evaluation took:
;;   0.448 seconds of real time
;;   0.448028 seconds of total run time (0.448028 user, 0.000000 system)
;;   100.00% CPU
;;   1,339,234,815 processor cycles
;;   401,840 bytes consed
;;   
;; 
;; 18522 
;; Evaluation took:
;;   0.259 seconds of real time
;;   0.260016 seconds of total run time (0.260016 user, 0.000000 system)
;;   100.39% CPU
;;   776,585,475 processor cycles
;;   381,024 bytes consed
于 2013-07-24T16:56:20.503 回答
2

即使在块编译打开时，内联声明层函数也会导致更快的速度。

在我的 Apple Air M1 上，层内联和块编译在 Arm64 版本的 SBCL 2.1.2 下运行时间为 0.06 秒。

CL-USER> (time (first-time 1000))
Evaluation took:
  0.060 seconds of real time
  0.060558 seconds of total run time (0.060121 user, 0.000437 system)
  101.67% CPU
  303,456 bytes consed

我刚刚记得在多维数据集中声明计数数组也应该有所帮助。

(declare (type (simple-array fixnum (*)) count))

如果没有内联层函数，它大约是 0.2 秒。

CL-USER> (time (first-time 1000))
Evaluation took:
  0.201 seconds of real time
  0.201049 seconds of total run time (0.200497 user, 0.000552 system)
  100.00% CPU
  251,488 bytes consed

或者将图层函数转换为宏可以使其更快。

(defmacro layer (x y z n)
  (declare (fixnum x y z n))
  `(logand #.(1- (ash 1 (integer-length most-positive-fixnum)))
      (+ (* 2 (+ (* ,x ,y) (* ,y ,z) (* ,x ,z)))
         (* 4 (+ ,x ,y ,z ,n -2) (1- ,n)))))

CL-USER> (time (first-time 1000))
Evaluation took:
  0.047 seconds of real time
  0.047032 seconds of total run time (0.046854 user, 0.000178 system)
  100.00% CPU
  312,576 bytes consed

以平凡的基准进行基准测试，它的平均运行时间仅低于 0.04 秒：

CL-USER> (benchmark:with-timing (100) (first-time 1000))
-                SAMPLES  TOTAL     MINIMUM   MAXIMUM   MEDIAN    AVERAGE    DEVIATION  
REAL-TIME        100      3.985173  0.039528  0.06012   0.039595  0.039852   0.002046   
RUN-TIME         100      3.985848  0.039534  0.06014   0.039605  0.039858   0.002048   
USER-RUN-TIME    100      3.975407  0.039466  0.059829  0.039519  0.039754   0.002026   
SYSTEM-RUN-TIME  100      0.010469  0.00005   0.000305  0.000088  0.000105   0.00005    
PAGE-FAULTS      100      0         0         0         0         0          0.0        
GC-RUN-TIME      100      0         0         0         0         0          0.0        
BYTES-CONSED     100      50200736  273056    504320    504320    502007.38  23010.477  
EVAL-CALLS       100      0         0         0         0         0          0.0
于 2021-03-12T18:13:53.827 回答