otherwise evaluate Else and return its values. Else defaults to NIL."
(let* ((pred-ctran (make-ctran))
(pred-lvar (make-lvar))
- (then-ctran (make-ctran))
- (then-block (ctran-starts-block then-ctran))
- (else-ctran (make-ctran))
- (else-block (ctran-starts-block else-ctran))
- (node (make-if :test pred-lvar
- :consequent then-block
- :alternative else-block)))
+ (then-ctran (make-ctran))
+ (then-block (ctran-starts-block then-ctran))
+ (else-ctran (make-ctran))
+ (else-block (ctran-starts-block else-ctran))
+ (node (make-if :test pred-lvar
+ :consequent then-block
+ :alternative else-block)))
;; IR1-CONVERT-MAYBE-PREDICATE requires DEST to be CIF, so the
;; order of the following two forms is important
(setf (lvar-dest pred-lvar) node)
(start-block start)
(ctran-starts-block next)
(let* ((dummy (make-ctran))
- (entry (make-entry))
- (cleanup (make-cleanup :kind :block
- :mess-up entry)))
+ (entry (make-entry))
+ (cleanup (make-cleanup :kind :block
+ :mess-up entry)))
(push entry (lambda-entries (lexenv-lambda *lexenv*)))
(setf (entry-cleanup entry) cleanup)
(link-node-to-previous-ctran entry start)
(let* ((env-entry (list entry next result))
(*lexenv* (make-lexenv :blocks (list (cons name env-entry))
- :cleanup cleanup)))
+ :cleanup cleanup)))
(ir1-convert-progn-body dummy next result forms))))
(def-ir1-translator return-from ((name &optional value) start next result)
(declare (ignore result))
(ctran-starts-block next)
(let* ((found (or (lexenv-find name blocks)
- (compiler-error "return for unknown block: ~S" name)))
- (value-ctran (make-ctran))
+ (compiler-error "return for unknown block: ~S" name)))
+ (exit-ctran (second found))
+ (value-ctran (make-ctran))
(value-lvar (make-lvar))
- (entry (first found))
- (exit (make-exit :entry entry
- :value value-lvar)))
+ (entry (first found))
+ (exit (make-exit :entry entry
+ :value value-lvar)))
+ (when (ctran-deleted-p exit-ctran)
+ (throw 'locall-already-let-converted exit-ctran))
(push exit (entry-exits entry))
(setf (lvar-dest value-lvar) exit)
(ir1-convert start value-ctran value-lvar value)
(link-node-to-previous-ctran exit value-ctran)
(let ((home-lambda (ctran-home-lambda-or-null start)))
(when home-lambda
- (push entry (lambda-calls-or-closes home-lambda))))
- (use-continuation exit (second found) (third found))))
+ (push entry (lambda-calls-or-closes home-lambda))))
+ (use-continuation exit exit-ctran (third found))))
;;; Return a list of the segments of a TAGBODY. Each segment looks
;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
(collect ((segments))
(let ((current (cons nil body)))
(loop
- (let ((tag-pos (position-if (complement #'listp) current :start 1)))
- (unless tag-pos
- (segments `(,@current nil))
- (return))
- (let ((tag (elt current tag-pos)))
- (when (assoc tag (segments))
- (compiler-error
- "The tag ~S appears more than once in the tagbody."
- tag))
- (unless (or (symbolp tag) (integerp tag))
- (compiler-error "~S is not a legal tagbody statement." tag))
- (segments `(,@(subseq current 0 tag-pos) (go ,tag))))
- (setq current (nthcdr tag-pos current)))))
+ (let ((tag-pos (position-if (complement #'listp) current :start 1)))
+ (unless tag-pos
+ (segments `(,@current nil))
+ (return))
+ (let ((tag (elt current tag-pos)))
+ (when (assoc tag (segments))
+ (compiler-error
+ "The tag ~S appears more than once in the tagbody."
+ tag))
+ (unless (or (symbolp tag) (integerp tag))
+ (compiler-error "~S is not a legal tagbody statement." tag))
+ (segments `(,@(subseq current 0 tag-pos) (go ,tag))))
+ (setq current (nthcdr tag-pos current)))))
(segments)))
;;; Set up the cleanup, emitting the entry node. Then make a block for
(start-block start)
(ctran-starts-block next)
(let* ((dummy (make-ctran))
- (entry (make-entry))
- (segments (parse-tagbody statements))
- (cleanup (make-cleanup :kind :tagbody
- :mess-up entry)))
+ (entry (make-entry))
+ (segments (parse-tagbody statements))
+ (cleanup (make-cleanup :kind :tagbody
+ :mess-up entry)))
(push entry (lambda-entries (lexenv-lambda *lexenv*)))
(setf (entry-cleanup entry) cleanup)
(link-node-to-previous-ctran entry start)
(use-ctran entry dummy)
(collect ((tags)
- (starts)
- (ctrans))
+ (starts)
+ (ctrans))
(starts dummy)
(dolist (segment (rest segments))
- (let* ((tag-ctran (make-ctran))
+ (let* ((tag-ctran (make-ctran))
(tag (list (car segment) entry tag-ctran)))
- (ctrans tag-ctran)
- (starts tag-ctran)
- (ctran-starts-block tag-ctran)
+ (ctrans tag-ctran)
+ (starts tag-ctran)
+ (ctran-starts-block tag-ctran)
(tags tag)))
(ctrans next)
(let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
- (mapc (lambda (segment start end)
- (ir1-convert-progn-body start end
+ (mapc (lambda (segment start end)
+ (ir1-convert-progn-body start end
(when (eq end next) result)
(rest segment)))
- segments (starts) (ctrans))))))
+ segments (starts) (ctrans))))))
;;; Emit an EXIT node without any value.
(def-ir1-translator go ((tag) start next result)
is constrained to be used only within the dynamic extent of the TAGBODY."
(ctran-starts-block next)
(let* ((found (or (lexenv-find tag tags :test #'eql)
- (compiler-error "attempt to GO to nonexistent tag: ~S"
- tag)))
- (entry (first found))
- (exit (make-exit :entry entry)))
+ (compiler-error "attempt to GO to nonexistent tag: ~S"
+ tag)))
+ (entry (first found))
+ (exit (make-exit :entry entry)))
(push exit (entry-exits entry))
(link-node-to-previous-ctran exit start)
(let ((home-lambda (ctran-home-lambda-or-null start)))
(when home-lambda
- (push entry (lambda-calls-or-closes home-lambda))))
+ (push entry (lambda-calls-or-closes home-lambda))))
(use-ctran exit (second found))))
\f
;;;; translators for compiler-magic special forms
;;; in-lexenv representation, stuff the results into *LEXENV*, and
;;; call FUN (with no arguments).
(defun %funcall-in-foomacrolet-lexenv (definitionize-fun
- definitionize-keyword
- definitions
- fun)
+ definitionize-keyword
+ definitions
+ fun)
(declare (type function definitionize-fun fun))
(declare (type (member :vars :funs) definitionize-keyword))
(declare (type list definitions))
(compiler-style-warn "duplicate definitions in ~S" definitions))
(let* ((processed-definitions (mapcar definitionize-fun definitions))
(*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
+ ;; I wonder how much of an compiler performance penalty this
+ ;; non-constant keyword is.
(funcall fun definitionize-keyword processed-definitions)))
;;; Tweak LEXENV to include the DEFINITIONS from a MACROLET, then
;;; EVAL can likewise make use of it.
(defun macrolet-definitionize-fun (context lexenv)
(flet ((fail (control &rest args)
- (ecase context
- (:compile (apply #'compiler-error control args))
- (:eval (error 'simple-program-error
+ (ecase context
+ (:compile (apply #'compiler-error control args))
+ (:eval (error 'simple-program-error
:format-control control
:format-arguments args)))))
(lambda (definition)
(destructuring-bind (name arglist &body body) definition
(unless (symbolp name)
(fail "The local macro name ~S is not a symbol." name))
+ (when (fboundp name)
+ (program-assert-symbol-home-package-unlocked
+ context name "binding ~A as a local macro"))
(unless (listp arglist)
(fail "The local macro argument list ~S is not a list."
arglist))
(defun symbol-macrolet-definitionize-fun (context)
(flet ((fail (control &rest args)
- (ecase context
- (:compile (apply #'compiler-error control args))
- (:eval (error 'simple-program-error
+ (ecase context
+ (:compile (apply #'compiler-error control args))
+ (:eval (error 'simple-program-error
:format-control control
:format-arguments args)))))
(lambda (definition)
(destructuring-bind (name expansion) definition
(unless (symbolp name)
(fail "The local symbol macro name ~S is not a symbol." name))
+ (when (or (boundp name) (eq (info :variable :kind name) :macro))
+ (program-assert-symbol-home-package-unlocked
+ context name "binding ~A as a local symbol-macro"))
(let ((kind (info :variable :kind name)))
(when (member kind '(:special :constant))
(fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S"
kind name)))
- `(,name . (MACRO . ,expansion))))))
+ ;; A magical cons that MACROEXPAND-1 understands.
+ `(,name . (macro . ,expansion))))))
(defun funcall-in-symbol-macrolet-lexenv (definitions fun context)
(%funcall-in-foomacrolet-lexenv
(handler-case (mapcar #'eval args)
(error (condition)
(compiler-error "Lisp error during evaluation of info args:~%~A"
- condition))))
+ condition))))
;;; Convert to the %%PRIMITIVE funny function. The first argument is
;;; the template, the second is a list of the results of any
(def-ir1-translator %primitive ((name &rest args) start next result)
(declare (type symbol name))
(let* ((template (or (gethash name *backend-template-names*)
- (bug "undefined primitive ~A" name)))
- (required (length (template-arg-types template)))
- (info (template-info-arg-count template))
- (min (+ required info))
- (nargs (length args)))
+ (bug "undefined primitive ~A" name)))
+ (required (length (template-arg-types template)))
+ (info (template-info-arg-count template))
+ (min (+ required info))
+ (nargs (length args)))
(if (template-more-args-type template)
- (when (< nargs min)
- (bug "Primitive ~A was called with ~R argument~:P, ~
- but wants at least ~R."
- name
- nargs
- min))
- (unless (= nargs min)
- (bug "Primitive ~A was called with ~R argument~:P, ~
+ (when (< nargs min)
+ (bug "Primitive ~A was called with ~R argument~:P, ~
+ but wants at least ~R."
+ name
+ nargs
+ min))
+ (unless (= nargs min)
+ (bug "Primitive ~A was called with ~R argument~:P, ~
but wants exactly ~R."
- name
- nargs
- min)))
+ name
+ nargs
+ min)))
(when (eq (template-result-types template) :conditional)
(bug "%PRIMITIVE was used with a conditional template."))
(bug "%PRIMITIVE was used with an unknown values template."))
(ir1-convert start next result
- `(%%primitive ',template
- ',(eval-info-args
- (subseq args required min))
- ,@(subseq args 0 required)
- ,@(subseq args min)))))
+ `(%%primitive ',template
+ ',(eval-info-args
+ (subseq args required min))
+ ,@(subseq args 0 required)
+ ,@(subseq args min)))))
\f
;;;; QUOTE
(reference-constant start next result thing))
\f
;;;; FUNCTION and NAMED-LAMBDA
+(defun name-lambdalike (thing)
+ (ecase (car thing)
+ ((named-lambda)
+ (second thing))
+ ((lambda instance-lambda)
+ `(lambda ,(second thing)))
+ ((lambda-with-lexenv)'
+ `(lambda ,(fifth thing)))))
+
(defun fun-name-leaf (thing)
(if (consp thing)
(cond
- ((member (car thing)
- '(lambda named-lambda instance-lambda lambda-with-lexenv))
- (ir1-convert-lambdalike
- thing
- :debug-name (debug-namify "#'~S" thing)
- :allow-debug-catch-tag t))
- ((legal-fun-name-p thing)
- (find-lexically-apparent-fun
- thing "as the argument to FUNCTION"))
- (t
- (compiler-error "~S is not a legal function name." thing)))
- (find-lexically-apparent-fun
- thing "as the argument to FUNCTION")))
+ ((member (car thing)
+ '(lambda named-lambda instance-lambda lambda-with-lexenv))
+ (values (ir1-convert-lambdalike
+ thing
+ :debug-name (name-lambdalike thing))
+ t))
+ ((legal-fun-name-p thing)
+ (values (find-lexically-apparent-fun
+ thing "as the argument to FUNCTION")
+ nil))
+ (t
+ (compiler-error "~S is not a legal function name." thing)))
+ (values (find-lexically-apparent-fun
+ thing "as the argument to FUNCTION")
+ nil)))
+
+(def-ir1-translator %%allocate-closures ((&rest leaves) start next result)
+ (aver (eq result 'nil))
+ (let ((lambdas leaves))
+ (ir1-convert start next result `(%allocate-closures ',lambdas))
+ (let ((allocator (node-dest (ctran-next start))))
+ (dolist (lambda lambdas)
+ (setf (functional-allocator lambda) allocator)))))
+
+(defmacro with-fun-name-leaf ((leaf thing start &key global) &body body)
+ `(multiple-value-bind (,leaf allocate-p)
+ (if ,global
+ (find-global-fun ,thing t)
+ (fun-name-leaf ,thing))
+ (if allocate-p
+ (let ((.new-start. (make-ctran)))
+ (ir1-convert ,start .new-start. nil `(%%allocate-closures ,leaf))
+ (let ((,start .new-start.))
+ ,@body))
+ (locally
+ ,@body))))
(def-ir1-translator function ((thing) start next result)
#!+sb-doc
"FUNCTION Name
Return the lexically apparent definition of the function Name. Name may also
be a lambda expression."
- (reference-leaf start next result (fun-name-leaf thing)))
+ (with-fun-name-leaf (leaf thing start)
+ (reference-leaf start next result leaf)))
+
+;;; Like FUNCTION, but ignores local definitions and inline
+;;; expansions, and doesn't nag about undefined functions.
+;;; Used for optimizing things like (FUNCALL 'FOO).
+(def-ir1-translator global-function ((thing) start next result)
+ (with-fun-name-leaf (leaf thing start :global t)
+ (reference-leaf start next result leaf)))
+
+(defun constant-global-fun-name (thing)
+ (let ((constantp (sb!xc:constantp thing)))
+ (and constantp
+ (let ((name (constant-form-value thing)))
+ (and (legal-fun-name-p name) name)))))
\f
;;;; FUNCALL
(let ((arg-names (make-gensym-list (length args))))
`(lambda (function ,@arg-names)
(%funcall ,(if (csubtypep (lvar-type function)
- (specifier-type 'function))
- 'function
- '(%coerce-callable-to-fun function))
- ,@arg-names))))
+ (specifier-type 'function))
+ 'function
+ '(%coerce-callable-to-fun function))
+ ,@arg-names))))
(def-ir1-translator %funcall ((function &rest args) start next result)
- (if (and (consp function) (eq (car function) 'function))
- (ir1-convert start next result
- `(,(fun-name-leaf (second function)) ,@args))
- (let ((ctran (make-ctran))
- (fun-lvar (make-lvar)))
- (ir1-convert start ctran fun-lvar `(the function ,function))
- (ir1-convert-combination-args fun-lvar ctran next result args))))
+ (cond ((and (consp function) (eq (car function) 'function))
+ (with-fun-name-leaf (leaf (second function) start)
+ (ir1-convert start next result `(,leaf ,@args))))
+ ((and (consp function) (eq (car function) 'global-function))
+ (with-fun-name-leaf (leaf (second function) start :global t)
+ (ir1-convert start next result `(,leaf ,@args))))
+ (t
+ (let ((ctran (make-ctran))
+ (fun-lvar (make-lvar)))
+ (ir1-convert start ctran fun-lvar `(the function ,function))
+ (ir1-convert-combination-args fun-lvar ctran next result args)))))
;;; This source transform exists to reduce the amount of work for the
;;; compiler. If the called function is a FUNCTION form, then convert
(define-source-transform funcall (function &rest args)
(if (and (consp function) (eq (car function) 'function))
`(%funcall ,function ,@args)
- (values nil t)))
+ (let ((name (constant-global-fun-name function)))
+ (if name
+ `(%funcall (global-function ,name) ,@args)
+ (values nil t)))))
-(deftransform %coerce-callable-to-fun ((thing) (function) *
- :important t)
+(deftransform %coerce-callable-to-fun ((thing) (function) *)
"optimize away possible call to FDEFINITION at runtime"
'thing)
\f
;;; variables are marked as such. Context is the name of the form, for
;;; error reporting purposes.
(declaim (ftype (function (list symbol) (values list list))
- extract-let-vars))
+ extract-let-vars))
(defun extract-let-vars (bindings context)
(collect ((vars)
- (vals)
- (names))
+ (vals)
+ (names))
(flet ((get-var (name)
- (varify-lambda-arg name
- (if (eq context 'let*)
- nil
- (names)))))
+ (varify-lambda-arg name
+ (if (eq context 'let*)
+ nil
+ (names)))))
(dolist (spec bindings)
- (cond ((atom spec)
- (let ((var (get-var spec)))
- (vars var)
- (names spec)
- (vals nil)))
- (t
- (unless (proper-list-of-length-p spec 1 2)
- (compiler-error "The ~S binding spec ~S is malformed."
- context
- spec))
- (let* ((name (first spec))
- (var (get-var name)))
- (vars var)
- (names name)
- (vals (second spec)))))))
-
+ (cond ((atom spec)
+ (let ((var (get-var spec)))
+ (vars var)
+ (names spec)
+ (vals nil)))
+ (t
+ (unless (proper-list-of-length-p spec 1 2)
+ (compiler-error "The ~S binding spec ~S is malformed."
+ context
+ spec))
+ (let* ((name (first spec))
+ (var (get-var name)))
+ (vars var)
+ (names name)
+ (vals (second spec)))))))
+ (dolist (name (names))
+ (when (eq (info :variable :kind name) :macro)
+ (program-assert-symbol-home-package-unlocked
+ :compile name "lexically binding symbol-macro ~A")))
(values (vars) (vals))))
(def-ir1-translator let ((bindings &body body) start next result)
During evaluation of the Forms, bind the Vars to the result of evaluating the
Value forms. The variables are bound in parallel after all of the Values are
evaluated."
- (if (null bindings)
- (ir1-translate-locally body start next result)
- (multiple-value-bind (forms decls)
- (parse-body body :doc-string-allowed nil)
- (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
- (binding* ((ctran (make-ctran))
- (fun-lvar (make-lvar))
- ((next result)
- (processing-decls (decls vars nil next result)
- (let ((fun (ir1-convert-lambda-body
- forms vars
- :debug-name (debug-namify "LET ~S"
- bindings))))
- (reference-leaf start ctran fun-lvar fun))
- (values next result))))
- (ir1-convert-combination-args fun-lvar ctran next result values))))))
+ (cond ((null bindings)
+ (ir1-translate-locally body start next result))
+ ((listp bindings)
+ (multiple-value-bind (forms decls)
+ (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
+ (binding* ((ctran (make-ctran))
+ (fun-lvar (make-lvar))
+ ((next result)
+ (processing-decls (decls vars nil next result
+ post-binding-lexenv)
+ (let ((fun (ir1-convert-lambda-body
+ forms
+ vars
+ :post-binding-lexenv post-binding-lexenv
+ :debug-name (debug-name 'let bindings))))
+ (reference-leaf start ctran fun-lvar fun))
+ (values next result))))
+ (ir1-convert-combination-args fun-lvar ctran next result values)))))
+ (t
+ (compiler-error "Malformed LET bindings: ~S." bindings))))
(def-ir1-translator let* ((bindings &body body)
- start next result)
+ start next result)
#!+sb-doc
"LET* ({(Var [Value]) | Var}*) Declaration* Form*
Similar to LET, but the variables are bound sequentially, allowing each Value
form to reference any of the previous Vars."
- (multiple-value-bind (forms decls)
- (parse-body body :doc-string-allowed nil)
- (multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
- (processing-decls (decls vars nil start next)
- (ir1-convert-aux-bindings start next result forms vars values)))))
+ (if (listp bindings)
+ (multiple-value-bind (forms decls)
+ (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
+ (processing-decls (decls vars nil start next post-binding-lexenv)
+ (ir1-convert-aux-bindings start
+ next
+ result
+ forms
+ vars
+ values
+ post-binding-lexenv))))
+ (compiler-error "Malformed LET* bindings: ~S." bindings)))
;;; logic shared between IR1 translators for LOCALLY, MACROLET,
;;; and SYMBOL-MACROLET
(declaim (ftype (function (list symbol) (values list list)) extract-flet-vars))
(defun extract-flet-vars (definitions context)
(collect ((names)
- (defs))
+ (defs))
(dolist (def definitions)
(when (or (atom def) (< (length def) 2))
- (compiler-error "The ~S definition spec ~S is malformed." context def))
+ (compiler-error "The ~S definition spec ~S is malformed." context def))
(let ((name (first def)))
- (check-fun-name name)
- (names name)
- (multiple-value-bind (forms decls) (parse-body (cddr def))
- (defs `(lambda ,(second def)
- ,@decls
- (block ,(fun-name-block-name name)
- . ,forms))))))
+ (check-fun-name name)
+ (when (fboundp name)
+ (program-assert-symbol-home-package-unlocked
+ :compile name "binding ~A as a local function"))
+ (names name)
+ (multiple-value-bind (forms decls) (parse-body (cddr def))
+ (defs `(lambda ,(second def)
+ ,@decls
+ (block ,(fun-name-block-name name)
+ . ,forms))))))
(values (names) (defs))))
+(defun ir1-convert-fbindings (start next result funs body)
+ (let ((ctran (make-ctran))
+ (dx-p (find-if #'leaf-dynamic-extent funs)))
+ (when dx-p
+ (ctran-starts-block ctran)
+ (ctran-starts-block next))
+ (ir1-convert start ctran nil `(%%allocate-closures ,@funs))
+ (cond (dx-p
+ (let* ((dummy (make-ctran))
+ (entry (make-entry))
+ (cleanup (make-cleanup :kind :dynamic-extent
+ :mess-up entry
+ :info (list (node-dest
+ (ctran-next start))))))
+ (push entry (lambda-entries (lexenv-lambda *lexenv*)))
+ (setf (entry-cleanup entry) cleanup)
+ (link-node-to-previous-ctran entry ctran)
+ (use-ctran entry dummy)
+
+ (let ((*lexenv* (make-lexenv :cleanup cleanup)))
+ (ir1-convert-progn-body dummy next result body))))
+ (t (ir1-convert-progn-body ctran next result body)))))
+
(def-ir1-translator flet ((definitions &body body)
- start next result)
+ start next result)
#!+sb-doc
"FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
Evaluate the Body-Forms with some local function definitions. The bindings
(multiple-value-bind (forms decls)
(parse-body body :doc-string-allowed nil)
(multiple-value-bind (names defs)
- (extract-flet-vars definitions 'flet)
+ (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))
+ :debug-name (debug-name 'flet n)))
names defs)))
(processing-decls (decls nil fvars next result)
(let ((*lexenv* (make-lexenv :funs (pairlis names fvars))))
- (ir1-convert-progn-body start next result forms)))))))
+ (ir1-convert-fbindings start next result fvars forms)))))))
(def-ir1-translator labels ((definitions &body body) start next result)
#!+sb-doc
each other."
(multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
(multiple-value-bind (names defs)
- (extract-flet-vars definitions 'labels)
- (let* ( ;; dummy LABELS functions, to be used as placeholders
+ (extract-flet-vars definitions 'labels)
+ (let* (;; dummy LABELS functions, to be used as placeholders
;; during construction of real LABELS functions
- (placeholder-funs (mapcar (lambda (name)
- (make-functional
- :%source-name name
- :%debug-name (debug-namify
- "LABELS placeholder ~S"
- name)))
- names))
- ;; (like PAIRLIS but guaranteed to preserve ordering:)
- (placeholder-fenv (mapcar #'cons names placeholder-funs))
+ (placeholder-funs (mapcar (lambda (name)
+ (make-functional
+ :%source-name name
+ :%debug-name (debug-name
+ 'labels-placeholder
+ name)))
+ names))
+ ;; (like PAIRLIS but guaranteed to preserve ordering:)
+ (placeholder-fenv (mapcar #'cons names placeholder-funs))
;; the real LABELS functions, compiled in a LEXENV which
;; includes the dummy LABELS functions
- (real-funs
- (let ((*lexenv* (make-lexenv :funs placeholder-fenv)))
- (mapcar (lambda (name def)
- (ir1-convert-lambda def
- :source-name name
- :debug-name (debug-namify
- "LABELS ~S" name)
- :allow-debug-catch-tag t))
- names defs))))
+ (real-funs
+ (let ((*lexenv* (make-lexenv :funs placeholder-fenv)))
+ (mapcar (lambda (name def)
+ (ir1-convert-lambda def
+ :source-name name
+ :debug-name (debug-name 'labels name)))
+ names defs))))
;; Modify all the references to the dummy function leaves so
;; that they point to the real function leaves.
- (loop for real-fun in real-funs and
- placeholder-cons in placeholder-fenv do
- (substitute-leaf real-fun (cdr placeholder-cons))
- (setf (cdr placeholder-cons) real-fun))
+ (loop for real-fun in real-funs and
+ placeholder-cons in placeholder-fenv do
+ (substitute-leaf real-fun (cdr placeholder-cons))
+ (setf (cdr placeholder-cons) real-fun))
;; Voila.
- (processing-decls (decls nil real-funs next result)
+ (processing-decls (decls nil real-funs next result)
(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 next result forms)))))))
+ (ir1-convert-fbindings start next result real-funs forms)))))))
+
\f
;;;; the THE special operator, and friends
""
#-nil
(let ((type (coerce-to-values (compiler-values-specifier-type type)))
- (old (when result (find-uses result))))
+ (old (when result (find-uses result))))
(ir1-convert start next result value)
(when result
(do-uses (use result)
(when (oddp len)
(compiler-error "odd number of args to SETQ: ~S" source))
(if (= len 2)
- (let* ((name (first things))
- (leaf (or (lexenv-find name vars)
- (find-free-var name))))
- (etypecase leaf
- (leaf
- (when (constant-p leaf)
- (compiler-error "~S is a constant and thus can't be set." name))
- (when (lambda-var-p leaf)
- (let ((home-lambda (ctran-home-lambda-or-null start)))
- (when home-lambda
- (pushnew leaf (lambda-calls-or-closes home-lambda))))
- (when (lambda-var-ignorep leaf)
- ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
- ;; requires that this be a STYLE-WARNING, not a full warning.
- (compiler-style-warn
- "~S is being set even though it was declared to be ignored."
- name)))
- (setq-var start next result leaf (second things)))
- (cons
- (aver (eq (car leaf) 'MACRO))
+ (let* ((name (first things))
+ (leaf (or (lexenv-find name vars)
+ (find-free-var name))))
+ (etypecase leaf
+ (leaf
+ (when (constant-p leaf)
+ (compiler-error "~S is a constant and thus can't be set." name))
+ (when (lambda-var-p leaf)
+ (let ((home-lambda (ctran-home-lambda-or-null start)))
+ (when home-lambda
+ (pushnew leaf (lambda-calls-or-closes home-lambda))))
+ (when (lambda-var-ignorep leaf)
+ ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
+ ;; requires that this be a STYLE-WARNING, not a full warning.
+ (compiler-style-warn
+ "~S is being set even though it was declared to be ignored."
+ name)))
+ (setq-var start next result leaf (second things)))
+ (cons
+ (aver (eq (car leaf) 'macro))
;; FIXME: [Free] type declaration. -- APD, 2002-01-26
- (ir1-convert start next result
+ (ir1-convert start next result
`(setf ,(cdr leaf) ,(second things))))
- (heap-alien-info
- (ir1-convert start next result
- `(%set-heap-alien ',leaf ,(second things))))))
- (collect ((sets))
- (do ((thing things (cddr thing)))
- ((endp thing)
- (ir1-convert-progn-body start next result (sets)))
- (sets `(setq ,(first thing) ,(second thing))))))))
+ (heap-alien-info
+ (ir1-convert start next result
+ `(%set-heap-alien ',leaf ,(second things))))))
+ (collect ((sets))
+ (do ((thing things (cddr thing)))
+ ((endp thing)
+ (ir1-convert-progn-body start next result (sets)))
+ (sets `(setq ,(first thing) ,(second thing))))))))
;;; This is kind of like REFERENCE-LEAF, but we generate a SET node.
;;; This should only need to be called in SETQ.
Do a non-local exit, return the values of Form from the CATCH whose tag
evaluates to the same thing as Tag."
(ir1-convert start next result-lvar
- `(multiple-value-call #'%throw ,tag ,result)))
+ `(multiple-value-call #'%throw ,tag ,result)))
;;; This is a special special form used to instantiate a cleanup as
;;; the current cleanup within the body. KIND is the kind of cleanup
(def-ir1-translator %within-cleanup
((kind mess-up &body body) start next result)
(let ((dummy (make-ctran))
- (dummy2 (make-ctran)))
+ (dummy2 (make-ctran)))
(ir1-convert start dummy nil mess-up)
(let* ((mess-node (ctran-use dummy))
- (cleanup (make-cleanup :kind kind
- :mess-up mess-node))
- (old-cup (lexenv-cleanup *lexenv*))
- (*lexenv* (make-lexenv :cleanup cleanup)))
+ (cleanup (make-cleanup :kind kind
+ :mess-up mess-node))
+ (old-cup (lexenv-cleanup *lexenv*))
+ (*lexenv* (make-lexenv :cleanup cleanup)))
(setf (entry-cleanup (cleanup-mess-up old-cup)) cleanup)
(ir1-convert dummy dummy2 nil '(%cleanup-point))
(ir1-convert-progn-body dummy2 next result body))))
;;; Note that environment analysis replaces references to escape
;;; functions with references to the corresponding NLX-INFO structure.
(def-ir1-translator %escape-fun ((tag) start next result)
- (let ((fun (ir1-convert-lambda
- `(lambda ()
- (return-from ,tag (%unknown-values)))
- :debug-name (debug-namify "escape function for ~S" tag))))
+ (let ((fun (let ((*allow-instrumenting* nil))
+ (ir1-convert-lambda
+ `(lambda ()
+ (return-from ,tag (%unknown-values)))
+ :debug-name (debug-name 'escape-fun tag))))
+ (ctran (make-ctran)))
(setf (functional-kind fun) :escape)
- (reference-leaf start next result fun)))
+ (ir1-convert start ctran nil `(%%allocate-closures ,fun))
+ (reference-leaf ctran next result fun)))
;;; Yet another special special form. This one looks up a local
;;; function and smashes it to a :CLEANUP function, as well as
;;; referencing it.
(def-ir1-translator %cleanup-fun ((name) start next result)
+ ;; FIXME: Should this not be :TEST #'EQUAL? What happens to
+ ;; (SETF FOO) here?
(let ((fun (lexenv-find name funs)))
(aver (lambda-p fun))
(setf (functional-kind fun) :cleanup)
start next result
(with-unique-names (exit-block)
`(block ,exit-block
- (%within-cleanup
- :catch
- (%catch (%escape-fun ,exit-block) ,tag)
- ,@body)))))
+ (%within-cleanup
+ :catch (%catch (%escape-fun ,exit-block) ,tag)
+ ,@body)))))
(def-ir1-translator unwind-protect
((protected &body cleanup) start next result)
start next result
(with-unique-names (cleanup-fun drop-thru-tag exit-tag next start count)
`(flet ((,cleanup-fun () ,@cleanup nil))
- ;; FIXME: If we ever get DYNAMIC-EXTENT working, then
- ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
- ;; and something can be done to make %ESCAPE-FUN have
- ;; dynamic extent too.
- (block ,drop-thru-tag
- (multiple-value-bind (,next ,start ,count)
- (block ,exit-tag
- (%within-cleanup
- :unwind-protect
- (%unwind-protect (%escape-fun ,exit-tag)
- (%cleanup-fun ,cleanup-fun))
- (return-from ,drop-thru-tag ,protected)))
- (,cleanup-fun)
- (%continue-unwind ,next ,start ,count)))))))
+ ;; FIXME: If we ever get DYNAMIC-EXTENT working, then
+ ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
+ ;; and something can be done to make %ESCAPE-FUN have
+ ;; dynamic extent too.
+ (block ,drop-thru-tag
+ (multiple-value-bind (,next ,start ,count)
+ (block ,exit-tag
+ (%within-cleanup
+ :unwind-protect
+ (%unwind-protect (%escape-fun ,exit-tag)
+ (%cleanup-fun ,cleanup-fun))
+ (return-from ,drop-thru-tag ,protected)))
+ (,cleanup-fun)
+ (%continue-unwind ,next ,start ,count)))))))
\f
;;;; multiple-value stuff
values from the first VALUES-FORM making up the first argument, etc."
(let* ((ctran (make-ctran))
(fun-lvar (make-lvar))
- (node (if args
- ;; If there are arguments, MULTIPLE-VALUE-CALL
- ;; turns into an MV-COMBINATION.
- (make-mv-combination fun-lvar)
- ;; If there are no arguments, then we convert to a
- ;; normal combination, ensuring that a MV-COMBINATION
- ;; always has at least one argument. This can be
- ;; regarded as an optimization, but it is more
- ;; important for simplifying compilation of
- ;; MV-COMBINATIONS.
- (make-combination fun-lvar))))
+ (node (if args
+ ;; If there are arguments, MULTIPLE-VALUE-CALL
+ ;; turns into an MV-COMBINATION.
+ (make-mv-combination fun-lvar)
+ ;; If there are no arguments, then we convert to a
+ ;; normal combination, ensuring that a MV-COMBINATION
+ ;; always has at least one argument. This can be
+ ;; regarded as an optimization, but it is more
+ ;; important for simplifying compilation of
+ ;; MV-COMBINATIONS.
+ (make-combination fun-lvar))))
(ir1-convert start ctran fun-lvar
- (if (and (consp fun) (eq (car fun) 'function))
- fun
- `(%coerce-callable-to-fun ,fun)))
+ (if (and (consp fun) (eq (car fun) 'function))
+ fun
+ (let ((name (constant-global-fun-name fun)))
+ (if name
+ `(global-function ,name)
+ `(%coerce-callable-to-fun ,fun)))))
(setf (lvar-dest fun-lvar) node)
(collect ((arg-lvars))
(let ((this-start ctran))
- (dolist (arg args)
- (let ((this-ctran (make-ctran))
+ (dolist (arg args)
+ (let ((this-ctran (make-ctran))
(this-lvar (make-lvar node)))
- (ir1-convert this-start this-ctran this-lvar arg)
- (setq this-start this-ctran)
- (arg-lvars this-lvar)))
- (link-node-to-previous-ctran node this-start)
- (use-continuation node next result)
- (setf (basic-combination-args node) (arg-lvars))))))
+ (ir1-convert this-start this-ctran this-lvar arg)
+ (setq this-start this-ctran)
+ (arg-lvars this-lvar)))
+ (link-node-to-previous-ctran node this-start)
+ (use-continuation node next result)
+ (setf (basic-combination-args node) (arg-lvars))))))
(def-ir1-translator multiple-value-prog1
((values-form &rest forms) start next result)
((null path) *current-path*)
(let ((first (first path)))
(when (or (eq first name)
- (eq first 'original-source-start))
- (return path)))))
+ (eq first 'original-source-start))
+ (return path)))))
projects / sbcl.git / blobdiff