cleanup: partial long cleanup in sniff_code_object and gencgc_apply_code_fixups
[sbcl.git] / src / compiler / alpha / values.lisp
1 ;;;; the Alpha implementation of unknown-values VOPs
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 (define-vop (reset-stack-pointer)
15   (:args (ptr :scs (any-reg)))
16   (:generator 1
17     (move ptr csp-tn)))
18
19 (define-vop (%%nip-values)
20   (:args (last-nipped-ptr :scs (any-reg) :target dest)
21          (last-preserved-ptr :scs (any-reg) :target src)
22          (moved-ptrs :scs (any-reg) :more t))
23   (:results (r-moved-ptrs :scs (any-reg) :more t))
24   (:temporary (:sc any-reg) src)
25   (:temporary (:sc any-reg) dest)
26   (:temporary (:sc non-descriptor-reg) temp)
27   (:ignore r-moved-ptrs)
28   (:generator 1
29     (move last-nipped-ptr dest)
30     (move last-preserved-ptr src)
31     (inst cmple csp-tn src temp)
32     (inst bne temp DONE)
33     LOOP
34     (loadw temp src)
35     (inst addq dest n-word-bytes dest)
36     (inst addq src n-word-bytes src)
37     (storew temp dest -1)
38     (inst cmple csp-tn src temp)
39     (inst beq temp LOOP)
40     DONE
41     (inst lda csp-tn 0 dest)
42     (inst subq src dest src)
43     (loop for moved = moved-ptrs then (tn-ref-across moved)
44           while moved
45           do (sc-case (tn-ref-tn moved)
46                ((descriptor-reg any-reg)
47                 (inst subq (tn-ref-tn moved) src (tn-ref-tn moved)))
48                ((control-stack)
49                 (load-stack-tn temp (tn-ref-tn moved))
50                 (inst subq temp src temp)
51                 (store-stack-tn (tn-ref-tn moved) temp))))))
52
53 ;;; Push some values onto the stack, returning the start and number of
54 ;;; values pushed as results. It is assumed that the Vals are wired to
55 ;;; the standard argument locations. Nvals is the number of values to
56 ;;; push.
57 ;;;
58 ;;; The generator cost is pseudo-random. We could get it right by
59 ;;; defining a bogus SC that reflects the costs of the
60 ;;; memory-to-memory moves for each operand, but this seems
61 ;;; unworthwhile.
62 (define-vop (push-values)
63   (:args
64    (vals :more t))
65   (:results
66    (start :scs (any-reg))
67    (count :scs (any-reg)))
68   (:info nvals)
69   (:temporary (:scs (descriptor-reg)) temp)
70   (:temporary (:scs (descriptor-reg)
71                :to (:result 0)
72                :target start)
73               start-temp)
74   (:generator 20
75     (move csp-tn start-temp)
76     (inst lda csp-tn (* nvals n-word-bytes) csp-tn)
77     (do ((val vals (tn-ref-across val))
78          (i 0 (1+ i)))
79         ((null val))
80       (let ((tn (tn-ref-tn val)))
81         (sc-case tn
82           (descriptor-reg
83            (storew tn start-temp i))
84           (control-stack
85            (load-stack-tn temp tn)
86            (storew temp start-temp i)))))
87     (move start-temp start)
88     (inst li (fixnumize nvals) count)))
89
90 ;;; Push a list of values on the stack, returning Start and Count as
91 ;;; used in unknown values continuations.
92 (define-vop (values-list)
93   (:args (arg :scs (descriptor-reg) :target list))
94   (:arg-types list)
95   (:policy :fast-safe)
96   (:results (start :scs (any-reg))
97             (count :scs (any-reg)))
98   (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list)
99   (:temporary (:scs (non-descriptor-reg)) temp)
100   (:temporary (:scs (non-descriptor-reg)) ndescr)
101   (:vop-var vop)
102   (:save-p :compute-only)
103   (:generator 0
104     (move arg list)
105     (move csp-tn start)
106
107     LOOP
108     (inst cmpeq list null-tn temp)
109     (inst bne temp done)
110     (loadw temp list cons-car-slot list-pointer-lowtag)
111     (loadw list list cons-cdr-slot list-pointer-lowtag)
112     (inst lda csp-tn n-word-bytes csp-tn)
113     (storew temp csp-tn -1)
114     (inst and list lowtag-mask ndescr)
115     (inst xor ndescr list-pointer-lowtag ndescr)
116     (inst beq ndescr loop)
117     (error-call vop bogus-arg-to-values-list-error list)
118
119     DONE
120     (inst subq csp-tn start count)))
121
122 ;;; Copy the &MORE arg block to the top of the stack so we can use
123 ;;; them as function arguments.
124 (define-vop (%more-arg-values)
125   (:args (context :scs (descriptor-reg any-reg) :target src)
126          (skip :scs (any-reg zero immediate))
127          (num :scs (any-reg) :target count))
128   (:arg-types * positive-fixnum positive-fixnum)
129   (:temporary (:sc any-reg :from (:argument 0)) src)
130   (:temporary (:sc any-reg :from (:argument 2)) dst)
131   (:temporary (:sc descriptor-reg :from (:argument 1)) temp)
132   (:temporary (:sc non-descriptor-reg) temp1)
133   (:results (start :scs (any-reg))
134             (count :scs (any-reg)))
135   (:generator 20
136     (sc-case skip
137       (zero
138        (move context src))
139       (immediate
140        (inst lda src (* (tn-value skip) n-word-bytes) context))
141       (any-reg
142        (inst addq context skip src)))
143     (move num count)
144     (inst move csp-tn start)
145     (inst beq num done)
146     (inst move csp-tn dst)
147     (inst addq csp-tn count csp-tn)
148     LOOP
149     (inst ldl temp 0 src)
150     (inst addq src 4 src)
151     (inst addq dst 4 dst)
152     (inst stl temp -4 dst)
153     (inst cmpeq dst csp-tn temp1)
154     (inst beq temp1 loop)
155     DONE))