;;;; DEFKNOWNs
#!+linkage-table
-(deftransform foreign-symbol-address-as-integer ((symbol &optional datap)
- (simple-string boolean))
- (if (and (constant-lvar-p symbol) (constant-lvar-p datap))
- `(sap-int (foreign-symbol-address symbol datap))
+(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-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 (#!-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-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
+ #!+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
+ (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-lispobj t)
+ (defsapref sap-ref-single single-float)
+ (defsapref sap-ref-double double-float)
+ (defsapref sap-ref-long long-float)
+) ; MACROLET
+
\f
;;;; transforms for converting sap relation operators
(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-lispobj)
+ (def %set-sap-ref-lispobj t t)
(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))
+\f
+;;; 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)
projects / sbcl.git / blobdiff