From: Alexey Dejneka Date: Wed, 20 Aug 2003 18:55:21 +0000 (+0000) Subject: 0.8.2.50: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=28ce7a00cbce6d27b127fd6a2783325c8198a568;p=sbcl.git 0.8.2.50: * Partially enable VALUES declaration: ... PROCESS-DECLS does not accept continuation; instead it returns the asserted type as the second result; ... new macro: PROCESSING-DECLS, rebinds *LEXENV* and puts THE on the result, if needed; * IR1-CONVERT-LAMBDA-BODY and similar do not accept/pass the result continuation; * remove obsolete LEXENV-WEAKEND-TYPE-RESTRICTIONS. --- diff --git a/NEWS b/NEWS index a9ed63a..c55253a 100644 --- a/NEWS +++ b/NEWS @@ -1980,6 +1980,7 @@ changes in sbcl-0.8.3 relative to sbcl-0.8.2: * new optimization on x86: logical functions and + now have optimized (UNSIGNED-BYTE 32) versions, which are automatically used when the result is truncated to 32 bits. + * VALUES declaration is partially enabled. * fixed some bugs revealed by Paul Dietz' test suite: ** The system now obeys the constraint imposed by UPGRADED-ARRAY-ELEMENT-TYPE that the upgraded array element diff --git a/src/code/eval.lisp b/src/code/eval.lisp index 3f29e59..2b9f400 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -65,10 +65,10 @@ (sb!c::*free-funs* (make-hash-table :test 'equal)) (sb!c::*free-vars* (make-hash-table :test 'eq)) (sb!c::*undefined-warnings* nil)) + ;; FIXME: VALUES declaration (sb!c::process-decls decls vars nil - (sb!c::make-continuation) lexenv)))) (eval-progn-body body lexenv)))) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index e82b3a4..b271599 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -522,8 +522,7 @@ (values (vars) (vals)))) -(def-ir1-translator let ((bindings &body body) - start cont) +(def-ir1-translator let ((bindings &body body) start cont) #!+sb-doc "LET ({(Var [Value]) | Var}*) Declaration* Form* During evaluation of the Forms, bind the Vars to the result of evaluating the @@ -533,12 +532,14 @@ (ir1-translate-locally body start cont) (multiple-value-bind (forms decls) (parse-body body nil) (multiple-value-bind (vars values) (extract-let-vars bindings 'let) - (let ((fun-cont (make-continuation))) - (let* ((*lexenv* (process-decls decls vars nil cont)) - (fun (ir1-convert-lambda-body - forms vars - :debug-name (debug-namify "LET ~S" bindings)))) - (reference-leaf start fun-cont fun)) + (let* ((fun-cont (make-continuation)) + (cont (processing-decls (decls vars nil cont) + (let ((fun (ir1-convert-lambda-body + forms vars + :debug-name (debug-namify "LET ~S" + bindings)))) + (reference-leaf start fun-cont fun)) + cont))) (ir1-convert-combination-args fun-cont cont values)))))) (def-ir1-translator let* ((bindings &body body) @@ -549,8 +550,8 @@ form to reference any of the previous Vars." (multiple-value-bind (forms decls) (parse-body body nil) (multiple-value-bind (vars values) (extract-let-vars bindings 'let*) - (let ((*lexenv* (process-decls decls vars nil cont))) - (ir1-convert-aux-bindings start cont forms vars values))))) + (processing-decls (decls vars nil cont) + (ir1-convert-aux-bindings start cont forms vars values))))) ;;; logic shared between IR1 translators for LOCALLY, MACROLET, ;;; and SYMBOL-MACROLET @@ -562,7 +563,7 @@ (defun ir1-translate-locally (body start cont &key vars funs) (declare (type list body) (type continuation start cont)) (multiple-value-bind (forms decls) (parse-body body nil) - (let ((*lexenv* (process-decls decls vars funs cont))) + (processing-decls (decls vars funs cont) (ir1-convert-progn-body start cont forms)))) (def-ir1-translator locally ((&body body) start cont) @@ -609,17 +610,16 @@ (multiple-value-bind (forms decls) (parse-body body nil) (multiple-value-bind (names defs) (extract-flet-vars definitions 'flet) - (let* ((fvars (mapcar (lambda (n d) - (ir1-convert-lambda d - :source-name n - :debug-name (debug-namify - "FLET ~S" n) - :allow-debug-catch-tag t)) - names defs)) - (*lexenv* (make-lexenv - :default (process-decls decls nil fvars cont) - :funs (pairlis names fvars)))) - (ir1-convert-progn-body start cont forms))))) + (let ((fvars (mapcar (lambda (n d) + (ir1-convert-lambda d + :source-name n + :debug-name (debug-namify + "FLET ~S" n) + :allow-debug-catch-tag t)) + names defs))) + (processing-decls (decls nil fvars cont) + (let ((*lexenv* (make-lexenv :funs (pairlis names fvars)))) + (ir1-convert-progn-body start cont forms))))))) (def-ir1-translator labels ((definitions &body body) start cont) #!+sb-doc @@ -630,7 +630,7 @@ (multiple-value-bind (forms decls) (parse-body body nil) (multiple-value-bind (names defs) (extract-flet-vars definitions 'labels) - (let* (;; dummy LABELS functions, to be used as placeholders + (let* ( ;; dummy LABELS functions, to be used as placeholders ;; during construction of real LABELS functions (placeholder-funs (mapcar (lambda (name) (make-functional @@ -661,14 +661,14 @@ (setf (cdr placeholder-cons) real-fun)) ;; Voila. - (let ((*lexenv* (make-lexenv - :default (process-decls decls nil real-funs cont) - ;; Use a proper FENV here (not the - ;; placeholder used earlier) so that if the - ;; lexical environment is used for inline - ;; expansion we'll get the right functions. - :funs (pairlis names real-funs)))) - (ir1-convert-progn-body start cont forms)))))) + (processing-decls (decls nil real-funs cont) + (let ((*lexenv* (make-lexenv + ;; Use a proper FENV here (not the + ;; placeholder used earlier) so that if the + ;; lexical environment is used for inline + ;; expansion we'll get the right functions. + :funs (pairlis names real-funs)))) + (ir1-convert-progn-body start cont forms))))))) ;;;; the THE special operator, and friends diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index ecb2a64..95fc019 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -273,12 +273,10 @@ &key aux-vars aux-vals - result (source-name '.anonymous.) debug-name (note-lexical-bindings t)) - (declare (list body vars aux-vars aux-vals) - (type (or continuation null) result)) + (declare (list body vars aux-vars aux-vals)) ;; We're about to try to put new blocks into *CURRENT-COMPONENT*. (aver-live-component *current-component*) @@ -288,7 +286,7 @@ :bind bind :%source-name source-name :%debug-name debug-name)) - (result (or result (make-continuation)))) + (result (make-continuation))) ;; just to check: This function should fail internal assertions if ;; we didn't set up a valid debug name above. @@ -411,13 +409,12 @@ (defun generate-optional-default-entry (res default-vars default-vals entry-vars entry-vals vars supplied-p-p body - aux-vars aux-vals cont + aux-vars aux-vals source-name debug-name force) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals vars body - aux-vars aux-vals) - (type (or continuation null) cont)) + aux-vars aux-vals)) (let* ((arg (first vars)) (arg-name (leaf-source-name arg)) (info (lambda-var-arg-info arg)) @@ -432,7 +429,7 @@ (list* (leaf-source-name supplied-p) arg-name default-vals) (cons arg entry-vars) (list* t arg-name entry-vals) - (rest vars) t body aux-vars aux-vals cont + (rest vars) t body aux-vars aux-vals source-name debug-name force) (ir1-convert-hairy-args @@ -441,7 +438,7 @@ (cons arg-name default-vals) (cons arg entry-vars) (cons arg-name entry-vals) - (rest vars) supplied-p-p body aux-vars aux-vals cont + (rest vars) supplied-p-p body aux-vars aux-vals source-name debug-name force)))) @@ -614,12 +611,11 @@ ;;; type when computing the type for the main entry's argument. (defun ir1-convert-more (res default-vars default-vals entry-vars entry-vals rest more-context more-count keys supplied-p-p - body aux-vars aux-vals cont + body aux-vars aux-vals source-name debug-name) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals keys body - aux-vars aux-vals) - (type (or continuation null) cont)) + aux-vars aux-vals)) (collect ((main-vars (reverse default-vars)) (main-vals default-vals cons) (bind-vars) @@ -675,7 +671,6 @@ body (main-vars) :aux-vars (append (bind-vars) aux-vars) :aux-vals (append (bind-vals) aux-vals) - :result cont :debug-name (debug-namify "varargs entry for ~A" (as-debug-name source-name debug-name)))) @@ -728,25 +723,23 @@ (defun ir1-convert-hairy-args (res default-vars default-vals entry-vars entry-vals vars supplied-p-p body aux-vars - aux-vals cont + aux-vals source-name debug-name force) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals vars body - aux-vars aux-vals) - (type (or continuation null) cont)) + aux-vars aux-vals)) (cond ((not vars) (if (optional-dispatch-keyp res) ;; Handle &KEY with no keys... (ir1-convert-more res default-vars default-vals entry-vars entry-vals nil nil nil vars supplied-p-p body aux-vars - aux-vals cont source-name debug-name) + aux-vals source-name debug-name) (let ((fun (ir1-convert-lambda-body body (reverse default-vars) :aux-vars aux-vars :aux-vals aux-vals - :result cont :debug-name (debug-namify "hairy arg processor for ~A" (as-debug-name source-name @@ -766,7 +759,6 @@ (nvals (cons (leaf-source-name arg) default-vals))) (ir1-convert-hairy-args res nvars nvals nvars nvals (rest vars) nil body aux-vars aux-vals - cont source-name debug-name nil))) (t @@ -778,7 +770,7 @@ (let ((ep (generate-optional-default-entry res default-vars default-vals entry-vars entry-vals vars supplied-p-p body - aux-vars aux-vals cont + aux-vars aux-vals source-name debug-name force))) ;; See GENERATE-OPTIONAL-DEFAULT-ENTRY. @@ -796,31 +788,31 @@ (ir1-convert-more res default-vars default-vals entry-vars entry-vals arg nil nil (rest vars) supplied-p-p body - aux-vars aux-vals cont + aux-vars aux-vals source-name debug-name)) (:more-context (ir1-convert-more res default-vars default-vals entry-vars entry-vals nil arg (second vars) (cddr vars) supplied-p-p - body aux-vars aux-vals cont + body aux-vars aux-vals source-name debug-name)) (:keyword (ir1-convert-more res default-vars default-vals entry-vars entry-vals nil nil nil vars supplied-p-p body aux-vars - aux-vals cont source-name debug-name))))))) + aux-vals source-name debug-name))))))) ;;; This function deals with the case where we have to make an ;;; OPTIONAL-DISPATCH to represent a LAMBDA. We cons up the result and ;;; call IR1-CONVERT-HAIRY-ARGS to do the work. When it is done, we ;;; figure out the MIN-ARGS and MAX-ARGS. -(defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont +(defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals &key (source-name '.anonymous.) (debug-name (debug-namify "OPTIONAL-DISPATCH ~S" vars))) - (declare (list body vars aux-vars aux-vals) (type continuation cont)) + (declare (list body vars aux-vars aux-vals)) (let ((res (make-optional-dispatch :arglist vars :allowp allowp :keyp keyp @@ -833,7 +825,7 @@ (aver-live-component *current-component*) (push res (component-new-functionals *current-component*)) (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals - cont source-name debug-name nil) + source-name debug-name nil) (setf (optional-dispatch-min-args res) min) (setf (optional-dispatch-max-args res) (+ (1- (length (optional-dispatch-entry-points res))) min)) @@ -842,8 +834,8 @@ ;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf. (defun ir1-convert-lambda (form &key (source-name '.anonymous.) - debug-name - allow-debug-catch-tag) + debug-name + allow-debug-catch-tag) (unless (consp form) (compiler-error "A ~S was found when expecting a lambda expression:~% ~S" @@ -863,27 +855,27 @@ (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* (= insert-debug-catch 3))) - `((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)))) + (binding* (((*lexenv* result-type) + (process-decls decls (append aux-vars vars) nil)) + (forms (if (and *allow-debug-catch-tag* + (policy *lexenv* (>= insert-debug-catch 2))) + `((catch (make-symbol "SB-DEBUG-CATCH-TAG") + ,@forms)) + forms)) + (forms (if (eq result-type *wild-type*) + forms + `((the ,result-type (progn ,@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 + :source-name source-name + :debug-name debug-name) + (ir1-convert-lambda-body forms vars + :aux-vars aux-vars + :aux-vals aux-vals + :source-name source-name + :debug-name debug-name)))) (setf (functional-inline-expansion res) form) (setf (functional-arg-documentation res) (cadr form)) res))))) @@ -944,7 +936,6 @@ `(() () () . ,(cdr fun))) (let ((*lexenv* (make-lexenv :default (process-decls decls nil nil - (make-continuation) (make-null-lexenv)) :vars (copy-list symbol-macros) :funs (mapcar (lambda (x) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 71ec219..7ee9fed 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1084,68 +1084,94 @@ "If true, processing of the VALUES declaration is inhibited.") ;;; Process a single declaration spec, augmenting the specified LEXENV -;;; RES and returning it as a result. VARS and FVARS are as described in -;;; PROCESS-DECLS. -(defun process-1-decl (raw-spec res vars fvars cont) +;;; RES. Return RES and result type. VARS and FVARS are as described +;;; in PROCESS-DECLS. +(defun process-1-decl (raw-spec res vars fvars) (declare (type list raw-spec vars fvars)) (declare (type lexenv res)) - (declare (type continuation cont)) - (let ((spec (canonized-decl-spec raw-spec))) - (case (first spec) - (special (process-special-decl spec res vars)) - (ftype - (unless (cdr spec) - (compiler-error "no type specified in FTYPE declaration: ~S" spec)) - (process-ftype-decl (second spec) res (cddr spec) fvars)) - ((inline notinline maybe-inline) - (process-inline-decl spec res fvars)) - ((ignore ignorable) - (process-ignore-decl spec vars fvars) - res) - (optimize - (make-lexenv - :default res - :policy (process-optimize-decl spec (lexenv-policy res)))) - (type - (process-type-decl (cdr spec) res vars)) - (values ;; FIXME -- APD, 2002-01-26 - (if t ; *suppress-values-declaration* - res - (let ((types (cdr spec))) - (ir1ize-the-or-values (if (eql (length types) 1) - (car types) - `(values ,@types)) - cont - res - "in VALUES declaration")))) - (dynamic-extent - (when (policy *lexenv* (> speed inhibit-warnings)) - (compiler-notify - "compiler limitation: ~ - ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) - res) - (t - (unless (info :declaration :recognized (first spec)) - (compiler-warn "unrecognized declaration ~S" raw-spec)) - res)))) + (let ((spec (canonized-decl-spec raw-spec)) + (result-type *wild-type*)) + (values + (case (first spec) + (special (process-special-decl spec res vars)) + (ftype + (unless (cdr spec) + (compiler-error "no type specified in FTYPE declaration: ~S" spec)) + (process-ftype-decl (second spec) res (cddr spec) fvars)) + ((inline notinline maybe-inline) + (process-inline-decl spec res fvars)) + ((ignore ignorable) + (process-ignore-decl spec vars fvars) + res) + (optimize + (make-lexenv + :default res + :policy (process-optimize-decl spec (lexenv-policy res)))) + (type + (process-type-decl (cdr spec) res vars)) + (values + (unless *suppress-values-declaration* + (let ((types (cdr spec))) + (setq result-type + (compiler-values-specifier-type + (if (singleton-p types) + (car types) + `(values ,@types))))) + res)) + (dynamic-extent + (when (policy *lexenv* (> speed inhibit-warnings)) + (compiler-notify + "compiler limitation: ~ + ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) + res) + (t + (unless (info :declaration :recognized (first spec)) + (compiler-warn "unrecognized declaration ~S" raw-spec)) + res)) + result-type))) ;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR ;;; and FUNCTIONAL structures which are being bound. In addition to -;;; filling in slots in the leaf structures, we return a new LEXENV +;;; filling in slots in the leaf structures, we return a new LEXENV, ;;; which reflects pervasive special and function type declarations, -;;; (NOT)INLINE declarations and OPTIMIZE declarations. CONT is the -;;; continuation affected by VALUES declarations. +;;; (NOT)INLINE declarations and OPTIMIZE declarations, and type of +;;; VALUES declarations. ;;; ;;; This is also called in main.lisp when PROCESS-FORM handles a use ;;; of LOCALLY. -(defun process-decls (decls vars fvars cont &optional (env *lexenv*)) - (declare (list decls vars fvars) (type continuation cont)) - (dolist (decl decls) - (dolist (spec (rest decl)) - (unless (consp spec) - (compiler-error "malformed declaration specifier ~S in ~S" spec decl)) - (setq env (process-1-decl spec env vars fvars cont)))) - env) +(defun process-decls (decls vars fvars &optional (env *lexenv*)) + (declare (list decls vars fvars)) + (let ((result-type *wild-type*)) + (dolist (decl decls) + (dolist (spec (rest decl)) + (unless (consp spec) + (compiler-error "malformed declaration specifier ~S in ~S" spec decl)) + (multiple-value-bind (new-env new-result-type) + (process-1-decl spec env vars fvars) + (setq env new-env) + (unless (eq new-result-type *wild-type*) + (setq result-type + (values-type-intersection result-type new-result-type)))))) + (values env result-type))) + +(defun %processing-decls (decls vars fvars cont fun) + (multiple-value-bind (*lexenv* result-type) + (process-decls decls vars fvars) + (cond ((eq result-type *wild-type*) + (funcall fun cont)) + (t + (let ((value-cont (make-continuation))) + (multiple-value-prog1 + (funcall fun value-cont) + (let ((cast (make-cast value-cont result-type + (lexenv-policy *lexenv*)))) + (link-node-to-previous-continuation cast value-cont) + (setf (continuation-dest value-cont) cast) + (use-continuation cast cont)))))))) +(defmacro processing-decls ((decls vars fvars cont) &body forms) + (check-type cont symbol) + `(%processing-decls ,decls ,vars ,fvars ,cont + (lambda (,cont) ,@forms))) ;;; Return the SPECVAR for NAME to use when we see a local SPECIAL ;;; declaration. If there is a global variable of that name, then diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 75c9723..789d7e1 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -544,7 +544,7 @@ ;;; beginning of the current value, rather than replacing it entirely. (defun make-lexenv (&key (default *lexenv*) funs vars blocks tags - type-restrictions weakend-type-restrictions + type-restrictions (lambda (lexenv-lambda default)) (cleanup (lexenv-cleanup default)) (policy (lexenv-policy default))) @@ -559,7 +559,6 @@ (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - (frob weakend-type-restrictions lexenv-weakend-type-restrictions) lambda cleanup policy))) ;;; Makes a LEXENV, suitable for using in a MACROLET introduced @@ -587,7 +586,6 @@ nil nil (lexenv-type-restrictions lexenv) ; XXX - (lexenv-weakend-type-restrictions lexenv) nil nil (lexenv-policy lexenv)))) diff --git a/src/compiler/lexenv.lisp b/src/compiler/lexenv.lisp index acdf1a3..8ff2674 100644 --- a/src/compiler/lexenv.lisp +++ b/src/compiler/lexenv.lisp @@ -28,7 +28,6 @@ (:constructor internal-make-lexenv (funs vars blocks tags type-restrictions - weakend-type-restrictions lambda cleanup policy))) ;; an alist of (NAME . WHAT), where WHAT is either a FUNCTIONAL (a ;; local function), a DEFINED-FUN, representing an @@ -58,7 +57,6 @@ ;; THING is a continuation, this is used to track the innermost THE ;; type declaration. (type-restrictions nil :type list) - (weakend-type-restrictions nil :type list) ;; the lexically enclosing lambda, if any ;; ;; FIXME: This should be :TYPE (OR CLAMBDA NULL), but it was too hard diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index d5db2d6..bb0ecb5 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -836,8 +836,9 @@ (defun process-toplevel-locally (body path compile-time-too &key vars funs) (declare (list path)) (multiple-value-bind (forms decls) (parse-body body nil) - (let* ((*lexenv* - (process-decls decls vars funs (make-continuation))) + (let* ((*lexenv* (process-decls decls vars funs)) + ;; FIXME: VALUES declaration + ;; ;; Binding *POLICY* is pretty much of a hack, since it ;; causes LOCALLY to "capture" enclosed proclamations. It ;; is necessary because CONVERT-AND-MAYBE-COMPILE uses the diff --git a/version.lisp-expr b/version.lisp-expr index e15af6e..e1c7f51 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.2.49" +"0.8.2.50"