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 inits args
)
57 (let ((unbound-marker-tn nil
)
58 (funcallable-instance-tramp-tn nil
))
60 (let ((kind (car init
))
64 (let ((raw-type (pop slot
))
65 (arg-tn (lvar-tn node block
(pop args
))))
66 (macrolet ((make-case ()
69 (vop set-slot node block object arg-tn
70 name
(+ sb
!vm
:instance-slots-offset slot
) lowtag
))
71 ,@(mapcar (lambda (rsd)
72 `(,(sb!kernel
::raw-slot-data-raw-type rsd
)
73 (vop ,(sb!kernel
::raw-slot-data-init-vop rsd
)
76 #!+raw-instance-init-vops
77 sb
!kernel
::*raw-slot-data-list
*
78 #!-raw-instance-init-vops
82 (vop set-slot node block object
83 (emit-constant (sb!kernel
::dd-layout-or-lose slot
))
84 name sb
!vm
:instance-slots-offset lowtag
))
86 (vop set-slot node block object
90 (lvar-tn node block
(pop args
)))
93 (setf unbound-marker-tn
94 (let ((tn (make-restricted-tn
96 (sc-number-or-lose 'sb
!vm
::any-reg
))))
97 (vop make-unbound-marker node block tn
)
101 (:funcallable-instance-tramp
102 (or funcallable-instance-tramp-tn
103 (setf funcallable-instance-tramp-tn
104 (let ((tn (make-restricted-tn
106 (sc-number-or-lose 'sb
!vm
::any-reg
))))
107 (vop make-funcallable-instance-tramp node block tn
)
109 name slot lowtag
))))))
111 (bug "Leftover args: ~S" args
)))
113 (defun emit-fixed-alloc (node block name words type lowtag result lvar
)
114 (let ((stack-allocate-p (and lvar
(lvar-dynamic-extent lvar
))))
115 (when stack-allocate-p
116 (vop current-stack-pointer node block
117 (ir2-lvar-stack-pointer (lvar-info lvar
))))
118 (vop fixed-alloc node block name words type lowtag stack-allocate-p result
)))
120 (defoptimizer ir2-convert-fixed-allocation
121 ((&rest args
) node block name words type lowtag inits
)
122 (let* ((lvar (node-lvar node
))
123 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
124 (result (first locs
)))
125 (emit-fixed-alloc node block name words type lowtag result lvar
)
126 (emit-inits node block name result lowtag inits args
)
127 (move-lvar-result node block locs lvar
)))
129 (defoptimizer ir2-convert-variable-allocation
130 ((extra &rest args
) node block name words type lowtag inits
)
131 (let* ((lvar (node-lvar node
))
132 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
133 (result (first locs
)))
134 (if (constant-lvar-p extra
)
135 (let ((words (+ (lvar-value extra
) words
)))
136 (emit-fixed-alloc node block name words type lowtag result lvar
))
137 (vop var-alloc node block
(lvar-tn node block extra
) name words
139 (emit-inits node block name result lowtag inits args
)
140 (move-lvar-result node block locs lvar
)))
142 (defoptimizer ir2-convert-structure-allocation
143 ((dd slot-specs
&rest args
) node block name words type lowtag inits
)
144 (let* ((lvar (node-lvar node
))
145 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
146 (result (first locs
)))
147 (aver (constant-lvar-p dd
))
148 (aver (constant-lvar-p slot-specs
))
149 (let* ((c-dd (lvar-value dd
))
150 (c-slot-specs (lvar-value slot-specs
))
151 (words (+ (sb!kernel
::dd-instance-length c-dd
) words
)))
152 (emit-fixed-alloc node block name words type lowtag result lvar
)
153 (emit-inits node block name result lowtag
`((:dd .
,c-dd
) ,@c-slot-specs
) args
)
154 (move-lvar-result node block locs lvar
))))
156 ;;; :SET-TRANS (in objdef.lisp DEFINE-PRIMITIVE-OBJECT) doesn't quite
157 ;;; cut it for symbols, where under certain compilation options
158 ;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather
159 ;;; than simply set the slot. So we build the IR2 converting function
160 ;;; by hand. -- CSR, 2003-05-08
161 (let ((fun-info (fun-info-or-lose '%set-symbol-value
)))
162 (setf (fun-info-ir2-convert fun-info
)
164 (let ((args (basic-combination-args node
)))
165 (destructuring-bind (symbol value
) args
166 (let ((value-tn (lvar-tn node block value
)))
168 (lvar-tn node block symbol
) value-tn
)
170 node block
(list value-tn
) (node-lvar node
))))))))