X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=f4b8a79d7c459da9c25fb252d854ffb42ffa611d;hb=711f75f20284c41f53485fda882fc7cc9e8e930f;hp=0ae854b60948725601dd418252e168e3972dcad5;hpb=372d68ae1432a96a527c662de3af3bb334808856;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 0ae854b..f4b8a79 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -157,29 +157,40 @@ (functional (ir2-convert-closure node block leaf res)) (global-var - (let ((unsafe (policy node (zerop safety))) - (name (leaf-source-name leaf))) - (ecase (global-var-kind leaf) - ((:special :unknown) - (aver (symbolp name)) - (let ((name-tn (emit-constant name))) - (if (or unsafe (info :variable :always-bound name)) - (vop fast-symbol-value node block name-tn res) - (vop symbol-value node block name-tn res)))) - (:global - (aver (symbolp name)) - (let ((name-tn (emit-constant name))) - (if (or unsafe (info :variable :always-bound name)) - (vop fast-symbol-global-value node block name-tn res) - (vop symbol-global-value node block name-tn res)))) - (:global-function - (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name))) - (if unsafe - (vop fdefn-fun node block fdefn-tn res) - (vop safe-fdefn-fun node block fdefn-tn res)))))))) + (ir2-convert-global-var node block leaf res))) (move-lvar-result node block locs lvar)) (values)) +(defun ir2-convert-global-var (node block leaf res) + (let ((unsafe (policy node (zerop safety))) + (name (leaf-source-name leaf))) + (ecase (global-var-kind leaf) + ((:special :unknown) + (aver (symbolp name)) + (let ((name-tn (emit-constant name))) + (if (or unsafe (info :variable :always-bound name)) + (vop fast-symbol-value node block name-tn res) + (vop symbol-value node block name-tn res)))) + (:global + (aver (symbolp name)) + (let ((name-tn (emit-constant name))) + (if (or unsafe (info :variable :always-bound name)) + (vop fast-symbol-global-value node block name-tn res) + (vop symbol-global-value node block name-tn res)))) + (:global-function + (cond #-sb-xc-host + ((and (info :function :definition name) + (info :function :info name)) + ;; Known functions can be saved without going through fdefns, + ;; except during cross-compilation + (emit-move node block (make-load-time-constant-tn :known-fun name) + res)) + (t + (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name))) + (if unsafe + (vop fdefn-fun node block fdefn-tn res) + (vop safe-fdefn-fun node block fdefn-tn res))))))))) + ;;; some sanity checks for a CLAMBDA passed to IR2-CONVERT-CLOSURE (defun assertions-on-ir2-converted-clambda (clambda) ;; This assertion was sort of an experiment. It would be nice and @@ -234,25 +245,39 @@ (type ir2-block ir2-block) (type functional functional) (type tn res)) - (aver (not (eql (functional-kind functional) :deleted))) - (unless (leaf-info functional) - (setf (leaf-info functional) - (make-entry-info :name (functional-debug-name functional)))) - (let ((closure (etypecase functional - (clambda - (assertions-on-ir2-converted-clambda functional) - (physenv-closure (get-lambda-physenv functional))) - (functional - (aver (eq (functional-kind functional) :toplevel-xep)) - nil)))) - - (cond (closure - (let* ((physenv (node-physenv ref)) - (tn (find-in-physenv functional physenv))) - (emit-move ref ir2-block tn res))) - (t - (let ((entry (make-load-time-constant-tn :entry functional))) - (emit-move ref ir2-block entry res))))) + (flet ((prepare () + (aver (not (eql (functional-kind functional) :deleted))) + (unless (leaf-info functional) + (setf (leaf-info functional) + (make-entry-info :name + (functional-debug-name functional)))))) + (let ((closure (etypecase functional + (clambda + (assertions-on-ir2-converted-clambda functional) + (physenv-closure (get-lambda-physenv functional))) + (functional + (aver (eq (functional-kind functional) :toplevel-xep)) + nil))) + global-var) + (cond (closure + (prepare) + (let* ((physenv (node-physenv ref)) + (tn (find-in-physenv functional physenv))) + (emit-move ref ir2-block tn res))) + ;; we're about to emit a reference to a "closure" that's actually + ;; an inlinable global function. + ((and (global-var-p (setf global-var + (functional-inline-expanded functional))) + (eq :global-function (global-var-kind global-var))) + (ir2-convert-global-var ref ir2-block global-var res)) + (t + ;; if we're here, we should have either a toplevel-xep (some + ;; global scope function in a different component) or an external + ;; reference to the "closure"'s body. + (prepare) + (aver (memq (functional-kind functional) '(:external :toplevel-xep))) + (let ((entry (make-load-time-constant-tn :entry functional))) + (emit-move ref ir2-block entry res)))))) (values)) (defun closure-initial-value (what this-env current-fp) @@ -1272,7 +1297,10 @@ (let ((lab (gen-label))) (setf (ir2-physenv-environment-start env) lab) - (vop note-environment-start node block lab))) + (vop note-environment-start node block lab) + #!+sb-safepoint + (unless (policy fun (>= inhibit-safepoints 2)) + (vop sb!vm::insert-safepoint node block)))) (values)) @@ -1539,8 +1567,7 @@ (progn (labels ((,unbind (vars) (declare (optimize (speed 2) (debug 0))) - (let ((unbound-marker (%primitive make-other-immediate-type - 0 sb!vm:unbound-marker-widetag))) + (let ((unbound-marker (%primitive make-unbound-marker))) (dolist (var vars) ;; CLHS says "bound and then made to have no value" -- user ;; should not be able to tell the difference between that and this. @@ -1765,6 +1792,55 @@ (def list*)) +(defoptimizer (mask-signed-field ir2-convert) ((width x) node block) + (block nil + (when (constant-lvar-p width) + (case (lvar-value width) + (#.(- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits) + (when (or (csubtypep (lvar-type x) + (specifier-type 'word)) + (csubtypep (lvar-type x) + (specifier-type 'sb!vm:signed-word))) + (let* ((lvar (node-lvar node)) + (temp (make-normal-tn + (if (csubtypep (lvar-type x) + (specifier-type 'word)) + (primitive-type-of most-positive-word) + (primitive-type-of + (- (ash most-positive-word -1)))))) + (results (lvar-result-tns + lvar + (list (primitive-type-or-lose 'fixnum))))) + (emit-move node block (lvar-tn node block x) temp) + (vop sb!vm::move-from-word/fixnum node block + temp (first results)) + (move-lvar-result node block results lvar) + (return)))) + (#.sb!vm:n-word-bits + (when (csubtypep (lvar-type x) (specifier-type 'word)) + (let* ((lvar (node-lvar node)) + (temp (make-normal-tn + (primitive-type-of most-positive-word))) + (results (lvar-result-tns + lvar + (list (primitive-type + (specifier-type 'sb!vm:signed-word)))))) + (emit-move node block (lvar-tn node block x) temp) + (vop sb!vm::word-move node block + temp (first results)) + (move-lvar-result node block results lvar) + (return)))))) + (if (template-p (basic-combination-info node)) + (ir2-convert-template node block) + (ir2-convert-full-call node block)))) + +;; just a fancy identity +(defoptimizer (%typep-wrapper ir2-convert) ((value variable type) node block) + (let* ((lvar (node-lvar node)) + (results (lvar-result-tns lvar (list (primitive-type-or-lose t))))) + (emit-move node block (lvar-tn node block value) (first results)) + (move-lvar-result node block results lvar))) + ;;; Convert the code in a component into VOPs. (defun ir2-convert (component) (declare (type component component)) @@ -1805,15 +1881,35 @@ 2block #!+sb-dyncount *dynamic-counts-tn* #!-sb-dyncount nil num)))) + #!+sb-safepoint + (let ((first-node (block-start-node block))) + (unless (or (and (bind-p first-node) + (xep-p (bind-lambda first-node))) + (and (valued-node-p first-node) + (node-lvar first-node) + (eq (lvar-fun-name + (node-lvar first-node)) + '%nlx-entry))) + (when (and (rest (block-pred block)) + (block-loop block) + (member (loop-kind (block-loop block)) + '(:natural :strange)) + (eq block (loop-head (block-loop block))) + (policy first-node (< inhibit-safepoints 2))) + (vop sb!vm::insert-safepoint first-node 2block)))) (ir2-convert-block block) (incf num)))))) (values)) ;;; If necessary, emit a terminal unconditional branch to go to the ;;; successor block. If the successor is the component tail, then -;;; there isn't really any successor, but if the end is an unknown, -;;; non-tail call, then we emit an error trap just in case the -;;; function really does return. +;;; there isn't really any successor, but if the end is a non-tail +;;; call to a function that's not *known* to never return, then we +;;; emit an error trap just in case the function really does return. +;;; +;;; Trapping after known calls makes it easier to understand type +;;; derivation bugs at runtime: they show up as nil-fun-returned-error, +;;; rather than the execution of arbitrary code or error traps. (defun finish-ir2-block (block) (declare (type cblock block)) (let* ((2block (block-info block)) @@ -1824,15 +1920,20 @@ (let ((target (first succ))) (cond ((eq target (component-tail (block-component block))) (when (and (basic-combination-p last) - (eq (basic-combination-kind last) :full)) + (or (eq (basic-combination-kind last) :full) + (and (eq (basic-combination-kind last) :known) + (eq (basic-combination-info last) :full)))) (let* ((fun (basic-combination-fun last)) (use (lvar-uses fun)) (name (and (ref-p use) (leaf-has-source-name-p (ref-leaf use)) - (leaf-source-name (ref-leaf use))))) + (leaf-source-name (ref-leaf use)))) + (ftype (and (info :function :info name) ; only use the FTYPE if + (info :function :type name)))) ; NAME was DEFKNOWN (unless (or (node-tail-p last) - (info :function :info name) - (policy last (zerop safety))) + (policy last (zerop safety)) + (and (fun-type-p ftype) + (eq *empty-type* (fun-type-returns ftype)))) (vop nil-fun-returned-error last 2block (if name (emit-constant name)