;;; compiler-pass1.lisp ;;; ;;; Copyright (C) 2003-2008 Peter Graves ;;; $Id$ ;;; ;;; 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 "JAVA") (proclaim '(optimize speed)) (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 (multiple-value-bind (body decls) (parse-body body) (expand-function-call-inline nil lambda-list ;; the forms below get wrapped ;; in a LET, making the decls ;; part of the decls of the LET. (copy-tree `(,@decls (block ,name ,@body))) args)) (cond ((intersection lambda-list '(&optional &rest &key &allow-other-keys &aux) :test #'eq) nil) (t (multiple-value-bind (body decls) (parse-body body) (setf body (copy-tree body)) `(lambda ,lambda-list ,@decls (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 ((remaining lambda-list) (state :req) keyword-required req opt key rest whole env aux key-p allow-others-p) (when (eq (car lambda-list) '&WHOLE) (let ((var (second lambda-list))) (when (memq var lambda-list-keywords) (error 'program-error :format-control "Lambda list keyword ~A found where &WHOLE ~ variable expected in lambda list ~A." :format-arguments (list var lambda-list))) (setf whole (list var)) (setf remaining (nthcdr 2 lambda-list)))) (do* ((arg (pop remaining) (pop tail)) (tail remaining tail)) ((and (null arg) (endp tail))) (let* ((allowable-previous-states ;; even if the arglist could theoretically contain the ;; keyword :req, this still works, because the cdr will ;; be NIL, meaning that the code below thinks we DIDN'T ;; find a new state. Which happens to be true. (cdr (member arg '(&whole &environment &aux &allow-other-keys &key &rest &optional :req))))) (cond (allowable-previous-states (setf keyword-required nil) ;; we have a keyword... (case arg (&key (setf key-p t)) (&rest (when (endp tail) (error 'program-error :format-control "&REST without variable in lambda list ~A." :format-arguments (list lambda-list))) (setf rest (list (pop tail)) keyword-required t)) (&allow-other-keys (unless (eq state '&KEY) (error 'program-error :format-control "&ALLOW-OTHER-KEYS outside of &KEY ~ section in lambda list ~A" :format-arguments (list lambda-list))) (setf allow-others-p t keyword-required t arg nil)) (&environment (setf env (list (pop tail)) keyword-required t ;; &ENVIRONMENT can appear anywhere; retain our last ;; state so we know what next keywords are valid arg state)) (&whole (error 'program-error :format-control "&WHOLE must appear first in lambda list ~A." :format-arguments (list lambda-list)))) (when arg ;; ### verify that the next state is valid (unless (or (null state) (member state allowable-previous-states)) (error 'program-error :format-control "~A not allowed after ~A ~ in lambda-list ~S" :format-arguments (list arg state lambda-list))) (setf state arg))) (keyword-required ;; a keyword was required, but none was found... (error 'program-error :format-control "Lambda list keyword expected, but found ~ ~A in lambda list ~A" :format-arguments (list arg lambda-list))) (t ;; a variable specification (case state (:req (push (list arg) req)) (&optional (cond ((symbolp arg) (push (list arg) opt)) ((consp arg) (push (list (car arg) (cadr arg) (caddr arg)) opt)) (t (error "Invalid &OPTIONAL variable.")))) (&key (cond ((symbolp arg) (push (list arg nil nil (sys::keywordify arg)) key)) ((consp arg) (push (list (if (consp (car arg)) (cadar arg) (car arg)) (cadr arg) (caddr arg) (if (consp (car arg)) (caar arg) (sys::keywordify (car arg)))) key)) (t (error "Invalid &KEY variable.")))) (&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.")))) (t (error 'program-error :format-control "Invalid state found: ~A." :format-arguments (list state)))))))) (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)) (loop for form in body for processed-form = (p1 form) collect processed-form while (not (and (consp processed-form) (memq (car processed-form) '(GO RETURN-FROM THROW)))))) (defknown p1-default (t) t) (declaim (inline p1-default)) (defun p1-default (form) (declare (optimize speed)) (cons (car form) (loop for f in (cdr form) collect (p1 f)))) (defun let/let*-variables (block bindings) (loop for binding in bindings if (consp binding) collect (make-variable :name (check-name (car binding)) :initform (cadr binding) :block block) else collect (make-variable :name (check-name binding) :block block))) (defun valid-let/let*-binding-p (varspec) (when (consp varspec) (unless (<= 1 (length varspec) 2) (compiler-error "The LET/LET* binding specification ~ ~S is invalid." varspec))) T) (defun check-let/let*-bindings (bindings) (every #'valid-let/let*-binding-p bindings)) (defknown p1-let-vars (t) t) (defun p1-let-vars (block varlist) (check-let/let*-bindings varlist) (let ((vars (let/let*-variables block varlist))) (dolist (variable vars) (setf (variable-initform variable) (p1 (variable-initform variable)))) (dolist (variable vars) (push variable *visible-variables*) (push variable *all-variables*)) vars)) (defknown p1-let*-vars (t) t) (defun p1-let*-vars (block varlist) (check-let/let*-bindings varlist) (let ((vars (let/let*-variables block varlist))) (dolist (variable vars) (setf (variable-initform variable) (p1 (variable-initform variable))) (push variable *visible-variables*) (push variable *all-variables*)) 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*))) (with-saved-compiler-policy (process-optimization-declarations body) (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*))) (with-saved-compiler-policy (process-optimization-declarations (cdr form)) (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))) (with-saved-compiler-policy (process-optimization-declarations body) (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*)) (form (list* (car form) (cadr 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*))) (setf (synchronized-form block) (list* 'threads:synchronized-on synchronized-object (p1-body body))) block)) (defun p1-java-jrun-exception-protected (form) (assert (eq (first form) 'java:jrun-exception-protected)) (assert (or (eq (car (second form)) 'lambda) (and (eq (car (second form)) 'function) (eq (car (second (second form))) 'lambda)))) (let* ((body (if (eq (car (second form)) 'lambda) (cddr (second form)) (cddr (second (second form))))) (block (make-exception-protected-node)) (*block* block) (*blocks* (cons block *blocks*))) (setf (exception-protected-form block) (p1-body body)) 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) ;; i believe this comment is misleading... ;; - from an /opstack/ safety perspective, all forms (including cleanup) can have non-local returns ;; original comment: (and unwinding-forms and unprotected-forms were above this line previously, meaning they ;; did not fall under an unwind-protect /block/ and hence lead to stack inconsistency problems) ;; ... because only the protected form is ;; protected by the UNWIND-PROTECT block (*blocks* (cons block *blocks*)) ;; this may be ok to have /above/ the blocks decl, since these should not be present inside the ;; exception handler and are therefore opstack safe ;; my little test case passes either way (whether this is here or above) ;; /but/ if the protected-form is marked as opstack unsafe, this should be too ;; why is the protected form marked opstack unsafe? (unwinding-forms (p1-body (copy-tree (cddr form)))) ;; the unprotected-forms actually end up inside an exception handler and as such, /do/ need ;; to be marked opstack unsafe (so this is now below the *blocks* decl) ;; (this name is now misleading from an opstack safety perspective) (unprotected-forms (p1-body (cddr form))) (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 lambda-list-names (lambda-list) "Returns a list of variable names extracted from `lambda-list'." (multiple-value-bind (req opt key key-p rest allow-key-p aux whole env) (parse-lambda-list lambda-list) (declare (ignore key-p allow-key-p)) (mapcan (lambda (x) (mapcar #'first x)) (list req opt key aux (list rest) (list whole) (list env))))) (defun lambda-list-keyword-p (x) (memq x lambda-list-keywords)) (defun rewrite-aux-vars (form) (let* ((lambda-list (cadr form)) (aux-p (memq '&AUX lambda-list)) (post-aux-&environment (memq '&ENVIRONMENT aux-p)) (lets (ldiff (cdr aux-p) post-aux-&environment)) ; strip trailing &environment aux-vars) (unless aux-p ;; no rewriting required (return-from rewrite-aux-vars form)) (dolist (var lets) (when (lambda-list-keyword-p var) (error 'program-error :format-control "Lambda list keyword ~A not allowed after &AUX in ~A." :format-arguments (list var lambda-list)))) (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 (append (subseq lambda-list 0 (position '&AUX lambda-list)) post-aux-&environment)) (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*)) (with-saved-compiler-policy (process-optimization-declarations (cddr form)) (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))) (let ((source-transform (source-transform name))) (when source-transform (let ((new-form (expand-source-transform (list* name (cddr 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 (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 (compiler-unsupported "P1 unhandled case ~S" 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) (JAVA:JRUN-EXCEPTION-PROTECTED p1-java-jrun-exception-protected) (JVM::WITH-INLINE-CODE identity))) (install-p1-handler (%car pair) (%cadr pair)))) (initialize-p1-handlers) (defun p1-compiland (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")