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-single single-float)
  84   (defsapref sap-ref-double double-float)
  85   (defsapref sap-ref-long long-float)
  86 ) ; MACROLET
  87
  88 \f
  89 ;;;; transforms for converting sap relation operators
  90
  91 (macrolet ((def (sap-fun int-fun)
  92              `(deftransform ,sap-fun ((x y) * *)
  93                 `(,',int-fun (sap-int x) (sap-int y)))))
  94   (def sap< <)
  95   (def sap<= <=)
  96   (def sap= =)
  97   (def sap>= >=)
  98   (def sap> >))
  99 \f
 100 ;;;; transforms for optimizing SAP+
 101
 102 (deftransform sap+ ((sap offset))
 103   (cond ((and (constant-lvar-p offset)
 104               (eql (lvar-value offset) 0))
 105          'sap)
 106         (t
 107          (splice-fun-args sap 'sap+ 2)
 108          '(lambda (sap offset1 offset2)
 109             (sap+ sap (+ offset1 offset2))))))
 110
 111 (macrolet ((def (fun element-size &optional setp value-type)
 112              (declare (ignorable value-type)
 113                       #!-x86 (ignore element-size))
 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                                                  ,element-size
 141                                                  0 ; lowtag
 142                                                  0 ; data offset
 143                                                  offset disp ,setp))))))))
 144   (def sap-ref-8 8)
 145   (def %set-sap-ref-8 8 t (unsigned-byte 8))
 146   (def signed-sap-ref-8 8)
 147   (def %set-signed-sap-ref-8 8 t (signed-byte 8))
 148   (def sap-ref-16 16)
 149   (def %set-sap-ref-16 16 t (unsigned-byte 16))
 150   (def signed-sap-ref-16 16)
 151   (def %set-signed-sap-ref-16 16 t (signed-byte 16))
 152   (def sap-ref-32 32)
 153   (def %set-sap-ref-32 32 t (unsigned-byte 32))
 154   (def signed-sap-ref-32 32)
 155   (def %set-signed-sap-ref-32 32 t (signed-byte 32))
 156   (def sap-ref-64 64)
 157   (def %set-sap-ref-64 64 t (unsigned-byte 64))
 158   (def signed-sap-ref-64 64)
 159   (def %set-signed-sap-ref-64 64 t (signed-byte 64))
 160   (def sap-ref-sap sb!vm:n-word-bits)
 161   (def %set-sap-ref-sap sb!vm:n-word-bits t system-area-pointer)
 162   (def sap-ref-single 32)
 163   (def %set-sap-ref-single 32 t single-float)
 164   (def sap-ref-double 64)
 165   (def %set-sap-ref-double 64 t double-float)
 166   #!+long-float (def sap-ref-long 96)
 167   #!+long-float (def %set-sap-ref-long 96 t 8))
 168
 169 (macrolet ((def (fun args 32-bit 64-bit)
 170                `(deftransform ,fun (,args)
 171                   (ecase sb!vm::n-word-bits
 172                     (32 '(,32-bit ,@args))
 173                     (64 '(,64-bit ,@args))))))
 174   (def sap-ref-word (sap offset) sap-ref-32 sap-ref-64)
 175   (def signed-sap-ref-word (sap offset) signed-sap-ref-32 signed-sap-ref-64)
 176   (def %set-sap-ref-word (sap offset value)
 177     %set-sap-ref-32 %set-sap-ref-64)
 178   (def %set-signed-sap-ref-word (sap offset value)
 179     %set-signed-sap-ref-32 %set-signed-sap-ref-64))