X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=2144cbda2d710fbd4704d4632224a94693c91869;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=8ed61a8aa3ff62d303238c685e0524f460ab6667;hpb=0794cd3908a441222f430ba0cf3bb7c3e1a96c63;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 8ed61a8..2144cbd 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -51,10 +51,7 @@ (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) ;;;; namespace management utilities @@ -71,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 @@ -211,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 @@ -244,6 +240,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 @@ -291,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 @@ -390,13 +390,14 @@ (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) @@ -449,23 +450,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,50 +479,52 @@ (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 @@ -533,8 +533,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 +580,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) @@ -624,10 +630,10 @@ ;; there's no need for us to accept ANSI's lameness when ;; processing our own code, though. #+sb-xc-host - (compiler-warn "reading an ignored variable: ~S" name))) + (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 @@ -743,8 +749,8 @@ (muffle-warning-or-die))) #-(and cmu sb-xc-host) (warning (lambda (c) - (compiler-warn "~@<~A~:@_~A~@:_~A~:>" - (wherestring) hint c) + (warn "~@<~A~:@_~A~@:_~A~:>" + (wherestring) hint c) (muffle-warning-or-die))) (error (lambda (c) (compiler-error "~@<~A~:@_~A~@:_~A~:>" @@ -922,36 +928,46 @@ (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) (find-free-var var-name)))) (etypecase var (leaf - (flet ((process-var (var bound-var) - (let* ((old-type (or (lexenv-find var type-restrictions) - (leaf-type var))) - (int (if (or (fun-type-p type) - (fun-type-p old-type)) - type - (type-approx-intersection2 old-type type)))) - (cond ((eq int *empty-type*) - (unless (policy *lexenv* (= inhibit-warnings 3)) - (compiler-warn - "The type declarations ~S and ~S for ~S conflict." - (type-specifier old-type) (type-specifier type) - var-name))) - (bound-var (setf (leaf-type bound-var) int)) - (t - (restr (cons var int))))))) + (flet + ((process-var (var bound-var) + (let* ((old-type (or (lexenv-find var type-restrictions) + (leaf-type var))) + (int (if (or (fun-type-p type) + (fun-type-p old-type)) + type + (type-approx-intersection2 + old-type type)))) + (cond ((eq int *empty-type*) + (unless (policy *lexenv* (= inhibit-warnings 3)) + (warn + 'type-warning + :format-control + "The type declarations ~S and ~S for ~S conflict." + :format-arguments + (list + (type-specifier old-type) + (type-specifier type) + var-name)))) + (bound-var (setf (leaf-type bound-var) int)) + (t + (restr (cons var int))))))) (process-var var bound-var) (awhen (and (lambda-var-p var) (lambda-var-specvar var)) (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 @@ -975,9 +991,10 @@ (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) @@ -994,15 +1011,17 @@ ;;; 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)) @@ -1016,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)) @@ -1047,24 +1074,22 @@ (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))) @@ -1109,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)))) @@ -1137,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)))) @@ -1150,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)) @@ -1193,8 +1235,13 @@ `(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)) @@ -1206,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