org.armedbear.lisp.compiler-pass1.lisp Maven / Gradle / Ivy
Go to download
Show more of this group Show more artifacts with this name
Show all versions of abcl Show documentation
Show all versions of abcl Show documentation
Common Lisp implementation running on the JVM
;;; compiler-pass1.lisp
;;;
;;; Copyright (C) 2003-2008 Peter Graves
;;; $Id: compiler-pass1.lisp 13533 2011-08-23 12:48:24Z ehuelsmann $
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module. An independent module is a module which is not derived from
;;; or based on this library. If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so. If you do not wish to do so, delete this
;;; exception statement from your version.
(in-package "JVM")
(require "LOOP")
(require "FORMAT")
(require "CLOS")
(require "PRINT-OBJECT")
(require "COMPILER-TYPES")
(require "KNOWN-FUNCTIONS")
(require "KNOWN-SYMBOLS")
(require "DUMP-FORM")
(require "OPCODES")
(require "JAVA")
(defun generate-inline-expansion (name lambda-list body
&optional (args nil args-p))
"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."
(if args-p
(expand-function-call-inline nil lambda-list
(copy-tree `((block ,name ,@body)))
args)
(cond ((intersection lambda-list
'(&optional &rest &key &allow-other-keys &aux)
:test #'eq)
nil)
(t
(setf body (copy-tree body))
(list 'LAMBDA lambda-list
(list* 'BLOCK name body))))))
;;; Pass 1.
(defun parse-lambda-list (lambda-list)
"Breaks the lambda list into the different elements, returning the values
required-vars
optional-vars
key-vars
key-p
rest-var
allow-other-keys-p
aux-vars
whole-var
env-var
where each of the vars returned is a list with these elements:
var - the actual variable name
initform - the init form if applicable; optional, keyword and aux vars
p-var - variable indicating presence
keyword - the keyword argument to match against
"
(let ((state :req)
req opt key rest whole env aux key-p allow-others-p)
(dolist (arg lambda-list)
(case arg
(&optional (setf state :opt))
(&key (setf state :key
key-p t))
(&rest (setf state :rest))
(&aux (setf state :aux))
(&allow-other-keys (setf state :none
allow-others-p t))
(&whole (setf state :whole))
(&environment (setf state :env))
(t
(case state
(:req (push arg req))
(:rest (setf rest (list arg)
state :none))
(:env (setf env (list arg)
state :req))
(:whole (setf whole (list arg)
state :req))
(:none
(error "Invalid lambda list: argument found in :none state."))
(:opt
(cond
((symbolp arg)
(push (list arg nil nil nil) opt))
((consp arg)
(push (list (car arg) (cadr arg) (caddr arg)) opt))
(t
(error "Invalid state."))))
(:aux
(cond
((symbolp arg)
(push (list arg nil nil nil) aux))
((consp arg)
(push (list (car arg) (cadr arg) nil nil) aux))
(t
(error "Invalid :aux state."))))
(:key
(cond
((symbolp arg)
(push (list arg nil nil (sys::keywordify arg)) key))
((and (consp arg)
(consp (car arg)))
(push (list (cadar arg) (cadr arg) (caddr arg) (caar arg)) key))
((consp arg)
(push (list (car arg) (cadr arg) (caddr arg)
(sys::keywordify (car arg))) key))
(t
(error "Invalid :key state."))))
(t (error "Invalid state found."))))))
(values
(nreverse req)
(nreverse opt)
(nreverse key)
key-p
rest allow-others-p
(nreverse aux) whole env)))
(define-condition lambda-list-mismatch (error)
((mismatch-type :reader lambda-list-mismatch-type :initarg :mismatch-type)))
(defmacro push-argument-binding (var form temp-bindings bindings)
(let ((g (gensym)))
`(let ((,g (gensym (symbol-name '#:temp))))
(push (list ,g ,form) ,temp-bindings)
(push (list ,var ,g) ,bindings))))
(defun match-lambda-list (parsed-lambda-list arguments)
(flet ((pop-required-argument ()
(if (null arguments)
(error 'lambda-list-mismatch :mismatch-type :too-few-arguments)
(pop arguments)))
(var (var-info) (car var-info))
(initform (var-info) (cadr var-info))
(p-var (var-info) (caddr var-info)))
(destructuring-bind (req opt key key-p rest allow-others-p aux whole env)
parsed-lambda-list
(declare (ignore whole env))
(let (req-bindings temp-bindings bindings ignorables)
;;Required arguments.
(setf req-bindings
(loop :for var :in req :collect `(,var ,(pop-required-argument))))
;;Optional arguments.
(when opt
(dolist (var-info opt)
(if arguments
(progn
(push-argument-binding (var var-info) (pop arguments)
temp-bindings bindings)
(when (p-var var-info)
(push `(,(p-var var-info) t) bindings)))
(progn
(push `(,(var var-info) ,(initform var-info)) bindings)
(when (p-var var-info)
(push `(,(p-var var-info) nil) bindings)))))
(setf bindings (nreverse bindings)))
(unless (or key-p rest (null arguments))
(error 'lambda-list-mismatch :mismatch-type :too-many-arguments))
;;Keyword and rest arguments.
(if key-p
(multiple-value-bind (kbindings ktemps kignor)
(match-keyword-and-rest-args
key allow-others-p rest arguments)
(setf bindings (append bindings kbindings)
temp-bindings (append temp-bindings ktemps)
ignorables (append kignor ignorables)))
(when rest
(let (rest-binding)
(push-argument-binding (var rest) `(list ,@arguments)
temp-bindings rest-binding)
(setf bindings (append bindings rest-binding)))))
;;Aux parameters.
(when aux
(setf bindings
`(,@bindings
,@(loop
:for var-info :in aux
:collect `(,(var var-info) ,(initform var-info))))))
(values (append req-bindings temp-bindings bindings)
ignorables)))))
(defun match-keyword-and-rest-args (key allow-others-p rest arguments)
(flet ((var (var-info) (car var-info))
(initform (var-info) (cadr var-info))
(p-var (var-info) (caddr var-info))
(keyword (var-info) (cadddr var-info)))
(when (oddp (list-length arguments))
(error 'lambda-list-mismatch
:mismatch-type :odd-number-of-keyword-arguments))
(let (temp-bindings bindings other-keys-found-p ignorables already-seen
args)
;;If necessary, make up a fake argument to hold :allow-other-keys,
;;needed later. This also handles nicely:
;; 3.4.1.4.1 Suppressing Keyword Argument Checking
;;third statement.
(unless (find :allow-other-keys key :key #'keyword)
(let ((allow-other-keys-temp (gensym (symbol-name :allow-other-keys))))
(push allow-other-keys-temp ignorables)
(push (list allow-other-keys-temp nil nil :allow-other-keys) key)))
;;First, let's bind the keyword arguments that have been passed by
;;the caller. If we encounter an unknown keyword, remember it.
;;As per the above, :allow-other-keys will never be considered
;;an unknown keyword.
(loop
:for var :in arguments :by #'cddr
:for value :in (cdr arguments) :by #'cddr
:do (let ((var-info (find var key :key #'keyword)))
(if (and var-info (not (member var already-seen)))
;;var is one of the declared keyword arguments
(progn
(push-argument-binding (var var-info) value
temp-bindings bindings)
(when (p-var var-info)
(push `(,(p-var var-info) t) bindings))
(push var args)
(push (var var-info) args)
(push var already-seen))
(let ((g (gensym)))
(push `(,g ,value) temp-bindings)
(push var args)
(push g args)
(push g ignorables)
(unless var-info
(setf other-keys-found-p t))))))
;;Then, let's bind those arguments that haven't been passed in
;;to their default value, in declaration order.
(let (defaults)
(loop
:for var-info :in key
:do (unless (find (var var-info) bindings :key #'car)
(push `(,(var var-info) ,(initform var-info)) defaults)
(when (p-var var-info)
(push `(,(p-var var-info) nil) defaults))))
(setf bindings (append (nreverse defaults) bindings)))
;;If necessary, check for unrecognized keyword arguments.
(when (and other-keys-found-p (not allow-others-p))
(if (loop
:for var :in arguments :by #'cddr
:if (eq var :allow-other-keys)
:do (return t))
;;We know that :allow-other-keys has been passed, so we
;;can access the binding for it and be sure to get the
;;value passed by the user and not an initform.
(let* ((arg (var (find :allow-other-keys key :key #'keyword)))
(binding (find arg bindings :key #'car))
(form (cadr binding)))
(if (constantp form)
(unless (eval form)
(error 'lambda-list-mismatch
:mismatch-type :unknown-keyword))
(setf (cadr binding)
`(or ,(cadr binding)
(error 'program-error
"Unrecognized keyword argument")))))
;;TODO: it would be nice to report *which* keyword
;;is unknown
(error 'lambda-list-mismatch :mismatch-type :unknown-keyword)))
(when rest
(setf bindings (append bindings `((,(var rest) (list ,@(nreverse args)))))))
(values bindings temp-bindings ignorables))))
#||test for the above
(handler-case
(let ((lambda-list
(multiple-value-list
(jvm::parse-lambda-list
'(a b &optional (c 42) &rest foo &key (bar c) baz ((kaz kuz) bar))))))
(jvm::match-lambda-list
lambda-list
'((print 1) 3 (print 32) :bar 2)))
(jvm::lambda-list-mismatch (x) (jvm::lambda-list-mismatch-type x)))
||#
(defun expand-function-call-inline (form lambda-list body args)
(handler-case
(multiple-value-bind (bindings ignorables)
(match-lambda-list (multiple-value-list
(parse-lambda-list lambda-list))
args)
`(let* ,bindings
,@(when ignorables
`((declare (ignorable ,@ignorables))))
,@body))
(lambda-list-mismatch (x)
(compiler-warn "Invalid function call: ~S (mismatch type: ~A)"
form (lambda-list-mismatch-type x))
form)))
;; Returns a list of declared free specials, if any are found.
(declaim (ftype (function (list list block-node) list)
process-declarations-for-vars))
(defun process-declarations-for-vars (body variables block)
(let ((free-specials '()))
(dolist (subform body)
(unless (and (consp subform) (eq (%car subform) 'DECLARE))
(return))
(let ((decls (%cdr subform)))
(dolist (decl decls)
(case (car decl)
((DYNAMIC-EXTENT FTYPE INLINE NOTINLINE OPTIMIZE)
;; Nothing to do here.
)
((IGNORE IGNORABLE)
(process-ignore/ignorable (%car decl) (%cdr decl) variables))
(SPECIAL
(dolist (name (%cdr decl))
(let ((variable (find-variable name variables)))
(cond ((and variable
;; see comment below (and DO-ALL-SYMBOLS.11)
(eq (variable-compiland variable)
*current-compiland*))
(setf (variable-special-p variable) t))
(t
(dformat t "adding free special ~S~%" name)
(push (make-variable :name name :special-p t
:block block)
free-specials))))))
(TYPE
(dolist (name (cddr decl))
(let ((variable (find-variable name variables)))
(when (and variable
;; Don't apply a declaration in a local function to
;; a variable defined in its parent. For an example,
;; see CREATE-GREEDY-NO-ZERO-MATCHER in cl-ppcre.
;; FIXME suboptimal, since we ignore the declaration
(eq (variable-compiland variable)
*current-compiland*))
(setf (variable-declared-type variable)
(make-compiler-type (cadr decl)))))))
(t
(dolist (name (cdr decl))
(let ((variable (find-variable name variables)))
(when variable
(setf (variable-declared-type variable)
(make-compiler-type (%car decl)))))))))))
free-specials))
(defun check-name (name)
;; FIXME Currently this error is signalled by the precompiler.
(unless (symbolp name)
(compiler-error "The variable ~S is not a symbol." name))
(when (constantp name)
(compiler-error "The name of the variable ~S is already in use to name a constant." name))
name)
(declaim (ftype (function (t) t) p1-body))
(defun p1-body (body)
(declare (optimize speed))
(let ((tail body))
(loop
(when (endp tail)
(return))
(setf (car tail) (p1 (%car tail)))
(setf tail (%cdr tail))))
body)
(defknown p1-default (t) t)
(declaim (inline p1-default))
(defun p1-default (form)
(setf (cdr form) (p1-body (cdr form)))
form)
(defmacro p1-let/let*-vars
(block varlist variables-var var body1 body2)
(let ((varspec (gensym))
(initform (gensym))
(name (gensym)))
`(let ((,variables-var ()))
(dolist (,varspec ,varlist)
(cond ((consp ,varspec)
;; Even though the precompiler already signals this
;; error, double checking can't hurt; after all, we're
;; also rewriting &AUX into LET* bindings.
(unless (<= 1 (length ,varspec) 2)
(compiler-error "The LET/LET* binding specification ~S is invalid."
,varspec))
(let* ((,name (%car ,varspec))
(,initform (p1 (%cadr ,varspec)))
(,var (make-variable :name (check-name ,name)
:initform ,initform
:block ,block)))
(when (neq ,initform (cadr ,varspec))
(setf (cadr ,varspec) ,initform))
(push ,var ,variables-var)
,@body1))
(t
(let ((,var (make-variable :name (check-name ,varspec)
:block ,block)))
(push ,var ,variables-var)
,@body1))))
,@body2)))
(defknown p1-let-vars (t) t)
(defun p1-let-vars (block varlist)
(p1-let/let*-vars block
varlist vars var
()
((setf vars (nreverse vars))
(dolist (variable vars)
(push variable *visible-variables*)
(push variable *all-variables*))
vars)))
(defknown p1-let*-vars (t) t)
(defun p1-let*-vars (block varlist)
(p1-let/let*-vars block
varlist vars var
((push var *visible-variables*)
(push var *all-variables*))
((nreverse vars))))
(defun p1-let/let* (form)
(declare (type cons form))
(let* ((*visible-variables* *visible-variables*)
(block (make-let/let*-node))
(*block* block)
(op (%car form))
(varlist (cadr form))
(body (cddr form)))
(aver (or (eq op 'LET) (eq op 'LET*)))
(when (eq op 'LET)
;; Convert to LET* if possible.
(if (null (cdr varlist))
(setf op 'LET*)
(dolist (varspec varlist (setf op 'LET*))
(or (atom varspec)
(constantp (cadr varspec))
(eq (car varspec) (cadr varspec))
(return)))))
(let ((vars (if (eq op 'LET)
(p1-let-vars block varlist)
(p1-let*-vars block varlist))))
;; Check for globally declared specials.
(dolist (variable vars)
(when (special-variable-p (variable-name variable))
(setf (variable-special-p variable) t
(let-environment-register block) t)))
;; For processing declarations, we want to walk the variable list from
;; last to first, since declarations apply to the last-defined variable
;; with the specified name.
(setf (let-free-specials block)
(process-declarations-for-vars body (reverse vars) block))
(setf (let-vars block) vars)
;; Make free specials visible.
(dolist (variable (let-free-specials block))
(push variable *visible-variables*)))
(let ((*blocks* (cons block *blocks*)))
(setf body (p1-body body)))
(setf (let-form block) (list* op varlist body))
block))
(defun p1-locally (form)
(let* ((*visible-variables* *visible-variables*)
(block (make-locally-node))
(*block* block)
(free-specials (process-declarations-for-vars (cdr form) nil block)))
(setf (locally-free-specials block) free-specials)
(dolist (special free-specials)
;; (format t "p1-locally ~S is special~%" name)
(push special *visible-variables*))
(let ((*blocks* (cons block *blocks*)))
(setf (locally-form block)
(list* 'LOCALLY (p1-body (cdr form))))
block)))
(defknown p1-m-v-b (t) t)
(defun p1-m-v-b (form)
(when (= (length (cadr form)) 1)
(let ((new-form `(let* ((,(caadr form) ,(caddr form))) ,@(cdddr form))))
(return-from p1-m-v-b (p1-let/let* new-form))))
(let* ((*visible-variables* *visible-variables*)
(block (make-m-v-b-node))
(*block* block)
(varlist (cadr form))
;; Process the values-form first. ("The scopes of the name binding and
;; declarations do not include the values-form.")
(values-form (p1 (caddr form)))
(*blocks* (cons block *blocks*))
(body (cdddr form)))
(let ((vars ()))
(dolist (symbol varlist)
(let ((var (make-variable :name symbol :block block)))
(push var vars)
(push var *visible-variables*)
(push var *all-variables*)))
;; Check for globally declared specials.
(dolist (variable vars)
(when (special-variable-p (variable-name variable))
(setf (variable-special-p variable) t
(m-v-b-environment-register block) t)))
(setf (m-v-b-free-specials block)
(process-declarations-for-vars body vars block))
(dolist (special (m-v-b-free-specials block))
(push special *visible-variables*))
(setf (m-v-b-vars block) (nreverse vars)))
(setf body (p1-body body))
(setf (m-v-b-form block)
(list* 'MULTIPLE-VALUE-BIND varlist values-form body))
block))
(defun p1-block (form)
(let* ((block (make-block-node (cadr form)))
(*block* block)
(*blocks* (cons block *blocks*)))
(setf (cddr form) (p1-body (cddr form)))
(setf (block-form block) form)
(when (block-non-local-return-p block)
;; Add a closure variable for RETURN-FROM to use
(push (setf (block-id-variable block)
(make-variable :name (gensym)
:block block
:used-non-locally-p t))
*all-variables*))
block))
(defun p1-catch (form)
(let* ((tag (p1 (cadr form)))
(body (cddr form))
(block (make-catch-node))
(*block* block)
;; our subform processors need to know
;; they're enclosed in a CATCH block
(*blocks* (cons block *blocks*))
(result '()))
(dolist (subform body)
(let ((op (and (consp subform) (%car subform))))
(push (p1 subform) result)
(when (memq op '(GO RETURN-FROM THROW))
(return))))
(setf result (nreverse result))
(when (and (null (cdr result))
(consp (car result))
(eq (caar result) 'GO))
(return-from p1-catch (car result)))
(push tag result)
(push 'CATCH result)
(setf (catch-form block) result)
block))
(defun p1-threads-synchronized-on (form)
(let* ((synchronized-object (p1 (cadr form)))
(body (cddr form))
(block (make-synchronized-node))
(*block* block)
(*blocks* (cons block *blocks*))
result)
(dolist (subform body)
(let ((op (and (consp subform) (%car subform))))
(push (p1 subform) result)
(when (memq op '(GO RETURN-FROM THROW))
(return))))
(setf (synchronized-form block)
(list* 'threads:synchronized-on synchronized-object
(nreverse result)))
block))
(defun p1-unwind-protect (form)
(if (= (length form) 2)
(p1 (second form)) ; No cleanup forms: (unwind-protect (...)) => (...)
;; in order to compile the cleanup forms twice (see
;; p2-unwind-protect-node), we need to p1 them twice; p1 outcomes
;; can be compiled (in the same compiland?) only once.
;;
;; However, p1 transforms the forms being processed, so, we
;; need to copy the forms to create a second copy.
(let* ((block (make-unwind-protect-node))
(*block* block)
;; a bit of jumping through hoops...
(unwinding-forms (p1-body (copy-tree (cddr form))))
(unprotected-forms (p1-body (cddr form)))
;; ... because only the protected form is
;; protected by the UNWIND-PROTECT block
(*blocks* (cons block *blocks*))
(protected-form (p1 (cadr form))))
(setf (unwind-protect-form block)
`(unwind-protect ,protected-form
(progn ,@unwinding-forms)
,@unprotected-forms))
block)))
(defknown p1-return-from (t) t)
(defun p1-return-from (form)
(let* ((name (second form))
(block (find-block name))
non-local-p)
(when (null block)
(compiler-error "RETURN-FROM ~S: no block named ~S is currently visible."
name name))
(dformat t "p1-return-from block = ~S~%" (block-name block))
(cond ((eq (block-compiland block) *current-compiland*)
;; Local case. If the RETURN is nested inside an UNWIND-PROTECT
;; which is inside the block we're returning from, we'll do a non-
;; local return anyway so that UNWIND-PROTECT can catch it and run
;; its cleanup forms.
;;(dformat t "*blocks* = ~S~%" (mapcar #'node-name *blocks*))
(let ((protected (enclosed-by-protected-block-p block)))
(dformat t "p1-return-from protected = ~S~%" protected)
(if protected
(setf (block-non-local-return-p block) t
non-local-p t)
;; non-local GO's ensure environment restoration
;; find out about this local GO
(when (null (block-needs-environment-restoration block))
(setf (block-needs-environment-restoration block)
(enclosed-by-environment-setting-block-p block))))))
(t
(setf (block-non-local-return-p block) t
non-local-p t)))
(when (block-non-local-return-p block)
(dformat t "non-local return from block ~S~%" (block-name block)))
(let ((value-form (p1 (caddr form))))
(push value-form (block-return-value-forms block))
(make-jump-node (list 'RETURN-FROM name value-form)
non-local-p block))))
(defun p1-tagbody (form)
(let* ((block (make-tagbody-node))
(*block* block)
(*blocks* (cons block *blocks*))
(*visible-tags* *visible-tags*)
(local-tags '())
(body (cdr form)))
;; Make all the tags visible before processing the body forms.
(dolist (subform body)
(when (or (symbolp subform) (integerp subform))
(let* ((tag (make-tag :name subform :label (gensym) :block block)))
(push tag local-tags)
(push tag *visible-tags*))))
(let ((new-body '())
(live t))
(dolist (subform body)
(cond ((or (symbolp subform) (integerp subform))
(push subform new-body)
(push (find subform local-tags :key #'tag-name :test #'eql)
(tagbody-tags block))
(setf live t))
((not live)
;; Nothing to do.
)
(t
(when (and (consp subform)
(memq (%car subform) '(GO RETURN-FROM THROW)))
;; Subsequent subforms are unreachable until we see another
;; tag.
(setf live nil))
(push (p1 subform) new-body))))
(setf (tagbody-form block) (list* 'TAGBODY (nreverse new-body))))
(when (some #'tag-used-non-locally (tagbody-tags block))
(push (setf (tagbody-id-variable block)
(make-variable :name (gensym)
:block block
:used-non-locally-p t))
*all-variables*))
block))
(defknown p1-go (t) t)
(defun p1-go (form)
(let* ((name (cadr form))
(tag (find-tag name)))
(unless tag
(error "p1-go: tag not found: ~S" name))
(setf (tag-used tag) t)
(let ((tag-block (tag-block tag))
non-local-p)
(cond ((eq (tag-compiland tag) *current-compiland*)
;; Does the GO leave an enclosing UNWIND-PROTECT or CATCH?
(if (enclosed-by-protected-block-p tag-block)
(setf (tagbody-non-local-go-p tag-block) t
(tag-used-non-locally tag) t
non-local-p t)
;; non-local GO's ensure environment restoration
;; find out about this local GO
(when (null (tagbody-needs-environment-restoration tag-block))
(setf (tagbody-needs-environment-restoration tag-block)
(enclosed-by-environment-setting-block-p tag-block)))))
(t
(setf (tagbody-non-local-go-p tag-block) t
(tag-used-non-locally tag) t
non-local-p t)))
(make-jump-node form non-local-p tag-block tag))))
(defun split-decls (forms specific-vars)
(let ((other-decls nil)
(specific-decls nil))
(dolist (form forms)
(unless (and (consp form) (eq (car form) 'DECLARE)) ; shouldn't happen
(return))
(dolist (decl (cdr form))
(case (car decl)
((OPTIMIZE DECLARATION DYNAMIC-EXTENT FTYPE INLINE NOTINLINE)
(push (list 'DECLARE decl) other-decls))
(SPECIAL
(dolist (name (cdr decl))
(if (memq name specific-vars)
(push `(DECLARE (SPECIAL ,name)) specific-decls)
(push `(DECLARE (SPECIAL ,name)) other-decls))))
(TYPE
(dolist (name (cddr decl))
(if (memq name specific-vars)
(push `(DECLARE (TYPE ,(cadr decl) ,name)) specific-decls)
(push `(DECLARE (TYPE ,(cadr decl) ,name)) other-decls))))
(t
(dolist (name (cdr decl))
(if (memq name specific-vars)
(push `(DECLARE (,(car decl) ,name)) specific-decls)
(push `(DECLARE (,(car decl) ,name)) other-decls)))))))
(values (nreverse other-decls)
(nreverse specific-decls))))
(defun rewrite-aux-vars (form)
(let* ((lambda-list (cadr form))
(aux-p (memq '&AUX lambda-list))
(lets (cdr aux-p))
aux-vars)
(unless aux-p
;; no rewriting required
(return-from rewrite-aux-vars form))
(multiple-value-bind (body decls)
(parse-body (cddr form))
(dolist (form lets)
(cond ((consp form)
(push (car form) aux-vars))
(t
(push form aux-vars))))
(setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
(multiple-value-bind (let-decls lambda-decls)
(split-decls decls (lambda-list-names lambda-list))
`(lambda ,lambda-list
,@lambda-decls
(let* ,lets
,@let-decls
,@body))))))
(defun rewrite-lambda (form)
(setf form (rewrite-aux-vars form))
(let* ((lambda-list (cadr form)))
(if (not (or (memq '&optional lambda-list)
(memq '&key lambda-list)))
;; no need to rewrite: no arguments with possible initforms anyway
form
(multiple-value-bind (body decls doc)
(parse-body (cddr form))
(let (state let-bindings new-lambda-list
(non-constants 0))
(do* ((vars lambda-list (cdr vars))
(var (car vars) (car vars)))
((endp vars))
(push (car vars) new-lambda-list)
(let ((replacement (gensym)))
(flet ((parse-compound-argument (arg)
"Returns the values NAME, KEYWORD, INITFORM, INITFORM-P,
SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument."
(destructuring-bind
(name &optional (initform nil initform-supplied-p)
(supplied-p nil supplied-p-supplied-p))
(if (listp arg) arg (list arg))
(if (listp name)
(values (cadr name) (car name)
initform initform-supplied-p
supplied-p supplied-p-supplied-p)
(values name (make-keyword name)
initform initform-supplied-p
supplied-p supplied-p-supplied-p)))))
(case var
(&optional (setf state :optional))
(&key (setf state :key))
((&whole &environment &rest &body &allow-other-keys)
;; do nothing special
)
(t
(cond
((atom var)
(setf (car new-lambda-list)
(if (eq state :key)
(list (list (make-keyword var) replacement))
replacement))
(push (list var replacement) let-bindings))
((constantp (second var))
;; so, we must have a consp-type var we're looking at
;; and it has a constantp initform
(multiple-value-bind
(name keyword initform initform-supplied-p
supplied-p supplied-p-supplied-p)
(parse-compound-argument var)
(let ((var-form (if (eq state :key)
(list keyword replacement)
replacement))
(supplied-p-replacement (gensym)))
(setf (car new-lambda-list)
(cond
((not initform-supplied-p)
(list var-form))
((not supplied-p-supplied-p)
(list var-form initform))
(t
(list var-form initform
supplied-p-replacement))))
(push (list name replacement) let-bindings)
;; if there was a 'supplied-p' variable, it might
;; be used in the declarations. Since those will be
;; moved below the LET* block, we need to move the
;; supplied-p parameter too.
(when supplied-p-supplied-p
(push (list supplied-p supplied-p-replacement)
let-bindings)))))
(t
(incf non-constants)
;; this is either a keyword or an optional argument
;; with a non-constantp initform
(multiple-value-bind
(name keyword initform initform-supplied-p
supplied-p supplied-p-supplied-p)
(parse-compound-argument var)
(declare (ignore initform-supplied-p))
(let ((var-form (if (eq state :key)
(list keyword replacement)
replacement))
(supplied-p-replacement (gensym)))
(setf (car new-lambda-list)
(list var-form nil supplied-p-replacement))
(push (list name `(if ,supplied-p-replacement
,replacement ,initform))
let-bindings)
(when supplied-p-supplied-p
(push (list supplied-p supplied-p-replacement)
let-bindings)))))))))))
(if (zerop non-constants)
;; there was no reason to rewrite...
form
(let ((rv
`(lambda ,(nreverse new-lambda-list)
,@(when doc (list doc))
(let* ,(nreverse let-bindings)
,@decls ,@body))))
rv)))))))
(defun validate-function-name (name)
(unless (or (symbolp name) (setf-function-name-p name))
(compiler-error "~S is not a valid function name." name))
name)
(defun construct-flet/labels-function (definition)
(let* ((name (car definition))
(block-name (fdefinition-block-name (validate-function-name name)))
(lambda-list (cadr definition))
(compiland (make-compiland :name name :parent *current-compiland*))
(local-function (make-local-function :name name :compiland compiland)))
(push local-function (compiland-children *current-compiland*))
(multiple-value-bind
(body decls)
(parse-body (cddr definition))
(setf (local-function-definition local-function)
(copy-tree (cdr definition)))
(setf (compiland-lambda-expression compiland)
(rewrite-lambda `(lambda ,lambda-list
,@decls
(block ,block-name
,@body)))))
local-function))
(defun p1-flet (form)
(let* ((local-functions
(mapcar #'(lambda (definition)
(construct-flet/labels-function definition))
(cadr form)))
(*local-functions* *local-functions*))
(dolist (local-function local-functions)
(p1-compiland (local-function-compiland local-function)))
(dolist (local-function local-functions)
(push local-function *local-functions*))
(with-saved-compiler-policy
(process-optimization-declarations (cddr form))
(let* ((block (make-flet-node))
(*block* block)
(*blocks* (cons block *blocks*))
(body (cddr form))
(*visible-variables* *visible-variables*))
(setf (flet-free-specials block)
(process-declarations-for-vars body nil block))
(dolist (special (flet-free-specials block))
(push special *visible-variables*))
(setf body (p1-body body) ;; affects the outcome of references-needed-p
(flet-form block)
(list* (car form)
(remove-if #'(lambda (fn)
(and (inline-p (local-function-name fn))
(not (local-function-references-needed-p fn))))
local-functions)
body))
block))))
(defun p1-labels (form)
(let* ((local-functions
(mapcar #'(lambda (definition)
(construct-flet/labels-function definition))
(cadr form)))
(*local-functions* *local-functions*)
(*visible-variables* *visible-variables*))
(dolist (local-function local-functions)
(push local-function *local-functions*))
(dolist (local-function local-functions)
(p1-compiland (local-function-compiland local-function)))
(let* ((block (make-labels-node))
(*block* block)
(*blocks* (cons block *blocks*))
(body (cddr form))
(*visible-variables* *visible-variables*))
(setf (labels-free-specials block)
(process-declarations-for-vars body nil block))
(dolist (special (labels-free-specials block))
(push special *visible-variables*))
(setf (labels-form block)
(list* (car form) local-functions (p1-body (cddr form))))
block)))
(defknown p1-funcall (t) t)
(defun p1-funcall (form)
(unless (> (length form) 1)
(compiler-warn "Wrong number of arguments for ~A." (car form))
(return-from p1-funcall form))
(let ((function-form (%cadr form)))
(when (and (consp function-form)
(eq (%car function-form) 'FUNCTION))
(let ((name (%cadr function-form)))
;; (format t "p1-funcall name = ~S~%" name)
(let ((source-transform (source-transform name)))
(when source-transform
;; (format t "found source transform for ~S~%" name)
;; (format t "old form = ~S~%" form)
;; (let ((new-form (expand-source-transform form)))
;; (when (neq new-form form)
;; (format t "new form = ~S~%" new-form)
;; (return-from p1-funcall (p1 new-form))))
(let ((new-form (expand-source-transform (list* name (cddr form)))))
;; (format t "new form = ~S~%" new-form)
(return-from p1-funcall (p1 new-form)))
)))))
;; Otherwise...
(p1-function-call form))
(defun p1-function (form)
(let ((form (copy-tree form))
local-function)
(cond ((and (consp (cadr form))
(or (eq (caadr form) 'LAMBDA)
(eq (caadr form) 'NAMED-LAMBDA)))
(let* ((named-lambda-p (eq (caadr form) 'NAMED-LAMBDA))
(named-lambda-form (when named-lambda-p
(cadr form)))
(name (when named-lambda-p
(cadr named-lambda-form)))
(lambda-form (if named-lambda-p
(cons 'LAMBDA (cddr named-lambda-form))
(cadr form)))
(lambda-list (cadr lambda-form))
(body (cddr lambda-form))
(compiland (make-compiland :name (if named-lambda-p
name (gensym "ANONYMOUS-LAMBDA-"))
:lambda-expression lambda-form
:parent *current-compiland*))
(local-function (make-local-function :compiland compiland)))
(push local-function (compiland-children *current-compiland*))
(multiple-value-bind (body decls)
(parse-body body)
(setf (compiland-lambda-expression compiland)
;; if there still was a doc-string present, remove it
(rewrite-lambda
`(lambda ,lambda-list ,@decls ,@body)))
(let ((*visible-variables* *visible-variables*)
(*current-compiland* compiland))
(p1-compiland compiland)))
(list 'FUNCTION local-function)))
((setf local-function (find-local-function (cadr form)))
(dformat "p1-function local function ~S~%" (cadr form))
;;we found out that the function needs a reference
(setf (local-function-references-needed-p local-function) t)
form)
(t
form))))
(defun p1-lambda (form)
(setf form (rewrite-lambda form))
(let* ((lambda-list (cadr form)))
(when (or (memq '&optional lambda-list)
(memq '&key lambda-list))
(let ((state nil))
(dolist (arg lambda-list)
(cond ((memq arg lambda-list-keywords)
(setf state arg))
((memq state '(&optional &key))
(when (and (consp arg)
(not (constantp (second arg))))
(compiler-unsupported
"P1-LAMBDA: can't handle optional argument with non-constant initform.")))))))
(p1-function (list 'FUNCTION form))))
(defun p1-eval-when (form)
(list* (car form) (cadr form) (mapcar #'p1 (cddr form))))
(defknown p1-progv (t) t)
(defun p1-progv (form)
;; We've already checked argument count in PRECOMPILE-PROGV.
(let* ((symbols-form (p1 (cadr form)))
(values-form (p1 (caddr form)))
(block (make-progv-node))
(*block* block)
(*blocks* (cons block *blocks*))
(body (cdddr form)))
;; The (commented out) block below means to detect compile-time
;; enumeration of bindings to be created (a quoted form in the symbols
;; position).
;; (when (and (quoted-form-p symbols-form)
;; (listp (second symbols-form)))
;; (dolist (name (second symbols-form))
;; (let ((variable (make-variable :name name :special-p t)))
;; (push
(setf (progv-environment-register block) t
(progv-form block)
`(progv ,symbols-form ,values-form ,@(p1-body body)))
block))
(defun p1-quote (form)
(unless (= (length form) 2)
(compiler-error "Wrong number of arguments for special operator ~A (expected 1, but received ~D)."
'QUOTE
(1- (length form))))
(let ((arg (%cadr form)))
(if (or (numberp arg) (characterp arg))
arg
form)))
(defun p1-setq (form)
(unless (= (length form) 3)
(error "Too many arguments for SETQ."))
(let ((arg1 (%cadr form))
(arg2 (%caddr form)))
(let ((variable (find-visible-variable arg1)))
(if variable
(progn
(when (variable-ignore-p variable)
(compiler-style-warn
"Variable ~S is assigned even though it was declared to be ignored."
(variable-name variable)))
(incf (variable-writes variable))
(cond ((eq (variable-compiland variable) *current-compiland*)
(dformat t "p1-setq: write ~S~%" arg1))
(t
(dformat t "p1-setq: non-local write ~S~%" arg1)
(setf (variable-used-non-locally-p variable) t))))
(dformat t "p1-setq: unknown variable ~S~%" arg1)))
(list 'SETQ arg1 (p1 arg2))))
(defun p1-the (form)
(unless (= (length form) 3)
(compiler-error "Wrong number of arguments for special operator ~A (expected 2, but received ~D)."
'THE
(1- (length form))))
(let ((type (%cadr form))
(expr (%caddr form)))
(cond ((and (listp type) (eq (car type) 'VALUES))
;; FIXME
(p1 expr))
((= *safety* 3)
(let* ((sym (gensym))
(new-expr `(let ((,sym ,expr))
(require-type ,sym ',type)
,sym)))
(p1 new-expr)))
((and (<= 1 *safety* 2) ;; at safety 1 or 2 check relatively
(symbolp type)) ;; simple types (those specified by a single symbol)
(let* ((sym (gensym))
(new-expr `(let ((,sym ,expr))
(require-type ,sym ',type)
,sym)))
(p1 new-expr)))
(t
(list 'THE type (p1 expr))))))
(defun p1-truly-the (form)
(unless (= (length form) 3)
(compiler-error "Wrong number of arguments for special operator ~A (expected 2, but received ~D)."
'TRULY-THE
(1- (length form))))
(list 'TRULY-THE (%cadr form) (p1 (%caddr form))))
(defknown p1-throw (t) t)
(defun p1-throw (form)
(list* 'THROW (mapcar #'p1 (cdr form))))
(defknown rewrite-function-call (t) t)
(defun rewrite-function-call (form)
(let ((op (car form)) (args (cdr form)))
(cond
((and (eq op 'funcall) (listp (car args)) (eq (caar args) 'lambda))
;;(funcall (lambda (...) ...) ...)
(let ((op (car args)) (args (cdr args)))
(expand-function-call-inline form (cadr op) (copy-tree (cddr op))
args)))
((and (listp op) (eq (car op) 'lambda))
;;((lambda (...) ...) ...)
(expand-function-call-inline form (cadr op) (copy-tree (cddr op)) args))
(t form))))
(defknown p1-function-call (t) t)
(defun p1-function-call (form)
(let ((new-form (rewrite-function-call form)))
(when (neq new-form form)
(return-from p1-function-call (p1 new-form))))
(let* ((op (car form))
(local-function (find-local-function op)))
(when local-function
;; (format t "p1 local call to ~S~%" op)
;; (format t "inline-p = ~S~%" (inline-p op))
(when (and *enable-inline-expansion* (inline-p op)
(local-function-definition local-function))
(let* ((definition (local-function-definition local-function))
(lambda-list (car definition))
(body (cdr definition))
(expansion (generate-inline-expansion op lambda-list body
(cdr form))))
(when expansion
(let ((explain *explain*))
(when (and explain (memq :calls explain))
(format t "; inlining call to local function ~S~%" op)))
(return-from p1-function-call
(let ((*inline-declarations*
(remove op *inline-declarations* :key #'car :test #'equal)))
(p1 expansion))))))))
(p1-default form))
(defun %funcall (fn &rest args)
"Dummy FUNCALL wrapper to force p1 not to optimize the call."
(apply fn args))
(defun p1-variable-reference (var)
(let ((variable (find-visible-variable var)))
(when (null variable)
(unless (or (special-variable-p var)
(memq var *undefined-variables*))
(compiler-style-warn
"Undefined variable ~S assumed special" var)
(push var *undefined-variables*))
(setf variable (make-variable :name var :special-p t))
(push variable *visible-variables*))
(let ((ref (make-var-ref variable)))
(unless (variable-special-p variable)
(when (variable-ignore-p variable)
(compiler-style-warn
"Variable ~S is read even though it was declared to be ignored."
(variable-name variable)))
(push ref (variable-references variable))
(incf (variable-reads variable))
(cond
((eq (variable-compiland variable) *current-compiland*)
(dformat t "p1: read ~S~%" var))
(t
(dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%"
var
(compiland-name (variable-compiland variable))
(compiland-name *current-compiland*))
(setf (variable-used-non-locally-p variable) t))))
ref)))
(defknown p1 (t) t)
(defun p1 (form)
(cond
((symbolp form)
(let (value)
(cond
((null form)
form)
((eq form t)
form)
((keywordp form)
form)
((and (constantp form)
(progn
(setf value (symbol-value form))
(or (numberp value)
(stringp value)
(pathnamep value))))
(setf form value))
(t
(p1-variable-reference form)))))
((atom form)
form)
(t
(let ((op (%car form))
handler)
(cond
((symbolp op)
(when (find-local-function op)
;; local functions shadow macros and functions in
;; the global environment as well as compiler macros
(return-from p1
(p1-function-call form)))
(when (compiler-macro-function op)
(unless (notinline-p op)
(multiple-value-bind (expansion expanded-p)
(compiler-macroexpand form)
;; Fall through if no change...
(when expanded-p
(return-from p1 (p1 expansion))))))
(cond
((setf handler (get op 'p1-handler))
(funcall handler form))
((macro-function op *compile-file-environment*)
(p1 (macroexpand form *compile-file-environment*)))
((special-operator-p op)
(compiler-unsupported "P1: unsupported special operator ~S" op))
(t
(p1-function-call form))))
((and (consp op) (eq (%car op) 'LAMBDA))
(let ((maybe-optimized-call (rewrite-function-call form)))
(if (eq maybe-optimized-call form)
(p1 `(%funcall (function ,op) ,@(cdr form)))
(p1 maybe-optimized-call))))
(t
form))))))
(defun install-p1-handler (symbol handler)
(setf (get symbol 'p1-handler) handler))
(defun initialize-p1-handlers ()
(dolist (pair '((AND p1-default)
(BLOCK p1-block)
(CATCH p1-catch)
(DECLARE identity)
(EVAL-WHEN p1-eval-when)
(FLET p1-flet)
(FUNCALL p1-funcall)
(FUNCTION p1-function)
(GO p1-go)
(IF p1-default)
;; used to be p1-if, which was used to rewrite the test
;; form to a LET-binding; that's not necessary, because
;; the test form doesn't lead to multiple operands on the
;; operand stack
(LABELS p1-labels)
(LAMBDA p1-lambda)
(LET p1-let/let*)
(LET* p1-let/let*)
(LOAD-TIME-VALUE identity)
(LOCALLY p1-locally)
(MULTIPLE-VALUE-BIND p1-m-v-b)
(MULTIPLE-VALUE-CALL p1-default)
(MULTIPLE-VALUE-LIST p1-default)
(MULTIPLE-VALUE-PROG1 p1-default)
(OR p1-default)
(PROGN p1-default)
(PROGV p1-progv)
(QUOTE p1-quote)
(RETURN-FROM p1-return-from)
(SETQ p1-setq)
(SYMBOL-MACROLET identity)
(TAGBODY p1-tagbody)
(THE p1-the)
(THROW p1-throw)
(TRULY-THE p1-truly-the)
(UNWIND-PROTECT p1-unwind-protect)
(THREADS:SYNCHRONIZED-ON
p1-threads-synchronized-on)
(JVM::WITH-INLINE-CODE identity)))
(install-p1-handler (%car pair) (%cadr pair))))
(initialize-p1-handlers)
(defun p1-compiland (compiland)
;; (format t "p1-compiland name = ~S~%" (compiland-name compiland))
(let ((*current-compiland* compiland)
(*local-functions* *local-functions*)
(*visible-variables* *visible-variables*)
(form (compiland-lambda-expression compiland)))
(aver (eq (car form) 'LAMBDA))
(setf form (rewrite-lambda form))
(with-saved-compiler-policy
(process-optimization-declarations (cddr form))
(let* ((lambda-list (cadr form))
(body (cddr form))
(closure (make-closure `(lambda ,lambda-list nil) nil))
(syms (sys::varlist closure))
(vars nil)
compiland-result)
(dolist (sym syms)
(let ((var (make-variable :name sym
:special-p (special-variable-p sym))))
(push var vars)
(push var *all-variables*)
(push var *visible-variables*)))
(setf (compiland-arg-vars compiland) (nreverse vars))
(let ((free-specials (process-declarations-for-vars body vars nil)))
(setf (compiland-free-specials compiland) free-specials)
(dolist (var free-specials)
(push var *visible-variables*)))
(setf compiland-result
(list* 'LAMBDA lambda-list (p1-body body)))
(setf (compiland-%single-valued-p compiland)
(single-valued-p compiland-result))
(setf (compiland-p1-result compiland)
compiland-result)))))
(provide "COMPILER-PASS1")