* 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
(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))))
(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
(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)
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
(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)
(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
(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
(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)))))))
\f
;;;; the THE special operator, and friends
&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*)
: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.
(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))
(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
(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))))
;;; 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)
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))))
(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
(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
(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.
(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
(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))
;;; 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"
(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)))))
`(() () () . ,(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)
"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
;;; 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)))
(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
nil
nil
(lexenv-type-restrictions lexenv) ; XXX
- (lexenv-weakend-type-restrictions lexenv)
nil
nil
(lexenv-policy lexenv))))
(: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
;; 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
(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
;;; 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"
projects / sbcl.git / commitdiff