<commit_before>;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-

;;; Copyright (c) 2009 <NAME>. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package :qt)

(defun binding-for-ctor (method instance)
  (if (typep instance 'dynamic-object)
      (class-binding (class-of instance))
      (data-binding (data-ref (ldb-module (qmethod-class method))))))

;; old-style NEW usage for INITIALIZE-INSTANCE methods kept around for
;; compatibility.
(defun new (instance &rest args)
  (check-type instance dynamic-object)
  (apply #'interpret-new instance args))

(defun interpret-new (class-or-instance &rest args)
  (let ((instance (full-resolve-ctor-this class-or-instance)))
    (funcall (resolve-new instance args) instance args)))

(defun make-symbols (prefix number)
  (loop for i below number
        collect (make-symbol (format nil "~A-~D" prefix i))))

(defun signature-type (object)
  (typecase object
    ((and abstract-qobject (not dynamic-object))
     (qobject-class object))
    (string
     ;; avoid having the length slip into the type
     'string)
    ;; similar issues:
    ((signed-byte 32) '(signed-byte 32))
    ((unsigned-byte 32) '(unsigned-byte 32))
    ((signed-byte 64) '(signed-byte 64))
    ((unsigned-byte 64) '(unsigned-byte 64))
    (t
     (type-of object))))

(defun parse-optimized-call-args (forms)
  (let ((type nil))
    (iter (for form in forms)
          (cond
            ((keywordp form)
             (when type
               (error "Duplicate type specification: ~A / ~A" type form))
             (setf type form))
            (t
             (collect type into types)
             (collect form into clean-forms)
             (setf type nil)))
          (finally
           (return (values types clean-forms))))))

(defun make-optimized (instance method
                       &key instance-resolver args resolver
                            env)
  (flet ((number-of-non-constantp (list)
           (loop for x in list
                 count (not (constantp x env)))))
   (multiple-value-bind (fix-types args) (parse-optimized-call-args args)
     (let ((argsyms (make-symbols 'arg (length args)))
           (sigsyms (make-symbols 'sig (number-of-non-constantp args))))
       `(let* (,@(iter (for arg in args)
                   (for sym in argsyms)
                   (unless (constantp arg env)
                     (collect `(,sym ,arg))))
               (instance ,(funcall instance-resolver instance))
               (method ,method)
               (types ',fix-types)
               (args ,(if (zerop (number-of-non-constantp args))
                          `',args
                          `(list*
                            ,@(loop for (arg . rest) on args
                                    for argsym in argsyms
                                    collect
                                    (if (constantp arg env)
                                        arg
                                        argsym)
                                    if (zerop (number-of-non-constantp rest))
                                    collect `',rest
                                    and
                                    do (loop-finish)))))
               ,@(loop with sigs = sigsyms
                       for arg in args
                       for argsym in argsyms
                       unless (constantp arg env)
                       collect `(,(pop sigs) (signature-type ,argsym))))
          (multiple-value-bind (instance-qclass instance-extra-sig)
              (typecase instance
                (integer
                 (values instance :static))
                (dynamic-object
                 (values (qobject-class instance)
                         (class-generation (class-of instance))))
                (t
                 (values (qobject-class instance) :instance)))
            (cached-values-bind (fun) ,resolver
                ((instance-qclass :hash t)
                 (instance-extra-sig)
                 (method)
                 ,@(loop for sig in sigsyms
                         collect `(,sig :hash sxhash)))
              (funcall fun instance args))))))))

(defmacro optimized-call (allow-override-p instance method &rest args
                          &environment env)
  (make-optimized instance method
    :instance-resolver #'compile-time-resolve-this
    :args args
    :resolver `(resolve-call ,allow-override-p instance method args types)
    :env env))

(defmacro optimized-new (class-or-instance &rest args<commit_msg>make-optimized: Add dynamic-extent declaration for args.<commit_after>;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-

;;; Copyright (c) 2009 <NAME>. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package :qt)

(defun binding-for-ctor (method instance)
  (if (typep instance 'dynamic-object)
      (class-binding (class-of instance))
      (data-binding (data-ref (ldb-module (qmethod-class method))))))

;; old-style NEW usage for INITIALIZE-INSTANCE methods kept around for
;; compatibility.
(defun new (instance &rest args)
  (check-type instance dynamic-object)
  (apply #'interpret-new instance args))

(defun interpret-new (class-or-instance &rest args)
  (let ((instance (full-resolve-ctor-this class-or-instance)))
    (funcall (resolve-new instance args) instance args)))

(defun make-symbols (prefix number)
  (loop for i below number
        collect (make-symbol (format nil "~A-~D" prefix i))))

(defun signature-type (object)
  (typecase object
    ((and abstract-qobject (not dynamic-object))
     (qobject-class object))
    (string
     ;; avoid having the length slip into the type
     'string)
    ;; similar issues:
    ((signed-byte 32) '(signed-byte 32))
    ((unsigned-byte 32) '(unsigned-byte 32))
    ((signed-byte 64) '(signed-byte 64))
    ((unsigned-byte 64) '(unsigned-byte 64))
    (t
     (type-of object))))

(defun parse-optimized-call-args (forms)
  (let ((type nil))
    (iter (for form in forms)
          (cond
            ((keywordp form)
             (when type
               (error "Duplicate type specification: ~A / ~A" type form))
             (setf type form))
            (t
             (collect type into types)
             (collect form into clean-forms)
             (setf type nil)))
          (finally
           (return (values types clean-forms))))))

(defun make-optimized (instance method
                       &key instance-resolver args resolver
                            env)
  (flet ((number-of-non-constantp (list)
           (loop for x in list
                 count (not (constantp x env)))))
   (multiple-value-bind (fix-types args) (parse-optimized-call-args args)
     (let ((argsyms (make-symbols 'arg (length args)))
           (sigsyms (make-symbols 'sig (number-of-non-constantp args))))
       `(let* (,@(iter (for arg in args)
                   (for sym in argsyms)
                   (unless (constantp arg env)
                     (collect `(,sym ,arg))))
               (instance ,(funcall instance-resolver instance))
               (method ,method)
               (types ',fix-types)
               (args ,(if (zerop (number-of-non-constantp args))
                          `',args
                          `(list*
                            ,@(loop for (arg . rest) on args
                                    for argsym in argsyms
                                    collect
                                    (if (constantp arg env)
                                        arg
                                        argsym)
                                    if (zerop (number-of-non-constantp rest))
                                    collect `',rest
                                    and
                                    do (loop-finish)))))
               ,@(loop with sigs = sigsyms
                       for arg in args
                       for argsym in argsyms
                       unless (constantp arg env)
                       collect `(,(pop sigs) (signature-type ,argsym))))
          (declare (dynamic-extent args))
          (multiple-value-bind (instance-qclass instance-extra-sig)
              (typecase instance
                (integer
                 (values instance :static))
                (dynamic-object
                 (values (qobject-class instance)
                         (class-generation (class-of instance))))
                (t
                 (values (qobject-class instance) :instance)))
            (cached-values-bind (fun) ,resolver
                ((instance-qclass :hash t)
                 (instance-extra-sig)
                 (method)
                 ,@(loop for sig in sigsyms
                         collect `(,sig :hash sxhash)))
              (funcall fun instance args))))))))

(defmacro optimized-call (allow-override-p instance method &rest args
                          &environment env)
  (make-optimized instance method
    :instance-resolver #'compile-time-resolve-this
    :args args
    :resolver `(resolve-call ,allow-override-p instance method args types)
    :env env))

(defmacro optimized-new (class-or-instance &rest args
{'fraction_non_alphanumeric': 0.10517757809157038, 'fraction_numerical': 0.0034231921266581087, 'mean_word_length': 1.8990324981394195, 'pattern_counts': {'":': 0, '<': 5, '<?xml version=': 0, '>': 5, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 18, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6772177', 'n_tokens_mistral': 3173, 'n_tokens_neox': 2983, 'n_words': 1077}