src/compiler/alpha/sap.lisp

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