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)
\f
;;;; namespace management utilities
;; 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
(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)))
(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
(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
(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))
: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)
(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)
(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)))
(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
(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))
(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))))
(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))))
`(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))
projects / sbcl.git / blobdiff