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.
12 (def-alloc %make-structure-instance 1 :structure-alloc
13 sb!vm:instance-header-widetag sb!vm:instance-pointer-lowtag
16 (defoptimizer (%make-structure-instance stack-allocate-result) ((&rest args))
19 (defoptimizer ir2-convert-reffer ((object) node block name offset lowtag)
20 (let* ((lvar (node-lvar node))
21 (locs (lvar-result-tns lvar
22 (list *backend-t-primitive-type*)))
24 (vop slot node block (lvar-tn node block object)
25 name offset lowtag res)
26 (move-lvar-result node block locs lvar)))
28 (defoptimizer ir2-convert-setter ((object value) node block name offset lowtag)
29 (let ((value-tn (lvar-tn node block value)))
30 (vop set-slot node block (lvar-tn node block object) value-tn
32 (move-lvar-result node block (list value-tn) (node-lvar node))))
34 ;;; FIXME: Isn't there a name for this which looks less like a typo?
35 ;;; (The name IR2-CONVERT-SETTER is used for something else, just above.)
36 (defoptimizer ir2-convert-setfer ((value object) node block name offset lowtag)
37 (let ((value-tn (lvar-tn node block value)))
38 (vop set-slot node block (lvar-tn node block object) value-tn
40 (move-lvar-result node block (list value-tn) (node-lvar node))))
42 #!+compare-and-swap-vops
43 (defoptimizer ir2-convert-casser
44 ((object old new) node block name offset lowtag)
45 (let* ((lvar (node-lvar node))
46 (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
48 (vop compare-and-swap-slot node block
49 (lvar-tn node block object)
50 (lvar-tn node block old)
51 (lvar-tn node block new)
54 (move-lvar-result node block locs lvar)))
56 (defun emit-inits (node block name object lowtag instance-length inits args)
57 #!-raw-instance-init-vops
58 (declare (ignore instance-length))
59 (let ((unbound-marker-tn nil)
60 (funcallable-instance-tramp-tn nil))
62 (let ((kind (car init))
66 (let ((raw-type (pop slot))
67 (arg-tn (lvar-tn node block (pop args))))
68 (macrolet ((make-case ()
71 (vop set-slot node block object arg-tn
72 name (+ sb!vm:instance-slots-offset slot) lowtag))
73 ,@(mapcar (lambda (rsd)
74 `(,(sb!kernel::raw-slot-data-raw-type rsd)
75 (vop ,(sb!kernel::raw-slot-data-init-vop rsd)
77 object arg-tn instance-length slot)))
78 #!+raw-instance-init-vops
79 sb!kernel::*raw-slot-data-list*
80 #!-raw-instance-init-vops
84 (vop set-slot node block object
85 (emit-constant (sb!kernel::dd-layout-or-lose slot))
86 name sb!vm:instance-slots-offset lowtag))
88 (vop set-slot node block object
92 (lvar-tn node block (pop args)))
95 (setf unbound-marker-tn
96 (let ((tn (make-restricted-tn
98 (sc-number-or-lose 'sb!vm::any-reg))))
99 (vop make-unbound-marker node block tn)
103 (:funcallable-instance-tramp
104 (or funcallable-instance-tramp-tn
105 (setf funcallable-instance-tramp-tn
106 (let ((tn (make-restricted-tn
108 (sc-number-or-lose 'sb!vm::any-reg))))
109 (vop make-funcallable-instance-tramp node block tn)
111 name slot lowtag))))))
113 (bug "Leftover args: ~S" args)))
115 (defun emit-fixed-alloc (node block name words type lowtag result lvar)
116 (let ((stack-allocate-p (and lvar (lvar-dynamic-extent lvar))))
117 (when stack-allocate-p
118 (vop current-stack-pointer node block
119 (ir2-lvar-stack-pointer (lvar-info lvar))))
120 (vop fixed-alloc node block name words type lowtag stack-allocate-p result)))
122 (defoptimizer ir2-convert-fixed-allocation
123 ((&rest args) node block name words type lowtag inits)
124 (let* ((lvar (node-lvar node))
125 (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
126 (result (first locs)))
127 (emit-fixed-alloc node block name words type lowtag result lvar)
128 (emit-inits node block name result lowtag words inits args)
129 (move-lvar-result node block locs lvar)))
131 (defoptimizer ir2-convert-variable-allocation
132 ((extra &rest args) node block name words type lowtag inits)
133 (let* ((lvar (node-lvar node))
134 (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
135 (result (first locs)))
136 (if (constant-lvar-p extra)
137 (let ((words (+ (lvar-value extra) words)))
138 (emit-fixed-alloc node block name words type lowtag result lvar))
139 (vop var-alloc node block (lvar-tn node block extra) name words
141 (emit-inits node block name result lowtag nil inits args)
142 (move-lvar-result node block locs lvar)))
144 (defoptimizer ir2-convert-structure-allocation
145 ((dd slot-specs &rest args) node block name words type lowtag inits)
146 (let* ((lvar (node-lvar node))
147 (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
148 (result (first locs)))
149 (aver (constant-lvar-p dd))
150 (aver (constant-lvar-p slot-specs))
151 (let* ((c-dd (lvar-value dd))
152 (c-slot-specs (lvar-value slot-specs))
153 (words (+ (sb!kernel::dd-instance-length c-dd) words)))
154 (emit-fixed-alloc node block name words type lowtag result lvar)
155 (emit-inits node block name result lowtag words `((:dd . ,c-dd) ,@c-slot-specs) args)
156 (move-lvar-result node block locs lvar))))
158 ;;; :SET-TRANS (in objdef.lisp DEFINE-PRIMITIVE-OBJECT) doesn't quite
159 ;;; cut it for symbols, where under certain compilation options
160 ;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather
161 ;;; than simply set the slot. So we build the IR2 converting function
162 ;;; by hand. -- CSR, 2003-05-08
163 (let ((fun-info (fun-info-or-lose '%set-symbol-value)))
164 (setf (fun-info-ir2-convert fun-info)
166 (let ((args (basic-combination-args node)))
167 (destructuring-bind (symbol value) args
168 (let ((value-tn (lvar-tn node block value)))
170 (lvar-tn node block symbol) value-tn)
172 node block (list value-tn) (node-lvar node))))))))