X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=2144cbda2d710fbd4704d4632224a94693c91869;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=45b1de9692e2eed438bb3d7b0ec7df10d46cda26;hpb=e2470cd3c62342d574cc80a621f29d7530345817;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 45b1de9..2144cbd 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -50,6 +50,8 @@ the efficiency of stable code.") (defvar *fun-names-in-this-file* nil) + +(defvar *post-binding-variable-lexenv* nil) ;;;; namespace management utilities @@ -66,7 +68,6 @@ (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 @@ -206,7 +207,7 @@ (: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 @@ -287,7 +288,10 @@ #+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 @@ -388,12 +392,12 @@ (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) @@ -516,11 +520,11 @@ 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 @@ -629,7 +633,7 @@ (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 @@ -962,8 +966,8 @@ (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 @@ -988,11 +992,9 @@ (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) @@ -1009,8 +1011,9 @@ ;;; 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)) @@ -1018,7 +1021,7 @@ (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)) @@ -1032,24 +1035,32 @@ (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)) @@ -1063,14 +1074,11 @@ (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)) @@ -1078,9 +1086,10 @@ 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))) @@ -1125,7 +1134,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)))) @@ -1153,7 +1162,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)))) @@ -1166,14 +1192,14 @@ ;;; 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)) @@ -1209,12 +1235,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)) @@ -1227,45 +1253,56 @@ ;;; 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