the efficiency of stable code.")
(defvar *fun-names-in-this-file* nil)
+
+(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
#+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
(component (make-empty-component))
(*current-component* component)
(*allow-instrumenting* t))
- (setf (component-name component) "initial component")
+ (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)
form
(ir1-convert-lambda
opname
- :debug-name (debug-namify
- "LAMBDA CAR "
+ :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
(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
(wherestring) hint c)
(muffle-warning-or-die)))
(error (lambda (c)
- (signal c)
(compiler-error "~@<~A~:@_~A~@:_~A~:>"
(wherestring) hint c))))
(funcall sb!xc:*macroexpand-hook* fun form *lexenv*)))))
(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
(collect ((res nil cons))
(dolist (name names)
(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)))
+ (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))
(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))
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
+ :disabled-package-locks (process-package-lock-decl
spec (lexenv-disabled-package-locks res))))
(t
(unless (info :declaration :recognized (first 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
projects / sbcl.git / blobdiff