byte-comp.lisp 80.7 KB
Newer Older
wlott's avatar
wlott committed
1
2
3
4
5
6
7
;;; -*- Package: C -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
8
  "$Header: src/compiler/byte-comp.lisp $")
wlott's avatar
wlott committed
9
10
11
12
13
14
15
16
17
18
19
;;;
;;; **********************************************************************
;;;
;;; This file contains the noise to byte-compile stuff.  It uses the
;;; same front end as the real compiler, but generates a byte-code instead
;;; of native code.
;;;
;;; Written by William Lott
;;;

(in-package "C")
20
21
(intl:textdomain "cmucl")

22
23
24
25
26
(export '(disassem-byte-component
	  disassem-byte-fun
	  backend-byte-fasl-file-type
	  backend-byte-fasl-file-implementation
	  byte-fasl-file-version))
wlott's avatar
wlott committed
27
28
29

;;; ### Remaining work:
;;;
30
;;; - add more inline operations.
wlott's avatar
wlott committed
31
;;; - Breakpoints/debugging info.
32
;;;
wlott's avatar
wlott committed
33

34
35
36

;;;; Fasl file format:

37
38
39
40
;; The fasl file version should be a series of hex digits in the range
;; 0-9 followed by a single hex digit in the range a-f.  Then the
;; version looks like a decimal number followed by a minor release
;; letter of a to f.
Raymond Toy's avatar
Raymond Toy committed
41
(defconstant byte-fasl-file-version #x20e)
42

43
(let* ((version-string (format nil "~X" byte-fasl-file-version)))
44
45
46
47
  ;; Add :cmu<n> to *features*
  (sys:register-lisp-feature (intern (concatenate 'string "CMU" version-string)
				     :keyword))
  ;; Same as above, except drop the trailing a-f character.
48
  (sys:register-lisp-feature (intern (concatenate 'string "CMU"
49
50
						  (subseq version-string 0
							  (1- (length version-string))))
51
52
				     :keyword)))

53
54
55
56
57
(defun backend-byte-fasl-file-type (backend)
  (ecase (backend-byte-order backend)
    (:big-endian "bytef")
    (:little-endian "lbytef")))

58
(defun backend-byte-fasl-file-implementation (backend)
59
60
  (ecase (backend-byte-order backend)
    (:big-endian big-endian-fasl-file-implementation)
ram's avatar
typo.    
ram committed
61
    (:little-endian little-endian-fasl-file-implementation)))
62

wlott's avatar
wlott committed
63
64
65
66
67
68
69
70
71
72
73
74
75
76

;;;; Stuff to emit noise.

;;; Note: we use the regular assembler, but we don't use any ``instructions''
;;; because there is no way to keep our byte-code instructions seperate from
;;; the instructions used by the native backend.  Besides, we don't want to do
;;; any scheduling or anything like that, anyway.

(declaim (inline output-byte))
(defun output-byte (segment byte)
  (declare (type new-assem:segment segment)
	   (type (unsigned-byte 8) byte))
  (new-assem:emit-byte segment byte))

ram's avatar
ram committed
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92

;;; OUTPUT-EXTENDED-OPERAND  --  Internal
;;;
;;;    Output Operand as 1 or 4 bytes, using #xFF as the extend code.
;;;
(defun output-extended-operand (segment operand)
  (declare (type (unsigned-byte 24) operand))
  (cond ((<= operand 254)
	 (output-byte segment operand))
	(t
	 (output-byte segment #xFF)
	 (output-byte segment (ldb (byte 8 16) operand))
	 (output-byte segment (ldb (byte 8 8) operand))
	 (output-byte segment (ldb (byte 8 0) operand)))))


wlott's avatar
wlott committed
93
94
95
;;; OUTPUT-BYTE-WITH-OPERAND -- internal.
;;;
;;; Output a byte, logior'ing in a 4 bit immediate constant.  If that
ram's avatar
ram committed
96
;;; immediate won't fit, then emit it as the next 1-4 bytes.
wlott's avatar
wlott committed
97
98
99
100
;;; 
(defun output-byte-with-operand (segment byte operand)
  (declare (type new-assem:segment segment)
	   (type (unsigned-byte 8) byte)
ram's avatar
ram committed
101
	   (type (unsigned-byte 24) operand))
wlott's avatar
wlott committed
102
103
104
105
  (cond ((<= operand 14)
	 (output-byte segment (logior byte operand)))
	(t
	 (output-byte segment (logior byte 15))
ram's avatar
ram committed
106
	 (output-extended-operand segment operand)))
wlott's avatar
wlott committed
107
108
  (undefined-value))

ram's avatar
ram committed
109

wlott's avatar
wlott committed
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
;;; OUTPUT-LABEL -- internal.
;;;
(defun output-label (segment label)
  (declare (type new-assem:segment segment)
	   (type new-assem:label label))
  (new-assem:assemble (segment)
    (new-assem:emit-label label)))

;;; OUTPUT-REFERENCE -- internal.
;;;
;;; Output a reference to LABEL.  If RELATIVE is NIL, then this reference
;;; can never be relative.
;;;
(defun output-reference (segment label)
  (declare (type new-assem:segment segment)
	   (type new-assem:label label))
  (new-assem:emit-back-patch
   segment
   3
   #'(lambda (segment posn)
       (declare (type new-assem:segment segment)
		(ignore posn))
       (let ((target (new-assem:label-position label)))
	 (assert (<= 0 target (1- (ash 1 24))))
	 (output-byte segment (ldb (byte 8 16) target))
	 (output-byte segment (ldb (byte 8 8) target))
	 (output-byte segment (ldb (byte 8 0) target))))))

;;; OUTPUT-BRANCH -- internal.
;;;
;;; Output some branch byte-sequence.
;;; 
(defun output-branch (segment kind label)
  (declare (type new-assem:segment segment)
	   (type (unsigned-byte 8) kind)
	   (type new-assem:label label))
  (new-assem:emit-chooser
   segment 4 1
   #'(lambda (segment posn delta)
       (when (<= (- (ash 1 7))
		 (- (new-assem:label-position label posn delta) posn 2)
		 (1- (ash 1 7)))
	 (new-assem:emit-chooser
	  segment 2 1
	  #'(lambda (segment posn delta)
	      (declare (ignore segment) (type index posn delta))
gerd's avatar
gerd committed
156
157
158
	      (when (and (eql kind byte-branch-always)
			 (zerop (- (new-assem:label-position label posn delta)
				   posn 2)))
wlott's avatar
wlott committed
159
		;; Don't emit anything, because the branch is to the following
gerd's avatar
gerd committed
160
161
		;; instruction.  Only do this for unconditional branches,
		;; because the conditional ones pop the byte stack.
wlott's avatar
wlott committed
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
		t))
	  #'(lambda (segment posn)
	      ;; We know we fit in one byte.
	      (declare (type new-assem:segment segment)
		       (type index posn))
	      (output-byte segment (logior kind 1))
	      (output-byte segment
			   (ldb (byte 8 0)
				(- (new-assem:label-position label) posn 2)))))
	 t))
   #'(lambda (segment posn)
       (declare (type new-assem:segment segment)
		(ignore posn))
       (let ((target (new-assem:label-position label)))
	 (assert (<= 0 target (1- (ash 1 24))))
	 (output-byte segment kind)
	 (output-byte segment (ldb (byte 8 16) target))
	 (output-byte segment (ldb (byte 8 8) target))
	 (output-byte segment (ldb (byte 8 0) target))))))


;;;; System constants, Xops, and inline functions.

