X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcompiler%2Fir1tran.lisp;h=3898e793d5a8a23233bf2d0f631bbdc0be43f301;hb=c097c9c3d4ce2888c9f32477c95397c69e4f80aa;hp=22654d10e31714d03fde3d7b4b9e2ae104347159;hpb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 22654d1..3898e79 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -50,11 +50,6 @@ the efficiency of stable code.") (defvar *fun-names-in-this-file* nil) - -;;; *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) ;;;; namespace management utilities @@ -244,6 +239,7 @@ ;; can't contain other objects (unless (typep value '(or #-sb-xc-host unboxed-array + #+sb-xc-host (simple-array (unsigned-byte 8) (*)) symbol number character @@ -390,7 +386,8 @@ (declare (list path)) (let* ((*current-path* path) (component (make-empty-component)) - (*current-component* component)) + (*current-component* component) + (*allow-instrumenting* t)) (setf (component-name component) "initial component") (setf (component-kind component) :initial) (let* ((forms (if for-value `(,form) `(,form nil))) @@ -449,23 +446,20 @@ (declaim (ftype (sfunction (ctran ctran (or lvar null) t) (values)) ir1-convert)) (macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws - ;; out of the body and converts a proxy form instead. - (ir1-error-bailout ((start next result - form - &optional - (proxy ``(error 'simple-program-error - :format-control "execution of a form compiled with errors:~% ~S" - :format-arguments (list ',,form)))) - &body body) - (with-unique-names (skip) - `(block ,skip - (catch 'ir1-error-abort + ;; out of the body and converts a condition signalling form + ;; instead. The source form is converted to a string since it + ;; may contain arbitrary non-externalizable objects. + (ir1-error-bailout ((start next result form) &body body) + (with-unique-names (skip condition) + `(block ,skip + (let ((,condition (catch 'ir1-error-abort (let ((*compiler-error-bailout* - (lambda () - (throw 'ir1-error-abort nil)))) + (lambda (&optional e) + (throw 'ir1-error-abort e)))) ,@body - (return-from ,skip nil))) - (ir1-convert ,start ,next ,result ,proxy))))) + (return-from ,skip nil))))) + (ir1-convert ,start ,next ,result + (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 @@ -481,48 +475,50 @@ (ir1-error-bailout (start next result form) (let ((*current-path* (or (gethash form *source-paths*) (cons form *current-path*)))) - (if (atom form) - (cond ((and (symbolp form) (not (keywordp form))) - (ir1-convert-var start next result form)) - ((leaf-p form) - (reference-leaf start next result form)) - (t - (reference-constant start next result form))) - (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-namify - "LAMBDA CAR " - opname) - :allow-debug-catch-tag t)))))))) + (cond ((step-form-p form) + (ir1-convert-step start next result form)) + ((atom form) + (cond ((and (symbolp form) (not (keywordp form))) + (ir1-convert-var start next result form)) + ((leaf-p form) + (reference-leaf start next result 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-namify + "LAMBDA CAR " + opname)))))))))) (values)) ;; Generate a reference to a manifest constant, creating a new leaf @@ -533,8 +529,7 @@ (declare (type ctran start next) (type (or lvar null) result) (inline find-constant)) - (ir1-error-bailout - (start next result value '(error "attempt to reference undumpable constant")) + (ir1-error-bailout (start next result value) (when (producing-fasl-file) (maybe-emit-make-load-forms value)) (let* ((leaf (find-constant value)) @@ -581,7 +576,14 @@ :notinline)) (let ((functional (defined-fun-functional leaf))) (when (and functional - (not (functional-kind functional))) + (not (functional-kind functional)) + ;; Bug MISC.320: ir1-transform + ;; can create a reference to a + ;; inline-expanded function, + ;; defined in another component. + (not (and (lambda-p functional) + (neq (lambda-component functional) + *current-component*)))) (maybe-reanalyze-functional functional)))) (when (and (lambda-p leaf) (memq (functional-kind leaf) @@ -923,8 +925,8 @@ (new-vars nil cons)) (dolist (var-name (rest decl)) (when (boundp var-name) - (with-single-package-locked-error - (:symbol var-name "declaring the type of ~A"))) + (compiler-assert-symbol-home-package-unlocked + 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) @@ -986,8 +988,8 @@ (collect ((res nil cons)) (dolist (name names) (when (fboundp name) - (with-single-package-locked-error - (:symbol name "declaring the ftype of ~A"))) + (compiler-assert-symbol-home-package-unlocked name + "declaring the ftype of ~A")) (let ((found (find name fvars :key #'leaf-source-name :test #'equal))) @@ -1012,8 +1014,7 @@ (declare (list spec vars) (type lexenv res)) (collect ((new-venv nil cons)) (dolist (name (cdr spec)) - (with-single-package-locked-error - (:symbol name "declaring ~A special")) + (compiler-assert-symbol-home-package-unlocked name "declaring ~A special") (let ((var (find-in-bindings vars name))) (etypecase var (cons @@ -1074,7 +1075,7 @@ (functional (when (policy *lexenv* (>= speed inhibit-warnings)) (compiler-notify "ignoring ~A declaration not at ~ - definition of local function:~% ~S" + definition of local function:~% ~S" sense name))) (global-var (push (cons name (make-new-inlinep found sense)) @@ -1124,7 +1125,7 @@ (setf (lambda-var-ignorep var) t))))) (values)) -(defun process-dx-decl (names vars) +(defun process-dx-decl (names vars fvars) (flet ((maybe-notify (control &rest args) (when (policy *lexenv* (> speed inhibit-warnings)) (apply #'compiler-notify control args)))) @@ -1152,7 +1153,24 @@ (eq (car name) 'function) (null (cddr name)) (valid-function-name-p (cadr name))) - (maybe-notify "ignoring DYNAMIC-EXTENT declaration for ~S" name)) + (let* ((fname (cadr name)) + (bound-fun (find fname fvars + :key #'leaf-source-name + :test #'equal))) + (etypecase bound-fun + (leaf + #!+stack-allocatable-closures + (setf (leaf-dynamic-extent bound-fun) t) + #!-stack-allocatable-closures + (maybe-notify + "ignoring DYNAMIC-EXTENT declaration on a function ~S ~ + (not supported on this platform)." fname)) + (cons + (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname)) + (null + (maybe-notify + "ignoring DYNAMIC-EXTENT declaration for free ~S" + fname))))) (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name)))) (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names)))) @@ -1208,12 +1226,12 @@ `(values ,@types))))) res)) (dynamic-extent - (process-dx-decl (cdr spec) vars) + (process-dx-decl (cdr spec) vars fvars) res) ((disable-package-locks enable-package-locks) (make-lexenv :default res - :disabled-package-locks (process-package-lock-decl + :disabled-package-locks (process-package-lock-decl spec (lexenv-disabled-package-locks res)))) (t (unless (info :declaration :recognized (first spec))