<commit_before>(in-package "NAPA-FFT.GEN")

;;; Basic block compiler.

(defstruct (vval
            (:constructor %make-vval))
  name ;; Var name
  type ;; type
  spills ;; available spill slots
  dests  ;; mandatory (write-once) destination slots
  status ;; "current" locations
  reads  ;; sorted list of locations of ops that read this var
  )

(defun vval (type &key (stem "VAR"))
  (%make-vval :name (gensym (coerce stem 'string))
              :type type
              :spills '()
              :dests '()
              :status '()
              :reads '()))

(defstruct (op
            (:constructor %make-op))
  body
  args
  deps
  writes)

(defun %%op (result-types body args)
  (let ((results (mapcar (lambda (type)
                           (vval type))
                         result-types)))
    (%make-op :body body
              :args args
              :deps (remove-duplicates (remove-if-not #'vval-p args))
              :writes results)))

(defvar *ops*)

(defun %op (result-types body args)
  (let ((op (%%op result-types body args)))
    (vector-push-extend op *ops*)
    (values-list (op-writes op))))

(defmacro op ((&rest types) body &rest args)
  `(%op ',types ,body (list ,@args)))

(defvar *vector*)

(defun @ (i)
 (aref *vector* i))

(defun (setf @) (value i)
  (when (vval-p value)
    (pushnew i (vval-spills value)))
  (setf (aref *vector* i) value))

(defun initialize-vector (type)
  (dotimes (i (length *vector*) *vector*)
    (setf (@ i) (vval type :stem (format nil "~A[~A]" 'vec i)))))

(defun note-writes ()
  (dotimes (i (length *vector*) *vector*)
    (let ((value (@ i)))
      (when (vval-p value)
        (pushnew i (vval-dests value))))))

(defmacro with-vector ((n &key (type '(complex double-float))
                            (maxlive 14))
                       &body body)
  `(let* ((*vector* (make-array ,n))
          (*ops* (make-array 16 :fill-pointer 0 :adjustable t))
          initial-vector)
     (initialize-vector ',type)
     (setf initial-vector (copy-seq *vector*))
     (locally
         ,@body)
     (note-writes)
     (emit-code
      (insert-spill *ops*
                    initial-vector
                    *vector*
                    ,maxlive)
      '(vec))))

(defmacro bblock ((&rest bindings) &body body)
  (let ((body `(locally ,@body)))
    (loop for (names types form) in (reverse bindings)
          do (setf body
                   `(multiple-value-bind ,names ,form
                        (declare ,@(mapcar (lambda (type name)
                                             `(type ,type ,name))
                                           types names)
                                 (ignorable ,@names))
                      ,body))
          finally (return body))))

(defstruct load-op
  var idx)

(defstruct store-op
  var idx)

(defun emit-code (ops body)
  (let ((clauses
          (loop for op across ops
                collect
                (etypecase op
                  (op
                   `(,(mapcar #'vval-name (op-writes op))
                     ,(mapcar #'vval-type (op-writes op))
                     (,(op-body op)
                       ,@(mapcar (lambda (x)
                                   (if (vval-p x)
                                       (vval-name x)
                                       x))
                                 (op-args op)))))
                  (load-op
                   (let ((var (load-op-var op)))
                     `((,(vval-name var)) (,(vval-type var))
                       (aref vec (+ start ,(load-op-idx op))))))<commit_msg>More scalable bblock macro: emit let*/progn when possible<commit_after>(in-package "NAPA-FFT.GEN")

;;; Basic block compiler.

(defstruct (vval
            (:constructor %make-vval))
  name ;; Var name
  type ;; type
  spills ;; available spill slots
  dests  ;; mandatory (write-once) destination slots
  status ;; "current" locations
  reads  ;; sorted list of locations of ops that read this var
  )

(defun vval (type &key (stem "VAR"))
  (%make-vval :name (gensym (coerce stem 'string))
              :type type
              :spills '()
              :dests '()
              :status '()
              :reads '()))

(defstruct (op
            (:constructor %make-op))
  body
  args
  deps
  writes)

(defun %%op (result-types body args)
  (let ((results (mapcar (lambda (type)
                           (vval type))
                         result-types)))
    (%make-op :body body
              :args args
              :deps (remove-duplicates (remove-if-not #'vval-p args))
              :writes results)))

(defvar *ops*)

(defun %op (result-types body args)
  (let ((op (%%op result-types body args)))
    (vector-push-extend op *ops*)
    (values-list (op-writes op))))

(defmacro op ((&rest types) body &rest args)
  `(%op ',types ,body (list ,@args)))

(defvar *vector*)

(defun @ (i)
 (aref *vector* i))

(defun (setf @) (value i)
  (when (vval-p value)
    (pushnew i (vval-spills value)))
  (setf (aref *vector* i) value))

(defun initialize-vector (type)
  (dotimes (i (length *vector*) *vector*)
    (setf (@ i) (vval type :stem (format nil "~A[~A]" 'vec i)))))

(defun note-writes ()
  (dotimes (i (length *vector*) *vector*)
    (let ((value (@ i)))
      (when (vval-p value)
        (pushnew i (vval-dests value))))))

(defmacro with-vector ((n &key (type '(complex double-float))
                            (maxlive 14))
                       &body body)
  `(let* ((*vector* (make-array ,n))
          (*ops* (make-array 16 :fill-pointer 0 :adjustable t))
          initial-vector)
     (initialize-vector ',type)
     (setf initial-vector (copy-seq *vector*))
     (locally
         ,@body)
     (note-writes)
     (emit-code
      (insert-spill *ops*
                    initial-vector
                    *vector*
                    ,maxlive)
      '(vec))))

(defun emit-bblock (bindings body)
  (let ((progn-acc '())
        (let*-acc  '())
        (forms-acc '()))
    (flet ((flush ()
             (cond (let*-acc
                    (let ((bindings (mapcar #'first let*-acc)))
                      (push `(let* ,(nreverse let*-acc)
                               (declare (ignorable
                                         ,@(nreverse bindings)))
                               ,@(nreverse progn-acc))
                            forms-acc))
                    (setf let*-acc nil
                          progn-acc nil))
                   (progn-acc
                    (push `(progn ,@(nreverse progn-acc))
                          forms-acc)
                    (setf progn-acc nil)))))
      (loop for binding in bindings
            do
               (etypecase (car binding)
                 (null
                  (push (third binding) progn-acc))
                 ((cons * null)
                  (destructuring-bind ((name) (type) form)
                      binding
                    (push `(,name (the ,type
                                       ,(if progn-acc
                                            `(progn
                                               ,@(nreverse progn-acc)
                                               ,form)
                                            form)))
                          let*-acc)))
                 (t
                  (flush)
                  (destructuring-bind (names types form)
                      binding
                    (push `(multiple-value-bind ,names
                               ,form
                             (declare ,@(mapcar (lambda (type name)
                                                  `(type ,type ,name))
                                                types names)
                                      (ignorable ,@names)))
                          forms-acc)))))
      (let ((acc body))
        (dolist (form forms-acc acc)
          (setf acc (append form (list acc))))))))

(defmacro bblock ((&rest bindings) &body body)
  (emit-bblock bindings `(locally ,@body)))

(defstruct load-op
  var idx)

(defstruct store-op
  var idx)

(defun emit-code (ops body)
  (let ((clauses
          (loop for op across ops
                collect
                (etypecase op
                  (op
                   `(,(mapcar #'vval-name (op-writes op))
                     ,(mapcar #'vval-type (op-writes op))
                     (,(op-body op)
                       ,@(mapcar (lambda (x)
                                   (if (vval-p x)
                                       (vval-name x)
                                       x))
                                 (op-args op)))))
                  (load-op
                   (let ((var (load-op-var op)))
                     `((,(vval-name var)) (,(vval-type var))
                       (aref vec (+ start ,(load-op-idx op))))))
{'fraction_non_alphanumeric': 0.13584734211721944, 'fraction_numerical': 0.0011358473421172195, 'mean_word_length': 1.2740185950413223, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 3, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 30, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2296646', 'n_tokens_mistral': 2621, 'n_tokens_neox': 2493, 'n_words': 716}