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 (defoptimizer ir2-convert-reffer
((object) node block name offset lowtag
)
13 (let* ((lvar (node-lvar node
))
14 (locs (lvar-result-tns lvar
15 (list *backend-t-primitive-type
*)))
17 (vop slot node block
(lvar-tn node block object
)
18 name offset lowtag res
)
19 (move-lvar-result node block locs lvar
)))
21 (defoptimizer ir2-convert-setter
((object value
) node block name offset lowtag
)
22 (let ((value-tn (lvar-tn node block value
)))
23 (vop set-slot node block
(lvar-tn node block object
) value-tn
25 (move-lvar-result node block
(list value-tn
) (node-lvar node
))))
27 ;;; FIXME: Isn't there a name for this which looks less like a typo?
28 ;;; (The name IR2-CONVERT-SETTER is used for something else, just above.)
29 (defoptimizer ir2-convert-setfer
((value object
) node block name offset lowtag
)
30 (let ((value-tn (lvar-tn node block value
)))
31 (vop set-slot node block
(lvar-tn node block object
) value-tn
33 (move-lvar-result node block
(list value-tn
) (node-lvar node
))))
35 #!+compare-and-swap-vops
36 (defoptimizer ir2-convert-casser
37 ((object old new
) node block name offset lowtag
)
38 (let* ((lvar (node-lvar node
))
39 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
41 (vop compare-and-swap-slot node block
42 (lvar-tn node block object
)
43 (lvar-tn node block old
)
44 (lvar-tn node block new
)
47 (move-lvar-result node block locs lvar
)))
49 (defun emit-inits (node block name result lowtag inits args
)
50 (let ((unbound-marker-tn nil
)
51 (funcallable-instance-tramp-tn nil
))
53 (let ((kind (car init
))
55 (vop set-slot node block result
59 (lvar-tn node block
(pop args
)))
62 (setf unbound-marker-tn
63 (let ((tn (make-restricted-tn
65 (sc-number-or-lose 'sb
!vm
::any-reg
))))
66 (vop make-unbound-marker node block tn
)
70 (:funcallable-instance-tramp
71 (or funcallable-instance-tramp-tn
72 (setf funcallable-instance-tramp-tn
73 (let ((tn (make-restricted-tn
75 (sc-number-or-lose 'sb
!vm
::any-reg
))))
76 (vop make-funcallable-instance-tramp node block tn
)
81 (defun emit-fixed-alloc (node block name words type lowtag result lvar
)
82 (let ((stack-allocate-p (and lvar
(lvar-dynamic-extent lvar
))))
83 (when stack-allocate-p
84 (vop current-stack-pointer node block
85 (ir2-lvar-stack-pointer (lvar-info lvar
))))
86 (vop fixed-alloc node block name words type lowtag stack-allocate-p result
)))
88 (defoptimizer ir2-convert-fixed-allocation
89 ((&rest args
) node block name words type lowtag inits
)
90 (let* ((lvar (node-lvar node
))
91 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
92 (result (first locs
)))
93 (emit-fixed-alloc node block name words type lowtag result lvar
)
94 (emit-inits node block name result lowtag inits args
)
95 (move-lvar-result node block locs lvar
)))
97 (defoptimizer ir2-convert-variable-allocation
98 ((extra &rest args
) node block name words type lowtag inits
)
99 (let* ((lvar (node-lvar node
))
100 (locs (lvar-result-tns lvar
(list *backend-t-primitive-type
*)))
101 (result (first locs
)))
102 (if (constant-lvar-p extra
)
103 (let ((words (+ (lvar-value extra
) words
)))
104 (emit-fixed-alloc node block name words type lowtag result lvar
))
105 (vop var-alloc node block
(lvar-tn node block extra
) name words
107 (emit-inits node block name result lowtag inits args
)
108 (move-lvar-result node block locs lvar
)))
110 ;;; :SET-TRANS (in objdef.lisp DEFINE-PRIMITIVE-OBJECT) doesn't quite
111 ;;; cut it for symbols, where under certain compilation options
112 ;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather
113 ;;; than simply set the slot. So we build the IR2 converting function
114 ;;; by hand. -- CSR, 2003-05-08
115 (let ((fun-info (fun-info-or-lose '%set-symbol-value
)))
116 (setf (fun-info-ir2-convert fun-info
)
118 (let ((args (basic-combination-args node
)))
119 (destructuring-bind (symbol value
) args
120 (let ((value-tn (lvar-tn node block value
)))
122 (lvar-tn node block symbol
) value-tn
)
124 node block
(list value-tn
) (node-lvar node
))))))))