185
186
;;; If (%fdefinition-marker% . name), then the value is the fdefinition 
(defvar *system-constant-codes* (make-hash-table :test #'equal))
wlott's avatar
wlott committed
187
188
189

(eval-when (compile eval)
  (defmacro def-system-constant (index form)
ram's avatar
ram committed
190
191
    `(let ((val ,form))
       (setf (gethash val *system-constant-codes*) ,index))))
wlott's avatar
wlott committed
192
193
194

(def-system-constant 0 nil)
(def-system-constant 1 t)
ram's avatar
ram committed
195
196
197
198
199
200
201
202
(def-system-constant 2 :start)
(def-system-constant 3 :end)
(def-system-constant 4 :test)
(def-system-constant 5 :count)
(def-system-constant 6 :test-not)
(def-system-constant 7 :key)
(def-system-constant 8 :from-end)
(def-system-constant 9 :type)
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
(def-system-constant 10 '(%fdefinition-marker% . error))
(def-system-constant 11 '(%fdefinition-marker% . format))
(def-system-constant 12 '(%fdefinition-marker% . %typep))
(def-system-constant 13 '(%fdefinition-marker% . eql))
(def-system-constant 14 '(%fdefinition-marker% . %negate))

(def-system-constant 15 '(%fdefinition-marker% . %%defun))
(def-system-constant 16 '(%fdefinition-marker% . %%defmacro))
(def-system-constant 17 '(%fdefinition-marker% . %%defconstant))
(def-system-constant 18 '(%fdefinition-marker% . length))
(def-system-constant 19 '(%fdefinition-marker% . equal))
(def-system-constant 20 '(%fdefinition-marker% . append))
(def-system-constant 21 '(%fdefinition-marker% . reverse))
(def-system-constant 22 '(%fdefinition-marker% . nreverse))
(def-system-constant 23 '(%fdefinition-marker% . nconc))
(def-system-constant 24 '(%fdefinition-marker% . list))
(def-system-constant 25 '(%fdefinition-marker% . list*))
220
221
(def-system-constant 26 '(%fdefinition-marker% . %coerce-to-function))
(def-system-constant 27 '(%fdefinition-marker% . values-list))
wlott's avatar
wlott committed
222
223

(defparameter *xop-names*
ram's avatar
ram committed
224
225
226
227
228
  '(breakpoint; 0
    dup; 1
    type-check; 2
    fdefn-function-or-lose; 3
    default-unknown-values; 4
229
    push-n-under; 5
ram's avatar
ram committed
230
231
    xop6
    xop7
wlott's avatar
wlott committed
232
    merge-unknown-values
ram's avatar
ram committed
233
    make-closure
wlott's avatar
wlott committed
234
235
236
237
238
239
    throw
    catch
    breakup
    return-from
    tagbody
    go
240
    unwind-protect))
wlott's avatar
wlott committed
241
242
243

(defun xop-index-or-lose (name)
  (or (position name *xop-names* :test #'eq)
244
      (error (intl:gettext "Unknown XOP ~S") name)))
wlott's avatar
wlott committed
245
246
247


(defstruct inline-function-info
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
  ;;
  ;; Name of the function that we convert into calls to this.
  (function (required-argument) :type symbol)
  ;;
  ;; Name of function that the interpreter should call to implement this.  May
  ;; not be the same as above if extra safety checks are required.
  (interpreter-function (required-argument) :type symbol)
  ;;
  ;; Inline operation number.
  (number (required-argument) :type (mod 32))
  ;;
  ;; Type calls must statisfy.
  (type (required-argument) :type function-type)
  ;;
  ;; If true, arg type checking need not be done.
  (safe (required-argument) :type (member t nil)))

(defparameter *inline-functions* (make-array 32 :initial-element nil))
(defparameter *inline-function-table* (make-hash-table :test #'eq))
(let ((number 0))
  (dolist (stuff
	   '((+ (fixnum fixnum) fixnum)
	     (- (fixnum fixnum) fixnum)
	     (make-value-cell (t) t)
	     (value-cell-ref (t) t)
	     (value-cell-setf (t t) (values))
	     (symbol-value (symbol) t :interpreter-function %byte-symbol-value)
	     (setf-symbol-value (t symbol) (values))
	     (%byte-special-bind (t symbol) (values))
	     (%byte-special-unbind () (values))
	     (cons-unique-tag () t); obsolete...
	     (%negate (fixnum) fixnum)
	     (< (fixnum fixnum) t)
	     (> (fixnum fixnum) t)
	     (car (t) t :interpreter-function %byte-car :safe t)
	     (cdr (t) t :interpreter-function %byte-cdr :safe t)
	     (length (list) t)
	     (cons (t t) t)
	     (list (t t) t)
287
288
289
	     (list* (t t t) t)
	     (%instance-ref (t t) t)
	     (%setf-instance-ref (t t t) (values))))
290
291
292
293
294
295
296
297
298
299
300
301
302
303
    (destructuring-bind (name arg-types result-type
			      &key (interpreter-function name) alias safe)
			stuff
      (let ((info
	     (make-inline-function-info
	      :function name
	      :number number
	      :interpreter-function interpreter-function
	      :type (specifier-type `(function ,arg-types ,result-type))
	      :safe safe)))
	(setf (svref *inline-functions* number) info)
	(setf (gethash name *inline-function-table*) info))
      (unless alias (incf number)))))

wlott's avatar
wlott committed
304
305

(defun inline-function-number-or-lose (function)
306
  (let ((info (gethash function *inline-function-table*)))
wlott's avatar
wlott committed
307
308
    (if info
	(inline-function-info-number info)
309
	(error (intl:gettext "Unknown inline function: ~S") function))))
wlott's avatar
wlott committed
310

311
312
313
314
315
316
317
318
319

;;;; Byte-code specific transforms:

