,@body
(return-from ,skip nil)))))
(ir1-convert ,start ,next ,result
- (make-compiler-error-form ,condition ,form)))))))
+ (make-compiler-error-form ,condition
+ ,form)))))))
;; Translate FORM into IR1. The code is inserted as the NEXT of the
;; CTRAN START. RESULT is the LVAR which receives the value of the
(ir1-error-bailout (start next result form)
(let ((*current-path* (or (gethash form *source-paths*)
(cons form *current-path*))))
- (cond ((step-form-p form)
- (ir1-convert-step start next result form))
- ((atom form)
+ (cond ((atom form)
(cond ((and (symbolp form) (not (keywordp form)))
(ir1-convert-var start next result form))
((leaf-p form)
(t
(reference-constant start next result form))))
(t
- (let ((opname (car form)))
- (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 next result
- form))
- (functional
- (ir1-convert-local-combination start next result
- form
- lexical-def))
- (global-var
- (ir1-convert-srctran start next result
- lexical-def form))
- (t
- (aver (and (consp lexical-def)
- (eq (car lexical-def) 'macro)))
- (ir1-convert start next result
- (careful-expand-macro (cdr lexical-def)
- form))))))
- ((or (atom opname) (not (eq (car opname) 'lambda)))
- (compiler-error "illegal function call"))
- (t
- ;; implicitly (LAMBDA ..) because the LAMBDA
- ;; expression is the CAR of an executed form
- (ir1-convert-combination start next result
- form
- (ir1-convert-lambda
- opname
- :debug-name (debug-name
- 'lambda-car
- opname))))))))))
+ (ir1-convert-functoid start next result form)))))
(values))
;; Generate a reference to a manifest constant, creating a new leaf
(when (lambda-var-p var)
(let ((home (ctran-home-lambda-or-null start)))
(when home
- (pushnew var (lambda-calls-or-closes home))))
+ (sset-adjoin var (lambda-calls-or-closes home))))
(when (lambda-var-ignorep var)
;; (ANSI's specification for the IGNORE declaration requires
;; that this be a STYLE-WARNING, not a full WARNING.)
(ir1-convert start next result `(%heap-alien ',var)))))
(values))
-;;; Convert anything that looks like a special form, global function
-;;; or compiler-macro call.
-(defun ir1-convert-global-functoid (start next result form)
- (declare (type ctran start next) (type (or lvar null) result) (list form))
- (let* ((fun-name (first form))
- (translator (info :function :ir1-convert fun-name))
- (cmacro-fun (sb!xc:compiler-macro-function fun-name *lexenv*)))
+;;; Find a compiler-macro for a form, taking FUNCALL into account.
+(defun find-compiler-macro (opname form)
+ (if (eq opname 'funcall)
+ (let ((fun-form (cadr form)))
+ (cond ((and (consp fun-form) (eq 'function (car fun-form)))
+ (let ((real-fun (cadr fun-form)))
+ (if (legal-fun-name-p real-fun)
+ (values (sb!xc:compiler-macro-function real-fun *lexenv*)
+ real-fun)
+ (values nil nil))))
+ ((sb!xc:constantp fun-form *lexenv*)
+ (let ((fun (constant-form-value fun-form *lexenv*)))
+ (if (legal-fun-name-p fun)
+ ;; CLHS tells us that local functions must shadow
+ ;; compiler-macro-functions, but since the call is
+ ;; through a name, we are obviously interested
+ ;; in the global function.
+ (values (sb!xc:compiler-macro-function fun nil) fun)
+ (values nil nil))))
+ (t
+ (values nil nil))))
+ (if (legal-fun-name-p opname)
+ (values (sb!xc:compiler-macro-function opname *lexenv*) opname)
+ (values nil nil))))
+
+;;; Picks of special forms and compiler-macro expansions, and hands
+;;; the rest to IR1-CONVERT-COMMON-FUNCTOID
+(defun ir1-convert-functoid (start next result form)
+ (let* ((op (car form))
+ (translator (and (symbolp op) (info :function :ir1-convert op))))
(cond (translator
- (when cmacro-fun
+ (when (sb!xc:compiler-macro-function op *lexenv*)
(compiler-warn "ignoring compiler macro for special form"))
(funcall translator start next result form))
- ((and cmacro-fun
- ;; gotcha: If you look up the DEFINE-COMPILER-MACRO
- ;; macro in the ANSI spec, you might think that
- ;; suppressing compiler-macro expansion when NOTINLINE
- ;; is some pre-ANSI hack. However, if you look up the
- ;; NOTINLINE declaration, you'll find that ANSI
- ;; requires this behavior after all.
- (not (eq (info :function :inlinep fun-name) :notinline)))
- (let ((res (careful-expand-macro cmacro-fun form)))
- (if (eq res form)
- (ir1-convert-global-functoid-no-cmacro
- start next result form fun-name)
- (ir1-convert start next result res))))
(t
- (ir1-convert-global-functoid-no-cmacro start next result
- form fun-name)))))
+ (multiple-value-bind (cmacro-fun cmacro-fun-name)
+ (find-compiler-macro op form)
+ (if (and cmacro-fun
+ ;; CLHS 3.2.2.1.3 specifies that NOTINLINE
+ ;; suppresses compiler-macros.
+ (not (fun-lexically-notinline-p cmacro-fun-name)))
+ (let ((res (careful-expand-macro cmacro-fun form)))
+ (if (eq res form)
+ (ir1-convert-common-functoid start next result form
+ op)
+ (ir1-convert start next result res)))
+ (ir1-convert-common-functoid start next result form op)))))))
-;;; Handle the case of where the call was not a compiler macro, or was
-;;; a compiler macro and passed.
-(defun ir1-convert-global-functoid-no-cmacro (start next result form fun)
+;;; Handles the "common" cases: any other forms except special forms
+;;; and compiler-macros.
+(defun ir1-convert-common-functoid (start next result form op)
+ (cond ((or (symbolp op) (leaf-p op))
+ (let ((lexical-def (if (leaf-p op) op (lexenv-find op funs))))
+ (typecase lexical-def
+ (null
+ (ir1-convert-global-functoid start next result form op))
+ (functional
+ (ir1-convert-local-combination start next result form
+ lexical-def))
+ (global-var
+ (ir1-convert-srctran start next result lexical-def form))
+ (t
+ (aver (and (consp lexical-def) (eq (car lexical-def) 'macro)))
+ (ir1-convert start next result
+ (careful-expand-macro (cdr lexical-def) form))))))
+ ((or (atom op) (not (eq (car op) 'lambda)))
+ (compiler-error "illegal function call"))
+ (t
+ ;; implicitly (LAMBDA ..) because the LAMBDA expression is
+ ;; the CAR of an executed form.
+ (ir1-convert-combination
+ start next result form
+ (ir1-convert-lambda op
+ :debug-name (debug-name 'inline-lambda op))))))
+
+;;; Convert anything that looks like a global function call.
+(defun ir1-convert-global-functoid (start next result form fun)
(declare (type ctran start next) (type (or lvar null) result)
(list form))
;; FIXME: Couldn't all the INFO calls here be converted into
- ;; standard CL functions, like MACRO-FUNCTION or something?
- ;; And what happens with lexically-defined (MACROLET) macros
- ;; here, anyway?
+ ;; standard CL functions, like MACRO-FUNCTION or something? And what
+ ;; happens with lexically-defined (MACROLET) macros here, anyway?
(ecase (info :function :kind fun)
(:macro
(ir1-convert start next result
(careful-expand-macro (info :function :macro-function fun)
- form)))
+ form))
+ (unless (policy *lexenv* (zerop store-xref-data))
+ (record-macroexpansion fun (ctran-block start) *current-path*)))
((nil :function)
(ir1-convert-srctran start next result
(find-free-fun fun "shouldn't happen! (no-cmacro)")
\f
;;;; converting combinations
+;;; Does this form look like something that we should add single-stepping
+;;; instrumentation for?
+(defun step-form-p (form)
+ (flet ((step-symbol-p (symbol)
+ (not (member (symbol-package symbol)
+ (load-time-value
+ ;; KLUDGE: packages we're not interested in
+ ;; stepping.
+ (mapcar #'find-package '(sb!c sb!int sb!impl
+ sb!kernel sb!pcl)))))))
+ (and *allow-instrumenting*
+ (policy *lexenv* (= insert-step-conditions 3))
+ (listp form)
+ (symbolp (car form))
+ (step-symbol-p (car form)))))
+
;;; Convert a function call where the function FUN is a LEAF. FORM is
;;; the source for the call. We return the COMBINATION node so that
;;; the caller can poke at it if it wants to.
(let ((ctran (make-ctran))
(fun-lvar (make-lvar)))
(ir1-convert start ctran fun-lvar `(the (or function symbol) ,fun))
- (ir1-convert-combination-args fun-lvar ctran next result (cdr form))))
+ (let ((combination
+ (ir1-convert-combination-args fun-lvar ctran next result
+ (cdr form))))
+ (when (step-form-p form)
+ ;; Store a string representation of the form in the
+ ;; combination node. This will let the IR2 translator know
+ ;; that we want stepper instrumentation for this node. The
+ ;; string will be stored in the debug-info by DUMP-1-LOCATION.
+ (setf (combination-step-info combination)
+ (let ((*print-pretty* t)
+ (*print-circle* t)
+ (*print-readably* nil))
+ (prin1-to-string form))))
+ combination)))
;;; Convert the arguments to a call and make the COMBINATION
;;; node. FUN-LVAR yields the function to call. ARGS is the list of
;;; If a LAMBDA-VAR being bound, we intersect the type with the var's
;;; type, otherwise we add a type restriction on the var. If a symbol
;;; macro, we just wrap a THE around the expansion.
-(defun process-type-decl (decl res vars)
+(defun process-type-decl (decl res vars context)
(declare (list decl vars) (type lexenv res))
(let ((type (compiler-specifier-type (first decl))))
(collect ((restr nil cons)
(new-vars nil cons))
(dolist (var-name (rest decl))
(when (boundp var-name)
- (compiler-assert-symbol-home-package-unlocked
- var-name "declaring the type of ~A"))
+ (program-assert-symbol-home-package-unlocked
+ context var-name "declaring the type of ~A"))
(let* ((bound-var (find-in-bindings vars var-name))
(var (or bound-var
(lexenv-find var-name vars)
;;; declarations for functions being bound, we must also deal with
;;; declarations that constrain the type of lexically apparent
;;; functions.
-(defun process-ftype-decl (spec res names fvars)
+(defun process-ftype-decl (spec res names fvars context)
(declare (type list names fvars)
(type lexenv res))
(let ((type (compiler-specifier-type spec)))
(collect ((res nil cons))
(dolist (name names)
(when (fboundp name)
- (compiler-assert-symbol-home-package-unlocked
- name "declaring the ftype of ~A"))
+ (program-assert-symbol-home-package-unlocked
+ context name "declaring the ftype of ~A"))
(let ((found (find name fvars :key #'leaf-source-name :test #'equal)))
(cond
(found
;;; special declaration is instantiated by throwing a special variable
;;; into the variables if BINDING-FORM-P is NIL, or otherwise into
;;; *POST-BINDING-VARIABLE-LEXENV*.
-(defun process-special-decl (spec res vars binding-form-p)
+(defun process-special-decl (spec res vars binding-form-p context)
(declare (list spec vars) (type lexenv res))
(collect ((new-venv nil cons))
(dolist (name (cdr spec))
- (compiler-assert-symbol-home-package-unlocked name "declaring ~A special")
+ (program-assert-symbol-home-package-unlocked
+ context name "declaring ~A special")
(let ((var (find-in-bindings vars name)))
(etypecase var
(cons
;;; Process a single declaration spec, augmenting the specified LEXENV
;;; RES. Return RES and result type. VARS and FVARS are as described
;;; PROCESS-DECLS.
-(defun process-1-decl (raw-spec res vars fvars binding-form-p)
+(defun process-1-decl (raw-spec res vars fvars binding-form-p context)
(declare (type list raw-spec vars fvars))
(declare (type lexenv res))
(let ((spec (canonized-decl-spec raw-spec))
(result-type *wild-type*))
(values
(case (first spec)
- (special (process-special-decl spec res vars binding-form-p))
+ (special (process-special-decl spec res vars binding-form-p context))
(ftype
(unless (cdr spec)
(compiler-error "no type specified in FTYPE declaration: ~S" spec))
- (process-ftype-decl (second spec) res (cddr spec) fvars))
+ (process-ftype-decl (second spec) res (cddr spec) fvars context))
((inline notinline maybe-inline)
(process-inline-decl spec res fvars))
((ignore ignorable)
:handled-conditions (process-unmuffle-conditions-decl
spec (lexenv-handled-conditions res))))
(type
- (process-type-decl (cdr spec) res vars))
+ (process-type-decl (cdr spec) res vars context))
(values
(unless *suppress-values-declaration*
(let ((types (cdr spec)))
;;;
;;; This is also called in main.lisp when PROCESS-FORM handles a use
;;; of LOCALLY.
-(defun process-decls (decls vars fvars &key (lexenv *lexenv*)
- (binding-form-p nil))
+(defun process-decls (decls vars fvars &key
+ (lexenv *lexenv*) (binding-form-p nil) (context :compile))
(declare (list decls vars fvars))
(let ((result-type *wild-type*)
(*post-binding-variable-lexenv* nil))
(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 lexenv vars fvars binding-form-p)
+ (process-1-decl spec lexenv vars fvars binding-form-p context)
(setq lexenv new-env)
(unless (eq new-result-type *wild-type*)
(setq result-type
projects / sbcl.git / blobdiff