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