(deftransform eql ((x y) ((or fixnum character) (or fixnum character))
		   * :when :byte)
  '(eq x y))

(deftransform char= ((x y) * * :when :byte)
  '(eq x y))
wlott's avatar
wlott committed
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352


;;;; Annotations hung off the IR1 while compiling.

(defstruct byte-component-info
  (constants (make-array 10 :adjustable t :fill-pointer 0)))


(defstruct byte-lambda-info
  (label nil :type (or null label))
  (stack-size 0 :type index)
  (interesting t :type (member t nil)))

(defun block-interesting (block)
  (byte-lambda-info-interesting (lambda-info (block-home-lambda block))))

(defstruct byte-lambda-var-info
  (argp nil :type (member t nil))
  (offset 0 :type index))

(defstruct byte-nlx-info
  (stack-slot nil :type (or null index))
  (label (new-assem:gen-label) :type new-assem:label)
  (duplicate nil :type (member t nil)))

(defstruct (byte-block-info
	    (:include block-annotation)
	    (:print-function %print-byte-block-info)
	    (:constructor make-byte-block-info
			  (block &key produces produces-sset consumes
			    total-consumes nlx-entries nlx-entry-p)))
  (label (new-assem:gen-label) :type new-assem:label)
  ;;
353
354
355
356
357
358
  ;; A list of the CONTINUATIONs describing values that this block pushes onto
  ;; the stack.  Note: PRODUCES and CONSUMES can contain the keyword :NLX-ENTRY
  ;; marking the place on the stack where a non-local-exit frame is added or
  ;; removed.  Since breaking up a NLX restores the stack, we don't have to
  ;; about (and in fact must not) discard values underneath a :NLX-ENTRY marker
  ;; evern though they appear to be dead (since they might not be.)
wlott's avatar
wlott committed
359
360
  (produces nil :type list)
  ;;
361
362
363
  ;; An SSET of the produces for faster set manipulations.  The elements are
  ;; the BYTE-CONTINUATION-INFO objects.  :NLX-ENTRY markers are not
  ;; represented.
wlott's avatar
wlott committed
364
365
  (produces-sset (make-sset) :type sset)
  ;;
366
367
  ;; A list of the continuations that this block pops from the stack.  See
  ;; PRODUCES.
wlott's avatar
wlott committed
368
369
370
371
372
373
374
375
376
377
378
  (consumes nil :type list)
  ;;
  ;; The transitive closure of what this block and all its successors
  ;; consume.  After stack-analysis, that is.
  (total-consumes (make-sset) :type sset)
  ;;
  ;; Set to T whenever the consumes lists of a successor changes and the
  ;; block is queued for re-analysis so we can easily avoid queueing the same
  ;; block several times.
  (already-queued nil :type (member t nil))
  ;;
379
380
  ;; The continuations and :NLX-ENTRY markers on the stack (in order) when this
  ;; block starts.
wlott's avatar
wlott committed
381
382
  (start-stack :unknown :type (or (member :unknown) list))
  ;;
383
384
  ;; The continuations and :NLX-ENTRY markers on the stack (in order) when this
  ;; block ends.
wlott's avatar
wlott committed
385
386
  (end-stack nil :type list)
  ;;
387
388
  ;; List of ((nlx-info*) produces consumes) for each ENTRY in this block that
  ;; is a NLX target.
wlott's avatar
wlott committed
389
390
391
392
393
394
395
396
397
398
399
400
  (nlx-entries nil :type list)
  ;;
  ;; T if this is an %nlx-entry point, and we shouldn't just assume we know
  ;; what is going to be on the stack.
  (nlx-entry-p nil :type (member t nil)))

(defprinter byte-block-info
  block)

(defstruct (byte-continuation-info
	    (:include sset-element)
	    (:print-function %print-byte-continuation-info)
401
402
	    (:constructor make-byte-continuation-info
			  (continuation results placeholders)))
wlott's avatar
wlott committed
403
404
  (continuation (required-argument) :type continuation)
  (results (required-argument)
405
406
407
408
409
410
	   :type (or (member :fdefinition :eq-test :unknown) index))
  ;;
  ;; If the DEST is a local non-MV call, then we may need to push some number
  ;; of placeholder args corresponding to deleted (unreferenced) args.  If
  ;; PLACEHOLDERS /= 0, then RESULTS is PLACEHOLDERS + 1.
  (placeholders (required-argument) :type index))
wlott's avatar
wlott committed
411
412
413

(defprinter byte-continuation-info
  continuation
414
415
  results
  (placeholders :test (/= placeholders 0)))
wlott's avatar
wlott committed
416
417
418
419


;;;; Annotate the IR1

420
(defun annotate-continuation (cont results &optional (placeholders 0))
wlott's avatar
wlott committed
421
422
423
424
425
426
  ;; For some reason, do-nodes does the same return node multiple times,
  ;; which causes annotate-continuation to be called multiple times on the
  ;; same continuation.  So we can't assert that we haven't done it.
  #+nil
  (assert (null (continuation-info cont)))
  (setf (continuation-info cont)
427
	(make-byte-continuation-info cont results placeholders))
wlott's avatar
wlott committed
428
429
430
431
432
433
  (undefined-value))

(defun annotate-set (set)
  ;; Annotate the value for one value.
  (annotate-continuation (set-value set) 1))

434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453

;;; ANNOTATE-BASIC-COMBINATION-ARGS  --  Internal
;;; 
;;;    We do different stack magic for non-MV and MV calls to figure out how
;;; many values should be pushed during compilation of each arg.
;;;
;;; Since byte functions are directly caller by the interpreter (there is no
;;; XEP), and it doesn't know which args are actually used, byte functions must
;;; allow unused args to be passed.  But this creates a problem with local
;;; calls, because these unused args would not otherwise be pushed (since the
;;; continuation has been deleted.)  So, in this function, we count up
;;; placeholders for any unused args contiguously preceding this one.  These
;;; placeholders are inserted under the referenced arg by
;;; CHECKED-CANONICALIZE-VALUES. 
;;;
;;; With MV calls, we try to figure out how many values are actually generated.
;;; We allow initial args to supply a fixed number of values, but everything
;;; after the first :unknown arg must also be unknown.  This picks off most of
;;; the standard uses (i.e. calls to apply), but still is easy to implement.
;;;
wlott's avatar
wlott committed
454
455
456
457
(defun annotate-basic-combination-args (call)
  (declare (type basic-combination call))
  (etypecase call
    (combination
458
459
460
461
462
463
464
465
466
467
468
469
470
471
     (if (and (eq (basic-combination-kind call) :local)
	      (member (functional-kind (combination-lambda call))
		      '(nil :optional :cleanup)))
	 (let ((placeholders 0))
	   (declare (type index placeholders))
	   (dolist (arg (combination-args call))
	     (cond (arg
		    (annotate-continuation arg (1+ placeholders) placeholders)
		    (setq placeholders 0))
		   (t
		    (incf placeholders)))))
	 (dolist (arg (combination-args call))
	   (when arg
	     (annotate-continuation arg 1)))))
wlott's avatar
wlott committed
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
    (mv-combination
     (labels
	 ((allow-fixed (remaining)
	    (when remaining
	      (let* ((cont (car remaining))
		     (values (nth-value 1
					(values-types
					 (continuation-derived-type cont)))))
		(cond ((eq values :unknown)
		       (force-to-unknown remaining))
		      (t
		       (annotate-continuation cont values)
		       (allow-fixed (cdr remaining)))))))
	  (force-to-unknown (remaining)
	    (when remaining
	      (let ((cont (car remaining)))
		(when cont
		  (annotate-continuation cont :unknown)))
	      (force-to-unknown (cdr remaining)))))
       (allow-fixed (mv-combination-args call)))))
  (undefined-value))

(defun annotate-local-call (call)
495
496
497
498
499
500
501
502
503
504
505
  (cond ((mv-combination-p call)
	 (annotate-continuation
	  (first (basic-combination-args call))
	  (length (lambda-vars (combination-lambda call)))))
	(t
	 (annotate-basic-combination-args call)
	 (when (member (functional-kind (combination-lambda call))
		       '(nil :optional :cleanup))
	   (dolist (arg (basic-combination-args call))
	     (when arg
	       (setf (continuation-%type-check arg) nil))))))
506
507
508
  (annotate-continuation (basic-combination-fun call) 0)
  (when (node-tail-p call)
    (set-tail-local-call-successor call)))
wlott's avatar
wlott committed
509

ram's avatar
ram committed
510
511
512
;;; ANNOTATE-FULL-CALL  --  Internal
;;;
;;;    Annotate the values for any :full combination.  This includes inline
513
514
515
;;; functions, multiple value calls & throw.  If a real full call or a safe
;;; inline operation, then clear any type-check annotations.  When we are done,
;;; remove jump to return for tail calls.
ram's avatar
ram committed
516
;;;
517
518
519
;;; Also, we annotate slot accessors as inline if no type check is needed and
;;; (for setters) no value needs to be left on the stack.
;;;
wlott's avatar
wlott committed
520
521
(defun annotate-full-call (call)
  (let* ((fun (basic-combination-fun call))
522
	 (args (basic-combination-args call))
wlott's avatar
wlott committed
523
	 (name (continuation-function-name fun))
524
	 (info (gethash name *inline-function-table*)))
525
526
    (flet ((annotate-args ()
	     (annotate-basic-combination-args call)
527
528
529
530
531
	     ;;
	     ;; We cannot assume that we can delete type checks here.
	     ;; For instance, (GCD X) will be source-transformed to
	     ;; (ABS X), and GCD expects an integer argument while ABS
	     ;; expects a number only.
532
	     (dolist (arg args)
533
534
	       (when (and (continuation-type-check arg)
			  (policy call (< safety 3)))
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
		 (setf (continuation-%type-check arg) :deleted)))
	     (annotate-continuation
	      fun
	      (if (continuation-function-name fun) :fdefinition 1))))
      (cond ((mv-combination-p call)
	     (cond ((eq name '%throw)
		    (assert (= (length args) 2))
		    (annotate-continuation (first args) 1)
		    (annotate-continuation (second args) :unknown)
		    (setf (node-tail-p call) nil)
		    (annotate-continuation fun 0))
		   (t
		    (annotate-args))))
	    ((and info
		  (valid-function-use call (inline-function-info-type info)))
	     (annotate-basic-combination-args call)
	     (setf (node-tail-p call) nil)
	     (setf (basic-combination-info call) info)
	     (annotate-continuation fun 0)
	     (when (inline-function-info-safe info)
	       (dolist (arg args)
		 (when (continuation-type-check arg)
		   (setf (continuation-%type-check arg) :deleted)))))
	    ((and name 
		  (let ((leaf (ref-leaf (continuation-use fun))))
		    (and (slot-accessor-p leaf)
			 (or (policy call (zerop safety))
			     (not (find 't args
					:key #'continuation-type-check)))
			 (if (consp name)
			     (not (continuation-dest (node-cont call)))
566
567
			     t)
			 (= (length args) (if (consp name) 2 1)))))
568
569
570
571
572
573
574
575
	     (setf (basic-combination-info call)
		   (gethash (if (consp name) '%setf-instance-ref '%instance-ref)
			    *inline-function-table*))
	     (setf (node-tail-p call) nil)
	     (annotate-continuation fun 0)
	     (annotate-basic-combination-args call))
	    (t
	     (annotate-args)))))
576
577
578
579
580
581
582
583

  ;; If this is (still) a tail-call, then blow away the return.
  (when (node-tail-p call)
    (node-ends-block call)
    (let ((block (node-block call)))
      (unlink-blocks block (first (block-succ block)))
      (link-blocks block (component-tail (block-component block)))))

wlott's avatar
wlott committed
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
  (undefined-value))

(defun annotate-known-call (call)
  (annotate-basic-combination-args call)
  (setf (node-tail-p call) nil)
  (annotate-continuation (basic-combination-fun call) 0)
  t)

(defun annotate-basic-combination (call)
  ;; Annotate the function.
  (let ((kind (basic-combination-kind call)))
    (case kind
      (:local
       (annotate-local-call call))
      (:full
       (annotate-full-call call))
ram's avatar
ram committed
600
601
602
      (:error
       (setf (basic-combination-kind call) :full)
       (annotate-full-call call))
wlott's avatar
wlott committed
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
      (t
       (unless (and (function-info-byte-compile kind)
		    (funcall (or (function-info-byte-annotate kind)
				 #'annotate-known-call)
			     call))
	 (setf (basic-combination-kind call) :full)
	 (annotate-full-call call)))))

  (undefined-value))

(defun annotate-if (if)
  ;; Annotate the test.
  (let* ((cont (if-test if))
	 (use (continuation-use cont)))
    (annotate-continuation
     cont
     (if (and (combination-p use)
	      (eq (continuation-function-name (combination-fun use)) 'eq)
	      (= (length (combination-args use)) 2))
	 ;; If the test is a call to EQ, then we can use branch-if-eq
	 ;; so don't need to actually funcall the test.
	 :eq-test
	 ;; Otherwise, funcall the test for 1 value.
	 1))))

(defun annotate-return (return)
  (let ((cont (return-result return)))
    (annotate-continuation
     cont
     (nth-value 1 (values-types (continuation-derived-type cont))))))

(defun annotate-exit (exit)
  (let ((cont (exit-value exit)))
    (when cont
      (annotate-continuation cont :unknown))))

(defun annotate-block (block)
  (do-nodes (node cont block)
    (etypecase node
      (bind)
      (ref)
      (cset (annotate-set node))
      (basic-combination (annotate-basic-combination node))
      (cif (annotate-if node))
      (creturn (annotate-return node))
      (entry)
      (exit (annotate-exit node))))
  (undefined-value))

(defun annotate-ir1 (component)
  (do-blocks (block component)
    (when (block-interesting block)
      (annotate-block block)))
  (undefined-value))



;;;; Stack analysis.

662
663
(defvar *byte-continuation-counter*)

664
665
666
667
668
669
670
671
672
673
;;; COMPUTE-PRODUCES-AND-CONSUMES  --  Internal
;;;
;;;    Scan the nodes in Block and compute the information that we will need to
;;; do flow analysis and our stack simulation walk.  We simulate the stack
;;; within the block, reducing it to ordered lists representing the values we
;;; remove from the top of the stack and place on the stack (not considering
;;; values that are produced and consumed within the block.)  A NLX entry point
;;; is considered to push a :NLX-ENTRY marker (can be though of as the run-time
;;; catch frame.)
;;;
wlott's avatar
wlott committed
674
675
676
677
678
(defun compute-produces-and-consumes (block)
  (let ((stack nil)
	(consumes nil)
	(total-consumes (make-sset))
	(nlx-entries nil)
679
	(nlx-entry-p nil))
wlott's avatar
wlott committed
680
681
682
683
684
685
686
    (labels ((interesting (cont)
	       (and cont
		    (let ((info (continuation-info cont)))
		      (and info
			   (not (member (byte-continuation-info-results info)
					'(0 :eq-test)))))))
	     (consume (cont)
687
	       (cond ((not (or (eq cont :nlx-entry) (interesting cont))))
wlott's avatar
wlott committed
688
689
690
691
		     (stack
		      (assert (eq (car stack) cont))
		      (pop stack))
		     (t
692
693
694
		      (adjoin-cont cont total-consumes)
		      (push cont consumes))))
	     (adjoin-cont (cont sset)
695
696
697
698
699
700
	       (unless (eq cont :nlx-entry)
		 (let ((info (continuation-info cont)))
		   (unless (byte-continuation-info-number info)
		     (setf (byte-continuation-info-number info)
			   (incf *byte-continuation-counter*)))
		   (sset-adjoin info sset)))))
wlott's avatar
wlott committed
701
702
703
704
705
706
707
708
709
710
711
      (do-nodes (node cont block)
	(etypecase node
	  (bind)
	  (ref)
	  (cset
	   (consume (set-value node)))
	  (basic-combination
	   (dolist (arg (reverse (basic-combination-args node)))
	     (when arg
	       (consume arg)))
	   (consume (basic-combination-fun node))
712
713
714
715
716
717
718
719
720
721
	   (case (continuation-function-name (basic-combination-fun node))
	     (%nlx-entry
	      (let ((nlx-info (continuation-value
			       (first (basic-combination-args node)))))
		(ecase (cleanup-kind (nlx-info-cleanup nlx-info))
		  ((:catch :unwind-protect)
		   (consume :nlx-entry))
		  ;;
		  ;; If for a lexical exit, we will see a breakup later, so
		  ;; don't consume :NLX-ENTRY now.
722
		  ((:tagbody :dynamic-extent))
723
724
725
726
727
		  (:block
		   (let ((cont (nlx-info-continuation nlx-info)))
		     (when (interesting cont)
		       (push cont stack))))))
	      (setf nlx-entry-p t))
728
729
730
731
732
733
734
	     (%lexical-exit-breakup
	      (unless (byte-nlx-info-duplicate
		       (nlx-info-info
			(continuation-value
			 (first (basic-combination-args node)))))
		(consume :nlx-entry)))
	     ((%catch-breakup %unwind-protect-breakup)
735
	      (consume :nlx-entry))))
wlott's avatar
wlott committed
736
737
738
739
740
	  (cif
	   (consume (if-test node)))
	  (creturn
	   (consume (return-result node)))
	  (entry
741
742
	   (let* ((cup (entry-cleanup node))
		  (nlx-info (cleanup-nlx-info cup)))
wlott's avatar
wlott committed
743
	     (when nlx-info
744
	       (push :nlx-entry stack)
745
	       (push (list nlx-info stack (reverse consumes))
746
		     nlx-entries))))
wlott's avatar
wlott committed
747
748
749
750
	  (exit
	   (when (exit-value node)
	     (consume (exit-value node)))))
	(when (and (not (exit-p node)) (interesting cont))
751
752
	  (push cont stack)))
    
wlott's avatar
wlott committed
753
      (setf (block-info block)
754
755
756
757
758
759
760
761
762
763
764
765
	    (make-byte-block-info
	     block
	     :produces stack
	     :produces-sset (let ((res (make-sset)))
			      (dolist (product stack)
				(adjoin-cont product res))
			      res)
	     :consumes (reverse consumes)
	     :total-consumes total-consumes
	     :nlx-entries nlx-entries
	     :nlx-entry-p nlx-entry-p))))

wlott's avatar
wlott committed
766
767
768
769
770
771
772
773
774
775
  (undefined-value))

(defun walk-successors (block stack)
  (let ((tail (component-tail (block-component block))))
    (dolist (succ (block-succ block))
      (unless (or (eq succ tail)
		  (not (block-interesting succ))
		  (byte-block-info-nlx-entry-p (block-info succ)))
	(walk-block succ block stack)))))

776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
;;; CONSUME-STUFF  --  Internal
;;;
;;;    Take a stack and a consumes list, and remove the appropriate stuff.
;;; When we consume a :NLX-ENTRY, we just remove the top marker, and leave any
;;; values on top intact.  This represents the desired effect of
;;; %CATCH-BREAKUP, etc., which don't affect any values on the stack.
;;;
(defun consume-stuff (stack stuff)
  (let ((new-stack stack))
    (dolist (cont stuff)
      (cond ((eq cont :nlx-entry)
	     (assert (find :nlx-entry new-stack))
	     (setq new-stack (remove :nlx-entry new-stack :count 1)))
	    (t
	     (assert (eq (car new-stack) cont))
	     (pop new-stack))))
    new-stack))

;;; WALK-NLX-ENTRY  --  Internal
;;;
796
797
798
799
800
;;; NLX-infos is the list of nlx-info structures for this ENTRY note.  Consume
;;; and Produce are the values from outside this block that were consumed and
;;; produced by this block before the ENTRY node.  Stack is the globally
;;; simulated stack at the start of this block.
;;;
wlott's avatar
wlott committed
801
(defun walk-nlx-entry (nlx-infos stack produce consume)
802
803
804
  (let ((stack (consume-stuff stack consume)))
    (dolist (nlx-info nlx-infos)
      (walk-block (nlx-info-target nlx-info) nil (append produce stack))))
805
  (undefined-value))
wlott's avatar
wlott committed
806

807
808
809
810
811
812
813

;;; WALK-BLOCK  --  Internal
;;;
;;;    Simulate the stack across block boundaries, discarding any values that
;;; are dead.  A :NLX-ENTRY marker prevents values live at a NLX entry point
;;; from being discarded prematurely.
;;;
wlott's avatar
wlott committed
814
815
816
817
818
819
820
821
822
823
824
825
826
(defun walk-block (block pred stack)
  ;; Pop everything off of stack that isn't live.
  (let* ((info (block-info block))
	 (live (byte-block-info-total-consumes info)))
    (collect ((pops))
      (let ((fixed 0))
	(flet ((flush-fixed ()
		 (unless (zerop fixed)
		   (pops `(%byte-pop-stack ,fixed))
		   (setf fixed 0))))
	  (loop
	    (unless stack
	      (return))
827
828
829
	    (let ((cont (car stack)))
	      (when (or (eq cont :nlx-entry)
			(sset-member (continuation-info cont) live))
wlott's avatar
wlott committed
830
831
		(return))
	      (pop stack)
832
833
834
	      (let ((results
		     (byte-continuation-info-results
		      (continuation-info cont))))
wlott's avatar
wlott committed
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
		(case results
		  (:unknown
		   (flush-fixed)
		   (pops `(%byte-pop-stack 0)))
		  (:fdefinition
		   (incf fixed))
		  (t
		   (incf fixed results))))))
	  (flush-fixed)))
      (when (pops)
	(assert pred)
	(let ((cleanup-block
	       (insert-cleanup-code pred block
				    (continuation-next (block-start block))
				    `(progn ,@(pops)))))
	  (annotate-block cleanup-block))))
851

wlott's avatar
wlott committed
852
853
854
855
856
857
858
    (cond ((eq (byte-block-info-start-stack info) :unknown)
	   ;; Record what the stack looked like at the start of this block.
	   (setf (byte-block-info-start-stack info) stack)
	   ;; Process any nlx entries that build off of our stack.
	   (dolist (stuff (byte-block-info-nlx-entries info))
	     (walk-nlx-entry (first stuff) stack (second stuff) (third stuff)))
	   ;; Remove whatever we consume.
859
	   (setq stack (consume-stuff stack (byte-block-info-consumes info)))
wlott's avatar
wlott committed
860
861
862
863
864
865
866
867
	   ;; Add whatever we produce.
	   (setf stack (append (byte-block-info-produces info) stack))
	   (setf (byte-block-info-end-stack info) stack)
	   ;; Pass that on to all our successors.
	   (walk-successors block stack))
	  (t
	   ;; We have already processed the successors of this block.  Just
	   ;; make sure we thing the stack is the same now as before.
gerd's avatar
gerd committed
868
869
870
871
	   ;;
	   ;; Comment out the assertion because it doesn't hold if there
	   ;; is an nlx-entry above.  I think.  --gerd 2003-10-09
	   #+nil 
wlott's avatar
wlott committed
872
873
874
	   (assert (equal (byte-block-info-start-stack info) stack)))))
  (undefined-value))

875
876
877
878
879
880
881
882
883
884
;;; BYTE-STACK-ANALYZE  --  Internal
;;;
;;;    Do lifetime flow analysis on values pushed on the stack, then call do
;;; the stack simulation walk to discard dead values.  In addition to
;;; considering the obvious inputs from a block's successors, we must also
;;; consider %NLX-ENTRY targets to be successors in order to ensure that any
;;; values only used in the NLX entry stay alive until we reach the mess-up
;;; node.  After then, we can keep the values from being discarded by placing a
;;; marker on the simulated stack.
;;;
wlott's avatar
wlott committed
885
886
(defun byte-stack-analyze (component)
  (let ((head nil))
887
888
889
890
891
892
    (let ((*byte-continuation-counter* 0))
      (do-blocks (block component)
	(when (block-interesting block)
	  (compute-produces-and-consumes block)
	  (push block head)
	  (setf (byte-block-info-already-queued (block-info block)) t))))
wlott's avatar
wlott committed
893
894
895
896
897
898
899
900
901
902
903
904
    (let ((tail (last head)))
      (labels ((maybe-enqueue (block)
		 (when (block-interesting block)
		   (let ((info (block-info block)))
		     (unless (byte-block-info-already-queued info)
		       (setf (byte-block-info-already-queued info) t)
		       (let ((new (list block)))
			 (if head
			     (setf (cdr tail) new)
			     (setf head new))
			 (setf tail new))))))
	       (maybe-enqueue-predecessors (block)
905
906
907
908
909
910
911
912
913
		 (when (byte-block-info-nlx-entry-p (block-info block))
		   (maybe-enqueue
		    (node-block
		     (cleanup-mess-up
		      (nlx-info-cleanup
		       (find block
			     (environment-nlx-info (block-environment block))
			     :key #'nlx-info-target))))))

wlott's avatar
wlott committed
914
915
916
917
918
919
920
921
922
		 (dolist (pred (block-pred block))
		   (unless (eq pred (component-head (block-component block)))
		     (maybe-enqueue pred)))))
	(loop
	  (unless head
	    (return))
	  (let* ((block (pop head))
		 (info (block-info block))
		 (total-consumes (byte-block-info-total-consumes info))
923
		 (produces-sset (byte-block-info-produces-sset info))
wlott's avatar
wlott committed
924
925
926
927
928
929
930
931
		 (did-anything nil))
	    (setf (byte-block-info-already-queued info) nil)
	    (dolist (succ (block-succ block))
	      (unless (eq succ (component-tail component))
		(let ((succ-info (block-info succ)))
		  (when (sset-union-of-difference
			 total-consumes
			 (byte-block-info-total-consumes succ-info)
932
			 produces-sset)
wlott's avatar
wlott committed
933
		    (setf did-anything t)))))
934
935
936
937
938
939
940
941
942
	    (dolist (nlx-list (byte-block-info-nlx-entries info))
	      (dolist (nlx-info (first nlx-list))
		(when (sset-union-of-difference
		       total-consumes
		       (byte-block-info-total-consumes
			(block-info
			 (nlx-info-target nlx-info)))
		       produces-sset)
		  (setf did-anything t))))
wlott's avatar
wlott committed
943
944
	    (when did-anything
	      (maybe-enqueue-predecessors block)))))))
945

wlott's avatar
wlott committed
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
  (walk-successors (component-head component) nil)
  (undefined-value))



;;;; Actually generate the byte-code

(defvar *byte-component-info*)

(defconstant byte-push-local		#b00000000)
(defconstant byte-push-arg		#b00010000)
(defconstant byte-push-constant		#b00100000)
(defconstant byte-push-system-constant	#b00110000)
(defconstant byte-push-int		#b01000000)
(defconstant byte-push-neg-int		#b01010000)
(defconstant byte-pop-local		#b01100000)
(defconstant byte-pop-n			#b01110000)
(defconstant byte-call			#b10000000)
(defconstant byte-tail-call		#b10010000)
(defconstant byte-multiple-call		#b10100000)
(defconstant byte-named			#b00001000)
(defconstant byte-local-call		#b10110000)
(defconstant byte-local-tail-call	#b10111000)
(defconstant byte-local-multiple-call	#b11000000)
(defconstant byte-return		#b11001000)
(defconstant byte-branch-always		#b11010000)
(defconstant byte-branch-if-true	#b11010010)
(defconstant byte-branch-if-false	#b11010100)
(defconstant byte-branch-if-eq		#b11010110)
(defconstant byte-xop			#b11011000)
(defconstant byte-inline-function	#b11100000)


(defun output-push-int (segment int)
  (declare (type new-assem:segment segment)
ram's avatar
ram committed
981
	   (type (integer #.(- (ash 1 24)) #.(1- (ash 1 24)))))
wlott's avatar
wlott committed
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
  (if (minusp int)
      (output-byte-with-operand segment byte-push-neg-int (- (1+ int)))
      (output-byte-with-operand segment byte-push-int int)))

(defun output-push-constant-leaf (segment constant)
  (declare (type new-assem:segment segment)
	   (type constant constant))
  (let ((info (constant-info constant)))
    (if info
	(output-byte-with-operand segment
				  (ecase (car info)
				    (:system-constant
				     byte-push-system-constant)
				    (:local-constant
				     byte-push-constant))
				  (cdr info))
	(let ((const (constant-value constant)))
ram's avatar
ram committed
999
	  (if (and (integerp const) (< (- (ash 1 24)) const (ash 1 24)))
wlott's avatar
wlott committed
1000
1001
1002
	      ;; It can be represented as an immediate.
	      (output-push-int segment const)
	      ;; We need to store it in the constants pool.
1003
1004
1005
1006
	      (let* ((posn
		      (unless (and (consp const)
				   (eq (car const) '%fdefinition-marker%))
			(gethash const *system-constant-codes*)))
wlott's avatar
wlott committed
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
		     (new-info (if posn
				   (cons :system-constant posn)
				   (cons :local-constant
					 (vector-push-extend
					  constant
					  (byte-component-info-constants
					   *byte-component-info*))))))
		(setf (constant-info constant) new-info)
		(output-push-constant-leaf segment constant)))))))

(defun output-push-constant (segment value)
  (if (and (integerp value)
ram's avatar
ram committed
1019
	   (< (- (ash 1 24)) value (ash 1 24)))
wlott's avatar
wlott committed
1020
1021
1022
      (output-push-int segment value)
      (output-push-constant-leaf segment (find-constant value))))

ram's avatar
ram committed
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042

;;; BYTE-LOAD-TIME-CONSTANT-INDEX  --  Internal
;;;
;;;    Return the offset of a load-time constant in the constant pool, adding
;;; it if absent.
;;;
(defun byte-load-time-constant-index (kind datum)
  (let ((constants (byte-component-info-constants *byte-component-info*)))
    (or (position-if #'(lambda (x)
			 (and (consp x)
			      (eq (car x) kind)
			      (typecase datum
				(cons (equal (cdr x) datum))
				(ctype (type= (cdr x) datum))
				(t
				 (eq (cdr x) datum)))))
		     constants)
	(vector-push-extend (cons kind datum) constants))))


wlott's avatar
wlott committed
1043
(defun output-push-load-time-constant (segment kind datum)
ram's avatar
ram committed
1044
1045
  (output-byte-with-operand segment byte-push-constant
			    (byte-load-time-constant-index kind datum))
wlott's avatar
wlott committed
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
  (undefined-value))

(defun output-do-inline-function (segment function)
  ;; Note: we don't annotate this as a call site, because it is used for
  ;; internal stuff.  Random functions that get inlined have code locations
  ;; added byte generate-byte-code-for-full-call below.
  (output-byte segment
	       (logior byte-inline-function
		       (inline-function-number-or-lose function))))

(defun output-do-xop (segment xop)
  (let ((index (xop-index-or-lose xop)))
    (cond ((< index 7)
	   (output-byte segment (logior byte-xop index)))
	  (t
	   (output-byte segment (logior byte-xop 7))
	   (output-byte segment index)))))

1064
1065
(defun closure-position (var env)
  (or (position var (environment-closure env))
1066
      (error (intl:gettext "Can't find ~S") var)))
1067

wlott's avatar
wlott committed
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
(defun output-ref-lambda-var (segment var env
				     &optional (indirect-value-cells t))
  (declare (type new-assem:segment segment)
	   (type lambda-var var)
	   (type environment env))
  (if (eq (lambda-environment (lambda-var-home var)) env)
      (let ((info (leaf-info var)))
	(output-byte-with-operand segment
				  (if (byte-lambda-var-info-argp info)
				      byte-push-arg
				      byte-push-local)
				  (byte-lambda-var-info-offset info)))
      (output-byte-with-operand segment
				byte-push-arg
1082
				(closure-position var env)))
wlott's avatar
wlott committed
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
  (when (and indirect-value-cells (lambda-var-indirect var))
    (output-do-inline-function segment 'value-cell-ref)))

(defun output-ref-nlx-info (segment info env)
  (if (eq (node-environment (cleanup-mess-up (nlx-info-cleanup info))) env)
      (output-byte-with-operand segment
				byte-push-local
				(byte-nlx-info-stack-slot
				 (nlx-info-info info)))
      (output-byte-with-operand segment
				byte-push-arg
1094
				(closure-position info env))))
wlott's avatar
wlott committed
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106

(defun output-set-lambda-var (segment var env &optional make-value-cells)
  (declare (type new-assem:segment segment)
	   (type lambda-var var)
	   (type environment env))
  (let ((indirect (lambda-var-indirect var)))
    (cond ((not (eq (lambda-environment (lambda-var-home var)) env))
	   ;; This is not this guys home environment.  So we need to get it
	   ;; the value cell out of the closure, and fill it in.
	   (assert indirect)
	   (assert (not make-value-cells))
	   (output-byte-with-operand segment byte-push-arg
1107
				     (closure-position var env))
wlott's avatar
wlott committed
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
	   (output-do-inline-function segment 'value-cell-setf))
	  (t
	   (let* ((pushp (and indirect (not make-value-cells)))
		  (byte-code (if pushp byte-push-local byte-pop-local))
		  (info (leaf-info var)))
	     (assert (not (byte-lambda-var-info-argp info)))
	     (when (and indirect make-value-cells)
	       ;; Replace the stack top with a value cell holding the
	       ;; stack top.
	       (output-do-inline-function segment 'make-value-cell))
	     (output-byte-with-operand segment byte-code
				       (byte-lambda-var-info-offset info))
	     (when pushp
	       (output-do-inline-function segment 'value-cell-setf)))))))

;;; CANONICALIZE-VALUES -- internal.
;;;
;;; Output whatever noise is necessary to canonicalize the values on the
;;; top of the stack.  Desired is the number we want, and supplied is the
;;; number we have.  Either push NIL or pop-n to make them balanced.
;;; Note: either desired or supplied can be :unknown, in which case it means
;;; use the ``unknown-values'' convention (which is the stack values followed
;;; by the number of values).
;;; 
(defun canonicalize-values (segment desired supplied)
  (declare (type new-assem:segment segment)
	   (type (or (member :unknown) index) desired supplied))
  (cond ((eq desired :unknown)
	 (unless (eq supplied :unknown)
	   (output-byte-with-operand segment byte-push-int supplied)))
	((eq supplied :unknown)
	 (unless (eq desired :unknown)
	   (output-push-int segment desired)
	   (output-do-xop segment 'default-unknown-values)))
	((< supplied desired)
	 (dotimes (i (- desired supplied))
	   (output-push-constant segment nil)))
	((> supplied desired)
	 (output-byte-with-operand segment byte-pop-n (- supplied desired))))
  (undefined-value))

ram's avatar
ram committed
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179

(defparameter *byte-type-weakenings*
  (mapcar #'specifier-type
	  '(fixnum single-float double-float simple-vector simple-bit-vector
		   bit-vector)))

;;; BYTE-GENERATE-TYPE-CHECK  --  Internal
;;;
;;;    Emit byte code to check that the value on TOS is of the specified Type.
;;; Node is used for policy information.  We weaken or entirely omit the type
;;; check if speed is more important than safety.
;;;
(defun byte-generate-type-check (segment type node)
  (declare (type ctype type) (type node node))
  (unless (or (policy node (zerop safety))
	      (csubtypep *universal-type* type))
    (let ((type (if (policy node (> speed safety))
		    (dolist (super *byte-type-weakenings* type)
		      (when (csubtypep type super) (return super)))
		    type)))
      (output-do-xop segment 'type-check)
      (output-extended-operand
       segment
       (byte-load-time-constant-index :type-predicate type)))))


;;; CHECKED-CANONICALIZE-VALUES  --  Internal
;;;
;;;    This function is used when we are generating code which delivers values
;;; to a continuation.  If this continuation needs a type check, and has a
;;; single value, then we do a type check.  We also CANONICALIZE-VALUES for the
1180
1181
1182
1183
1184
;;; continuation's desired number of values (w/o the placeholders.)
;;;
;;; Somewhat unrelatedly, we also push placeholders for deleted arguments to
;;; local calls.  Although we check first, the actual PUSH-N-UNDER is done
;;; afterward, since then the single value we want is stack top.
ram's avatar
ram committed
1185
1186
1187
1188
;;;
(defun checked-canonicalize-values (segment cont supplied)
  (let ((info (continuation-info cont)))
    (if info
1189
1190
1191
1192
1193
1194
	(let ((desired (byte-continuation-info-results info))
	      (placeholders (byte-continuation-info-placeholders info)))
	  (unless (zerop placeholders)
	    (assert (eql desired (1+ placeholders)))
	    (setq desired 1))

ram's avatar
ram committed
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
	  (flet ((do-check ()
		   (byte-generate-type-check
		    segment
		    (single-value-type (continuation-asserted-type cont))
		    (continuation-dest cont))))
	    (cond
	     ((member (continuation-type-check cont) '(nil :deleted))
	      (canonicalize-values segment desired supplied))
	     ((eql supplied 1)
	      (do-check)
	      (canonicalize-values segment desired supplied))
	     ((eql desired 1)
	      (canonicalize-values segment desired supplied)
	      (do-check))
	     (t
1210
1211
1212
1213
1214
1215
	      (canonicalize-values segment desired supplied))))

	  (unless (zerop placeholders)
	    (output-do-xop segment 'push-n-under)
	    (output-extended-operand segment placeholders)))

ram's avatar
ram committed
1216
1217
1218
	(canonicalize-values segment 0 supplied))))


1219
1220
1221
1222
1223
;;; GENERATE-BYTE-CODE-FOR-BIND  --  Internal
;;;
;;;    Emit prologue for non-let functions.  Assigned arguments must be copied
;;; into locals, and argument type checking may need to be done.
;;;
wlott's avatar
wlott committed
1224
1225
1226
1227
1228
1229
1230
1231
(defun generate-byte-code-for-bind (segment bind cont)
  (declare (type new-assem:segment segment) (type bind bind)
	   (ignore cont))
  (let ((lambda (bind-lambda bind))
	(env (node-environment bind)))
    (ecase (lambda-kind lambda)
      ((nil :top-level :escape :cleanup :optional)
       (let* ((info (lambda-info lambda))
1232
	      (type-check (policy (lambda-bind lambda) (not (zerop safety))))
wlott's avatar
wlott committed
1233
1234
1235
1236
1237
1238
1239
1240
	      (frame-size (byte-lambda-info-stack-size info)))
	 (cond ((< frame-size (* 255 2))
		(output-byte segment (ceiling frame-size 2)))
	       (t
		(output-byte segment 255)
		(output-byte segment (ldb (byte 8 16) frame-size))
		(output-byte segment (ldb (byte 8 8) frame-size))
		(output-byte segment (ldb (byte 8 0) frame-size))))
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269

	 (do ((argnum (1- (+ (length (lambda-vars lambda))
			     (length (environment-closure
				      (lambda-environment lambda)))))
		      (1- argnum))
	      (vars (lambda-vars lambda) (cdr vars))
	      (pops 0))
	     ((null vars)
	      (unless (zerop pops)
		(output-byte-with-operand segment byte-pop-n pops)))
	   (declare (fixnum argnum pops)) 
	   (let* ((var (car vars))
		  (info (lambda-var-info var))
		  (type (leaf-type var)))
	     (cond ((not info))
		   ((byte-lambda-var-info-argp info)
		    (when (and type-check
			       (not (csubtypep *universal-type* type)))
		      (output-byte-with-operand segment byte-push-arg argnum)
		      (byte-generate-type-check segment type bind)
		      (incf pops)))
		   (t
		    (output-byte-with-operand segment byte-push-arg argnum)
		    (when type-check
		      (byte-generate-type-check segment type bind))
		    (output-set-lambda-var segment var env t)))))))

      ;; Everything has been taken care of in the combination node.
      ((:let :mv-let :assignment))))
wlott's avatar
wlott committed
1270
1271
  (undefined-value))

ram's avatar
ram committed
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295

;;; This hashtable translates from n-ary function names to the two-arg specific
;;; versions which we call to avoid rest-arg consing.
;;;
(defvar *two-arg-functions* (make-hash-table :test #'eq))

(dolist (fun '((KERNEL:TWO-ARG-IOR  LOGIOR)
	       (KERNEL:TWO-ARG-*  *)
	       (KERNEL:TWO-ARG-+  +)
	       (KERNEL:TWO-ARG-/  /)
	       (KERNEL:TWO-ARG--  -)
	       (KERNEL:TWO-ARG->  >)
	       (KERNEL:TWO-ARG-<  <)
	       (KERNEL:TWO-ARG-=  =)
	       (KERNEL:TWO-ARG-LCM  LCM)
	       (KERNEL:TWO-ARG-AND  LOGAND)
	       (KERNEL:TWO-ARG-GCD  GCD)
	       (KERNEL:TWO-ARG-XOR  LOGXOR)

	       (two-arg-char= char=)
	       (two-arg-char< char<)
	       (two-arg-char> char>)
	       (two-arg-char-equal char-equal)
	       (two-arg-char-lessp char-lessp)
1296
1297
1298
1299
	       (two-arg-char-greaterp char-greaterp)
	       (two-arg-string= string=)
	       (two-arg-string< string<)
	       (two-arg-string> string>)))
ram's avatar
ram committed
1300
1301
1302
1303

  (setf (gethash (second fun) *two-arg-functions*) (first fun)))


1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
;;; If a system constant, push that, otherwise use a load-time constant.
;;;
(defun output-push-fdefinition (segment name)
  (let ((offset (gethash `(%fdefinition-marker% . ,name)
			 *system-constant-codes*)))
    (if offset
	(output-byte-with-operand segment byte-push-system-constant
				  offset)
	(output-push-load-time-constant segment :fdefinition name))))

wlott's avatar
wlott committed
1314
1315
1316
(defun generate-byte-code-for-ref (segment ref cont)
  (declare (type new-assem:segment segment) (type ref ref)
	   (type continuation cont))
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
  (let ((info (continuation-info cont)))
    ;; If there is no info, then nobody wants the result.
    (when info
      (let ((values (byte-continuation-info-results info))
	    (leaf (ref-leaf ref)))
	(cond
	 ((eq values :fdefinition)
	  (assert (and (global-var-p leaf)
		       (eq (global-var-kind leaf)
			   :global-function)))
ram's avatar
ram committed
1327
	  (let* ((name (global-var-name leaf))
1328
1329
1330
1331
1332
1333
		 (dest (continuation-dest cont))
		 (two-arg
		  (when (and (not (mv-combination-p dest))
			     (= 2 (length (basic-combination-args dest))))
		    (gethash name *two-arg-functions*))))
	    (output-push-fdefinition segment (or two-arg name))))
1334
1335
1336
1337
1338
1339
	 ((eql values 0)
	  ;; Real easy!
	  nil)
	 (t
	  (etypecase leaf
	    (constant
1340
1341
1342
1343
1344
	     (cond ((legal-immediate-constant-p leaf)
		    (output-push-constant-leaf segment leaf))
		   (t
		    (output-push-constant segment (leaf-name leaf))
		    (output-do-inline-function segment 'symbol-value))))
1345
1346
	    (clambda
	     (let* ((refered-env (lambda-environment leaf))
emarsden's avatar
   
emarsden committed
1347
		    (closure (and refered-env (environment-closure refered-env))))
1348
1349
1350
	       (if (null closure)
		   (output-push-load-time-constant segment :entry leaf)
		   (let ((my-env (node-environment ref)))
1351
		     (output-push-load-time-constant segment :entry leaf)
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
		     (dolist (thing closure)
		       (etypecase thing
			 (lambda-var
			  (output-ref-lambda-var segment thing my-env nil))
			 (nlx-info
			  (output-ref-nlx-info segment thing my-env))))
		     (output-push-int segment (length closure))
		     (output-do-xop segment 'make-closure)))))
	    (functional
	     (output-push-load-time-constant segment :entry leaf))
	    (lambda-var
	     (output-ref-lambda-var segment leaf (node-environment ref)))
	    (global-var
	     (ecase (global-var-kind leaf)
	       ((:special :global :constant)
		(output-push-constant segment (global-var-name leaf))
		(output-do-inline-function segment 'symbol-value))
	       (:global-function
1370
		(output-push-fdefinition segment (global-var-name leaf))
1371
		(output-do-xop segment 'fdefn-function-or-lose)))))
ram's avatar
ram committed
1372
	  (checked-canonicalize-values segment cont 1))))))
wlott's avatar
wlott committed
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
  (undefined-value))

(defun generate-byte-code-for-set (segment set cont)
  (declare (type new-assem:segment segment) (type cset set)
	   (type continuation cont))
  (let* ((leaf (set-var set))
	 (info (continuation-info cont))
	 (values (if info
		     (byte-continuation-info-results info)
		     0)))
    (etypecase leaf
      (global-var
1385
1386
1387
       (unless (eql values 0)
	 ;; Someone wants the value, so copy it.
	 (output-do-xop segment 'dup))
wlott's avatar
wlott committed
1388
1389
1390
1391
1392
       (ecase (global-var-kind leaf)
	 ((:special :global)
	  (output-push-constant segment (global-var-name leaf))
	  (output-do-inline-function segment 'setf-symbol-value))))
      (lambda-var
1393
1394
1395
1396
1397
1398
1399
1400
       (cond ((leaf-refs leaf)
	      (unless (eql values 0)
		;; Someone wants the value, so copy it.
		(output-do-xop segment 'dup))
	      (output-set-lambda-var segment leaf (node-environment set)))
	     ;; If no-one wants the value then pop it else leave it for them.
	     ((eql values 0)
	      (output-byte-with-operand segment byte-pop-n 1)))))
wlott's avatar
wlott committed
1401
    (unless (eql values 0)
ram's avatar
ram committed
1402
      (checked-canonicalize-values segment cont 1)))
wlott's avatar
wlott committed
1403
1404
1405
1406
  (undefined-value))

(defun generate-byte-code-for-local-call (segment call cont num-args)
  (let* ((lambda (combination-lambda call))
ram's avatar
ram committed
1407
	 (vars (lambda-vars lambda))
wlott's avatar
wlott committed
1408
1409
	 (env (lambda-environment lambda)))
    (ecase (functional-kind lambda)
ram's avatar
ram committed
1410
1411
1412
1413
1414
1415
1416
1417
      ((:let :assignment)
       (dolist (var (reverse vars))
	 (when (lambda-var-refs var)
	   (output-set-lambda-var segment var env t))))
      (:mv-let
       (let ((do-check (member (continuation-type-check
				(first (basic-combination-args call)))
			       '(t :error))))
wlott's avatar
wlott committed
1418
	 (dolist (var (reverse vars))
ram's avatar
ram committed
1419
1420
1421
	   (when do-check
	     (byte-generate-type-check segment (leaf-type var) call))
	   (output-set-lambda-var segment var env t))))
wlott's avatar
wlott committed
1422
1423
1424
      ((nil :optional :cleanup)
       ;; We got us a local call.  
       (assert (not (eq num-args :unknown)))
1425
1426
1427
1428
1429
1430
1431
       ;;
       ;; Push any trailing placeholder args...
       (dolist (x (reverse (basic-combination-args call)))
	 (when x (return))
	 (output-push-int segment 0))
       ;;
       ;; Then push closure vars.
wlott's avatar
wlott committed
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
       (let ((closure (environment-closure env)))
	 (when closure
	   (let ((my-env (node-environment call)))
	     (dolist (thing (reverse closure))
	       (etypecase thing
		 (lambda-var
		  (output-ref-lambda-var segment thing my-env nil))
		 (nlx-info
		  (output-ref-nlx-info segment thing my-env)))))
	   (incf num-args (length closure))))
       (let ((results
	      (let ((info (continuation-info cont)))
		(if info
		    (byte-continuation-info-results info)
		    0))))
	 ;; Emit the op for whatever flavor of call we are using.
	 (let ((operand
		(cond ((> num-args 6)
		       (output-push-int segment num-args)
		       7)
		      (t
		       num-args))))
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
	   (multiple-value-bind
	       (opcode ret-vals)
	       (cond ((node-tail-p call)
		      (values byte-local-tail-call 0))
		     ((member results '(0 1))
		      (values byte-local-call 1))
		     (t
		      (values byte-local-multiple-call :unknown)))
	     ;; ### :call-site
	     (output-byte segment (logior opcode operand))
	     ;; Emit a reference to the label.
	     (output-reference segment
			       (byte-lambda-info-label (lambda-info lambda)))
	     ;; ### :unknown-return
	     ;; Fix up the results.
	     (unless (node-tail-p call)
	       (checked-canonicalize-values segment cont ret-vals))))))))
wlott's avatar
wlott committed
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
  (undefined-value))

(defun generate-byte-code-for-full-call (segment call cont num-args)
  (let ((info (basic-combination-info call))
	(results
	 (let ((info (continuation-info cont)))
	   (if info
	       (byte-continuation-info-results info)
	       0))))
    (cond
     (info
      ;; It's an inline function.
      (assert (not (node-tail-p call)))
      (let* ((type (inline-function-info-type info))
	     (desired-args (function-type-nargs type))
	     (supplied-results
	      (nth-value 1
1488
1489
1490
1491
1492
1493
1494
			 (values-types (function-type-returns type))))
	     (leaf (ref-leaf (continuation-use (basic-combination-fun call)))))
	(cond ((slot-accessor-p leaf)
	       (assert (= num-args (1- desired-args)))
	       (output-push-int segment (dsd-index (slot-accessor-slot leaf))))
	      (t
	       (canonicalize-values segment desired-args num-args)))
wlott's avatar
wlott committed
1495
1496
	;; ### :call-site
	(output-byte segment (logior byte-inline-function
ram's avatar
ram committed
1497
				     (inline-function-info-number info)))
wlott's avatar
wlott committed
1498
	;; ### :known-return
ram's avatar
ram committed
1499
	(checked-canonicalize-values segment cont supplied-results)))
wlott's avatar
wlott committed
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
     (t
      (let ((operand
	     (cond ((eq num-args :unknown)
		    7)
		   ((> num-args 6)
		    (output-push-int segment num-args)
		    7)
		   (t
		    num-args))))
	(when (eq (byte-continuation-info-results
		   (continuation-info
		    (basic-combination-fun call)))
		  :fdefinition)
	  (setf operand (logior operand byte-named)))
	;; ### :call-site
ram's avatar
ram committed
1515
1516
1517
1518
	(cond
	 ((node-tail-p call)
	  (output-byte segment (logior byte-tail-call operand)))
	 (t
1519
1520
1521
1522
1523
1524
1525
	  (multiple-value-bind
	      (opcode ret-vals)
	      (case results
		(:unknown (values byte-multiple-call :unknown))
		((0 1) (values byte-call 1))
		(t (values byte-multiple-call :unknown)))
	  (output-byte segment (logior opcode operand))
ram's avatar
ram committed
1526
	  ;; ### :unknown-return
1527
	  (checked-canonicalize-values segment cont ret-vals)))))))))
ram's avatar
ram committed
1528

wlott's avatar
wlott committed
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549

(defun generate-byte-code-for-known-call (segment call cont num-args)
  (block nil
    (catch 'give-up
      (funcall (function-info-byte-compile (basic-combination-kind call)) call
	       (let ((info (continuation-info cont)))
		 (if info
		     (byte-continuation-info-results info)
		     0))
	       num-args segment)
      (return))
    (assert (member (byte-continuation-info-results
		     (continuation-info
		      (basic-combination-fun call)))
		    '(1 :fdefinition)))
    (generate-byte-code-for-full-call segment call cont num-args))
  (undefined-value))

(defun generate-byte-code-for-generic-combination (segment call cont)
  (declare (type new-assem:segment segment) (type basic-combination call)
	   (type continuation cont))
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
  (labels ((examine (args num-fixed)
	     (cond
	      ((null args)
	       ;; None of the arugments supply :unknown values, so
	       ;; we know exactly how many there are.
	       num-fixed)
	      (t
	       (let* ((vals
		       (byte-continuation-info-results
			(continuation-info (car args)))))
		 (cond
		  ((eq vals :unknown)
		   (unless (null (cdr args))
		     ;; There are (length args) :unknown value blocks on
		     ;; the top of the stack.  We need to combine them.
		     (output-push-int segment (length args))
		     (output-do-xop segment 'merge-unknown-values))
		   (unless (zerop num-fixed)
		     ;; There are num-fixed fixed args above the unknown
		     ;; values block that want in on the action also.
		     ;; So add num-fixed to the count.
		     (output-push-int segment num-fixed)
		     (output-do-inline-function segment '+))
		   :unknown)
		  (t
		   (examine (cdr args) (+ num-fixed vals)))))))))
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
    (let* ((args (basic-combination-args call))
	   (kind (basic-combination-kind call))
	   (num-args (if (and (eq kind :local)
			      (combination-p call))
			 (length args)
			 (examine args 0))))
      (case kind
	(:local
	 (generate-byte-code-for-local-call segment call cont num-args))
	(:full
	 (generate-byte-code-for-full-call segment call cont num-args))
	(t
	 (generate-byte-code-for-known-call segment call cont num-args))))))
wlott's avatar
wlott committed
1589
1590
1591
1592
1593
1594

(defun generate-byte-code-for-basic-combination (segment call cont)
  (cond ((and (mv-combination-p call)
	      (eq (continuation-function-name (basic-combination-fun call))
		  '%throw))
	 ;; ### :internal-error
ram's avatar
ram committed
1595
	 (output-do-xop segment 'throw))
wlott's avatar
wlott committed
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
	(t
	 (generate-byte-code-for-generic-combination segment call cont))))

(defun generate-byte-code-for-if (segment if cont)
  (declare (type new-assem:segment segment) (type cif if)
	   (ignore cont))
  (let* ((next-info (byte-block-info-next (block-info (node-block if))))
	 (consequent-info (block-info (if-consequent if)))
	 (alternate-info (block-info (if-alternative if))))
    (cond ((eq (byte-continuation-info-results
		(continuation-info (if-test if)))
	       :eq-test)
	   (output-branch segment
			  byte-branch-if-eq
			  (byte-block-info-label consequent-info))
	   (unless (eq next-info alternate-info)
	     (output-branch segment
			    byte-branch-always
			    (byte-block-info-label alternate-info))))
	  ((eq next-info consequent-info)
	   (output-branch segment
			  byte-branch-if-false
			  (byte-block-info-label alternate-info)))
	  (t
	   (output-branch segment
			  byte-branch-if-true
			  (byte-block-info-label consequent-info))
	   (unless (eq next-info alternate-info)
	     (output-branch segment
			    byte-branch-always
			    (byte-block-info-label alternate-info)))))))

(defun generate-byte-code-for-return (segment return cont)
  (declare (type new-assem:segment segment) (type creturn return)
	   (ignore cont))
  (let* ((result (return-result return))
	 (info (continuation-info result))
	 (results (byte-continuation-info-results info)))
    (cond ((eq results :unknown)
	   (setf results 7))
	  ((> results 6)
	   (output-byte-with-operand segment byte-push-int results)
	   (setf results 7)))
    (output-byte segment (logior byte-return results)))
  (undefined-value))

(defun generate-byte-code-for-entry (segment entry cont)
  (declare (type new-assem:segment segment) (type entry entry)
	   (ignore cont))
  (dolist (exit (entry-exits entry))
    (let ((nlx-info (find-nlx-info entry (node-cont exit))))
      (when nlx-info
	(let ((kind (cleanup-kind (nlx-info-cleanup nlx-info))))
	  (when (member kind '(:block :tagbody))
	    ;; Generate a unique tag.
1651
1652
1653
1654
1655
	    (output-push-constant
	     segment
	     (format nil "Tag for ~A" (component-name *compile-component*)))
	    (output-push-constant segment nil)
	    (output-do-inline-function segment 'cons)
wlott's avatar
wlott committed
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
	    ;; Save it so people can close over it.
	    (output-do-xop segment 'dup)
	    (output-byte-with-operand segment
				      byte-pop-local
				      (byte-nlx-info-stack-slot
				       (nlx-info-info nlx-info)))
	    ;; Now do the actual XOP.
	    (ecase kind
	      (:block
	       (output-do-xop segment 'catch)
	       (output-reference segment
				 (byte-nlx-info-label
				  (nlx-info-info nlx-info))))
	      (:tagbody
	       (output-do-xop segment 'tagbody)))
	    (return))))))
  (undefined-value))

(defun generate-byte-code-for-exit (segment exit cont)
  (declare (ignore cont))
  (let ((nlx-info (find-nlx-info (exit-entry exit) (node-cont exit))))
    (output-byte-with-operand segment
			      byte-push-arg
1679
1680
			      (closure-position nlx-info
						(node-environment exit)))
wlott's avatar
wlott committed
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695