Constantfolding go brrrrr

optimization.lisp

(defpackage #:optimizations
  (:use #:cl)
  (:shadow #:+))

(in-package #:optimizations)


(declaim (inline quaternion))
(defstruct quaternion
  (a 0 :type real)
  (b 0 :type real)
  (c 0 :type real)
  (d 0 :type real))


(defmethod make-load-form ((q quaternion) &optional env)
  (declare (ignore env))
  (make-load-form-saving-slots q))

(define-compiler-macro make-quaternion (&whole form &key (a 0) (b 0) (c 0) (d 0) &environment env)
  (if (and (constantp a env)
         (constantp b env)
         (constantp c env)
         (constantp d env))
      (make-quaternion :a (introspect-environment:constant-form-value a)
                       :b (introspect-environment:constant-form-value b)
                       :c (introspect-environment:constant-form-value c)
                       :d (introspect-environment:constant-form-value d))
      form))

(define-compiler-macro quaternion-a (&whole form q &environment env)
  (declare (ignore env))
  (if (and (listp q) (eql (first q) 'make-quaternion))
      (getf (cdr q) :a 0)
      form))

(define-compiler-macro quaternion-b (&whole form q &environment env)
  (declare (ignore env))
  (if (and (listp q) (eql (first q) 'make-quaternion))
      (getf (cdr q) :b 0)
      form))

(define-compiler-macro quaternion-c (&whole form q &environment env)
  (declare (ignore env))
  (if (and (listp q) (eql (first q) 'make-quaternion))
      (getf (cdr q) :c 0)
      form))

(define-compiler-macro quaternion-d (&whole form q &environment env)
  (declare (ignore env))
  (if (and (listp q) (eql (first q) 'make-quaternion))
      (getf (cdr q) :d 0)
      form))


(defun %two-arg-add (fst snd)
  (declare (optimize (speed 3) (compilation-speed 0)))
  (with-slots ((a1 a) (b1 b) (c1 c) (d1 d)) fst
    (with-slots ((a2 a) (b2 b) (c2 c) (d2 d)) snd
      (make-quaternion :a (cl:+ a1 a2) :b (cl:+ b1 b2) :c (cl:+ c1 c2) :d (cl:+ d1 d2)))))

(define-compiler-macro %two-arg-add (&whole form fst snd &environment env)
  (declare (ignore form))
  (let ((newa1 (funcall (compiler-macro-function 'quaternion-a) `(quaternion-a ,fst) env))
        (newb1 (funcall (compiler-macro-function 'quaternion-b) `(quaternion-b ,fst) env))
        (newc1 (funcall (compiler-macro-function 'quaternion-c) `(quaternion-c ,fst) env))
        (newd1 (funcall (compiler-macro-function 'quaternion-d) `(quaternion-d ,fst) env))
        (newa2 (funcall (compiler-macro-function 'quaternion-a) `(quaternion-a ,snd) env))
        (newb2 (funcall (compiler-macro-function 'quaternion-b) `(quaternion-b ,snd) env))
        (newc2 (funcall (compiler-macro-function 'quaternion-c) `(quaternion-c ,snd) env))
        (newd2 (funcall (compiler-macro-function 'quaternion-d) `(quaternion-d ,snd) env)))
    (funcall (compiler-macro-function 'make-quaternion) `(make-quaternion :a (cl:+ ,newa1 ,newa2)
                                                                          :b (cl:+ ,newb1 ,newb2)
                                                                          :c (cl:+ ,newc1 ,newc2)
                                                                          :d (cl:+ ,newd1 ,newd2)) env)))


(defun collect+ (ls)
  (loop :with res := '()
        :for obj :in ls
        :if (and (listp obj) (eql '+ (first obj)))
          :do (setf res (append (reverse (collect+ (rest obj))) res))
        :else
          :do (push obj res)
        :finally (return (reverse res))))


(defun + (&rest numbers)
  (case (length numbers)
    (0 0)
    (1 (first numbers))
    (2 (typecase (car numbers)
         (number (apply #'cl:+ numbers))
         (otherwise
          (%two-arg-add (first numbers) (second numbers)))))
    (otherwise
     (flet ((collect+ (ls)
              (loop :with res := '()
                    :for obj :in ls
                    :if (and (listp obj) (eql '+ (first obj)))
                      :do (setf res (append (reverse (collect+ (rest obj))) res))
                    :else
                      :do (push obj res)
                    :finally (return (reverse res)))))
       (let ((newarglist (collect+ numbers)))
         (typecase (car newarglist)
           (number (apply #'cl:+ newarglist))
           (otherwise (reduce #'%two-arg-add newarglist))))))))


(define-compiler-macro + (&whole form &rest numbers &environment env)
  (if (constantp (length numbers) env)
      (case (length numbers)
        (0 0)
        (1 (first numbers))
        (2 (typecase (car numbers)
             (number `(cl:+ ,@numbers))
             (otherwise
              (funcall (compiler-macro-function '%two-arg-add)
                       `(%two-arg-add ,(first numbers) ,(second numbers)) env))))
        (otherwise
         (flet ((collect+ (ls)
                  (loop :with res := '()
                        :for obj :in ls
                        :if (and (listp obj) (eql '+ (first obj)))
                          :do (setf res (append (reverse (collect+ (rest obj))) res))
                        :else
                          :do (push obj res)
                        :finally (return (reverse res)))))
           (let ((newarglist (collect+ numbers)))
             (typecase (car newarglist)
               (number `(cl:+ ,@newarglist))
               (otherwise (reduce (lambda (a b) `('%two-arg-add ,a ,b)) newarglist)))))))
      form))