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              `(progn
 114                 (deftransform ,fun ((sap offset ,@(when setp `(new-value))) * *)
 115                   (splice-fun-args sap 'sap+ 2)
 116                   `(lambda (sap offset1 offset2 ,@',(when setp `(new-value)))
 117                      (,',fun sap (+ offset1 offset2) ,@',(when setp `(new-value)))))
 118                 ;; Avoid defining WITH-OFFSET transforms for accessors whose
 119                 ;; sizes are larger than the word size; they'd probably be
 120                 ;; pointless to optimize anyway and tricky to boot.
 121                 ,(unless (and (listp value-type)
 122                               (or (eq (first value-type) 'unsigned-byte)
 123                                   (eq (first value-type) 'signed-byte))
 124                               (> (second value-type) sb!vm:n-word-bits))
 125                    #!+x86
 126                    (let ((with-offset-fun (intern (format nil "~A-WITH-OFFSET" fun))))
 127                      `(progn
 128                         ,(cond
 129                           (setp
 130                            `(deftransform ,fun ((sap offset new-value)
 131                                                 (system-area-pointer fixnum ,value-type) *)
 132                              `(,',with-offset-fun sap (truly-the fixnum offset) 0 new-value)))
 133                           (t
 134                            `(deftransform ,fun ((sap offset) (system-area-pointer fixnum) *)
 135                               `(,',with-offset-fun sap (truly-the fixnum offset) 0))))
 136                         (deftransform ,with-offset-fun ((sap offset disp
 137                                                              ,@(when setp `(new-value))) * *)
 138                           (fold-index-addressing ',with-offset-fun
 139                                                  ,element-size
 140                                                  0 ; lowtag
 141                                                  0 ; data offset
 142                                                  offset disp ,setp))))))))
 143   (def sap-ref-8 8)
 144   (def %set-sap-ref-8 8 t (unsigned-byte 8))
 145   (def signed-sap-ref-8 8)
 146   (def %set-signed-sap-ref-8 8 t (signed-byte 8))
 147   (def sap-ref-16 16)
 148   (def %set-sap-ref-16 16 t (unsigned-byte 16))
 149   (def signed-sap-ref-16 16)
 150   (def %set-signed-sap-ref-16 16 t (signed-byte 16))
 151   (def sap-ref-32 32)
 152   (def %set-sap-ref-32 32 t (unsigned-byte 32))
 153   (def signed-sap-ref-32 32)
 154   (def %set-signed-sap-ref-32 32 t (signed-byte 32))
 155   (def sap-ref-64 64)
 156   (def %set-sap-ref-64 64 t (unsigned-byte 64))
 157   (def signed-sap-ref-64 64)
 158   (def %set-signed-sap-ref-64 64 t (signed-byte 64))
 159   (def sap-ref-sap sb!vm:n-word-bits)
 160   (def %set-sap-ref-sap sb!vm:n-word-bits t system-area-pointer)
 161   (def sap-ref-single 32)
 162   (def %set-sap-ref-single 32 t single-float)
 163   (def sap-ref-double 64)
 164   (def %set-sap-ref-double 64 t double-float)
 165   #!+long-float (def sap-ref-long 96)
 166   #!+long-float (def %set-sap-ref-long 96 t 8))
 167
 168 (macrolet ((def (fun args 32-bit 64-bit)
 169                `(deftransform ,fun (,args)
 170                   (ecase sb!vm::n-word-bits
 171                     (32 '(,32-bit ,@args))
 172                     (64 '(,64-bit ,@args))))))
 173   (def sap-ref-word (sap offset) sap-ref-32 sap-ref-64)
 174   (def signed-sap-ref-word (sap offset) signed-sap-ref-32 signed-sap-ref-64)
 175   (def %set-sap-ref-word (sap offset value)
 176     %set-sap-ref-32 %set-sap-ref-64)
 177   (def %set-signed-sap-ref-word (sap offset value)
 178     %set-signed-sap-ref-32 %set-signed-sap-ref-64))