1.0.32.34: remove curious-hacker-cruft from constraints.lisp
[sbcl.git] / src / compiler / ppc / values.lisp
1 ;;;
2 ;;; Written by Rob MacLachlan
3 ;;;
4 ;;; Converted for SPARC by William Lott.
5 ;;;
6
7 (in-package "SB!VM")
8
9 (define-vop (reset-stack-pointer)
10   (:args (ptr :scs (any-reg)))
11   (:generator 1
12     (move csp-tn ptr)))
13
14 ;;; sparc version translated to ppc by David Steuber with help from #lisp.
15 (define-vop (%%nip-values)
16   (:args (last-nipped-ptr :scs (any-reg) :target dest)
17          (last-preserved-ptr :scs (any-reg) :target src)
18          (moved-ptrs :scs (any-reg) :more t))
19   (:results (r-moved-ptrs :scs (any-reg) :more t))
20   (:temporary (:sc any-reg) src)
21   (:temporary (:sc any-reg) dest)
22   (:temporary (:sc non-descriptor-reg) temp)
23   (:ignore r-moved-ptrs)
24   (:generator 1
25     (inst mr dest last-nipped-ptr)
26     (inst mr src last-preserved-ptr)
27     (inst cmplw csp-tn src)
28     (inst ble DONE)
29     LOOP
30     (loadw temp src)
31     (inst addi dest dest n-word-bytes)
32     (inst addi src src n-word-bytes)
33     (storew temp dest -1)
34     (inst cmplw csp-tn src)
35     (inst bgt LOOP)
36     DONE
37     (inst mr csp-tn dest)
38     (inst sub src src dest)
39     (loop for moved = moved-ptrs then (tn-ref-across moved)
40           while moved
41           do (sc-case (tn-ref-tn moved)
42                ((descriptor-reg any-reg)
43                 (inst sub (tn-ref-tn moved) (tn-ref-tn moved) src))
44                ((control-stack)
45                 (load-stack-tn temp (tn-ref-tn moved))
46                 (inst sub temp temp src)
47                 (store-stack-tn (tn-ref-tn moved) temp))))))
48
49
50 ;;; Push some values onto the stack, returning the start and number of values
51 ;;; pushed as results.  It is assumed that the Vals are wired to the standard
52 ;;; argument locations.  Nvals is the number of values to push.
53 ;;;
54 ;;; The generator cost is pseudo-random.  We could get it right by defining a
55 ;;; bogus SC that reflects the costs of the memory-to-memory moves for each
56 ;;; operand, but this seems unworthwhile.
57 ;;;
58 (define-vop (push-values)
59   (:args (vals :more t))
60   (:results (start :scs (any-reg) :from :load)
61             (count :scs (any-reg)))
62   (:info nvals)
63   (:temporary (:scs (descriptor-reg)) temp)
64   (:generator 20
65     (inst mr start csp-tn)
66     (inst addi csp-tn csp-tn (* nvals n-word-bytes))
67     (do ((val vals (tn-ref-across val))
68          (i 0 (1+ i)))
69         ((null val))
70       (let ((tn (tn-ref-tn val)))
71         (sc-case tn
72           (descriptor-reg
73            (storew tn start i))
74           (control-stack
75            (load-stack-tn temp tn)
76            (storew temp start i)))))
77     (inst lr count (fixnumize nvals))))
78
79 ;;; Push a list of values on the stack, returning Start and Count as used in
80 ;;; unknown values continuations.
81 ;;;
82 (define-vop (values-list)
83   (:args (arg :scs (descriptor-reg) :target list))
84   (:arg-types list)
85   (:policy :fast-safe)
86   (:results (start :scs (any-reg))
87             (count :scs (any-reg)))
88   (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list)
89   (:temporary (:scs (descriptor-reg)) temp)
90   (:temporary (:scs (non-descriptor-reg)) ndescr)
91   (:vop-var vop)
92   (:save-p :compute-only)
93   (:generator 0
94     (let ((loop (gen-label))
95           (done (gen-label)))
96
97       (move list arg)
98       (move start csp-tn)
99
100       (emit-label loop)
101       (inst cmpw list null-tn)
102       (loadw temp list cons-car-slot list-pointer-lowtag)
103       (inst beq done)
104       (loadw list list cons-cdr-slot list-pointer-lowtag)
105       (inst addi csp-tn csp-tn n-word-bytes)
106       (storew temp csp-tn -1)
107       (test-type list loop nil (list-pointer-lowtag) :temp ndescr)
108       (error-call vop 'bogus-arg-to-values-list-error list)
109
110       (emit-label done)
111       (inst sub count csp-tn start))))
112
113
114 ;;; Copy the more arg block to the top of the stack so we can use them
115 ;;; as function arguments.
116 ;;;
117 (define-vop (%more-arg-values)
118   (:args (context :scs (descriptor-reg any-reg) :target src)
119          (skip :scs (any-reg zero immediate))
120          (num :scs (any-reg) :target count))
121   (:arg-types * positive-fixnum positive-fixnum)
122   (:temporary (:sc any-reg :from (:argument 0)) src)
123   (:temporary (:sc any-reg :from (:argument 2)) dst)
124   (:temporary (:sc descriptor-reg :from (:argument 1)) temp)
125   (:temporary (:sc any-reg) i)
126   (:results (start :scs (any-reg))
127             (count :scs (any-reg)))
128   (:generator 20
129     (sc-case skip
130       (zero
131        (inst mr src context))
132       (immediate
133        (inst addi src context (* (tn-value skip) n-word-bytes)))
134       (any-reg
135        (inst add src context skip)))
136     (inst mr. count num)
137     (inst mr start csp-tn)
138     (inst beq done)
139     (inst mr dst csp-tn)
140     (inst add csp-tn csp-tn count)
141     (inst mr i count)
142     LOOP
143     (inst cmpwi i 4)
144     (inst subi i i 4)
145     (inst lwzx temp src i)
146     (inst stwx temp dst i)
147     (inst bne loop)
148     DONE))