Changeset 12420


Ignore:
Timestamp:
02/05/10 23:18:57 (11 years ago)
Author:
astalla
Message:

Tentative inlining of named local function with complex lambda lists;
fixed a bug with inline declarations in a flet block that were incorrectly
applied to local function declared in the flet, too.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

    r12416 r12420  
    4646
    4747(eval-when (:compile-toplevel :load-toplevel :execute)
    48   (defun generate-inline-expansion (block-name lambda-list body)
    49     (cond ((intersection lambda-list
    50                          '(&optional &rest &key &allow-other-keys &aux)
    51                          :test #'eq)
    52            nil)
    53           (t
    54            (setf body (copy-tree body))
    55            (list 'LAMBDA lambda-list
    56                  (list* 'BLOCK block-name body)))))
    57   ) ; EVAL-WHEN
     48  (defun generate-inline-expansion (name lambda-list body
     49            &optional (args nil args-p))
     50    "Generates code that can be used to expand a named local function inline. It can work either per-function (no args provided) or per-call."
     51    (if args-p
     52  (expand-function-call-inline
     53   nil lambda-list
     54   (copy-tree `((block ,name
     55      (locally
     56          (declare (notinline ,name))
     57        ,@body))))
     58   args)
     59  (cond ((intersection lambda-list
     60           '(&optional &rest &key &allow-other-keys &aux)
     61           :test #'eq)
     62         nil)
     63        (t
     64         (setf body (copy-tree body))
     65         (list 'LAMBDA lambda-list
     66         (list* 'BLOCK name body))))))
     67    ) ; EVAL-WHEN
    5868
    5969;;; Pass 1.
     
    235245      (loop
    236246   :for var :in arguments :by #'cddr
    237    :for value :in (cdr arguments) by #'cddr
     247   :for value :in (cdr arguments) :by #'cddr
    238248   :do (let ((var-info (find var key :key #'keyword)))
    239249         (if (and var-info (not (member var already-seen)))
     
    291301      (when rest
    292302  (setf bindings (append bindings `((,(var rest) (list ,@(nreverse args)))))))
    293       (print bindings)
    294303      (values bindings temp-bindings ignorables))))
    295304
     
    305314  (jvm::lambda-list-mismatch (x) (jvm::lambda-list-mismatch-type x)))
    306315||#
     316
     317(defun expand-function-call-inline (form lambda-list body args)
     318  (handler-case
     319      (multiple-value-bind (bindings ignorables)
     320    (match-lambda-list (multiple-value-list
     321            (parse-lambda-list lambda-list))
     322           args)
     323  `(let* ,bindings
     324     (declare (ignorable ,@ignorables))
     325     ,@body))
     326    (lambda-list-mismatch (x)
     327      (compiler-warn "Invalid function call: ~S (mismatch type: ~A)"
     328         form (lambda-list-mismatch-type x))
     329      form)))
    307330
    308331;; Returns a list of declared free specials, if any are found.
     
    888911      form local-functions lambda-list name body
    889912      ((let ((local-function (make-local-function :name name
    890                                                   :compiland compiland)))
     913                                                  :compiland compiland))
     914       (definition (cons lambda-list body)))
    891915   (multiple-value-bind (body decls) (parse-body body)
    892916     (let* ((block-name (fdefinition-block-name name))
    893917      (lambda-expression
    894                    (rewrite-lambda
    895        `(lambda ,lambda-list ,@decls (block ,block-name ,@body))))
     918       (rewrite-lambda `(lambda ,lambda-list ,@decls (block ,block-name ,@body))))
    896919      (*visible-variables* *visible-variables*)
    897920      (*local-functions* *local-functions*)
    898921      (*current-compiland* compiland))
    899922       (setf (compiland-lambda-expression compiland) lambda-expression)
     923       (setf (local-function-definition local-function)
     924       (copy-tree definition))
    900925       (setf (local-function-inline-expansion local-function)
    901926       (generate-inline-expansion block-name lambda-list body))
     
    903928   (push local-function local-functions)))
    904929      ((with-saved-compiler-policy
     930   (let ((inline-decls *inline-declarations*))
    905931     (process-optimization-declarations (cddr form))
    906          (let* ((block (make-flet-node))
    907                 (*blocks* (cons block *blocks*))
    908                 (body (cddr form))
    909                 (*visible-variables* *visible-variables*))
    910            (setf (flet-free-specials block)
    911                  (process-declarations-for-vars body nil block))
    912            (dolist (special (flet-free-specials block))
    913              (push special *visible-variables*))
    914            (setf (flet-form block)
    915                  (list* (car form) local-functions (p1-body (cddr form))))
    916            block)))))
     932     (let* ((block (make-flet-node))
     933      (*blocks* (cons block *blocks*))
     934      (body (cddr form))
     935      (*visible-variables* *visible-variables*))
     936       (setf (flet-free-specials block)
     937       (process-declarations-for-vars body nil block))
     938       (dolist (special (flet-free-specials block))
     939         (push special *visible-variables*))
     940       (setf (flet-form block)
     941       (let ((*inline-declarations* inline-decls))
     942         (list* (car form) local-functions (p1-body (cddr form)))))
     943       block))))))
    917944
    918945
     
    12251252    (if (and (listp op)
    12261253       (eq (car op) 'lambda))
    1227   (handler-case
    1228       (let ((lambda-list
    1229        (multiple-value-list (parse-lambda-list (cadr op))))
    1230       (body (cddr op)))
    1231         (multiple-value-bind (bindings ignorables)
    1232       (match-lambda-list lambda-list args)
    1233     `(let* ,bindings
    1234        (declare (ignorable ,@ignorables))
    1235        ,@body)))
    1236     (lambda-list-mismatch (x)
    1237       (compiler-warn "Invalid function call: ~S (mismatch type: ~A)"
    1238          form (lambda-list-mismatch-type x))
    1239       form))
     1254  (expand-function-call-inline form (cadr op) (cddr op) args)
    12401255  (if (unsafe-p args)
    12411256      (let ((arg1 (car args)))
     
    12741289;;            (format t "inline-p = ~S~%" (inline-p op))
    12751290
    1276            (when (and *enable-inline-expansion* (inline-p op))
    1277              (let ((expansion (local-function-inline-expansion local-function)))
     1291           (when (and *enable-inline-expansion* (inline-p op)
     1292          (local-function-definition local-function))
     1293             (let* ((definition (local-function-definition local-function))
     1294        (lambda-list (car definition))
     1295        (body (cdr definition))
     1296        (expansion (generate-inline-expansion op lambda-list body
     1297                (cdr form))))
    12781298               (when expansion
    12791299                 (let ((explain *explain*))
     
    12811301                     (format t ";   inlining call to local function ~S~%" op)))
    12821302                 (return-from p1-function-call
    1283                    (p1 (expand-inline form expansion))))))
     1303       (p1 expansion)))))
    12841304
    12851305           ;; FIXME
Note: See TracChangeset for help on using the changeset viewer.