X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcompiler%2Fir2tran.lisp;h=e2b593e4de2c81e924aa081019861ededda9c25a;hb=cd5a858174d892f876699373dc3ea389cf2c4d40;hp=d518f0ca53554db51d812d1eac37d39093f5fae3;hpb=c097dfd6528faa7efb98d5e021711a9969a67212;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index d518f0c..e2b593e 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -31,14 +31,16 @@ ;;; If there is any CHECK-xxx template for TYPE, then return it, ;;; otherwise return NIL. +;;; The second value is T if the template needs TYPE to be passed (defun type-check-template (type) (declare (type ctype type)) (multiple-value-bind (check-ptype exact) (primitive-type type) (if exact (primitive-type-check check-ptype) - (let ((name (hairy-type-check-template-name type))) + (multiple-value-bind (name type-needed) + (hairy-type-check-template-name type) (if name - (template-or-lose name) + (values (template-or-lose name) type-needed) nil))))) ;;; Emit code in BLOCK to check that VALUE is of the specified TYPE, @@ -49,21 +51,17 @@ (defun emit-type-check (node block value result type) (declare (type tn value result) (type node node) (type ir2-block block) (type ctype type)) - (emit-move-template node block (type-check-template type) value result) + (multiple-value-bind (template type-needed) (type-check-template type) + (if type-needed + (emit-load-template node block template value result (list type)) + (emit-move-template node block template value result))) (values)) ;;; Allocate an indirect value cell. (defevent make-value-cell-event "Allocate heap value cell for lexical var.") (defun emit-make-value-cell (node block value res) (event make-value-cell-event node) - (let* ((leaf (tn-leaf res)) - (dx (when leaf (leaf-dynamic-extent leaf)))) - (when (and dx (neq :truly dx) (leaf-has-source-name-p leaf)) - (compiler-notify "cannot stack allocate value cell for ~S" (leaf-source-name leaf))) - (vop make-value-cell node block value - ;; FIXME: See bug 419 - (eq :truly dx) - res))) + (vop make-value-cell node block value nil res)) ;;;; leaf reference @@ -98,29 +96,41 @@ ;;; If LEAF already has a constant TN, return that, otherwise make a ;;; TN for it. -(defun constant-tn (leaf) +(defun constant-tn (leaf boxedp) (declare (type constant leaf)) - (or (leaf-info leaf) - (setf (leaf-info leaf) - (make-constant-tn leaf)))) + ;; When convenient we can have both a boxed and unboxed TN for + ;; constant. + (if boxedp + (or (constant-boxed-tn leaf) + (setf (constant-boxed-tn leaf) (make-constant-tn leaf t))) + (or (leaf-info leaf) + (setf (leaf-info leaf) (make-constant-tn leaf nil))))) ;;; Return a TN that represents the value of LEAF, or NIL if LEAF ;;; isn't directly represented by a TN. ENV is the environment that ;;; the reference is done in. -(defun leaf-tn (leaf env) +(defun leaf-tn (leaf env boxedp) (declare (type leaf leaf) (type physenv env)) (typecase leaf (lambda-var (unless (lambda-var-indirect leaf) (find-in-physenv leaf env))) - (constant (constant-tn leaf)) + (constant (constant-tn leaf boxedp)) (t nil))) ;;; This is used to conveniently get a handle on a constant TN during ;;; IR2 conversion. It returns a constant TN representing the Lisp ;;; object VALUE. (defun emit-constant (value) - (constant-tn (find-constant value))) + (constant-tn (find-constant value) t)) + +(defun boxed-ref-p (ref) + (let ((dest (lvar-dest (ref-lvar ref)))) + (cond ((and (basic-combination-p dest) (eq :full (basic-combination-kind dest))) + t) + ;; Other cases? + (t + nil)))) ;;; Convert a REF node. The reference must not be delayed. (defun ir2-convert-ref (node block) @@ -141,36 +151,51 @@ ((and indirect (not (eq (node-physenv node) (lambda-physenv (lambda-var-home leaf))))) - (vop ancestor-frame-ref node block tn (leaf-info leaf) res)) + (let ((reffer (third (primitive-type-indirect-cell-type + (primitive-type (leaf-type leaf)))))) + (if reffer + (funcall reffer node block tn (leaf-info leaf) res) + (vop ancestor-frame-ref node block tn (leaf-info leaf) res)))) (t (emit-move node block tn res))))) (constant - (emit-move node block (constant-tn leaf) res)) + (emit-move node block (constant-tn leaf (boxed-ref-p node)) res)) (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 @@ -235,13 +260,23 @@ (physenv-closure (get-lambda-physenv functional))) (functional (aver (eq (functional-kind functional) :toplevel-xep)) - nil)))) - + nil))) + global-var) (cond (closure (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. + (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)) @@ -342,7 +377,11 @@ ((and indirect (not (eq (node-physenv node) (lambda-physenv (lambda-var-home leaf))))) - (vop ancestor-frame-set node block tn val (leaf-info leaf))) + (let ((setter (fourth (primitive-type-indirect-cell-type + (primitive-type (leaf-type leaf)))))) + (if setter + (funcall setter node block tn val (leaf-info leaf)) + (vop ancestor-frame-set node block tn val (leaf-info leaf))))) (t (emit-move node block val tn)))))) (global-var (aver (symbolp (leaf-source-name leaf))) @@ -377,7 +416,7 @@ (ecase (ir2-lvar-kind 2lvar) (:delayed (let ((ref (lvar-uses lvar))) - (leaf-tn (ref-leaf ref) (node-physenv ref)))) + (leaf-tn (ref-leaf ref) (node-physenv ref) (boxed-ref-p ref)))) (:fixed (aver (= (length (ir2-lvar-locs 2lvar)) 1)) (first (ir2-lvar-locs 2lvar))))) @@ -421,7 +460,7 @@ ;;; an lvar. ;;; ;;; If the lvar isn't annotated (meaning the values are discarded) or -;;; is unknown-values, the then we make temporaries for each supplied +;;; is unknown-values, then we make temporaries for each supplied ;;; value, providing a place to compute the result in until we decide ;;; what to do with it (if anything.) ;;; @@ -470,7 +509,7 @@ ;;; Return a list of TNs wired to the standard value passing ;;; conventions that can be used to receive values according to the -;;; unknown-values convention. This is used with together +;;; unknown-values convention. This is used together with ;;; MOVE-LVAR-RESULT for delivering unknown values to a fixed values ;;; lvar. ;;; @@ -528,7 +567,7 @@ ;;; If necessary, emit coercion code needed to deliver the RESULTS to ;;; the specified lvar. NODE and BLOCK provide context for emitting ;;; code. Although usually obtained from STANDARD-RESULT-TNs or -;;; LVAR-RESULT-TNs, RESULTS my be a list of any type or +;;; LVAR-RESULT-TNs, RESULTS may be a list of any type or ;;; number of TNs. ;;; ;;; If the lvar is fixed values, then move the results into the lvar @@ -638,13 +677,15 @@ (emit-template node block template args nil (list* (block-label consequent) not-p info-args)) - (unless (drop-thru-p if alternative) - (vop branch node block (block-label alternative)))) + (if (drop-thru-p if alternative) + (register-drop-thru alternative) + (vop branch node block (block-label alternative)))) (t (emit-template node block template args nil info-args) (vop branch-if node block (block-label consequent) flags not-p) - (unless (drop-thru-p if alternative) - (vop branch node block (block-label alternative))))))) + (if (drop-thru-p if alternative) + (register-drop-thru alternative) + (vop branch node block (block-label alternative))))))) ;;; Convert an IF that isn't the DEST of a conditional template. (defun ir2-convert-if (node block) @@ -664,7 +705,7 @@ (let* ((type (node-derived-type call)) (types (mapcar #'primitive-type - (if (values-type-p type) + (if (args-type-p type) (append (args-type-required type) (args-type-optional type)) (list type)))) @@ -790,9 +831,15 @@ ;;; OLD-FP. If null, then the call is to the same environment (an ;;; :ASSIGNMENT), so we only move the arguments, and leave the ;;; environment alone. -(defun emit-psetq-moves (node block fun old-fp) +;;; +;;; CLOSURE-FP is for calling a closure that has "implicit" value +;;; cells (stored in the allocating stack frame), and is the frame +;;; pointer TN to use for values allocated in the outbound stack +;;; frame. This is distinct from OLD-FP for the specific case of a +;;; tail-local-call. +(defun emit-psetq-moves (node block fun old-fp &optional (closure-fp old-fp)) (declare (type combination node) (type ir2-block block) (type clambda fun) - (type (or tn null) old-fp)) + (type (or tn null) old-fp closure-fp)) (let ((actuals (mapcar (lambda (x) (when x (lvar-tn node block x))) @@ -822,7 +869,7 @@ (let ((this-1env (node-physenv node)) (called-env (physenv-info (lambda-physenv fun)))) (dolist (thing (ir2-physenv-closure called-env)) - (temps (closure-initial-value (car thing) this-1env old-fp)) + (temps (closure-initial-value (car thing) this-1env closure-fp)) (locs (cdr thing))) (temps old-fp) (locs (ir2-physenv-old-fp called-env)))) @@ -835,9 +882,16 @@ ;;; function's passing location. (defun ir2-convert-tail-local-call (node block fun) (declare (type combination node) (type ir2-block block) (type clambda fun)) - (let ((this-env (physenv-info (node-physenv node)))) + (let ((this-env (physenv-info (node-physenv node))) + (current-fp (make-stack-pointer-tn))) (multiple-value-bind (temps locs) - (emit-psetq-moves node block fun (ir2-physenv-old-fp this-env)) + (emit-psetq-moves node block fun + (ir2-physenv-old-fp this-env) current-fp) + + ;; If we're about to emit a move from CURRENT-FP then we need to + ;; initialize it. + (when (find current-fp temps) + (vop current-fp node block current-fp)) (mapc (lambda (temp loc) (emit-move node block temp loc)) @@ -941,7 +995,7 @@ ((node-tail-p node) (ir2-convert-tail-local-call node block fun)) (t - (let ((start (block-label (lambda-block fun))) + (let ((start (block-trampoline (lambda-block fun))) (returns (tail-set-info (lambda-tail-set fun))) (lvar (node-lvar node))) (ecase (if returns @@ -1244,7 +1298,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)) @@ -1466,7 +1523,17 @@ (binding* ((lvar (node-lvar node) :exit-if-null) (2lvar (lvar-info lvar))) (ecase (ir2-lvar-kind 2lvar) - (:fixed (ir2-convert-full-call node block)) + (:fixed + ;; KLUDGE: this is very much unsafe, and can leak random stack values. + ;; OTOH, I think the :FIXED case can only happen with (safety 0) in the + ;; first place. + ;; -PK + (loop for loc in (ir2-lvar-locs 2lvar) + for idx upfrom 0 + do (vop sb!vm::more-arg node block + (lvar-tn node block context) + (emit-constant idx) + loc))) (:unknown (let ((locs (ir2-lvar-locs 2lvar))) (vop* %more-arg-values node block @@ -1501,8 +1568,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. @@ -1727,6 +1793,46 @@ (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)))))) + (ir2-convert-full-call node block))) + ;;; Convert the code in a component into VOPs. (defun ir2-convert (component) (declare (type component component)) @@ -1767,6 +1873,22 @@ 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)) @@ -1803,7 +1925,9 @@ (aver (not named)) tn))))))) ((not (eq (ir2-block-next 2block) (block-info target))) - (vop branch last 2block (block-label target))))))) + (vop branch last 2block (block-label target))) + (t + (register-drop-thru target)))))) (values))