X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsaptran.lisp;h=80b5e581469e229dc22e03e2196b105ad97e0aa2;hb=19319c931fc1636835dbef71808cc10e252bcf45;hp=2f17e65ce87875e730ce2b459b9550fdfeedb044;hpb=4ad052044a22f502d9dc6faf6dfe01f3bab84262;p=sbcl.git

diff --git a/src/compiler/saptran.lisp b/src/compiler/saptran.lisp
index 2f17e65..80b5e58 100644
--- a/src/compiler/saptran.lisp
+++ b/src/compiler/saptran.lisp
@@ -13,148 +13,223 @@
 
 ;;;; DEFKNOWNs
 
-(defknown foreign-symbol-address (simple-string) system-area-pointer
-  (movable flushable))
+#!+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
+          (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)
-  ())
-
-#!+alpha
-(defknown sap-ref-64 (system-area-pointer fixnum) (unsigned-byte 64)
-  (flushable))
-#!+alpha
-(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)
-  ())
-
-#!+alpha
-(defknown signed-sap-ref-64 (system-area-pointer fixnum) (signed-byte 64)
-  (flushable))
-#!+alpha
-(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
+
 
 ;;;; transforms for converting sap relation operators
 
-(macrolet ((def-frob (sap-fun int-fun)
+(macrolet ((def (sap-fun int-fun)
              `(deftransform ,sap-fun ((x y) * *)
                 `(,',int-fun (sap-int x) (sap-int y)))))
-  (def-frob sap< <)
-  (def-frob sap<= <=)
-  (def-frob sap= =)
-  (def-frob sap>= >=)
-  (def-frob sap> >))
+  (def sap< <)
+  (def sap<= <=)
+  (def sap= =)
+  (def sap>= >=)
+  (def sap> >))
 
 ;;;; transforms for optimizing SAP+
 
 (deftransform sap+ ((sap offset))
-  (cond ((and (constant-continuation-p offset)
-	      (eql (continuation-value offset) 0))
-	 'sap)
-	(t
-	 (extract-function-args sap 'sap+ 2)
-	 '(lambda (sap offset1 offset2)
-	    (sap+ sap (+ offset1 offset2))))))
-
-(macrolet ((def-frob (fun)
-             `(deftransform ,fun ((sap offset) * *)
-                (extract-function-args sap 'sap+ 2)
-                 `(lambda (sap offset1 offset2)
-                   (,',fun sap (+ offset1 offset2))))))
-  (def-frob sap-ref-8)
-  (def-frob %set-sap-ref-8)
-  (def-frob signed-sap-ref-8)
-  (def-frob %set-signed-sap-ref-8)
-  (def-frob sap-ref-16)
-  (def-frob %set-sap-ref-16)
-  (def-frob signed-sap-ref-16)
-  (def-frob %set-signed-sap-ref-16)
-  (def-frob sap-ref-32)
-  (def-frob %set-sap-ref-32)
-  (def-frob signed-sap-ref-32)
-  (def-frob %set-signed-sap-ref-32)
-  (def-frob sap-ref-sap)
-  (def-frob %set-sap-ref-sap)
-  (def-frob sap-ref-single)
-  (def-frob %set-sap-ref-single)
-  (def-frob sap-ref-double)
-  (def-frob %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
-  #!+long-float (def-frob sap-ref-long)
-  #!+long-float (def-frob %set-sap-ref-long))
+  (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)