src/compiler/saptran.lisp

   1 ;;;; optimizations for SAP operations
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   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.
  11
  12 (in-package "SB!C")
  13 \f
  14 ;;;; DEFKNOWNs
  15
  16 #!+linkage-table
  17 (deftransform foreign-symbol-address ((symbol &optional datap) (simple-string boolean)
  18                                       * :important t :policy :fast-safe)
  19   (if (and (constant-lvar-p symbol)
  20            (constant-lvar-p datap)
  21            #!+sb-dynamic-core (not (lvar-value datap)))
  22       `(values (sap-int (foreign-symbol-sap symbol datap))
  23                (or #!+sb-dynamic-core t))
  24       (give-up-ir1-transform)))
  25
  26 (deftransform foreign-symbol-sap ((symbol &optional datap)
  27                                       (simple-string &optional boolean))
  28     #!-linkage-table
  29     (if (null datap)
  30         (give-up-ir1-transform)
  31         `(foreign-symbol-sap symbol))
  32     #!+linkage-table
  33     (if (and (constant-lvar-p symbol) (constant-lvar-p datap))
  34         (let (#!-sb-dynamic-core (name (lvar-value symbol))
  35               (datap (lvar-value datap)))
  36           #!-sb-dynamic-core
  37           (if (or #+sb-xc-host t ; only static symbols on host
  38                   (not datap)
  39                   (find-foreign-symbol-in-table name *static-foreign-symbols*))
  40               `(foreign-symbol-sap ,name) ; VOP
  41               `(foreign-symbol-dataref-sap ,name)) ; VOP
  42           #!+sb-dynamic-core
  43           (if datap
  44               `(foreign-symbol-dataref-sap symbol)
  45               `(foreign-symbol-sap symbol)))
  46         (give-up-ir1-transform)))
  47
  48 (defknown (sap< sap<= sap= sap>= sap>)
  49           (system-area-pointer system-area-pointer) boolean
  50   (movable flushable))
  51
  52 (defknown sap+ (system-area-pointer integer) system-area-pointer
  53   (movable flushable))
  54 (defknown sap- (system-area-pointer system-area-pointer)
  55                (signed-byte #.sb!vm::n-word-bits)
  56   (movable flushable))
  57
  58 (defknown sap-int (system-area-pointer)
  59   (unsigned-byte #.sb!vm::n-machine-word-bits)
  60   (movable flushable foldable))
  61 (defknown int-sap ((unsigned-byte #.sb!vm::n-machine-word-bits))
  62   system-area-pointer (movable))
  63
  64 (macrolet ((defsapref (fun value-type)
  65              (let (#!+x86
  66                    (with-offset-fun (intern (format nil "~A-WITH-OFFSET" fun)))
  67                    (set-fun (intern (format nil "%SET-~A" fun)))
  68                    #!+x86
  69                    (set-with-offset-fun (intern (format nil "%SET-~A-WITH-OFFSET" fun))))
  70                `(progn
  71                   (defknown ,fun (system-area-pointer fixnum) ,value-type
  72                     (flushable))
  73                   #!+x86
  74                   (defknown ,with-offset-fun (system-area-pointer fixnum fixnum) ,value-type
  75                     (flushable always-translatable))
  76                   (defknown ,set-fun (system-area-pointer fixnum ,value-type) ,value-type
  77                     ())
  78                   #!+x86
  79                   (defknown ,set-with-offset-fun (system-area-pointer fixnum fixnum ,value-type) ,value-type
  80                     (always-translatable))))))
  81   (defsapref sap-ref-8 (unsigned-byte 8))
  82   (defsapref sap-ref-16 (unsigned-byte 16))
  83   (defsapref sap-ref-32 (unsigned-byte 32))
  84   (defsapref sap-ref-64 (unsigned-byte 64))
  85   (defsapref sap-ref-word (unsigned-byte #.sb!vm:n-word-bits))
  86   (defsapref signed-sap-ref-8 (signed-byte 8))
  87   (defsapref signed-sap-ref-16 (signed-byte 16))
  88   (defsapref signed-sap-ref-32 (signed-byte 32))
  89   (defsapref signed-sap-ref-64 (signed-byte 64))
  90   (defsapref signed-sap-ref-word (signed-byte #.sb!vm:n-word-bits))
  91   (defsapref sap-ref-sap system-area-pointer)
  92   (defsapref sap-ref-lispobj t)
  93   (defsapref sap-ref-single single-float)
  94   (defsapref sap-ref-double double-float)
  95   (defsapref sap-ref-long long-float)
  96 ) ; MACROLET
  97
  98 \f
  99 ;;;; transforms for converting sap relation operators
 100
 101 (macrolet ((def (sap-fun int-fun)
 102              `(deftransform ,sap-fun ((x y) * *)
 103                 `(,',int-fun (sap-int x) (sap-int y)))))
 104   (def sap< <)
 105   (def sap<= <=)
 106   (def sap= =)
 107   (def sap>= >=)
 108   (def sap> >))
 109 \f
 110 ;;;; transforms for optimizing SAP+
 111
 112 (deftransform sap+ ((sap offset))
 113   (cond ((and (constant-lvar-p offset)
 114               (eql (lvar-value offset) 0))
 115          'sap)
 116         (t
 117          (splice-fun-args sap 'sap+ 2)
 118          '(lambda (sap offset1 offset2)
 119             (sap+ sap (+ offset1 offset2))))))
 120
 121 (macrolet ((def (fun &optional setp value-type)
 122              (declare (ignorable value-type))
 123              `(progn
 124                 (deftransform ,fun ((sap offset ,@(when setp `(new-value))) * *)
 125                   (splice-fun-args sap 'sap+ 2)
 126                   `(lambda (sap offset1 offset2 ,@',(when setp `(new-value)))
 127                      (,',fun sap (+ offset1 offset2) ,@',(when setp `(new-value)))))
 128                 ;; Avoid defining WITH-OFFSET transforms for accessors whose
 129                 ;; sizes are larger than the word size; they'd probably be
 130                 ;; pointless to optimize anyway and tricky to boot.
 131                 ,(unless (and (listp value-type)
 132                               (or (eq (first value-type) 'unsigned-byte)
 133                                   (eq (first value-type) 'signed-byte))
 134                               (> (second value-type) sb!vm:n-word-bits))
 135                    #!+x86
 136                    (let ((with-offset-fun (intern (format nil "~A-WITH-OFFSET" fun))))
 137                      `(progn
 138                         ,(cond
 139                           (setp
 140                            `(deftransform ,fun ((sap offset new-value)
 141                                                 (system-area-pointer fixnum ,value-type) *)
 142                              `(,',with-offset-fun sap (truly-the fixnum offset) 0 new-value)))
 143                           (t
 144                            `(deftransform ,fun ((sap offset) (system-area-pointer fixnum) *)
 145                               `(,',with-offset-fun sap (truly-the fixnum offset) 0))))
 146                         (deftransform ,with-offset-fun ((sap offset disp
 147                                                              ,@(when setp `(new-value))) * *)
 148                           (fold-index-addressing ',with-offset-fun
 149                                                  8 ; all sap-offsets are in bytes
 150                                                  0 ; lowtag
 151                                                  0 ; data offset
 152                                                  offset disp ,setp))))))))
 153   (def sap-ref-8)
 154   (def %set-sap-ref-8 t (unsigned-byte 8))
 155   (def signed-sap-ref-8)
 156   (def %set-signed-sap-ref-8 t (signed-byte 8))
 157   (def sap-ref-16)
 158   (def %set-sap-ref-16 t (unsigned-byte 16))
 159   (def signed-sap-ref-16)
 160   (def %set-signed-sap-ref-16 t (signed-byte 16))
 161   (def sap-ref-32)
 162   (def %set-sap-ref-32 t (unsigned-byte 32))
 163   (def signed-sap-ref-32)
 164   (def %set-signed-sap-ref-32 t (signed-byte 32))
 165   (def sap-ref-64)
 166   (def %set-sap-ref-64 t (unsigned-byte 64))
 167   (def signed-sap-ref-64)
 168   (def %set-signed-sap-ref-64 t (signed-byte 64))
 169   (def sap-ref-sap)
 170   (def %set-sap-ref-sap t system-area-pointer)
 171   (def sap-ref-lispobj)
 172   (def %set-sap-ref-lispobj t t)
 173   (def sap-ref-single)
 174   (def %set-sap-ref-single t single-float)
 175   (def sap-ref-double)
 176   (def %set-sap-ref-double t double-float)
 177   #!+long-float (def sap-ref-long)
 178   #!+long-float (def %set-sap-ref-long t long-float))
 179
 180 (macrolet ((def (fun args 32-bit 64-bit)
 181                `(deftransform ,fun (,args)
 182                   (ecase sb!vm::n-word-bits
 183                     (32 '(,32-bit ,@args))
 184                     (64 '(,64-bit ,@args))))))
 185   (def sap-ref-word (sap offset) sap-ref-32 sap-ref-64)
 186   (def signed-sap-ref-word (sap offset) signed-sap-ref-32 signed-sap-ref-64)
 187   (def %set-sap-ref-word (sap offset value)
 188     %set-sap-ref-32 %set-sap-ref-64)
 189   (def %set-signed-sap-ref-word (sap offset value)
 190     %set-signed-sap-ref-32 %set-signed-sap-ref-64))
 191 \f
 192 ;;; Transforms for 64-bit SAP accessors on 32-bit platforms.
 193
 194 #!-64-bit
 195 (progn
 196 #!+#.(cl:if (cl:eq :little-endian sb!c:*backend-byte-order*) '(and) '(or))
 197 (progn
 198   (deftransform sap-ref-64 ((sap offset) (* *))
 199     '(logior (sap-ref-32 sap offset)
 200              (ash (sap-ref-32 sap (+ offset 4)) 32)))
 201
 202   (deftransform signed-sap-ref-64 ((sap offset) (* *))
 203     '(logior (sap-ref-32 sap offset)
 204              (ash (signed-sap-ref-32 sap (+ offset 4)) 32)))
 205
 206   (deftransform %set-sap-ref-64 ((sap offset value) (* * *))
 207     '(progn
 208        (%set-sap-ref-32 sap offset (logand value #xffffffff))
 209        (%set-sap-ref-32 sap (+ offset 4) (ash value -32))))
 210
 211   (deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *))
 212     '(progn
 213        (%set-sap-ref-32 sap offset (logand value #xffffffff))
 214        (%set-signed-sap-ref-32 sap (+ offset 4) (ash value -32)))))
 215
 216 #!+#.(cl:if (cl:eq :big-endian sb!c:*backend-byte-order*) '(and) '(or))
 217 (progn
 218   (deftransform sap-ref-64 ((sap offset) (* *))
 219     '(logior (ash (sap-ref-32 sap offset) 32)
 220              (sap-ref-32 sap (+ offset 4))))
 221
 222   (deftransform signed-sap-ref-64 ((sap offset) (* *))
 223     '(logior (ash (signed-sap-ref-32 sap offset) 32)
 224              (sap-ref-32 sap (+ 4 offset))))
 225
 226   (deftransform %set-sap-ref-64 ((sap offset value) (* * *))
 227     '(progn
 228        (%set-sap-ref-32 sap offset (ash value -32))
 229        (%set-sap-ref-32 sap (+ offset 4) (logand value #xffffffff))))
 230
 231   (deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *))
 232     '(progn
 233        (%set-signed-sap-ref-32 sap offset (ash value -32))
 234        (%set-sap-ref-32 sap (+ 4 offset) (logand value #xffffffff)))))
 235 ) ; (= 32 SB!VM:N-MACHINE-WORD-BITS)