1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
15 (defoptimizer ir2-convert-reffer ((object) node block name offset lowtag)
16 (let* ((cont (node-cont node))
17 (locs (continuation-result-tns cont
18 (list *backend-t-primitive-type*)))
20 (vop slot node block (continuation-tn node block object)
21 name offset lowtag res)
22 (move-continuation-result node block locs cont)))
25 (defun needs-remembering (cont)
26 (if (csubtypep (continuation-type cont)
27 (load-time-value (specifier-type '(or fixnum character
32 (defoptimizer ir2-convert-setter ((object value) node block name offset lowtag)
33 (let ((value-tn (continuation-tn node block value)))
34 (vop set-slot node block (continuation-tn node block object) value-tn
35 name offset lowtag #!+gengc (needs-remembering value))
36 (move-continuation-result node block (list value-tn) (node-cont node))))
38 (defoptimizer ir2-convert-setfer ((value object) node block name offset lowtag)
39 (let ((value-tn (continuation-tn node block value)))
40 (vop set-slot node block (continuation-tn node block object) value-tn
41 name offset lowtag #!+gengc (needs-remembering value))
42 (move-continuation-result node block (list value-tn) (node-cont node))))
44 (defun do-inits (node block name result lowtag inits args)
45 (let ((unbound-marker-tn nil))
47 (let ((kind (car init))
49 (vop set-slot node block result
53 (continuation-tn node block (pop args)))
56 (setf unbound-marker-tn
57 (let ((tn (make-restricted-tn
59 (sc-number-or-lose 'sb!vm::any-reg))))
60 (vop make-unbound-marker node block tn)
64 name slot lowtag #!+gengc nil))))
67 (defun do-fixed-alloc (node block name words type lowtag result)
69 (vop fixed-alloc node block name words type lowtag result)
71 (if (>= words sb!vm:large-object-cutoff)
72 (vop large-alloc node block (emit-constant (logandc2 (1+ words) 1))
73 (emit-constant lowtag) (emit-constant type) (emit-constant 0) name
75 (vop fixed-alloc node block name words type lowtag result)))
77 (defoptimizer ir2-convert-fixed-allocation
78 ((&rest args) node block name words type lowtag inits)
79 (let* ((cont (node-cont node))
80 (locs (continuation-result-tns cont
81 (list *backend-t-primitive-type*)))
82 (result (first locs)))
83 (do-fixed-alloc node block name words type lowtag result)
84 (do-inits node block name result lowtag inits args)
85 (move-continuation-result node block locs cont)))
87 (defoptimizer ir2-convert-variable-allocation
88 ((extra &rest args) node block name words type lowtag inits)
89 (let* ((cont (node-cont node))
90 (locs (continuation-result-tns cont
91 (list *backend-t-primitive-type*)))
92 (result (first locs)))
93 (if (constant-continuation-p extra)
94 (let ((words (+ (continuation-value extra) words)))
95 (do-fixed-alloc node block name words type lowtag result))
96 (vop var-alloc node block (continuation-tn node block extra) name words
98 (do-inits node block name result lowtag inits args)
99 (move-continuation-result node block locs cont)))
103 ;;;; other allocation support
106 (defoptimizer (make-array-header ir2-convert) ((type rank) node block)
107 (let* ((cont (node-cont node))
108 (locs (continuation-result-tns cont
109 (list *backend-t-primitive-type*)))
110 (result (first locs)))
111 (if (and (constant-continuation-p type)
112 (constant-continuation-p rank))
113 (do-fixed-alloc node block 'make-array-header
114 (+ (continuation-value rank)
115 sb!vm:array-dimensions-offset)
116 (continuation-value type)
117 sb!vm:other-pointer-type result)
118 (vop make-array-header node block (continuation-tn node block type)
119 (continuation-tn node block rank) result))
120 (move-continuation-result node block locs cont)))
122 ;;;; replacements for stuff in ir2tran to make gengc work
125 (defun ir2-convert-closure (node block leaf res)
126 (declare (type ref node) (type ir2-block block)
127 (type functional leaf) (type tn res))
128 (unless (leaf-info leaf)
129 (setf (leaf-info leaf) (make-entry-info)))
130 (let ((entry (make-load-time-constant-tn :entry leaf))
131 (closure (etypecase leaf
133 (environment-closure (get-lambda-environment leaf)))
135 (assert (eq (functional-kind leaf) :top-level-xep))
138 (let ((this-env (node-environment node)))
139 #!+gengc (let ((temp (make-normal-tn *backend-t-primitive-type*)))
140 (do-fixed-alloc node block 'make-closure
142 sb!vm:closure-info-offset)
143 sb!vm:closure-header-type
144 sb!vm:function-pointer-type
146 (emit-move node block entry temp)
147 (vop %set-function-self node block temp res temp))
148 ;; KLUDGE: #!-GENGC nested inside #!+GENGC doesn't make much sense;
149 ;; it's just a literal translation of the CMU CL distinction between
150 ;; host and backend. If GENGC code is ever revived, this should be
152 #!-gengc (vop make-closure node block entry (length closure) res)
153 (loop for what in closure and n from 0 do
154 (unless (and (lambda-var-p what)
155 (null (leaf-refs what)))
156 (vop closure-init node block
158 (find-in-environment what this-env)
161 (emit-move node block entry res)))
165 (defun ir2-convert-set (node block)
166 (declare (type cset node) (type ir2-block block))
167 (let* ((cont (node-cont node))
168 (leaf (set-var node))
169 (value (set-value node))
170 (val-tn (continuation-tn node block value))
171 (locs (if (continuation-info cont)
172 (continuation-result-tns
173 cont (list (primitive-type (leaf-type leaf))))
177 (when (leaf-refs leaf)
178 (let ((tn (find-in-environment leaf (node-environment node))))
179 (if (lambda-var-indirect leaf)
180 (vop value-cell-set node block tn val-tn
181 (needs-remembering value))
182 (emit-move node block val-tn tn)))))
184 (ecase (global-var-kind leaf)
186 (assert (symbolp (leaf-name leaf)))
187 (vop set node block (emit-constant (leaf-name leaf)) val-tn
188 (needs-remembering value))))))
191 (emit-move node block val-tn (first locs))
192 (move-continuation-result node block locs cont)))
196 (defoptimizer (%lexical-exit-breakup ir2-convert) ((info) node block)
197 (vop value-cell-set node block
198 (find-in-environment (continuation-value info) (node-environment node))
203 (defoptimizer (%slot-setter ir2-convert) ((value str) node block)
204 (let ((val (continuation-tn node block value)))
205 (vop instance-set node block
206 (continuation-tn node block str)
212 (combination-fun node)))))
213 (needs-remembering value))
215 (move-continuation-result node block (list val) (node-cont node))))