src/compiler/alpha/alloc.lisp

   1 ;;;; allocation VOPs for the Alpha port
   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 ;;;; LIST and LIST*
  15 (defoptimizer (list stack-allocate-result) ((&rest args))
  16   (not (null args)))
  17 (defoptimizer (list* stack-allocate-result) ((&rest args))
  18   (not (null (rest args))))
  19
  20 (define-vop (list-or-list*)
  21   (:args (things :more t))
  22   (:temporary (:scs (descriptor-reg) :type list) ptr)
  23   (:temporary (:scs (descriptor-reg)) temp)
  24   (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
  25               res)
  26   (:info num)
  27   (:results (result :scs (descriptor-reg)))
  28   (:variant-vars star)
  29   (:policy :safe)
  30   (:node-var node)
  31   (:generator 0
  32     (cond ((zerop num)
  33            (move null-tn result))
  34           ((and star (= num 1))
  35            (move (tn-ref-tn things) result))
  36           (t
  37            (macrolet
  38                ((store-car (tn list &optional (slot cons-car-slot))
  39                   `(let ((reg
  40                           (sc-case ,tn
  41                             ((any-reg descriptor-reg) ,tn)
  42                             (zero zero-tn)
  43                             (null null-tn)
  44                             (control-stack
  45                              (load-stack-tn temp ,tn)
  46                              temp))))
  47                      (storew reg ,list ,slot list-pointer-lowtag))))
  48              (let* ((dx-p (node-stack-allocate-p node))
  49                     (cons-cells (if star (1- num) num))
  50                     (space (* (pad-data-block cons-size) cons-cells)))
  51                (pseudo-atomic (:extra (if dx-p 0 space))
  52                  (cond (dx-p
  53                         (align-csp res)
  54                         (inst bis csp-tn list-pointer-lowtag res)
  55                         (inst lda csp-tn space csp-tn))
  56                        (t
  57                         (inst bis alloc-tn list-pointer-lowtag res)))
  58                  (move res ptr)
  59                  (dotimes (i (1- cons-cells))
  60                    (store-car (tn-ref-tn things) ptr)
  61                    (setf things (tn-ref-across things))
  62                    (inst lda ptr (pad-data-block cons-size) ptr)
  63                    (storew ptr ptr
  64                            (- cons-cdr-slot cons-size)
  65                            list-pointer-lowtag))
  66                  (store-car (tn-ref-tn things) ptr)
  67                  (cond (star
  68                         (setf things (tn-ref-across things))
  69                         (store-car (tn-ref-tn things) ptr cons-cdr-slot))
  70                        (t
  71                         (storew null-tn ptr
  72                                 cons-cdr-slot list-pointer-lowtag)))
  73                  (aver (null (tn-ref-across things)))
  74                  (move res result))))))))
  75
  76 (define-vop (list list-or-list*)
  77   (:variant nil))
  78
  79 (define-vop (list* list-or-list*)
  80   (:variant t))
  81 \f
  82 ;;;; special purpose inline allocators
  83
  84 (define-vop (allocate-code-object)
  85   (:args (boxed-arg :scs (any-reg))
  86          (unboxed-arg :scs (any-reg)))
  87   (:results (result :scs (descriptor-reg)))
  88   (:temporary (:scs (non-descriptor-reg)) ndescr)
  89   (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
  90   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
  91   (:generator 100
  92     (inst li (lognot lowtag-mask) ndescr)
  93     (inst lda boxed (fixnumize (1+ code-trace-table-offset-slot))
  94           boxed-arg)
  95     (inst and boxed ndescr boxed)
  96     (inst srl unboxed-arg word-shift unboxed)
  97     (inst lda unboxed lowtag-mask unboxed)
  98     (inst and unboxed ndescr unboxed)
  99     (inst sll boxed (- n-widetag-bits word-shift) ndescr)
 100     (inst bis ndescr code-header-widetag ndescr)
 101
 102     (pseudo-atomic ()
 103       (inst bis alloc-tn other-pointer-lowtag result)
 104       (storew ndescr result 0 other-pointer-lowtag)
 105       (storew unboxed result code-code-size-slot other-pointer-lowtag)
 106       (storew null-tn result code-entry-points-slot other-pointer-lowtag)
 107       (inst addq alloc-tn boxed alloc-tn)
 108       (inst addq alloc-tn unboxed alloc-tn))
 109
 110     (storew null-tn result code-debug-info-slot other-pointer-lowtag)))
 111
 112 (define-vop (make-fdefn)
 113   (:policy :fast-safe)
 114   (:translate make-fdefn)
 115   (:args (name :scs (descriptor-reg) :to :eval))
 116   (:temporary (:scs (non-descriptor-reg)) temp)
 117   (:results (result :scs (descriptor-reg) :from :argument))
 118   (:generator 37
 119     (with-fixed-allocation (result temp fdefn-widetag fdefn-size)
 120       (storew name result fdefn-name-slot other-pointer-lowtag)
 121       (storew null-tn result fdefn-fun-slot other-pointer-lowtag)
 122       (inst li (make-fixup "undefined_tramp" :foreign) temp)
 123       (storew temp result fdefn-raw-addr-slot other-pointer-lowtag))))
 124
 125 (define-vop (make-closure)
 126   (:args (function :to :save :scs (descriptor-reg)))
 127   (:info length stack-allocate-p)
 128   (:temporary (:scs (non-descriptor-reg)) temp)
 129   (:results (result :scs (descriptor-reg)))
 130   (:generator 10
 131     (let* ((size (+ length closure-info-offset))
 132            (alloc-size (pad-data-block size)))
 133       (inst li
 134             (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
 135             temp)
 136       (pseudo-atomic (:extra (if stack-allocate-p 0 alloc-size))
 137         (cond (stack-allocate-p
 138                (align-csp result)
 139                (inst bis csp-tn fun-pointer-lowtag result)
 140                (inst lda csp-tn alloc-size csp-tn))
 141               (t
 142                (inst bis alloc-tn fun-pointer-lowtag result)))
 143         (storew temp result 0 fun-pointer-lowtag)
 144         (storew function result closure-fun-slot fun-pointer-lowtag)))))
 145
 146 ;;; The compiler likes to be able to directly make value cells.
 147 (define-vop (make-value-cell)
 148   (:args (value :to :save :scs (descriptor-reg any-reg null zero)))
 149   (:temporary (:scs (non-descriptor-reg)) temp)
 150   (:info stack-allocate-p)
 151   (:ignore stack-allocate-p)
 152   (:results (result :scs (descriptor-reg)))
 153   (:generator 10
 154     (with-fixed-allocation
 155         (result temp value-cell-header-widetag value-cell-size)
 156       (storew value result value-cell-value-slot other-pointer-lowtag))))
 157 \f
 158 ;;;; automatic allocators for primitive objects
 159
 160 (define-vop (make-unbound-marker)
 161   (:args)
 162   (:results (result :scs (any-reg)))
 163   (:generator 1
 164     (inst li unbound-marker-widetag result)))
 165
 166 (define-vop (make-funcallable-instance-tramp)
 167   (:args)
 168   (:results (result :scs (any-reg)))
 169   (:generator 1
 170     (inst li (make-fixup "funcallable_instance_tramp" :foreign) result)))
 171
 172 (define-vop (fixed-alloc)
 173   (:args)
 174   (:info name words type lowtag stack-allocate-p)
 175   (:ignore name stack-allocate-p)
 176   (:results (result :scs (descriptor-reg)))
 177   (:temporary (:scs (non-descriptor-reg)) temp)
 178   (:generator 4
 179     (pseudo-atomic (:extra (pad-data-block words))
 180       (inst bis alloc-tn lowtag result)
 181       (when type
 182         (inst li (logior (ash (1- words) n-widetag-bits) type) temp)
 183         (storew temp result 0 lowtag)))))
 184
 185 (define-vop (var-alloc)
 186   (:args (extra :scs (any-reg)))
 187   (:arg-types positive-fixnum)
 188   (:info name words type lowtag)
 189   (:ignore name)
 190   (:results (result :scs (descriptor-reg)))
 191   (:temporary (:scs (non-descriptor-reg)) header)
 192   (:temporary (:scs (non-descriptor-reg)) bytes)
 193   (:generator 6
 194     (inst lda bytes (* (1+ words) n-word-bytes) extra)
 195     (inst sll bytes (- n-widetag-bits 2) header)
 196     (inst lda header (+ (ash -2 n-widetag-bits) type) header)
 197     (inst srl bytes n-lowtag-bits bytes)
 198     (inst sll bytes n-lowtag-bits bytes)
 199     (pseudo-atomic ()
 200       (inst bis alloc-tn lowtag result)
 201       (storew header result 0 lowtag)
 202       (inst addq alloc-tn bytes alloc-tn))))