X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=d87619172f0308e4d51b0cddb38ac063439bae89;hb=e7dc41bb0e683c1ea329ce720cddd148da6e92e1;hp=c6cf4d0bdd421c7f799e88524dc27cde1cb5d351;hpb=3558758e6943e53c15bf76c2d4cfd4ee896c726b;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index c6cf4d0..d876191 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -487,9 +487,7 @@ (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) @@ -497,41 +495,7 @@ (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 @@ -649,48 +613,95 @@ (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)") @@ -790,6 +801,22 @@ ;;;; 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. @@ -799,7 +826,19 @@ (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