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)
;;;; node.
;;; Make a :ENTRY cleanup and emit an ENTRY node, then convert the
-;;; body in the modified environment. We make CONT start a block now,
+;;; body in the modified environment. We make NEXT start a block now,
;;; since if it was done later, the block would be in the wrong
;;; environment.
(def-ir1-translator block ((name &rest forms) start next result)
result of Value-Form."
(unless (symbolp name)
(compiler-error "The block name ~S is not a symbol." name))
+ (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)
Evaluate the Value-Form, returning its values from the lexically enclosing
BLOCK Block-Name. This is constrained to be used only within the dynamic
extent of the BLOCK."
- ;; CMU CL comment:
- ;; We make CONT start a block just so that it will have a block
- ;; assigned. People assume that when they pass a continuation into
- ;; IR1-CONVERT as CONT, it will have a block when it is done.
+ ;; old comment:
+ ;; We make NEXT start a block just so that it will have a block
+ ;; assigned. People assume that when they pass a ctran into
+ ;; IR1-CONVERT as NEXT, it will have a block when it is done.
;; KLUDGE: Note that this block is basically fictitious. In the code
;; (BLOCK B (RETURN-FROM B) (SETQ X 3))
;; it's the block which answers the question "which block is
(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
to the next statement following that tag. A Tag must an integer or a
symbol. A statement must be a list. Other objects are illegal within the
body."
+ (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)
+ (compiler-assert-symbol-home-package-unlocked
+ 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))
+ (compiler-assert-symbol-home-package-unlocked
+ 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) &body body)
+ `(multiple-value-bind (,leaf allocate-p) (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)))
\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 ((fun-ctran (make-ctran))
+ (with-fun-name-leaf (leaf (second function) start)
+ (ir1-convert start next result `(,leaf ,@args)))
+ (let ((ctran (make-ctran))
(fun-lvar (make-lvar)))
- (ir1-convert start fun-ctran fun-lvar `(the function ,function))
- (ir1-convert-combination-args fun-ctran fun-lvar next result args))))
+ (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
`(%funcall ,function ,@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)
+ (compiler-assert-symbol-home-package-unlocked
+ 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* ((fun-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 fun-ctran fun-lvar fun))
- (values next result))))
- (ir1-convert-combination-args fun-ctran fun-lvar 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)
+ (compiler-assert-symbol-home-package-unlocked
+ 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
(def-ir1-translator truly-the ((type value) start next result)
#!+sb-doc
""
- (declare (inline member))
#-nil
(let ((type (coerce-to-values (compiler-values-specifier-type type)))
- (old (find-uses result)))
+ (old (when result (find-uses result))))
(ir1-convert start next result value)
- (do-uses (use result)
- (unless (memq use old)
- (derive-node-type use type))))
+ (when result
+ (do-uses (use result)
+ (unless (memq use old)
+ (derive-node-type use type)))))
#+nil
(the-in-policy type value '((type-check . 0)) start cont))
\f
(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
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
"MULTIPLE-VALUE-CALL Function Values-Form*
Call FUNCTION, passing all the values of each VALUES-FORM as arguments,
values from the first VALUES-FORM making up the first argument, etc."
- (let* ((fun-ctran (make-ctran))
+ (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))))
- (ir1-convert start fun-ctran fun-lvar
- (if (and (consp fun) (eq (car fun) 'function))
- fun
- `(%coerce-callable-to-fun ,fun)))
+ (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)))
(setf (lvar-dest fun-lvar) node)
(collect ((arg-lvars))
- (let ((this-start fun-ctran))
- (dolist (arg args)
- (let ((this-ctran (make-ctran))
+ (let ((this-start 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))))))
-
-;;; MULTIPLE-VALUE-PROG1 is represented implicitly in IR1 by having a
-;;; the result code use result continuation (CONT), but transfer
-;;; control to the evaluation of the body. In other words, the result
-;;; continuation isn't IMMEDIATELY-USED-P by the nodes that compute
-;;; the result.
-;;;
-;;; In order to get the control flow right, we convert the result with
-;;; a dummy result continuation, then convert all the uses of the
-;;; dummy to be uses of CONT. If a use is an EXIT, then we also
-;;; substitute CONT for the dummy in the corresponding ENTRY node so
-;;; that they are consistent. Note that this doesn't amount to
-;;; changing the exit target, since the control destination of an exit
-;;; is determined by the block successor; we are just indicating the
-;;; continuation that the result is delivered to.
-;;;
-;;; We then convert the body, using another dummy continuation in its
-;;; own block as the result. After we are done converting the body, we
-;;; move all predecessors of the dummy end block to CONT's block.
-;;;
-;;; Note that we both exploit and maintain the invariant that the CONT
-;;; to an IR1 convert method either has no block or starts the block
-;;; that control should transfer to after completion for the form.
-;;; Nested MV-PROG1's work because during conversion of the result
-;;; form, we use dummy continuation whose block is the true control
-;;; destination.
+ (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)
#!+sb-doc
Evaluate Values-Form and then the Forms, but return all the values of
Values-Form."
(let ((dummy (make-ctran)))
+ (ctran-starts-block dummy)
(ir1-convert start dummy result values-form)
(ir1-convert-progn-body dummy next nil forms)))
\f
((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