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)
\f
;;;; namespace management utilities
;;; CONSTANT might be circular. We also check that the constant (and
;;; any subparts) are dumpable at all.
(eval-when (:compile-toplevel :load-toplevel :execute)
- ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD)
+ ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD)
;; below. -- AL 20010227
(def!constant list-to-hash-table-threshold 32))
(defun maybe-emit-make-load-forms (constant)
;;; our block and link it to that block. If the continuation is not
;;; currently used, then we set the DERIVED-TYPE for the continuation
;;; to that of the node, so that a little type propagation gets done.
-;;;
-;;; We also deal with a bit of THE's semantics here: we weaken the
-;;; assertion on CONT to be no stronger than the assertion on CONT in
-;;; our scope. See the IR1-CONVERT method for THE.
#!-sb-fluid (declaim (inline use-continuation))
(defun use-continuation (node cont)
(declare (type node node) (type continuation cont))
(error "~S is already a predecessor of ~S." node-block block))
(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)
- (reoptimize-continuation cont))))))
+ (reoptimize-continuation cont)))
\f
;;;; exported functions
:format-control "execution of a form compiled with errors:~% ~S"
:format-arguments (list ',,form))))
&body body)
- (let ((skip (gensym "SKIP")))
+ (with-unique-names (skip)
`(block ,skip
(catch 'ir1-error-abort
(let ((*compiler-error-bailout*
(t
(reference-constant start cont form)))
(let ((opname (car form)))
- (cond ((symbolp opname)
- (let ((lexical-def (lexenv-find opname funs)))
+ (cond ((or (symbolp opname) (leaf-p opname))
+ (let ((lexical-def (if (leaf-p opname)
+ opname
+ (lexenv-find opname funs))))
(typecase lexical-def
(null (ir1-convert-global-functoid start cont form))
(functional
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
(when (producing-fasl-file)
(maybe-emit-make-load-forms value))
(let* ((leaf (find-constant value))
- (res (make-ref (leaf-type leaf) leaf)))
+ (res (make-ref leaf)))
(push res (leaf-refs leaf))
(link-node-to-previous-continuation res start)
(use-continuation res cont)))
(when (typep functional '(or optional-dispatch clambda))
;; When FUNCTIONAL knows its component
- (when (lambda-p functional)
+ (when (lambda-p functional)
(aver (eql (lambda-component functional) *current-component*)))
(pushnew functional
;;; functional instead.
(defun reference-leaf (start cont leaf)
(declare (type continuation start cont) (type leaf leaf))
- (with-continuation-type-assertion
- (cont (or (lexenv-find leaf type-restrictions) *wild-type*)
- "in DECLARE")
- (let* ((leaf (or (and (defined-fun-p leaf)
- (not (eq (defined-fun-inlinep leaf)
- :notinline))
- (let ((functional (defined-fun-functional leaf)))
- (when (and functional
- (not (functional-kind functional)))
- (maybe-reanalyze-functional functional))))
- leaf))
- (res (make-ref (leaf-type leaf)
- leaf)))
- (push res (leaf-refs leaf))
- (setf (leaf-ever-used leaf) t)
- (link-node-to-previous-continuation res start)
- (use-continuation res cont))))
+ (let* ((type (lexenv-find leaf type-restrictions))
+ (leaf (or (and (defined-fun-p leaf)
+ (not (eq (defined-fun-inlinep leaf)
+ :notinline))
+ (let ((functional (defined-fun-functional leaf)))
+ (when (and functional
+ (not (functional-kind functional)))
+ (maybe-reanalyze-functional functional))))
+ leaf))
+ (ref (make-ref leaf)))
+ (push ref (leaf-refs leaf))
+ (setf (leaf-ever-used leaf) t)
+ (link-node-to-previous-continuation ref start)
+ (cond (type (let* ((ref-cont (make-continuation))
+ (cast (make-cast ref-cont
+ (make-single-value-type type)
+ (lexenv-policy *lexenv*))))
+ (setf (continuation-dest ref-cont) cast)
+ (use-continuation ref ref-cont)
+ (link-node-to-previous-continuation cast ref-cont)
+ (use-continuation cast cont)))
+ (t (use-continuation ref cont)))))
;;; Convert a reference to a symbolic constant or variable. If the
;;; symbol is entered in the LEXENV-VARS we use that definition,
(reference-leaf start cont var))
(cons
(aver (eq (car var) 'MACRO))
+ ;; FIXME: [Free] type declarations. -- APD, 2002-01-26
(ir1-convert start cont (cdr var)))
(heap-alien-info
(ir1-convert start cont `(%heap-alien ',var)))))
ir1-convert-combination))
(defun ir1-convert-combination (start cont form fun)
(let ((fun-cont (make-continuation)))
- (reference-leaf start fun-cont fun)
+ (ir1-convert start fun-cont `(the (or function symbol) ,fun))
(ir1-convert-combination-args fun-cont cont (cdr form))))
;;; Convert the arguments to a call and make the COMBINATION
(declare (type continuation fun-cont cont) (list args))
(let ((node (make-combination fun-cont)))
(setf (continuation-dest fun-cont) node)
- (assert-continuation-type fun-cont
- (specifier-type '(or function symbol)))
- (setf (continuation-%externally-checkable-type fun-cont) nil)
(collect ((arg-conts))
(let ((this-start fun-cont))
(dolist (arg args)
(fun-cont (basic-combination-fun node))
(type (leaf-type var)))
(when (validate-call-type node type t)
- (setf (continuation-%derived-type fun-cont) type)
- (setf (continuation-reoptimize fun-cont) nil)
- (setf (continuation-%type-check fun-cont) nil)))
+ (setf (continuation-%derived-type fun-cont)
+ (make-single-value-type type))
+ (setf (continuation-reoptimize fun-cont) nil)))
(values))
;;; Convert a call to a local function, or if the function has already
(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
(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."
;;; declarations that constrain the type of lexically apparent
;;; functions.
(defun process-ftype-decl (spec res names fvars)
- (declare (type type-specifier spec)
- (type list names fvars)
+ (declare (type list names fvars)
(type lexenv res))
(let ((type (compiler-specifier-type spec)))
(collect ((res nil cons))
:policy (process-optimize-decl spec (lexenv-policy res))))
(type
(process-type-decl (cdr spec) res vars))
- (values
- (if *suppress-values-declaration*
+ (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)
(compiler-error
"The list ~S is too long to be an arg specifier."
spec)))))))
-
+
(dolist (name required)
(let ((var (varify-lambda-arg name (names-so-far))))
(vars var)
(names-so-far name)))
-
+
(dolist (spec optional)
(if (atom spec)
(let ((var (varify-lambda-arg spec (names-so-far))))
(vars var)
(names-so-far name)
(parse-default spec info))))
-
+
(when restp
(let ((var (varify-lambda-arg rest (names-so-far))))
(setf (lambda-var-arg-info var) (make-arg-info :kind :rest))
(make-arg-info :kind :more-count))
(vars var)
(names-so-far more-count)))
-
+
(dolist (spec keys)
(cond
((atom spec)
(vars var)
(names-so-far name)
(parse-default spec info))))))
-
+
(dolist (spec aux)
(cond ((atom spec)
(let ((var (varify-lambda-arg spec nil)))
(ir1-convert-progn-body start cont body)
(let ((fun-cont (make-continuation))
(fun (ir1-convert-lambda-body body
- (list (first aux-vars))
- :aux-vars (rest aux-vars)
- :aux-vals (rest aux-vals)
- :debug-name (debug-namify
- "&AUX bindings ~S"
- aux-vars))))
+ (list (first aux-vars))
+ :aux-vars (rest aux-vars)
+ :aux-vals (rest aux-vals)
+ :debug-name (debug-namify
+ "&AUX bindings ~S"
+ aux-vars))))
(reference-leaf start fun-cont fun)
(ir1-convert-combination-args fun-cont cont
(list (first aux-vals)))))
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))
:%debug-name debug-name))
(result (or result (make-continuation))))
+ (continuation-starts-block result)
+
;; just to check: This function should fail internal assertions if
;; we didn't set up a valid debug name above.
;;
(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)
:cleanup nil)))
(setf (bind-lambda bind) lambda)
(setf (node-lexenv bind) *lexenv*)
-
+
(let ((cont1 (make-continuation))
(cont2 (make-continuation)))
(continuation-starts-block cont1)
(setf (lambda-tail-set lambda) tail-set)
(setf (lambda-return lambda) return)
(setf (continuation-dest result) return)
- (setf (continuation-%externally-checkable-type result) nil)
+ (flush-continuation-externally-checkable-type result)
(setf (block-last block) return)
(link-node-to-previous-continuation return result)
(use-continuation return dummy))
(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)))
`((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))
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"
"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))))
\f
;;;; defining global functions
;;; 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)
: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
(defun %compiler-defun (name lambda-with-lexenv)
(let ((defined-fun nil)) ; will be set below if we're in the compiler
-
+
(when (boundp '*lexenv*) ; when in the compiler
(when sb!xc:*compile-print*
(compiler-mumble "~&; recognizing DEFUN ~S~%" name))
(cond (lambda-with-lexenv
(setf (info :function :inline-expansion-designator name)
lambda-with-lexenv)
- (when defined-fun
+ (when defined-fun
(setf (defined-fun-inline-expansion defined-fun)
lambda-with-lexenv)))
(t
projects / sbcl.git / blobdiff