X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-ir2tran.lisp;h=db6030081f3e4827e97452ff3e0be9dc061e944a;hb=5edd74f6911093805a009a152b32216b3dba59f7;hp=247e09bbb8eed3e3de4eb778b2c829d99c45c405;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index 247e09b..db60300 100644 --- a/src/compiler/generic/vm-ir2tran.lisp +++ b/src/compiler/generic/vm-ir2tran.lisp @@ -18,24 +18,18 @@ name offset lowtag res) (move-continuation-result node block locs cont))) -#!+gengc -(defun needs-remembering (cont) - (if (csubtypep (continuation-type cont) - (load-time-value (specifier-type '(or fixnum character - (member t nil))))) - nil - t)) - (defoptimizer ir2-convert-setter ((object value) node block name offset lowtag) (let ((value-tn (continuation-tn node block value))) (vop set-slot node block (continuation-tn node block object) value-tn - name offset lowtag #!+gengc (needs-remembering value)) + name offset lowtag) (move-continuation-result node block (list value-tn) (node-cont node)))) +;;; FIXME: Isn't there a name for this which looks less like a typo? +;;; (The name IR2-CONVERT-SETTER is used for something else, just above.) (defoptimizer ir2-convert-setfer ((value object) node block name offset lowtag) (let ((value-tn (continuation-tn node block value))) (vop set-slot node block (continuation-tn node block object) value-tn - name offset lowtag #!+gengc (needs-remembering value)) + name offset lowtag) (move-continuation-result node block (list value-tn) (node-cont node)))) (defun do-inits (node block name result lowtag inits args) @@ -46,7 +40,7 @@ (vop set-slot node block result (ecase kind (:arg - (assert args) + (aver args) (continuation-tn node block (pop args))) (:unbound (or unbound-marker-tn @@ -58,18 +52,11 @@ tn)))) (:null (emit-constant nil))) - name slot lowtag #!+gengc nil)))) - (assert (null args))) + name slot lowtag)))) + (aver (null args))) (defun do-fixed-alloc (node block name words type lowtag result) - #!-gengc - (vop fixed-alloc node block name words type lowtag result) - #!+gengc - (if (>= words sb!vm:large-object-cutoff) - (vop large-alloc node block (emit-constant (logandc2 (1+ words) 1)) - (emit-constant lowtag) (emit-constant type) (emit-constant 0) name - result) - (vop fixed-alloc node block name words type lowtag result))) + (vop fixed-alloc node block name words type lowtag result)) (defoptimizer ir2-convert-fixed-allocation ((&rest args) node block name words type lowtag inits) @@ -94,119 +81,3 @@ type lowtag result)) (do-inits node block name result lowtag inits args) (move-continuation-result node block locs cont))) - - - -;;;; other allocation support - -#!+gengc -(defoptimizer (make-array-header ir2-convert) ((type rank) node block) - (let* ((cont (node-cont node)) - (locs (continuation-result-tns cont - (list *backend-t-primitive-type*))) - (result (first locs))) - (if (and (constant-continuation-p type) - (constant-continuation-p rank)) - (do-fixed-alloc node block 'make-array-header - (+ (continuation-value rank) - sb!vm:array-dimensions-offset) - (continuation-value type) - sb!vm:other-pointer-type result) - (vop make-array-header node block (continuation-tn node block type) - (continuation-tn node block rank) result)) - (move-continuation-result node block locs cont))) - -;;;; replacements for stuff in ir2tran to make gengc work - -#!+gengc -(defun ir2-convert-closure (node block leaf res) - (declare (type ref node) (type ir2-block block) - (type functional leaf) (type tn res)) - (unless (leaf-info leaf) - (setf (leaf-info leaf) (make-entry-info))) - (let ((entry (make-load-time-constant-tn :entry leaf)) - (closure (etypecase leaf - (clambda - (environment-closure (get-lambda-environment leaf))) - (functional - (assert (eq (functional-kind leaf) :top-level-xep)) - nil)))) - (if closure - (let ((this-env (node-environment node))) - #!+gengc (let ((temp (make-normal-tn *backend-t-primitive-type*))) - (do-fixed-alloc node block 'make-closure - (+ (length closure) - sb!vm:closure-info-offset) - sb!vm:closure-header-type - sb!vm:function-pointer-type - res) - (emit-move node block entry temp) - (vop %set-function-self node block temp res temp)) - ;; KLUDGE: #!-GENGC nested inside #!+GENGC doesn't make much sense; - ;; it's just a literal translation of the CMU CL distinction between - ;; host and backend. If GENGC code is ever revived, this should be - ;; cleaned up. - #!-gengc (vop make-closure node block entry (length closure) res) - (loop for what in closure and n from 0 do - (unless (and (lambda-var-p what) - (null (leaf-refs what))) - (vop closure-init node block - res - (find-in-environment what this-env) - n - nil)))) - (emit-move node block entry res))) - (values)) - -#!+gengc -(defun ir2-convert-set (node block) - (declare (type cset node) (type ir2-block block)) - (let* ((cont (node-cont node)) - (leaf (set-var node)) - (value (set-value node)) - (val-tn (continuation-tn node block value)) - (locs (if (continuation-info cont) - (continuation-result-tns - cont (list (primitive-type (leaf-type leaf)))) - nil))) - (etypecase leaf - (lambda-var - (when (leaf-refs leaf) - (let ((tn (find-in-environment leaf (node-environment node)))) - (if (lambda-var-indirect leaf) - (vop value-cell-set node block tn val-tn - (needs-remembering value)) - (emit-move node block val-tn tn))))) - (global-var - (ecase (global-var-kind leaf) - ((:special :global) - (assert (symbolp (leaf-name leaf))) - (vop set node block (emit-constant (leaf-name leaf)) val-tn - (needs-remembering value)))))) - - (when locs - (emit-move node block val-tn (first locs)) - (move-continuation-result node block locs cont))) - (values)) - -#!+gengc -(defoptimizer (%lexical-exit-breakup ir2-convert) ((info) node block) - (vop value-cell-set node block - (find-in-environment (continuation-value info) (node-environment node)) - (emit-constant 0) - nil)) - -#!+gengc -(defoptimizer (%slot-setter ir2-convert) ((value str) node block) - (let ((val (continuation-tn node block value))) - (vop instance-set node block - (continuation-tn node block str) - val - (dsd-index - (slot-accessor-slot - (ref-leaf - (continuation-use - (combination-fun node))))) - (needs-remembering value)) - - (move-continuation-result node block (list val) (node-cont node))))