X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsaptran.lisp;h=19945d2b5e3e0df7501e0a4ed8fd5a60c8b2e830;hb=e981481e65e869a92420616163b2ba3ec68b25d7;hp=64f067b166557a4280bc3fbba8a3da30cd453b59;hpb=75b52379bdc2269961af6a1308eca63610f38ac3;p=sbcl.git diff --git a/src/compiler/saptran.lisp b/src/compiler/saptran.lisp index 64f067b..19945d2 100644 --- a/src/compiler/saptran.lisp +++ b/src/compiler/saptran.lisp @@ -14,118 +14,77 @@ ;;;; DEFKNOWNs #!+linkage-table -(deftransform foreign-symbol-address-as-integer ((symbol &optional datap) - (simple-string boolean)) +(deftransform foreign-symbol-address ((symbol &optional datap) (simple-string boolean)) (if (and (constant-lvar-p symbol) (constant-lvar-p datap)) - `(sap-int (foreign-symbol-address symbol datap)) + `(sap-int (foreign-symbol-sap symbol datap)) (give-up-ir1-transform))) -(deftransform foreign-symbol-address ((symbol &optional datap) - (simple-string &optional boolean)) +(deftransform foreign-symbol-sap ((symbol &optional datap) + (simple-string &optional boolean)) #!-linkage-table (if (null datap) - (give-up-ir1-transform) - `(foreign-symbol-address symbol)) + (give-up-ir1-transform) + `(foreign-symbol-sap symbol)) #!+linkage-table (if (and (constant-lvar-p symbol) (constant-lvar-p datap)) - (let ((name (lvar-value symbol)) - (datap (lvar-value datap))) - (if (or #+sb-xc-host t ; only static symbols on host + (let ((name (lvar-value symbol)) + (datap (lvar-value datap))) + (if (or #+sb-xc-host t ; only static symbols on host (not datap) - (find-foreign-symbol-in-table name *static-foreign-symbols*)) - `(foreign-symbol-address ,name) ; VOP - `(foreign-symbol-dataref-address ,name))) ; VOP - (give-up-ir1-transform))) + (find-foreign-symbol-in-table name *static-foreign-symbols*)) + `(foreign-symbol-sap ,name) ; VOP + `(foreign-symbol-dataref-sap ,name))) ; VOP + (give-up-ir1-transform))) (defknown (sap< sap<= sap= sap>= sap>) - (system-area-pointer system-area-pointer) boolean + (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 32) +(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 #!-alpha 32 #!+alpha 64) - (movable flushable)) -(defknown int-sap ((unsigned-byte #!-alpha 32 #!+alpha 64)) +(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)) -(defknown sap-ref-8 (system-area-pointer fixnum) (unsigned-byte 8) - (flushable)) -(defknown %set-sap-ref-8 (system-area-pointer fixnum (unsigned-byte 8)) - (unsigned-byte 8) - ()) - -(defknown sap-ref-16 (system-area-pointer fixnum) (unsigned-byte 16) - (flushable)) -(defknown %set-sap-ref-16 (system-area-pointer fixnum (unsigned-byte 16)) - (unsigned-byte 16) - ()) - -(defknown sap-ref-32 (system-area-pointer fixnum) (unsigned-byte 32) - (flushable)) -(defknown %set-sap-ref-32 (system-area-pointer fixnum (unsigned-byte 32)) - (unsigned-byte 32) - ()) - -;; FIXME These are supported natively on alpha and using deftransforms -;; in compiler/x86/sap.lisp, which in OAO$n$ style need copying to -;; other 32 bit systems -(defknown sap-ref-64 (system-area-pointer fixnum) (unsigned-byte 64) - (flushable)) -(defknown %set-sap-ref-64 (system-area-pointer fixnum (unsigned-byte 64)) - (unsigned-byte 64) - ()) - -(defknown signed-sap-ref-8 (system-area-pointer fixnum) (signed-byte 8) - (flushable)) -(defknown %set-signed-sap-ref-8 (system-area-pointer fixnum (signed-byte 8)) - (signed-byte 8) - ()) - -(defknown signed-sap-ref-16 (system-area-pointer fixnum) (signed-byte 16) - (flushable)) -(defknown %set-signed-sap-ref-16 (system-area-pointer fixnum (signed-byte 16)) - (signed-byte 16) - ()) - -(defknown signed-sap-ref-32 (system-area-pointer fixnum) (signed-byte 32) - (flushable)) -(defknown %set-signed-sap-ref-32 (system-area-pointer fixnum (signed-byte 32)) - (signed-byte 32) - ()) - -(defknown signed-sap-ref-64 (system-area-pointer fixnum) (signed-byte 64) - (flushable)) -(defknown %set-signed-sap-ref-64 (system-area-pointer fixnum (signed-byte 64)) - (signed-byte 64) - ()) - -(defknown sap-ref-sap (system-area-pointer fixnum) system-area-pointer - (flushable)) -(defknown %set-sap-ref-sap (system-area-pointer fixnum system-area-pointer) - system-area-pointer - ()) - -(defknown sap-ref-single (system-area-pointer fixnum) single-float - (flushable)) -(defknown sap-ref-double (system-area-pointer fixnum) double-float - (flushable)) -#!+(or x86 long-float) -(defknown sap-ref-long (system-area-pointer fixnum) long-float - (flushable)) - -(defknown %set-sap-ref-single - (system-area-pointer fixnum single-float) single-float - ()) -(defknown %set-sap-ref-double - (system-area-pointer fixnum double-float) double-float - ()) -#!+long-float -(defknown %set-sap-ref-long - (system-area-pointer fixnum long-float) long-float - ()) +(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-single single-float) + (defsapref sap-ref-double double-float) + (defsapref sap-ref-long long-float) +) ; MACROLET + ;;;; transforms for converting sap relation operators @@ -142,43 +101,123 @@ (deftransform sap+ ((sap offset)) (cond ((and (constant-lvar-p offset) - (eql (lvar-value offset) 0)) - 'sap) - (t - (extract-fun-args sap 'sap+ 2) - '(lambda (sap offset1 offset2) - (sap+ sap (+ offset1 offset2)))))) - -(macrolet ((def (fun) - `(deftransform ,fun ((sap offset) * *) - (extract-fun-args sap 'sap+ 2) - `(lambda (sap offset1 offset2) - (,',fun sap (+ offset1 offset2)))))) + (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) + (def %set-sap-ref-8 t (unsigned-byte 8)) (def signed-sap-ref-8) - (def %set-signed-sap-ref-8) + (def %set-signed-sap-ref-8 t (signed-byte 8)) (def sap-ref-16) - (def %set-sap-ref-16) + (def %set-sap-ref-16 t (unsigned-byte 16)) (def signed-sap-ref-16) - (def %set-signed-sap-ref-16) + (def %set-signed-sap-ref-16 t (signed-byte 16)) (def sap-ref-32) - (def %set-sap-ref-32) + (def %set-sap-ref-32 t (unsigned-byte 32)) (def signed-sap-ref-32) - (def %set-signed-sap-ref-32) + (def %set-signed-sap-ref-32 t (signed-byte 32)) (def sap-ref-64) - (def %set-sap-ref-64) + (def %set-sap-ref-64 t (unsigned-byte 64)) (def signed-sap-ref-64) - (def %set-signed-sap-ref-64) + (def %set-signed-sap-ref-64 t (signed-byte 64)) (def sap-ref-sap) - (def %set-sap-ref-sap) + (def %set-sap-ref-sap t system-area-pointer) (def sap-ref-single) - (def %set-sap-ref-single) + (def %set-sap-ref-single t single-float) (def sap-ref-double) - (def %set-sap-ref-double) - ;; The original CMUCL code had #!+(and x86 long-float) for this first one, - ;; but only #!+long-float for the second. This was redundant, since the - ;; LONG-FLOAT target feature only exists on X86. So we removed the - ;; redundancy. --njf 2002-01-08 + (def %set-sap-ref-double t double-float) #!+long-float (def sap-ref-long) - #!+long-float (def %set-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)