1 ;;;; optimizations for SAP operations
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
17 (deftransform foreign-symbol-address
((symbol &optional datap
) (simple-string boolean
))
18 (if (and (constant-lvar-p symbol
) (constant-lvar-p datap
))
19 `(sap-int (foreign-symbol-sap symbol datap
))
20 (give-up-ir1-transform)))
22 (deftransform foreign-symbol-sap
((symbol &optional datap
)
23 (simple-string &optional boolean
))
26 (give-up-ir1-transform)
27 `(foreign-symbol-sap symbol
))
29 (if (and (constant-lvar-p symbol
) (constant-lvar-p datap
))
30 (let ((name (lvar-value symbol
))
31 (datap (lvar-value datap
)))
32 (if (or #+sb-xc-host t
; only static symbols on host
34 (find-foreign-symbol-in-table name
*static-foreign-symbols
*))
35 `(foreign-symbol-sap ,name
) ; VOP
36 `(foreign-symbol-dataref-sap ,name
))) ; VOP
37 (give-up-ir1-transform)))
39 (defknown (sap< sap
<= sap
= sap
>= sap
>)
40 (system-area-pointer system-area-pointer
) boolean
43 (defknown sap
+ (system-area-pointer integer
) system-area-pointer
45 (defknown sap-
(system-area-pointer system-area-pointer
)
46 (signed-byte #.sb
!vm
::n-word-bits
)
49 (defknown sap-int
(system-area-pointer)
50 (unsigned-byte #.sb
!vm
::n-machine-word-bits
)
51 (movable flushable foldable
))
52 (defknown int-sap
((unsigned-byte #.sb
!vm
::n-machine-word-bits
))
53 system-area-pointer
(movable))
55 (macrolet ((defsapref (fun value-type
)
57 (with-offset-fun (intern (format nil
"~A-WITH-OFFSET" fun
)))
58 (set-fun (intern (format nil
"%SET-~A" fun
)))
60 (set-with-offset-fun (intern (format nil
"%SET-~A-WITH-OFFSET" fun
))))
62 (defknown ,fun
(system-area-pointer fixnum
) ,value-type
65 (defknown ,with-offset-fun
(system-area-pointer fixnum fixnum
) ,value-type
66 (flushable always-translatable
))
67 (defknown ,set-fun
(system-area-pointer fixnum
,value-type
) ,value-type
70 (defknown ,set-with-offset-fun
(system-area-pointer fixnum fixnum
,value-type
) ,value-type
71 (always-translatable))))))
72 (defsapref sap-ref-8
(unsigned-byte 8))
73 (defsapref sap-ref-16
(unsigned-byte 16))
74 (defsapref sap-ref-32
(unsigned-byte 32))
75 (defsapref sap-ref-64
(unsigned-byte 64))
76 (defsapref sap-ref-word
(unsigned-byte #.sb
!vm
:n-word-bits
))
77 (defsapref signed-sap-ref-8
(signed-byte 8))
78 (defsapref signed-sap-ref-16
(signed-byte 16))
79 (defsapref signed-sap-ref-32
(signed-byte 32))
80 (defsapref signed-sap-ref-64
(signed-byte 64))
81 (defsapref signed-sap-ref-word
(signed-byte #.sb
!vm
:n-word-bits
))
82 (defsapref sap-ref-sap system-area-pointer
)
83 (defsapref sap-ref-single single-float
)
84 (defsapref sap-ref-double double-float
)
85 (defsapref sap-ref-long long-float
)
89 ;;;; transforms for converting sap relation operators
91 (macrolet ((def (sap-fun int-fun
)
92 `(deftransform ,sap-fun
((x y
) * *)
93 `(,',int-fun
(sap-int x
) (sap-int y
)))))
100 ;;;; transforms for optimizing SAP+
102 (deftransform sap
+ ((sap offset
))
103 (cond ((and (constant-lvar-p offset
)
104 (eql (lvar-value offset
) 0))
107 (splice-fun-args sap
'sap
+ 2)
108 '(lambda (sap offset1 offset2
)
109 (sap+ sap
(+ offset1 offset2
))))))
111 (macrolet ((def (fun &optional setp value-type
)
112 (declare (ignorable value-type
) (ignore element-size
))
114 (deftransform ,fun
((sap offset
,@(when setp
`(new-value))) * *)
115 (splice-fun-args sap
'sap
+ 2)
116 `(lambda (sap offset1 offset2
,@',(when setp
`(new-value)))
117 (,',fun sap
(+ offset1 offset2
) ,@',(when setp
`(new-value)))))
118 ;; Avoid defining WITH-OFFSET transforms for accessors whose
119 ;; sizes are larger than the word size; they'd probably be
120 ;; pointless to optimize anyway and tricky to boot.
121 ,(unless (and (listp value-type
)
122 (or (eq (first value-type
) 'unsigned-byte
)
123 (eq (first value-type
) 'signed-byte
))
124 (> (second value-type
) sb
!vm
:n-word-bits
))
126 (let ((with-offset-fun (intern (format nil
"~A-WITH-OFFSET" fun
))))
130 `(deftransform ,fun
((sap offset new-value
)
131 (system-area-pointer fixnum
,value-type
) *)
132 `(,',with-offset-fun sap
(truly-the fixnum offset
) 0 new-value
)))
134 `(deftransform ,fun
((sap offset
) (system-area-pointer fixnum
) *)
135 `(,',with-offset-fun sap
(truly-the fixnum offset
) 0))))
136 (deftransform ,with-offset-fun
((sap offset disp
137 ,@(when setp
`(new-value))) * *)
138 (fold-index-addressing ',with-offset-fun
139 8 ; all sap-offsets are in bytes
142 offset disp
,setp
))))))))
144 (def %set-sap-ref-8 t
(unsigned-byte 8))
145 (def signed-sap-ref-8
)
146 (def %set-signed-sap-ref-8 t
(signed-byte 8))
148 (def %set-sap-ref-16 t
(unsigned-byte 16))
149 (def signed-sap-ref-16
)
150 (def %set-signed-sap-ref-16 t
(signed-byte 16))
152 (def %set-sap-ref-32 t
(unsigned-byte 32))
153 (def signed-sap-ref-32
)
154 (def %set-signed-sap-ref-32 t
(signed-byte 32))
156 (def %set-sap-ref-64 t
(unsigned-byte 64))
157 (def signed-sap-ref-64
)
158 (def %set-signed-sap-ref-64 t
(signed-byte 64))
160 (def %set-sap-ref-sap t system-area-pointer
)
162 (def %set-sap-ref-single t single-float
)
164 (def %set-sap-ref-double t double-float
)
165 #!+long-float
(def sap-ref-long
)
166 #!+long-float
(def %set-sap-ref-long t long-float
))
168 (macrolet ((def (fun args
32-bit
64-bit
)
169 `(deftransform ,fun
(,args
)
170 (ecase sb
!vm
::n-word-bits
171 (32 '(,32-bit
,@args
))
172 (64 '(,64-bit
,@args
))))))
173 (def sap-ref-word
(sap offset
) sap-ref-32 sap-ref-64
)
174 (def signed-sap-ref-word
(sap offset
) signed-sap-ref-32 signed-sap-ref-64
)
175 (def %set-sap-ref-word
(sap offset value
)
176 %set-sap-ref-32 %set-sap-ref-64
)
177 (def %set-signed-sap-ref-word
(sap offset value
)
178 %set-signed-sap-ref-32 %set-signed-sap-ref-64
))