X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=c5f7b4184d7edb1aa2a1f78b9a0697486ff09a09;hb=5d0643d3b70aade43037e8b7cdf39b7e12f5d3fd;hp=5343ea75cc5f00e5e4bca2c6766471f8336432cc;hpb=a260738d7a71680079d972b102b4e4db4e8dc3ae;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 5343ea7..c5f7b41 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -48,6 +48,11 @@ to optimize code which uses those definitions? Setting this true gives non-ANSI, early-CMU-CL behavior. It can be useful for improving the efficiency of stable code.") + +;;; *ALLOW-DEBUG-CATCH-TAG* controls whether we should allow the +;;; insertion a (CATCH ...) around code to allow the debugger RETURN +;;; command to function. +(defvar *allow-debug-catch-tag* t) ;;;; namespace management utilities @@ -330,11 +335,18 @@ (push node-block (block-pred block)) (add-continuation-use node cont) (unless (eq (continuation-asserted-type cont) *wild-type*) - (let ((new (values-type-union (continuation-asserted-type cont) - (or (lexenv-find cont type-restrictions) - *wild-type*)))) - (when (type/= new (continuation-asserted-type cont)) - (setf (continuation-asserted-type cont) new) + (let* ((restriction (or (lexenv-find cont type-restrictions) + *wild-type*)) + (wrestriction (or (lexenv-find cont weakend-type-restrictions) + *wild-type*)) + (newatype (values-type-union (continuation-asserted-type cont) + restriction)) + (newctype (values-type-union (continuation-type-to-check cont) + wrestriction))) + (when (or (type/= newatype (continuation-asserted-type cont)) + (type/= newctype (continuation-type-to-check cont))) + (setf (continuation-asserted-type cont) newatype) + (setf (continuation-type-to-check cont) newctype) (reoptimize-continuation cont)))))) ;;;; exported functions @@ -494,7 +506,8 @@ opname :debug-name (debug-namify "LAMBDA CAR ~S" - opname))))))))) + opname) + :allow-debug-catch-tag t)))))))) (values)) ;; Generate a reference to a manifest constant, creating a new leaf @@ -747,7 +760,8 @@ (let ((node (make-combination fun-cont))) (setf (continuation-dest fun-cont) node) (assert-continuation-type fun-cont - (specifier-type '(or function symbol))) + (specifier-type '(or function symbol)) + (lexenv-policy *lexenv*)) (setf (continuation-%externally-checkable-type fun-cont) nil) (collect ((arg-conts)) (let ((this-start fun-cont)) @@ -889,7 +903,7 @@ (declare (list decl vars) (type lexenv res)) (let ((type (compiler-specifier-type (first decl)))) (collect ((restr nil cons) - (new-vars nil cons)) + (new-vars nil cons)) (dolist (var-name (rest decl)) (let* ((bound-var (find-in-bindings vars var-name)) (var (or bound-var @@ -897,26 +911,31 @@ (find-free-var var-name)))) (etypecase var (leaf - (let* ((old-type (or (lexenv-find var type-restrictions) - (leaf-type var))) - (int (if (or (fun-type-p type) - (fun-type-p old-type)) - type - (type-approx-intersection2 old-type type)))) - (cond ((eq int *empty-type*) - (unless (policy *lexenv* (= inhibit-warnings 3)) - (compiler-warn - "The type declarations ~S and ~S for ~S conflict." - (type-specifier old-type) (type-specifier type) - var-name))) - (bound-var (setf (leaf-type bound-var) int)) - (t - (restr (cons var int)))))) + (flet ((process-var (var bound-var) + (let* ((old-type (or (lexenv-find var type-restrictions) + (leaf-type var))) + (int (if (or (fun-type-p type) + (fun-type-p old-type)) + type + (type-approx-intersection2 old-type type)))) + (cond ((eq int *empty-type*) + (unless (policy *lexenv* (= inhibit-warnings 3)) + (compiler-warn + "The type declarations ~S and ~S for ~S conflict." + (type-specifier old-type) (type-specifier type) + var-name))) + (bound-var (setf (leaf-type bound-var) int)) + (t + (restr (cons var int))))))) + (process-var var bound-var) + (awhen (and (lambda-var-p var) + (lambda-var-specvar var)) + (process-var it nil)))) (cons ;; FIXME: non-ANSI weirdness (aver (eq (car var) 'MACRO)) (new-vars `(,var-name . (MACRO . (the ,(first decl) - ,(cdr var)))))) + ,(cdr var)))))) (heap-alien-info (compiler-error "~S is an alien variable, so its type can't be declared." @@ -1423,7 +1442,8 @@ aux-vals result (source-name '.anonymous.) - debug-name) + debug-name + (note-lexical-bindings t)) (declare (list body vars aux-vars aux-vals) (type (or continuation null) result)) @@ -1459,7 +1479,8 @@ (svars var) (new-venv (cons (leaf-source-name specvar) specvar))) (t - (note-lexical-binding (leaf-source-name var)) + (when note-lexical-bindings + (note-lexical-binding (leaf-source-name var))) (new-venv (cons (leaf-source-name var) var)))))) (let ((*lexenv* (make-lexenv :vars (new-venv) @@ -1467,7 +1488,7 @@ :cleanup nil))) (setf (bind-lambda bind) lambda) (setf (node-lexenv bind) *lexenv*) - + (let ((cont1 (make-continuation)) (cont2 (make-continuation))) (continuation-starts-block cont1) @@ -1508,19 +1529,27 @@ (declare (type clambda fun) (list vars vals defaults)) (let* ((fvars (reverse vars)) (arg-vars (mapcar (lambda (var) - (unless (lambda-var-specvar var) - (note-lexical-binding (leaf-source-name var))) (make-lambda-var :%source-name (leaf-source-name var) :type (leaf-type var) :where-from (leaf-where-from var) :specvar (lambda-var-specvar var))) fvars)) - (fun (ir1-convert-lambda-body `((%funcall ,fun - ,@(reverse vals) - ,@defaults)) - arg-vars - :debug-name "&OPTIONAL processor"))) + (fun (collect ((default-bindings) + (default-vals)) + (dolist (default defaults) + (if (constantp default) + (default-vals default) + (let ((var (gensym))) + (default-bindings `(,var ,default)) + (default-vals var)))) + (ir1-convert-lambda-body `((let (,@(default-bindings)) + (%funcall ,fun + ,@(reverse vals) + ,@(default-vals)))) + arg-vars + :debug-name "&OPTIONAL processor" + :note-lexical-bindings nil)))) (mapc (lambda (var arg-var) (when (cdr (leaf-refs arg-var)) (setf (leaf-ever-used var) t))) @@ -1652,7 +1681,8 @@ (setq ,n-value ,n-value-temp)))))) (when (and (not allowp) (eq keyword :allow-other-keys)) (setq found-allow-p t) - (setq clause (append clause `((setq ,n-allowp ,n-value-temp))))) + (setq clause + (append clause `((setq ,n-allowp ,n-value-temp))))) (temps `(,n-value ,default)) (tests clause))) @@ -1688,9 +1718,10 @@ `((let ,(temps) ,@(body) (%funcall ,(optional-dispatch-main-entry res) - . ,(arg-vals)))) ; FIXME: What is the '.'? ,@? + ,@(arg-vals)))) (arg-vars) - :debug-name (debug-namify "~S processing" '&more)))) + :debug-name (debug-namify "~S processing" '&more) + :note-lexical-bindings nil))) (setf (optional-dispatch-more-entry res) ep)))) (values)) @@ -1932,7 +1963,9 @@ res)) ;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf. -(defun ir1-convert-lambda (form &key (source-name '.anonymous.) debug-name) +(defun ir1-convert-lambda (form &key (source-name '.anonymous.) + debug-name + allow-debug-catch-tag) (unless (consp form) (compiler-error "A ~S was found when expecting a lambda expression:~% ~S" @@ -1948,28 +1981,65 @@ "The lambda expression has a missing or non-list lambda list:~% ~S" form)) - (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals) - (make-lambda-vars (cadr form)) - (multiple-value-bind (forms decls) (parse-body (cddr form)) - (let* ((result-cont (make-continuation)) - (*lexenv* (process-decls decls - (append aux-vars vars) - nil result-cont)) - (res (if (or (find-if #'lambda-var-arg-info vars) keyp) - (ir1-convert-hairy-lambda forms vars keyp - allow-other-keys - aux-vars aux-vals result-cont - :source-name source-name - :debug-name debug-name) - (ir1-convert-lambda-body forms vars - :aux-vars aux-vars - :aux-vals aux-vals - :result result-cont - :source-name source-name - :debug-name debug-name)))) - (setf (functional-inline-expansion res) form) - (setf (functional-arg-documentation res) (cadr form)) - res)))) + (let ((*allow-debug-catch-tag* (and *allow-debug-catch-tag* allow-debug-catch-tag))) + (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals) + (make-lambda-vars (cadr form)) + (multiple-value-bind (forms decls) (parse-body (cddr form)) + (let* ((result-cont (make-continuation)) + (*lexenv* (process-decls decls + (append aux-vars vars) + nil result-cont)) + (forms (if (and *allow-debug-catch-tag* + (policy *lexenv* (> debug (max speed space)))) + `((catch (make-symbol "SB-DEBUG-CATCH-TAG") + ,@forms)) + forms)) + (res (if (or (find-if #'lambda-var-arg-info vars) keyp) + (ir1-convert-hairy-lambda forms vars keyp + allow-other-keys + aux-vars aux-vals result-cont + :source-name source-name + :debug-name debug-name) + (ir1-convert-lambda-body forms vars + :aux-vars aux-vars + :aux-vals aux-vals + :result result-cont + :source-name source-name + :debug-name debug-name)))) + (setf (functional-inline-expansion res) form) + (setf (functional-arg-documentation res) (cadr form)) + res))))) + +;;; helper for LAMBDA-like things, to massage them into a form +;;; suitable for IR1-CONVERT-LAMBDA. +;;; +;;; KLUDGE: We cons up a &REST list here, maybe for no particularly +;;; good reason. It's probably lost in the noise of all the other +;;; consing, but it's still inelegant. And we force our called +;;; functions to do full runtime keyword parsing, ugh. -- CSR, +;;; 2003-01-25 +(defun ir1-convert-lambdalike (thing &rest args + &key (source-name '.anonymous.) + debug-name allow-debug-catch-tag) + (ecase (car thing) + ((lambda) (apply #'ir1-convert-lambda thing args)) + ((instance-lambda) + (let ((res (apply #'ir1-convert-lambda + `(lambda ,@(cdr thing)) args))) + (setf (getf (functional-plist res) :fin-function) t) + res)) + ((named-lambda) + (let ((name (cadr thing))) + (if (legal-fun-name-p name) + (let ((res (apply #'ir1-convert-lambda `(lambda ,@(cddr thing)) + :source-name name + :debug-name nil + args))) + (assert-global-function-definition-type name res) + res) + (apply #'ir1-convert-lambda `(lambda ,@(cddr thing)) + :debug-name name args)))) + ((lambda-with-lexenv) (apply #'ir1-convert-inline-lambda thing args)))) ;;;; defining global functions @@ -1979,7 +2049,8 @@ ;;; reflect the state at the definition site. (defun ir1-convert-inline-lambda (fun &key (source-name '.anonymous.) - debug-name) + debug-name + allow-debug-catch-tag) (destructuring-bind (decls macros symbol-macros &rest body) (if (eq (car fun) 'lambda-with-lexenv) (cdr fun) @@ -1996,7 +2067,8 @@ :policy (lexenv-policy *lexenv*)))) (ir1-convert-lambda `(lambda ,@body) :source-name source-name - :debug-name debug-name)))) + :debug-name debug-name + :allow-debug-catch-tag nil)))) ;;; Get a DEFINED-FUN object for a function we are about to define. If ;;; the function has been forward referenced, then substitute for the