;;;; optimizations for SAP operations ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. ;;;; ;;;; This software is derived from the CMU CL system, which was ;;;; written at Carnegie Mellon University and released into the ;;;; public domain. The software is in the public domain and is ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. (in-package "SB!C") ;;;; DEFKNOWNs #!+linkage-table (deftransform foreign-symbol-address ((symbol &optional datap) (simple-string boolean) * :important t :policy :fast-safe) (if (and (constant-lvar-p symbol) (constant-lvar-p datap) #!+sb-dynamic-core (not (lvar-value datap))) `(values (sap-int (foreign-symbol-sap symbol datap)) (or #!+sb-dynamic-core t)) (give-up-ir1-transform))) (deftransform foreign-symbol-sap ((symbol &optional datap) (simple-string &optional boolean)) #!-linkage-table (if (null datap) (give-up-ir1-transform) `(foreign-symbol-sap symbol)) #!+linkage-table (if (and (constant-lvar-p symbol) (constant-lvar-p datap)) (let (#!-sb-dynamic-core (name (lvar-value symbol)) (datap (lvar-value datap))) #!-sb-dynamic-core (if (or #+sb-xc-host t ; only static symbols on host (not datap) (find-foreign-symbol-in-table name *static-foreign-symbols*)) `(foreign-symbol-sap ,name) ; VOP `(foreign-symbol-dataref-sap ,name)) ; VOP #!+sb-dynamic-core (if datap `(foreign-symbol-dataref-sap symbol) `(foreign-symbol-sap symbol))) (give-up-ir1-transform))) (defknown (sap< sap<= sap= sap>= sap>) (system-area-pointer system-area-pointer) boolean (movable flushable)) (defknown sap+ (system-area-pointer integer) system-area-pointer (movable flushable)) (defknown sap- (system-area-pointer system-area-pointer) (signed-byte #.sb!vm::n-word-bits) (movable flushable)) (defknown sap-int (system-area-pointer) (unsigned-byte #.sb!vm::n-machine-word-bits) (movable flushable foldable)) (defknown int-sap ((unsigned-byte #.sb!vm::n-machine-word-bits)) system-area-pointer (movable)) (macrolet ((defsapref (fun value-type) (let (#!+x86 (with-offset-fun (intern (format nil "~A-WITH-OFFSET" fun))) (set-fun (intern (format nil "%SET-~A" fun))) #!+x86 (set-with-offset-fun (intern (format nil "%SET-~A-WITH-OFFSET" fun)))) `(progn (defknown ,fun (system-area-pointer fixnum) ,value-type (flushable)) #!+x86 (defknown ,with-offset-fun (system-area-pointer fixnum fixnum) ,value-type (flushable always-translatable)) (defknown ,set-fun (system-area-pointer fixnum ,value-type) ,value-type ()) #!+x86 (defknown ,set-with-offset-fun (system-area-pointer fixnum fixnum ,value-type) ,value-type (always-translatable)))))) (defsapref sap-ref-8 (unsigned-byte 8)) (defsapref sap-ref-16 (unsigned-byte 16)) (defsapref sap-ref-32 (unsigned-byte 32)) (defsapref sap-ref-64 (unsigned-byte 64)) (defsapref sap-ref-word (unsigned-byte #.sb!vm:n-word-bits)) (defsapref signed-sap-ref-8 (signed-byte 8)) (defsapref signed-sap-ref-16 (signed-byte 16)) (defsapref signed-sap-ref-32 (signed-byte 32)) (defsapref signed-sap-ref-64 (signed-byte 64)) (defsapref signed-sap-ref-word (signed-byte #.sb!vm:n-word-bits)) (defsapref sap-ref-sap system-area-pointer) (defsapref sap-ref-lispobj t) (defsapref sap-ref-single single-float) (defsapref sap-ref-double double-float) (defsapref sap-ref-long long-float) ) ; MACROLET ;;;; transforms for converting sap relation operators (macrolet ((def (sap-fun int-fun) `(deftransform ,sap-fun ((x y) * *) `(,',int-fun (sap-int x) (sap-int y))))) (def sap< <) (def sap<= <=) (def sap= =) (def sap>= >=) (def sap> >)) ;;;; transforms for optimizing SAP+ (deftransform sap+ ((sap offset)) (cond ((and (constant-lvar-p offset) (eql (lvar-value offset) 0)) 'sap) (t (splice-fun-args sap 'sap+ 2) '(lambda (sap offset1 offset2) (sap+ sap (+ offset1 offset2)))))) (macrolet ((def (fun &optional setp value-type) (declare (ignorable value-type)) `(progn (deftransform ,fun ((sap offset ,@(when setp `(new-value))) * *) (splice-fun-args sap 'sap+ 2) `(lambda (sap offset1 offset2 ,@',(when setp `(new-value))) (,',fun sap (+ offset1 offset2) ,@',(when setp `(new-value))))) ;; Avoid defining WITH-OFFSET transforms for accessors whose ;; sizes are larger than the word size; they'd probably be ;; pointless to optimize anyway and tricky to boot. ,(unless (and (listp value-type) (or (eq (first value-type) 'unsigned-byte) (eq (first value-type) 'signed-byte)) (> (second value-type) sb!vm:n-word-bits)) #!+x86 (let ((with-offset-fun (intern (format nil "~A-WITH-OFFSET" fun)))) `(progn ,(cond (setp `(deftransform ,fun ((sap offset new-value) (system-area-pointer fixnum ,value-type) *) `(,',with-offset-fun sap (truly-the fixnum offset) 0 new-value))) (t `(deftransform ,fun ((sap offset) (system-area-pointer fixnum) *) `(,',with-offset-fun sap (truly-the fixnum offset) 0)))) (deftransform ,with-offset-fun ((sap offset disp ,@(when setp `(new-value))) * *) (fold-index-addressing ',with-offset-fun 8 ; all sap-offsets are in bytes 0 ; lowtag 0 ; data offset offset disp ,setp)))))))) (def sap-ref-8) (def %set-sap-ref-8 t (unsigned-byte 8)) (def signed-sap-ref-8) (def %set-signed-sap-ref-8 t (signed-byte 8)) (def sap-ref-16) (def %set-sap-ref-16 t (unsigned-byte 16)) (def signed-sap-ref-16) (def %set-signed-sap-ref-16 t (signed-byte 16)) (def sap-ref-32) (def %set-sap-ref-32 t (unsigned-byte 32)) (def signed-sap-ref-32) (def %set-signed-sap-ref-32 t (signed-byte 32)) (def sap-ref-64) (def %set-sap-ref-64 t (unsigned-byte 64)) (def signed-sap-ref-64) (def %set-signed-sap-ref-64 t (signed-byte 64)) (def sap-ref-sap) (def %set-sap-ref-sap t system-area-pointer) (def sap-ref-lispobj) (def %set-sap-ref-lispobj t t) (def sap-ref-single) (def %set-sap-ref-single t single-float) (def sap-ref-double) (def %set-sap-ref-double t double-float) #!+long-float (def sap-ref-long) #!+long-float (def %set-sap-ref-long t long-float)) (macrolet ((def (fun args 32-bit 64-bit) `(deftransform ,fun (,args) (ecase sb!vm::n-word-bits (32 '(,32-bit ,@args)) (64 '(,64-bit ,@args)))))) (def sap-ref-word (sap offset) sap-ref-32 sap-ref-64) (def signed-sap-ref-word (sap offset) signed-sap-ref-32 signed-sap-ref-64) (def %set-sap-ref-word (sap offset value) %set-sap-ref-32 %set-sap-ref-64) (def %set-signed-sap-ref-word (sap offset value) %set-signed-sap-ref-32 %set-signed-sap-ref-64)) ;;; Transforms for 64-bit SAP accessors on 32-bit platforms. #!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or)) (progn #!+#.(cl:if (cl:eq :little-endian sb!c:*backend-byte-order*) '(and) '(or)) (progn (deftransform sap-ref-64 ((sap offset) (* *)) '(logior (sap-ref-32 sap offset) (ash (sap-ref-32 sap (+ offset 4)) 32))) (deftransform signed-sap-ref-64 ((sap offset) (* *)) '(logior (sap-ref-32 sap offset) (ash (signed-sap-ref-32 sap (+ offset 4)) 32))) (deftransform %set-sap-ref-64 ((sap offset value) (* * *)) '(progn (%set-sap-ref-32 sap offset (logand value #xffffffff)) (%set-sap-ref-32 sap (+ offset 4) (ash value -32)))) (deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *)) '(progn (%set-sap-ref-32 sap offset (logand value #xffffffff)) (%set-signed-sap-ref-32 sap (+ offset 4) (ash value -32))))) #!+#.(cl:if (cl:eq :big-endian sb!c:*backend-byte-order*) '(and) '(or)) (progn (deftransform sap-ref-64 ((sap offset) (* *)) '(logior (ash (sap-ref-32 sap offset) 32) (sap-ref-32 sap (+ offset 4)))) (deftransform signed-sap-ref-64 ((sap offset) (* *)) '(logior (ash (signed-sap-ref-32 sap offset) 32) (sap-ref-32 sap (+ 4 offset)))) (deftransform %set-sap-ref-64 ((sap offset value) (* * *)) '(progn (%set-sap-ref-32 sap offset (ash value -32)) (%set-sap-ref-32 sap (+ offset 4) (logand value #xffffffff)))) (deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *)) '(progn (%set-signed-sap-ref-32 sap offset (ash value -32)) (%set-sap-ref-32 sap (+ 4 offset) (logand value #xffffffff))))) ) ; (= 32 SB!VM:N-MACHINE-WORD-BITS)