src/compiler/alpha/sap.lisp

   1 ;;;; the Alpha VM definition of 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!VM")
  13 \f
  14 ;;;; moves and coercions
  15
  16 ;;; Move a tagged SAP to an untagged representation.
  17 (define-vop (move-to-sap)
  18   (:args (x :scs (descriptor-reg)))
  19   (:results (y :scs (sap-reg)))
  20   (:note "system area pointer indirection")
  21   (:generator 1
  22     (loadq y x sap-pointer-slot other-pointer-lowtag)))
  23 (define-move-vop move-to-sap :move
  24   (descriptor-reg) (sap-reg))
  25
  26 ;;; Move an untagged SAP to a tagged representation.
  27 (define-vop (move-from-sap)
  28   (:args (x :scs (sap-reg) :target sap))
  29   (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
  30   (:temporary (:scs (non-descriptor-reg)) ndescr)
  31   (:results (y :scs (descriptor-reg)))
  32   (:note "system area pointer allocation")
  33   (:generator 20
  34     (move x sap)
  35     (with-fixed-allocation (y ndescr sap-widetag sap-size)
  36       (storeq sap y sap-pointer-slot other-pointer-lowtag))))
  37 (define-move-vop move-from-sap :move
  38   (sap-reg) (descriptor-reg))
  39
  40 ;;; Move untagged SAP values.
  41 (define-vop (sap-move)
  42   (:args (x :target y
  43             :scs (sap-reg)
  44             :load-if (not (location= x y))))
  45   (:results (y :scs (sap-reg)
  46                :load-if (not (location= x y))))
  47   (:effects)
  48   (:affected)
  49   (:generator 0
  50     (move x y)))
  51 (define-move-vop sap-move :move
  52   (sap-reg) (sap-reg))
  53
  54 ;;; Move untagged SAP arguments/return-values.
  55 (define-vop (move-sap-arg)
  56   (:args (x :target y
  57             :scs (sap-reg))
  58          (fp :scs (any-reg)
  59              :load-if (not (sc-is y sap-reg))))
  60   (:results (y))
  61   (:generator 0
  62     (sc-case y
  63       (sap-reg
  64        (move x y))
  65       (sap-stack
  66        (storeq x fp (tn-offset y))))))
  67 (define-move-vop move-sap-arg :move-arg
  68   (descriptor-reg sap-reg) (sap-reg))
  69
  70 ;;; Use standard MOVE-ARG + coercion to move an untagged sap to a
  71 ;;; descriptor passing location.
  72 (define-move-vop move-arg :move-arg
  73   (sap-reg) (descriptor-reg))
  74 \f
  75 ;;;; SAP-INT and INT-SAP
  76
  77 (define-vop (sap-int)
  78   (:args (sap :scs (sap-reg) :target int))
  79   (:arg-types system-area-pointer)
  80   (:results (int :scs (unsigned-reg)))
  81   (:result-types unsigned-num)
  82   (:translate sap-int)
  83   (:policy :fast-safe)
  84   (:generator 1
  85     (move sap int)))
  86
  87 (define-vop (int-sap)
  88   (:args (int :scs (unsigned-reg) :target sap))
  89   (:arg-types unsigned-num)
  90   (:results (sap :scs (sap-reg)))
  91   (:result-types system-area-pointer)
  92   (:translate int-sap)
  93   (:policy :fast-safe)
  94   (:generator 1
  95     (move int sap)))
  96 \f
  97 ;;;; POINTER+ and POINTER-
  98
  99 (define-vop (pointer+)
 100   (:translate sap+)
 101   (:args (ptr :scs (sap-reg))
 102          (offset :scs (signed-reg immediate)))
 103   (:arg-types system-area-pointer signed-num)
 104   (:results (res :scs (sap-reg)))
 105   (:result-types system-area-pointer)
 106   (:policy :fast-safe)
 107   (:generator 1
 108     (sc-case offset
 109       (signed-reg
 110        (inst addq offset ptr res))
 111       (immediate
 112        (inst lda res (tn-value offset) ptr)))))
 113
 114 (define-vop (pointer-)
 115   (:translate sap-)
 116   (:args (ptr1 :scs (sap-reg))
 117          (ptr2 :scs (sap-reg)))
 118   (:arg-types system-area-pointer system-area-pointer)
 119   (:policy :fast-safe)
 120   (:results (res :scs (signed-reg)))
 121   (:result-types signed-num)
 122   (:generator 1
 123     (inst subq ptr1 ptr2 res)))
 124 \f
 125 ;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
 126
 127 (macrolet ((def-system-ref-and-set
 128              (ref-name set-name sc type size &optional signed)
 129              (let ((ref-name-c (symbolicate ref-name "-C"))
 130                    (set-name-c (symbolicate set-name "-C")))
 131                `(progn
 132                   (define-vop (,ref-name)
 133                     (:translate ,ref-name)
 134                     (:policy :fast-safe)
 135                     (:args (object :scs (sap-reg) :target sap)
 136                            (offset :scs (signed-reg)))
 137                     (:arg-types system-area-pointer signed-num)
 138                     ,@(when (or (eq size :byte) (eq size :short))
 139                         `((:temporary (:sc non-descriptor-reg) temp)
 140                           (:temporary (:sc non-descriptor-reg) temp1)))
 141                     (:results (result :scs (,sc)))
 142                     (:result-types ,type)
 143                     (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
 144                     (:generator 5
 145                                 (inst addq object offset sap)
 146                                 ,@(ecase size
 147                                     (:byte
 148                                      (if signed
 149                                          '((inst ldq_u temp 0 sap)
 150                                            (inst lda temp1 1 sap)
 151                                            (inst extqh temp temp1 temp)
 152                                            (inst sra temp 56 result))
 153                                        '((inst ldq_u temp 0 sap)
 154                                          (inst lda temp1 0 sap)
 155                                          (inst extbl temp temp1 result))))
 156                                     (:short
 157                                      (if signed
 158                                          '((inst ldq_u temp 0 sap)
 159                                            (inst lda temp1 0 sap)
 160                                            (inst extwl temp temp1 temp)
 161                                            (inst sll temp 48 temp)
 162                                            (inst sra temp 48 result))
 163                                        '((inst ldq_u temp 0 sap)
 164                                          (inst lda temp1 0 sap)
 165                                          (inst extwl temp temp1 result))))
 166                                     (:long
 167                                      `((inst ldl result 0 sap)
 168                                        ,@(unless signed
 169                                            '((inst mskll result 4 result)))))
 170                                     (:quad
 171                                      '((inst ldq result 0 sap)))
 172                                     (:single
 173                                      '((inst lds result 0 sap)))
 174                                     (:double
 175                                      '((inst ldt result 0 sap))))))
 176                   (define-vop (,ref-name-c)
 177                     (:translate ,ref-name)
 178                     (:policy :fast-safe)
 179                     (:args (object :scs (sap-reg)))
 180                     (:arg-types system-area-pointer
 181                                 (:constant ,(if (eq size :double)
 182                                                 ;; We need to be able to add 4.
 183                                                 `(integer ,(- (ash 1 16))
 184                                                           ,(- (ash 1 16) 5))
 185                                               '(signed-byte 16))))
 186                     ,@(when (or (eq size :byte) (eq size :short))
 187                         `((:temporary (:scs (non-descriptor-reg)) temp)
 188                           (:temporary (:sc non-descriptor-reg) temp1)))
 189                     (:info offset)
 190                     (:results (result :scs (,sc)))
 191                     (:result-types ,type)
 192                     (:generator 4
 193                                 ,@(ecase size
 194                                     (:byte
 195                                      (if signed
 196                                          '((inst ldq_u temp offset object)
 197                                            (inst lda temp1 (1+ offset) object)
 198                                            (inst extqh temp temp1 temp)
 199                                            (inst sra temp 56 result))
 200                                        '((inst ldq_u temp offset object)
 201                                          (inst lda temp1 offset object)
 202                                          (inst extbl temp temp1 result))))
 203                                     (:short
 204                                      (if signed
 205                                          '((inst ldq_u temp offset object)
 206                                            (inst lda temp1 offset object)
 207                                            (inst extwl temp temp1 temp)
 208                                            (inst sll temp 48 temp)
 209                                            (inst sra temp 48 result))
 210                                        '((inst ldq_u temp offset object)
 211                                          (inst lda temp1 offset object)
 212                                          (inst extwl temp temp1 result))))
 213                                     (:long
 214                                      `((inst ldl result offset object)
 215                                        ,@(unless signed
 216                                            '((inst mskll result 4 result)))))
 217                                     (:quad
 218                                      '((inst ldq result offset object)))
 219                                     (:single
 220                                      '((inst lds result offset object)))
 221                                     (:double
 222                                      '((inst ldt
 223                                              result
 224                                              (+ offset n-word-bytes)
 225                                              object))))))
 226                   (define-vop (,set-name)
 227                     (:translate ,set-name)
 228                     (:policy :fast-safe)
 229                     (:args (object :scs (sap-reg) :target sap)
 230                            (offset :scs (signed-reg))
 231                            (value :scs (,sc) :target result))
 232                     (:arg-types system-area-pointer signed-num ,type)
 233                     (:results (result :scs (,sc)))
 234                     (:result-types ,type)
 235                     (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
 236                     ,@(when (or (eq size :byte) (eq size :short))
 237                         `((:temporary (:sc non-descriptor-reg) temp)
 238                           (:temporary (:sc non-descriptor-reg) temp1)
 239                           (:temporary (:sc non-descriptor-reg) temp2)))
 240                     (:generator 5
 241                                 (inst addq object offset sap)
 242                                 ,@(ecase size
 243                                     (:byte
 244                                      '((inst lda temp 0 sap)
 245                                        (inst ldq_u temp1 0 sap)
 246                                        (inst insbl value temp temp2)
 247                                        (inst mskbl temp1 temp temp1)
 248                                        (inst bis temp1 temp2 temp1)
 249                                        (inst stq_u temp1 0 sap)
 250                                        (inst move value result)))
 251                                     (:short
 252                                      '((inst lda temp 0 sap)
 253                                        (inst ldq_u temp1 0 sap)
 254                                        (inst mskwl temp1 temp temp1)
 255                                        (inst inswl value temp temp2)
 256                                        (inst bis temp1 temp2 temp)
 257                                        (inst stq_u temp 0 sap)
 258                                        (inst move value result)))
 259                                     (:long
 260                                      '((inst stl value 0 sap)
 261                                        (move value result)))
 262                                     (:quad
 263                                      '((inst stq value 0 sap)
 264                                        (move value result)))
 265                                     (:single
 266                                      '((unless (location= result value)
 267                                          (inst fmove value result))
 268                                        (inst sts value 0 sap)))
 269                                     (:double
 270                                      '((unless (location= result value)
 271                                          (inst fmove value result))
 272                                        (inst stt value 0 sap))))))
 273                   (define-vop (,set-name-c)
 274                     (:translate ,set-name)
 275                     (:policy :fast-safe)
 276                     (:args (object :scs (sap-reg))
 277                            (value :scs (,sc) :target result))
 278                     (:arg-types system-area-pointer
 279                                 (:constant ,(if (eq size :double)
 280                                                 ;; We need to be able to add 4.
 281                                                 `(integer ,(- (ash 1 16))
 282                                                           ,(- (ash 1 16) 5))
 283                                               '(signed-byte 16)))
 284                                 ,type)
 285                     ,@(when (or (eq size :byte) (eq size :short))
 286                         `((:temporary (:sc non-descriptor-reg) temp)
 287                           (:temporary (:sc non-descriptor-reg) temp1)
 288                           (:temporary (:sc non-descriptor-reg) temp2)))
 289                     (:info offset)
 290                     (:results (result :scs (,sc)))
 291                     (:result-types ,type)
 292                     (:generator 5
 293                                 ,@(ecase size
 294                                     (:byte
 295                                      '((inst lda temp offset object)
 296                                        (inst ldq_u temp1 offset object)
 297                                        (inst insbl value temp temp2)
 298                                        (inst mskbl temp1 temp temp1)
 299                                        (inst bis temp1 temp2 temp1)
 300                                        (inst stq_u temp1 offset object)
 301                                        (inst move value result)))
 302                                     (:short
 303                                      '((inst lda temp offset object)
 304                                        (inst ldq_u temp1 offset object)
 305                                        (inst mskwl temp1 temp temp1)
 306                                        (inst inswl value temp temp2)
 307                                        (inst bis temp1 temp2 temp)
 308                                        (inst stq_u temp offset object)
 309                                        (inst move value result)))
 310                                     (:long
 311                                      '((inst stl value offset object)
 312                                        (move value result)))
 313                                     (:quad
 314                                      '((inst stq value offset object)
 315                                        (move value result)))
 316                                     (:single
 317                                      '((unless (location= result value)
 318                                          (inst fmove value result))
 319                                        (inst sts value offset object)))
 320                                     (:double
 321                                      '((unless (location= result value)
 322                                          (inst fmove value result))
 323                                        (inst stt value offset object))))))))))
 324   (def-system-ref-and-set sap-ref-8 %set-sap-ref-8
 325     unsigned-reg positive-fixnum :byte nil)
 326   (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
 327     signed-reg tagged-num :byte t)
 328   (def-system-ref-and-set sap-ref-16 %set-sap-ref-16
 329     unsigned-reg positive-fixnum :short nil)
 330   (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
 331     signed-reg tagged-num :short t)
 332   (def-system-ref-and-set sap-ref-32 %set-sap-ref-32
 333     unsigned-reg unsigned-num :long nil)
 334   (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
 335     signed-reg signed-num :long t)
 336   (def-system-ref-and-set sap-ref-64 %set-sap-ref-64
 337     unsigned-reg unsigned-num :quad nil)
 338   (def-system-ref-and-set signed-sap-ref-64 %set-signed-sap-ref-64
 339     signed-reg signed-num :quad t)
 340   (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
 341     sap-reg system-area-pointer :quad)
 342   (def-system-ref-and-set sap-ref-lispobj %set-sap-ref-lispobj
 343     descriptor-reg * :long)
 344   (def-system-ref-and-set sap-ref-single %set-sap-ref-single
 345     single-reg single-float :single)
 346   (def-system-ref-and-set sap-ref-double %set-sap-ref-double
 347     double-reg double-float :double))
 348 \f
 349 ;;; noise to convert normal Lisp data objects into SAPs
 350
 351 (define-vop (vector-sap)
 352   (:translate vector-sap)
 353   (:policy :fast-safe)
 354   (:args (vector :scs (descriptor-reg)))
 355   (:results (sap :scs (sap-reg)))
 356   (:result-types system-area-pointer)
 357   (:generator 2
 358     (inst lda sap
 359           (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
 360           vector)))