cleanup: partial long cleanup in sniff_code_object and gencgc_apply_code_fixups
[sbcl.git] / src / compiler / x86 / values.lisp
1 ;;;; unknown-values VOPs for the x86 VM
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 esp-tn ptr)))
18
19 (define-vop (%%nip-values)
20   (:args (last-nipped-ptr :scs (any-reg) :target edi)
21          (last-preserved-ptr :scs (any-reg) :target esi)
22          (moved-ptrs :scs (any-reg) :more t))
23   (:results (r-moved-ptrs :scs (any-reg) :more t)
24             ;; same as MOVED-PTRS
25             )
26   (:temporary (:sc any-reg :offset esi-offset) esi)
27   (:temporary (:sc any-reg :offset edi-offset) edi)
28   (:ignore r-moved-ptrs)
29   (:generator 1
30     (move edi last-nipped-ptr)
31     (move esi last-preserved-ptr)
32     (inst sub esi n-word-bytes)
33     (inst sub edi n-word-bytes)
34     (inst cmp esp-tn esi)
35     (inst jmp :a done)
36     (inst std)
37     LOOP
38     (inst movs :dword)
39     (inst cmp esp-tn esi)
40     (inst jmp :be loop)
41     (inst cld)
42     DONE
43     (inst lea esp-tn (make-ea :dword :base edi :disp n-word-bytes))
44     (inst sub edi esi)
45     (loop for moved = moved-ptrs then (tn-ref-across moved)
46           while moved
47           do (inst add (tn-ref-tn moved) edi))))
48
49 ;;; Push some values onto the stack, returning the start and number of values
50 ;;; pushed as results. It is assumed that the Vals are wired to the standard
51 ;;; argument locations. Nvals is the number of values to push.
52 ;;;
53 ;;; The generator cost is pseudo-random. We could get it right by defining a
54 ;;; bogus SC that reflects the costs of the memory-to-memory moves for each
55 ;;; operand, but this seems unworthwhile.
56 (define-vop (push-values)
57   (:args (vals :more t))
58   (:temporary (:sc unsigned-reg :to (:result 0) :target start) temp)
59   (:results (start) (count))
60   (:info nvals)
61   (:generator 20
62     (move temp esp-tn)                  ; WARN pointing 1 below
63     (do ((val vals (tn-ref-across val)))
64         ((null val))
65       (inst push (tn-ref-tn val)))
66     (move start temp)
67     (inst mov count (fixnumize nvals))))
68
69 ;;; Push a list of values on the stack, returning Start and Count as used in
70 ;;; unknown values continuations.
71 (define-vop (values-list)
72   (:args (arg :scs (descriptor-reg) :target list))
73   (:arg-types list)
74   (:policy :fast-safe)
75   (:results (start :scs (any-reg))
76             (count :scs (any-reg)))
77   (:temporary (:sc descriptor-reg :from (:argument 0) :to (:result 1)) list)
78   (:temporary (:sc descriptor-reg :to (:result 1)) nil-temp)
79   (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 1)) eax)
80   (:vop-var vop)
81   (:save-p :compute-only)
82   (:generator 0
83     (move list arg)
84     (move start esp-tn)                 ; WARN pointing 1 below
85     (inst mov nil-temp nil-value)
86
87     LOOP
88     (inst cmp list nil-temp)
89     (inst jmp :e done)
90     (pushw list cons-car-slot list-pointer-lowtag)
91     (loadw list list cons-cdr-slot list-pointer-lowtag)
92     (inst mov eax list)
93     (inst and al-tn lowtag-mask)
94     (inst cmp al-tn list-pointer-lowtag)
95     (inst jmp :e loop)
96     (error-call vop 'bogus-arg-to-values-list-error list)
97
98     DONE
99     (inst mov count start)              ; start is high address
100     (inst sub count esp-tn)))           ; stackp is low address
101
102 ;;; Copy the more arg block to the top of the stack so we can use them
103 ;;; as function arguments.
104 ;;;
105 ;;; Accepts a context as produced by more-arg-context; points to the first
106 ;;; value on the stack, not 4 bytes above as in other contexts.
107 ;;;
108 ;;; Return a context that is 4 bytes above the first value, suitable for
109 ;;; defining a new stack frame.
110 (define-vop (%more-arg-values)
111   (:args (context :scs (descriptor-reg any-reg) :target src)
112          (skip :scs (any-reg immediate))
113          (num :scs (any-reg) :target count))
114   (:arg-types * positive-fixnum positive-fixnum)
115   (:temporary (:sc any-reg :offset esi-offset :from (:argument 0)) src)
116   (:temporary (:sc descriptor-reg :offset eax-offset) temp)
117   (:temporary (:sc unsigned-reg :offset ecx-offset) loop-index)
118   (:results (start :scs (any-reg))
119             (count :scs (any-reg)))
120   (:generator 20
121     (sc-case skip
122       (immediate
123        (cond ((zerop (tn-value skip))
124               (move src context)
125               (move count num))
126              (t
127               (inst lea src (make-ea :dword :base context
128                                      :disp (- (* (tn-value skip)
129                                                  n-word-bytes))))
130               (move count num)
131               (inst sub count (* (tn-value skip) n-word-bytes)))))
132
133       (any-reg
134        (move src context)
135        (inst sub src skip)
136        (move count num)
137        (inst sub count skip)))
138
139     (move loop-index count)
140     (inst mov start esp-tn)
141     (inst jecxz done)  ; check for 0 count?
142
143     (inst sub esp-tn count)
144     (inst sub src count)
145
146     LOOP
147     (inst mov temp (make-ea :dword :base src :index loop-index))
148     (inst sub loop-index n-word-bytes)
149     (inst mov (make-ea :dword :base esp-tn :index loop-index) temp)
150     (inst jmp :nz LOOP)
151
152     DONE
153     ))
154