(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)
+(defvar *post-binding-variable-lexenv* nil)
\f
;;;; namespace management utilities
(unless (info :function :kind name)
(setf (info :function :kind name) :function)
(setf (info :function :where-from name) :assumed))
-
(let ((where (info :function :where-from name)))
(when (and (eq where :assumed)
;; In the ordinary target Lisp, it's silly to report
(:macro
(let ((expansion (info :variable :macro-expansion name))
(type (type-specifier (info :variable :type name))))
- `(MACRO . (the ,type ,expansion))))
+ `(macro . (the ,type ,expansion))))
(:constant
(let ((value (info :variable :constant-value name)))
(make-constant :value value
;; 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
#+sb-xc-host structure!object
#-sb-xc-host instance
(when (emit-make-load-form value)
- (dotimes (i (%instance-length value))
+ (dotimes (i (- (%instance-length value)
+ #+sb-xc-host 0
+ #-sb-xc-host (layout-n-untagged-slots
+ (%instance-ref value 0))))
(grovel (%instance-ref value i)))))
(t
(compiler-error
(declare (list path))
(let* ((*current-path* path)
(component (make-empty-component))
- (*current-component* component))
- (setf (component-name component) "initial 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)))
(res (ir1-convert-lambda-body
forms ()
- :debug-name (debug-namify "top level form " form))))
+ :debug-name (debug-name 'top-level-form form))))
(setf (functional-entry-fun res) res
(functional-arg-documentation res) ()
(functional-kind res) :toplevel)
(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-name
+ 'lambda-car
+ opname))))))))))
(values))
-
+
;; Generate a reference to a manifest constant, creating a new leaf
;; if necessary. If we are producing a fasl file, make sure that
;; MAKE-LOAD-FORM gets used on any parts of the constant that it
(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)
(warn "reading an ignored variable: ~S" name)))
(reference-leaf start next result var))
(cons
- (aver (eq (car var) 'MACRO))
+ (aver (eq (car var) 'macro))
;; FIXME: [Free] type declarations. -- APD, 2002-01-26
(ir1-convert start next result (cdr var)))
(heap-alien-info
(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"))
(let* ((bound-var (find-in-bindings vars var-name))
(var (or bound-var
(lexenv-find var-name vars)
(process-var it nil))))
(cons
;; FIXME: non-ANSI weirdness
- (aver (eq (car var) 'MACRO))
- (new-vars `(,var-name . (MACRO . (the ,(first decl)
+ (aver (eq (car var) 'macro))
+ (new-vars `(,var-name . (macro . (the ,(first decl)
,(cdr var))))))
(heap-alien-info
(compiler-error
(let ((type (compiler-specifier-type spec)))
(collect ((res nil cons))
(dolist (name names)
- (let ((found (find name fvars
- :key #'leaf-source-name
- :test #'equal)))
+ (when (fboundp name)
+ (compiler-assert-symbol-home-package-unlocked
+ name "declaring the ftype of ~A"))
+ (let ((found (find name fvars :key #'leaf-source-name :test #'equal)))
(cond
(found
(setf (leaf-type found) type)
;;; Process a special declaration, returning a new LEXENV. A non-bound
;;; special declaration is instantiated by throwing a special variable
-;;; into the variables.
-(defun process-special-decl (spec res vars)
+;;; 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)
(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")
(let ((var (find-in-bindings vars name)))
(etypecase var
(cons
- (aver (eq (car var) 'MACRO))
+ (aver (eq (car var) 'macro))
(compiler-error
"~S is a symbol-macro and thus can't be declared special."
name))
(setf (lambda-var-specvar var)
(specvar-for-binding name)))
(null
- (unless (assoc name (new-venv) :test #'eq)
+ (unless (or (assoc name (new-venv) :test #'eq))
(new-venv (cons name (specvar-for-binding name))))))))
- (if (new-venv)
- (make-lexenv :default res :vars (new-venv))
- res)))
+ (cond (binding-form-p
+ (setf *post-binding-variable-lexenv*
+ (append (new-venv) *post-binding-variable-lexenv*))
+ res)
+ ((new-venv)
+ (make-lexenv :default res :vars (new-venv)))
+ (t
+ res))))
;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP
-;;; (and TYPE if notinline).
-(defun make-new-inlinep (var inlinep)
+;;; (and TYPE if notinline), plus type-restrictions from the lexenv.
+(defun make-new-inlinep (var inlinep local-type)
(declare (type global-var var) (type inlinep inlinep))
- (let ((res (make-defined-fun
- :%source-name (leaf-source-name var)
- :where-from (leaf-where-from var)
- :type (if (and (eq inlinep :notinline)
- (not (eq (leaf-where-from var) :declared)))
- (specifier-type 'function)
- (leaf-type var))
- :inlinep inlinep)))
+ (let* ((type (if (and (eq inlinep :notinline)
+ (not (eq (leaf-where-from var) :declared)))
+ (specifier-type 'function)
+ (leaf-type var)))
+ (res (make-defined-fun
+ :%source-name (leaf-source-name var)
+ :where-from (leaf-where-from var)
+ :type (if local-type
+ (type-intersection local-type type)
+ type)
+ :inlinep inlinep)))
(when (defined-fun-p var)
(setf (defined-fun-inline-expansion res)
(defined-fun-inline-expansion var))
(let ((sense (cdr (assoc (first spec) *inlinep-translations* :test #'eq)))
(new-fenv ()))
(dolist (name (rest spec))
- (let ((fvar (find name fvars
- :key #'leaf-source-name
- :test #'equal)))
+ (let ((fvar (find name fvars :key #'leaf-source-name :test #'equal)))
(if fvar
(setf (functional-inlinep fvar) sense)
- (let ((found
- (find-lexically-apparent-fun
- name "in an inline or notinline declaration")))
+ (let ((found (find-lexically-apparent-fun
+ name "in an inline or notinline declaration")))
(etypecase found
(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))
- new-fenv)))))))
-
+ (let ((type
+ (cdr (assoc found (lexenv-type-restrictions res)))))
+ (push (cons name (make-new-inlinep found sense type))
+ new-fenv))))))))
(if new-fenv
(make-lexenv :default res :funs new-fenv)
res)))
(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))))
;;; 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)
+(defun process-1-decl (raw-spec res vars fvars binding-form-p)
(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))
+ (special (process-special-decl spec res vars binding-form-p))
(ftype
(unless (cdr spec)
(compiler-error "no type specified in FTYPE declaration: ~S" spec))
`(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
+ spec (lexenv-disabled-package-locks res))))
(t
(unless (info :declaration :recognized (first spec))
(compiler-warn "unrecognized declaration ~S" raw-spec))
;;; filling in slots in the leaf structures, we return a new LEXENV,
;;; which reflects pervasive special and function type declarations,
;;; (NOT)INLINE declarations and OPTIMIZE declarations, and type of
-;;; VALUES declarations.
+;;; VALUES declarations. If BINDING-FORM-P is true, the third return
+;;; value is a list of VARs that should not apply to the lexenv of the
+;;; initialization forms for the bindings, but should apply to the body.
;;;
;;; This is also called in main.lisp when PROCESS-FORM handles a use
;;; of LOCALLY.
-(defun process-decls (decls vars fvars &optional (env *lexenv*))
+(defun process-decls (decls vars fvars &key (lexenv *lexenv*)
+ (binding-form-p nil))
(declare (list decls vars fvars))
- (let ((result-type *wild-type*))
+ (let ((result-type *wild-type*)
+ (*post-binding-variable-lexenv* nil))
(dolist (decl decls)
(dolist (spec (rest decl))
(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 env vars fvars)
- (setq env new-env)
+ (process-1-decl spec lexenv vars fvars binding-form-p)
+ (setq lexenv new-env)
(unless (eq new-result-type *wild-type*)
(setq result-type
(values-type-intersection result-type new-result-type))))))
- (values env result-type)))
+ (values lexenv result-type *post-binding-variable-lexenv*)))
-(defun %processing-decls (decls vars fvars ctran lvar fun)
- (multiple-value-bind (*lexenv* result-type)
- (process-decls decls vars fvars)
+(defun %processing-decls (decls vars fvars ctran lvar binding-form-p fun)
+ (multiple-value-bind (*lexenv* result-type post-binding-lexenv)
+ (process-decls decls vars fvars :binding-form-p binding-form-p)
(cond ((eq result-type *wild-type*)
- (funcall fun ctran lvar))
+ (funcall fun ctran lvar post-binding-lexenv))
(t
(let ((value-ctran (make-ctran))
(value-lvar (make-lvar)))
(multiple-value-prog1
- (funcall fun value-ctran value-lvar)
+ (funcall fun value-ctran value-lvar post-binding-lexenv)
(let ((cast (make-cast value-lvar result-type
(lexenv-policy *lexenv*))))
(link-node-to-previous-ctran cast value-ctran)
(setf (lvar-dest value-lvar) cast)
(use-continuation cast ctran lvar))))))))
-(defmacro processing-decls ((decls vars fvars ctran lvar) &body forms)
+(defmacro processing-decls ((decls vars fvars ctran lvar
+ &optional post-binding-lexenv)
+ &body forms)
(check-type ctran symbol)
(check-type lvar symbol)
- `(%processing-decls ,decls ,vars ,fvars ,ctran ,lvar
- (lambda (,ctran ,lvar) ,@forms)))
+ (let ((post-binding-lexenv-p (not (null post-binding-lexenv)))
+ (post-binding-lexenv (or post-binding-lexenv (gensym))))
+ `(%processing-decls ,decls ,vars ,fvars ,ctran ,lvar
+ ,post-binding-lexenv-p
+ (lambda (,ctran ,lvar ,post-binding-lexenv)
+ (declare (ignorable ,post-binding-lexenv))
+ ,@forms))))
;;; Return the SPECVAR for NAME to use when we see a local SPECIAL
;;; declaration. If there is a global variable of that name, then