X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=5f3706625c114a1be6ce853ab1c7d1e3a2154882;hb=dc4be57ff0baeee18d43fbee1bfc1af4af50e522;hp=4b9543b9a0dc4cd239aa97b91ed75c3e863b78ec;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 4b9543b..5f37066 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -50,11 +50,6 @@ 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) ;;;; namespace management utilities @@ -71,7 +66,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 @@ -244,6 +238,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 @@ -303,20 +298,17 @@ ;;;; some flow-graph hacking utilities ;;; This function sets up the back link between the node and the -;;; continuation which continues at it. +;;; ctran which continues at it. (defun link-node-to-previous-ctran (node ctran) (declare (type node node) (type ctran ctran)) (aver (not (ctran-next ctran))) (setf (ctran-next ctran) node) (setf (node-prev node) ctran)) -;;; This function is used to set the continuation for a node, and thus -;;; determine what receives the value and what is evaluated next. If -;;; the continuation has no block, then we make it be in the block -;;; that the node is in. If the continuation heads its block, we end -;;; our block and link it to that block. If the continuation is not -;;; currently used, then we set the DERIVED-TYPE for the continuation -;;; to that of the node, so that a little type propagation gets done. +;;; This function is used to set the ctran for a node, and thus +;;; determine what is evaluated next. If the ctran has no block, then +;;; we make it be in the block that the node is in. If the ctran heads +;;; its block, we end our block and link it to that block. #!-sb-fluid (declaim (inline use-ctran)) (defun use-ctran (node ctran) (declare (type node node) (type ctran ctran)) @@ -340,9 +332,10 @@ (setf (block-succ node-block) (list block)) (when (memq node-block (block-pred block)) (error "~S is already a predecessor of ~S." node-block block)) - (push node-block (block-pred block)) - #+nil(reoptimize-ctran ctran))) ; XXX + (push node-block (block-pred block)))) +;;; This function is used to set the ctran for a node, and thus +;;; determine what receives the value. (defun use-lvar (node lvar) (declare (type valued-node node) (type (or lvar null) lvar)) (aver (not (node-lvar node))) @@ -392,13 +385,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 ~S" form)))) + :debug-name (debug-name 'top-level-form form)))) (setf (functional-entry-fun res) res (functional-arg-documentation res) () (functional-kind res) :toplevel) @@ -451,23 +445,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 @@ -483,50 +474,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 ~S" - 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 @@ -535,8 +528,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)) @@ -583,7 +575,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) @@ -621,7 +620,12 @@ (when (lambda-var-ignorep var) ;; (ANSI's specification for the IGNORE declaration requires ;; that this be a STYLE-WARNING, not a full WARNING.) - (compiler-style-warn "reading an ignored variable: ~S" name))) + #-sb-xc-host + (compiler-style-warn "reading an ignored variable: ~S" name) + ;; there's no need for us to accept ANSI's lameness when + ;; processing our own code, though. + #+sb-xc-host + (warn "reading an ignored variable: ~S" name))) (reference-leaf start next result var)) (cons (aver (eq (car var) 'MACRO)) @@ -740,8 +744,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~:>" @@ -778,24 +782,24 @@ (declaim (ftype (sfunction (ctran ctran (or lvar null) list leaf) combination) ir1-convert-combination)) (defun ir1-convert-combination (start next result form fun) - (let ((fun-ctran (make-ctran)) + (let ((ctran (make-ctran)) (fun-lvar (make-lvar))) - (ir1-convert start fun-ctran fun-lvar `(the (or function symbol) ,fun)) - (ir1-convert-combination-args fun-ctran fun-lvar next result (cdr form)))) + (ir1-convert start ctran fun-lvar `(the (or function symbol) ,fun)) + (ir1-convert-combination-args fun-lvar ctran next result (cdr form)))) ;;; Convert the arguments to a call and make the COMBINATION -;;; node. FUN-CONT is the continuation which yields the function to -;;; call. ARGS is the list of arguments for the call, which defaults -;;; to the cdr of source. We return the COMBINATION node. -(defun ir1-convert-combination-args (fun-ctran fun-lvar next result args) - (declare (type ctran fun-ctran next) +;;; node. FUN-LVAR yields the function to call. ARGS is the list of +;;; arguments for the call, which defaults to the cdr of source. We +;;; return the COMBINATION node. +(defun ir1-convert-combination-args (fun-lvar start next result args) + (declare (type ctran start next) (type lvar fun-lvar) (type (or lvar null) result) (list args)) (let ((node (make-combination fun-lvar))) (setf (lvar-dest fun-lvar) node) (collect ((arg-lvars)) - (let ((this-start fun-ctran)) + (let ((this-start start)) (dolist (arg args) (let ((this-ctran (make-ctran)) (this-lvar (make-lvar node))) @@ -829,7 +833,7 @@ (ir1-convert start next result transformed))) (ir1-convert-maybe-predicate start next result form var)))))) -;;; If the function has the PREDICATE attribute, and the CONT's DEST +;;; If the function has the PREDICATE attribute, and the RESULT's DEST ;;; isn't an IF, then we convert (IF
T NIL), ensuring that a ;;; predicate always appears in a conditional context. ;;; @@ -858,9 +862,9 @@ ;;; call is legal. ;;; ;;; If the call is legal, we also propagate type assertions from the -;;; function type to the arg and result continuations. We do this now -;;; so that IR1 optimize doesn't have to redundantly do the check -;;; later so that it can do the type propagation. +;;; function type to the arg and result lvars. We do this now so that +;;; IR1 optimize doesn't have to redundantly do the check later so +;;; that it can do the type propagation. (defun ir1-convert-combination-checking-type (start next result form var) (declare (type ctran start next) (type (or lvar null) result) (list form) @@ -919,28 +923,38 @@ (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)) @@ -972,9 +986,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) @@ -996,6 +1011,7 @@ (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 @@ -1020,17 +1036,20 @@ 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)) @@ -1044,24 +1063,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))) @@ -1106,6 +1123,55 @@ (setf (lambda-var-ignorep var) t))))) (values)) +(defun process-dx-decl (names vars fvars) + (flet ((maybe-notify (control &rest args) + (when (policy *lexenv* (> speed inhibit-warnings)) + (apply #'compiler-notify control args)))) + (if (policy *lexenv* (= stack-allocate-dynamic-extent 3)) + (dolist (name names) + (cond + ((symbolp name) + (let* ((bound-var (find-in-bindings vars name)) + (var (or bound-var + (lexenv-find name vars) + (find-free-var name)))) + (etypecase var + (leaf + (if bound-var + (setf (leaf-dynamic-extent var) t) + (maybe-notify + "ignoring DYNAMIC-EXTENT declaration for free ~S" + name))) + (cons + (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name)) + (heap-alien-info + (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S" + name))))) + ((and (consp name) + (eq (car name) 'function) + (null (cddr name)) + (valid-function-name-p (cadr 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)))) + ;;; FIXME: This is non-ANSI, so the default should be T, or it should ;;; go away, I think. (defvar *suppress-values-declaration* nil @@ -1136,6 +1202,16 @@ (make-lexenv :default res :policy (process-optimize-decl spec (lexenv-policy res)))) + (muffle-conditions + (make-lexenv + :default res + :handled-conditions (process-muffle-conditions-decl + spec (lexenv-handled-conditions res)))) + (unmuffle-conditions + (make-lexenv + :default res + :handled-conditions (process-unmuffle-conditions-decl + spec (lexenv-handled-conditions res)))) (type (process-type-decl (cdr spec) res vars)) (values @@ -1148,11 +1224,13 @@ `(values ,@types))))) res)) (dynamic-extent - (when (policy *lexenv* (> speed inhibit-warnings)) - (compiler-notify - "compiler limitation: ~ - ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) + (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))