src/compiler/hppa/alloc.lisp

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