src/compiler/alpha/alloc.lisp

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