1 ;;;;------------------------------------------------------------------
3 ;;;; Copyright (C) 2001,2000, 2002-2005,
4 ;;;; Department of Computer Science, University of Tromso, Norway
6 ;;;; Description: A simple lisp compiler.
7 ;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
8 ;;;; Created at: Wed Oct 25 12:30:49 2000
9 ;;;; Distribution: See the accompanying file COPYING.
11 ;;;; $Id: compiler.lisp,v 1.193 2008/02/23 22:36:21 ffjeld Exp $
13 ;;;;------------------------------------------------------------------
17 (defvar *warn-function-change-p
* t
18 "Emit a warning whenever a named function's code-vector changes size.")
20 (defvar *compiler-verbose-p
* nil
)
22 (defvar *compiler-do-optimize
* t
23 "Apply the peephole optimizer to function code.")
25 (defvar *explain-peephole-optimizations
* nil
26 "Emit some cryptic information about which peephole optimization
27 heuristics that fire. Used for debugging the optimizer.")
29 (defvar *compiler-use-cmov-p
* nil
30 "Allow the compiler to emit CMOV instructions, making the code
31 incompatible with pre-pentium CPUs.")
33 (defvar *compiler-auto-stack-checks-p
* t
34 "Make every compiled function check upon entry that the
35 stack-pointer is within bounds. Costs 3 code-bytes and a few cycles.")
37 (defvar *compiler-allow-transients
* t
38 "Allow the compiler to keep function arguments solely in registers.
39 Hurst debugging, improves performance.")
41 (defvar *compiler-local-segment-prefix
* '(:fs-override
)
42 "Use these assembly-instruction prefixes when accessing the thread-local
45 (defvar *compiler-global-segment-prefix
* nil
46 "Use these assembly-instruction prefixes when accessing the global
49 (defparameter *compiler-physical-segment-prefix
* '(:gs-override
)
50 "Use this instruction prefix when accessing a physical memory location (i.e. typically some memory-mapped hardware device).")
52 (defparameter *compiler-nonlocal-lispval-read-segment-prefix
* '()
53 "Use this segment prefix when reading a lispval at (potentially)
54 non-local locations.")
56 (defparameter *compiler-nonlocal-lispval-write-segment-prefix
* '(:es-override
)
57 "Use this segment prefix when writing a lispval at (potentially)
58 non-local locations.")
60 (defparameter *compiler-use-cons-reader-segment-protocol-p
* nil
)
62 (defparameter *compiler-cons-read-segment-prefix
* '(:gs-override
)
63 "Use this segment prefix for CAR and CDR, when using cons-reader protocol.")
65 (defvar *compiler-allow-untagged-word-bits
* 0
66 "Allow (temporary) untagged values of this bit-size to exist, because
67 the system ensures one way or another that there can be no pointers below
70 (defvar *compiler-use-into-unbound-protocol
* t
71 "Use #x7fffffff as the <unbound-value> and thereby the INTO
72 instruction for checking whether a value is the unbound value.")
74 (defvar *compiler-compile-eval-whens
* t
75 "When encountering (eval-when (:compile-toplevel) <code>),
76 compile, using the host compiler, the code rather than just using eval.")
78 (defvar *compiler-compile-macro-expanders
* t
79 "For macros of any kind, compile the macro-expanders using the host compiler.")
81 (defvar *compiler-do-type-inference
* t
82 "Spend time and effort performing type inference and optimization.")
84 (defvar *compiler-produce-defensive-code
* t
85 "Try to make code be extra cautious.")
87 (defvar *compiler-relink-recursive-funcall
* t
88 "If true, also recursive function calls look up the function through the function name,
89 which enables tracing of recursive functions.")
91 (defvar *compiler-trust-user-type-declarations-p
* t
)
93 (defvar *compiling-function-name
* nil
)
94 (defvar muerte.cl
:*compile-file-pathname
* nil
)
96 (defvar *extended-code-expanders
*
97 (make-hash-table :test
#'eq
))
99 (defvar *extended-code-find-write-binding-and-type
*
100 (make-hash-table :test
#'eq
))
103 (defparameter +enter-stack-frame-code
+
108 (defun duplicatesp (list)
109 "Returns TRUE iff at least one object occurs more than once in LIST."
112 (or (member (car list
) (cdr list
))
113 (duplicatesp (cdr list
)))))
115 (defun compute-call-extra-prefix (pc size
)
116 (let* ((return-pointer-tag (ldb (byte 3 0)
119 ((or (= (tag :even-fixnum
) return-pointer-tag
)
120 (= (tag :odd-fixnum
) return-pointer-tag
))
123 ;;; ((= 3 return-pointer-tag)
124 ;;; ;; Insert two NOPs, 3 -> 5
126 ((= (tag :character
) return-pointer-tag
)
127 ;; Insert three NOPs, 2 -> 5
131 (defun make-compiled-primitive (form environment top-level-p docstring
)
132 "Primitive functions have no funobj, no stack-frame, and no implied
133 parameter/return value passing conventions."
134 (declare (ignore top-level-p docstring
))
135 (let* ((env (make-local-movitz-environment environment nil
))
136 (body-code (compiler-call #'compile-form
141 :result-mode
:ignore
))
142 ;; (ignmore (format t "~{~S~%~}" body-code))
143 (resolved-code (finalize-code body-code nil nil
)))
145 (multiple-value-bind (code-vector symtab
)
146 (let ((asm:*instruction-compute-extra-prefix-map
*
147 '((:call . compute-call-extra-prefix
))))
148 (asm:assemble-proglist
(translate-program resolved-code
:muerte.cl
:cl
)
149 :symtab
(list (cons :nil-value
(image-nil-word *image
*)))))
150 (values (make-movitz-vector (length code-vector
)
152 :initial-contents code-vector
)
155 (defun register-function-code-size (funobj)
156 (let* ((name (movitz-print (movitz-funobj-name funobj
)))
158 (new-size (length (movitz-vector-symbolic-data (movitz-funobj-code-vector funobj
)))))
160 (let ((old-size (gethash hash-name
(function-code-sizes *image
*))))
163 ((not *warn-function-change-p
*))
164 ((> new-size old-size
)
165 (warn "~S grew from ~D to ~D bytes." name old-size new-size
))
166 ((< new-size old-size
)
167 (warn "~S shrunk from ~D to ~D bytes" name old-size new-size
))))
168 (setf (gethash hash-name
(function-code-sizes *image
*)) new-size
))
171 (defclass movitz-funobj-pass1
()
174 :accessor movitz-funobj-name
)
176 :initarg
:lambda-list
177 :accessor movitz-funobj-lambda-list
)
179 :accessor function-envs
)
182 :accessor funobj-env
)
186 :accessor movitz-funobj-extent
)
189 :accessor movitz-allocation
)
192 :initarg
:entry-protocol
193 :reader funobj-entry-protocol
))
194 (:documentation
"This class is used for funobjs during the first compiler pass.
195 Before the second pass, such objects will be change-class-ed to proper movitz-funobjs.
196 This way, we ensure that no undue side-effects on the funobj occur during pass 1."))
198 (defmethod print-object ((object movitz-funobj-pass1
) stream
)
199 (print-unreadable-object (object stream
:type t
:identity t
)
200 (when (slot-boundp object
'name
)
201 (write (movitz-funobj-name object
) :stream stream
)))
204 (defun movitz-macro-expander-make-function (lambda-form &key name
(type :unknown
))
205 "Make a lambda-form that is a macro-expander into a proper function.
206 Gensym a name whose symbol-function is set to the macro-expander, and return that symbol."
207 (let ((function-name (gensym (format nil
"~A-expander-~@[~A-~]" type name
))))
208 (if *compiler-compile-macro-expanders
*
209 (with-host-environment ()
210 (compile function-name lambda-form
))
211 (setf (symbol-function function-name
)
212 (coerce lambda-form
'function
)))
215 (defun make-compiled-funobj (name lambda-list declarations form env top-level-p
&key funobj
)
216 "Compiler entry-point for making a (lexically) top-level function."
217 (handler-bind (((or warning error
)
220 (if (not (boundp 'muerte.cl
:*compile-file-pathname
*))
221 (format *error-output
*
222 "~&;; While Movitz compiling ~S:" name
)
223 (format *error-output
*
224 "~&;; While Movitz compiling ~S in ~A:"
225 name muerte.cl
:*compile-file-pathname
*)))))
226 (with-retries-until-true (retry-funobj "Retry compilation of ~S." name
)
227 (make-compiled-funobj-pass2
228 (make-compiled-funobj-pass1 name lambda-list declarations
229 form env top-level-p
:funobj funobj
)))))
231 (defun make-compiled-funobj-pass1 (name lambda-list declarations form env top-level-p
233 "Per funobj (i.e. not necessarily top-level) entry-point for first-pass compilation.
234 If funobj is provided, its identity will be kept, but its type (and values) might change."
235 ;; The ability to provide funobj's identity is important when a
236 ;; function must be referenced before it can be compiled, e.g. for
237 ;; mutually recursive (lexically bound) functions.
238 (with-retries-until-true (retry-pass1 "Retry first-pass compilation of ~S." name
)
239 ;; First-pass is mostly functional, so it can safely be restarted.
240 (multiple-value-bind (required-vars optional-vars rest-var key-vars aux-vars allow-p min max edx-var
)
241 (decode-normal-lambda-list lambda-list
)
242 (declare (ignore aux-vars allow-p min max
))
243 ;; There are several main branches through the function
244 ;; compiler, and this is where we decide which one to take.
246 ((let ((sub-form (cddr form
)))
247 (and (consp (car sub-form
))
248 (eq 'muerte
::numargs-case
(caar sub-form
))))
249 'make-compiled-function-pass1-numarg-case
)
250 ((and (= 1 (length required-vars
)) ; (x &optional y)
251 (= 1 (length optional-vars
))
252 (movitz-constantp (nth-value 1 (decode-optional-formal (first optional-vars
)))
257 'make-compiled-function-pass1-1req1opt
)
258 (t 'make-compiled-function-pass1
))
259 name lambda-list declarations form env top-level-p funobj
))))
261 (defun ensure-pass1-funobj (funobj class
&rest init-args
)
262 "If funobj is nil, return a fresh funobj of class.
263 Otherwise coerce funobj to class."
264 (apply #'reinitialize-instance
266 (change-class funobj class
)
267 (make-instance class
))
270 (defun make-compiled-function-pass1-numarg-case (name lambda-list declarations form env top-level-p funobj
)
271 (let* ((funobj (ensure-pass1-funobj funobj
'movitz-funobj-pass1
272 :entry-protocol
:numargs-case
274 :lambda-list
(movitz-read (lambda-list-simplify lambda-list
))))
275 (funobj-env (make-local-movitz-environment env funobj
:type
'funobj-env
)))
276 (setf (funobj-env funobj
) funobj-env
277 (function-envs funobj
) nil
)
278 (loop for
(numargs lambda-list . clause-body
) in
(cdr (caddr form
))
279 do
(when (duplicatesp lambda-list
)
280 (error "There are duplicates in lambda-list ~S." lambda-list
))
281 (multiple-value-bind (clause-body clause-declarations
)
282 (parse-declarations-and-body clause-body
)
284 (add-bindings-from-lambda-list lambda-list
285 (make-local-movitz-environment
288 :declaration-context
:funobj
290 (append clause-declarations
292 (function-form (list* 'muerte.cl
::block
293 (compute-function-block-name name
)
295 (multiple-value-bind (arg-init-code need-normalized-ecx-p
)
296 (make-function-arguments-init funobj function-env
)
297 (setf (extended-code function-env
)
298 (append arg-init-code
299 (compiler-call #'compile-form
300 :form
(make-special-funarg-shadowing function-env function-form
)
303 :top-level-p top-level-p
304 :result-mode
:function
)))
305 (setf (need-normalized-ecx-p function-env
) need-normalized-ecx-p
))
306 (push (cons numargs function-env
)
307 (function-envs funobj
)))))
310 (defun make-compiled-function-pass1-1req1opt (name lambda-list declarations form env top-level-p funobj
)
312 (when (duplicatesp lambda-list
)
313 (error "There are duplicates in lambda-list ~S." lambda-list
))
314 (let* ((funobj (ensure-pass1-funobj funobj
'movitz-funobj-pass1
315 :entry-protocol
:1req1opt
317 :lambda-list
(movitz-read (lambda-list-simplify lambda-list
))))
318 (funobj-env (make-local-movitz-environment env funobj
:type
'funobj-env
))
319 (function-env (add-bindings-from-lambda-list
321 (make-local-movitz-environment funobj-env funobj
323 :need-normalized-ecx-p nil
324 :declaration-context
:funobj
325 :declarations declarations
)))
326 (optional-env (make-local-movitz-environment function-env funobj
327 :type
'function-env
)))
328 (setf (funobj-env funobj
) funobj-env
)
329 ;; (print-code 'arg-init-code arg-init-code)
330 (setf (extended-code optional-env
)
331 (compiler-call #'compile-form
332 :form
(optional-function-argument-init-form
333 (movitz-binding (first (optional-vars function-env
)) function-env nil
))
337 (setf (extended-code function-env
)
338 (append #+ignore arg-init-code
339 (compiler-call #'compile-form
340 :form
(make-special-funarg-shadowing function-env form
)
343 :top-level-p top-level-p
344 :result-mode
:function
)))
345 (setf (function-envs funobj
)
346 (list (cons 'muerte.cl
::t function-env
)
347 (cons :optional optional-env
)))
350 (defun make-compiled-function-pass1 (name lambda-list declarations form env top-level-p funobj
)
352 (when (duplicatesp lambda-list
)
353 (error "There are duplicates in lambda-list ~S." lambda-list
))
354 (let* ((funobj (ensure-pass1-funobj funobj
'movitz-funobj-pass1
356 :lambda-list
(movitz-read (lambda-list-simplify lambda-list
))))
357 (funobj-env (make-local-movitz-environment env funobj
:type
'funobj-env
))
358 (function-env (add-bindings-from-lambda-list
360 (make-local-movitz-environment funobj-env funobj
362 :declaration-context
:funobj
363 :declarations declarations
))))
364 (setf (funobj-env funobj
) funobj-env
365 (function-envs funobj
) (list (cons 'muerte.cl
::t function-env
)))
366 (multiple-value-bind (arg-init-code need-normalized-ecx-p
)
367 (make-function-arguments-init funobj function-env
)
368 (setf (need-normalized-ecx-p function-env
) need-normalized-ecx-p
)
369 (setf (extended-code function-env
)
370 (append arg-init-code
371 (compiler-call #'compile-form
372 :form
(make-special-funarg-shadowing function-env form
)
375 :top-level-p top-level-p
376 :result-mode
:function
))))
380 (defun make-compiled-funobj-pass2 (toplevel-funobj-pass1)
381 "This is the entry-poing for second pass compilation for each top-level funobj."
382 (check-type toplevel-funobj-pass1 movitz-funobj-pass1
)
383 (let ((toplevel-funobj (change-class toplevel-funobj-pass1
'movitz-funobj
)))
384 (multiple-value-bind (toplevel-funobj function-binding-usage
)
385 (resolve-borrowed-bindings toplevel-funobj
)
389 (resolve-sub-functions toplevel-funobj function-binding-usage
)))))))
391 (defstruct (type-analysis (:type list
))
395 (multiple-value-list (type-specifier-encode nil
)))
396 (declared-encoded-type
397 (multiple-value-list (type-specifier-encode t
))))
399 (defun make-type-analysis-with-declaration (binding)
401 (if (not (and *compiler-trust-user-type-declarations-p
*
402 (movitz-env-get (binding-name binding
) :variable-type
403 nil
(binding-env binding
) nil
)))
404 (multiple-value-list (type-specifier-encode t
))
406 (type-specifier-encode (movitz-env-get (binding-name binding
) :variable-type
407 t
(binding-env binding
) nil
))))))
408 ;; (warn "~S decl: ~A" binding (apply #'encoded-type-decode declared-type))
409 (make-type-analysis :declared-encoded-type declared-type
)))
411 (defun analyze-bindings (toplevel-funobj)
412 "Figure out usage of bindings in a toplevel funobj.
413 Side-effects each binding's binding-store-type."
414 (if (not *compiler-do-type-inference
*)
416 ((analyze-code (code)
417 (dolist (instruction code
)
418 (when (listp instruction
)
420 (find-written-binding-and-type instruction
)))
422 (setf (binding-store-type binding
)
423 (multiple-value-list (type-specifier-encode t
)))))
424 (analyze-code (instruction-sub-program instruction
)))))
425 (analyze-funobj (funobj)
426 (loop for
(nil . function-env
) in
(function-envs funobj
)
427 do
(analyze-code (extended-code function-env
)))
428 (loop for function-binding in
(sub-function-binding-usage funobj
) by
#'cddr
429 do
(analyze-funobj (function-binding-funobj function-binding
)))
431 (analyze-funobj toplevel-funobj
))
432 (let ((binding-usage (make-hash-table :test
'eq
)))
433 (labels ((binding-resolved-p (binding)
434 (or (typep binding
'constant-object-binding
)
435 (typep binding
'function-argument
)
436 (let ((analysis (gethash binding binding-usage
)))
438 (null (type-analysis-thunks analysis
))))))
439 (binding-resolve (binding)
441 ((not (bindingp binding
))
443 ((typep binding
'constant-object-binding
)
444 (apply #'encoded-type-decode
445 (binding-store-type binding
)))
446 ((typep binding
'function-argument
)
448 ((let ((analysis (gethash binding binding-usage
)))
449 (assert (and (and analysis
450 (null (type-analysis-thunks analysis
))))
452 "Can't resolve unresolved binding ~S." binding
)))
453 (*compiler-trust-user-type-declarations-p
*
454 (let ((analysis (gethash binding binding-usage
)))
455 (multiple-value-call #'encoded-type-decode
456 (apply #'encoded-types-and
457 (append (type-analysis-declared-encoded-type analysis
)
458 (type-analysis-encoded-type analysis
))))))
459 (t (let ((analysis (gethash binding binding-usage
)))
460 (apply #'encoded-type-decode
461 (type-analysis-encoded-type analysis
))))))
462 (type-is-t (type-specifier)
463 (or (eq type-specifier t
)
464 (and (listp type-specifier
)
465 (eq 'or
(car type-specifier
))
466 (some #'type-is-t
(cdr type-specifier
)))))
467 (analyze-store (binding type thunk thunk-args
)
468 (assert (not (null type
)) ()
469 "store-lexical with empty type.")
470 (assert (or (typep type
'binding
)
471 (eql 1 (type-specifier-num-values type
))) ()
472 "store-lexical with multiple-valued type: ~S for ~S" type binding
)
473 #+ignore
(warn "store ~S type ~S, thunk ~S" binding type thunk
)
474 (let ((analysis (or (gethash binding binding-usage
)
475 (setf (gethash binding binding-usage
)
476 (make-type-analysis-with-declaration binding
)))))
479 (assert (some #'bindingp thunk-args
))
480 (push (cons thunk thunk-args
) (type-analysis-thunks analysis
)))
481 ((and (bindingp type
)
482 (binding-eql type binding
))
483 (break "got binding type")
485 (t (setf (type-analysis-encoded-type analysis
)
489 (values-list (type-analysis-encoded-type analysis
))
490 (type-specifier-encode type
))))))))
492 #+ignore
(print-code 'analyze code
)
493 (dolist (instruction code
)
494 (when (listp instruction
)
495 (multiple-value-bind (store-binding store-type thunk thunk-args
)
496 (find-written-binding-and-type instruction
)
498 #+ignore
(warn "store: ~S binding ~S type ~S thunk ~S"
499 instruction store-binding store-type thunk
)
500 (analyze-store store-binding store-type thunk thunk-args
)))
501 (analyze-code (instruction-sub-program instruction
)))))
502 (analyze-funobj (funobj)
503 (loop for
(nil . function-env
) in
(function-envs funobj
)
504 do
(analyze-code (extended-code function-env
)))
505 (loop for function-binding in
(sub-function-binding-usage funobj
) by
#'cddr
506 do
(analyze-funobj (function-binding-funobj function-binding
)))
508 ;; 1. Examine each store to lexical bindings.
509 (analyze-funobj toplevel-funobj
)
511 (flet ((resolve-thunks ()
512 (loop with more-thunks-p
= t
515 do
(setf more-thunks-p nil
)
516 (maphash (lambda (binding analysis
)
517 (declare (ignore binding
))
518 (setf (type-analysis-thunks analysis
)
519 (loop for
(thunk . thunk-args
) in
(type-analysis-thunks analysis
)
520 if
(not (every #'binding-resolved-p thunk-args
))
521 collect
(cons thunk thunk-args
)
524 (warn "because ~S=>~S->~S completing ~S: ~S and ~S"
526 (mapcar #'binding-resolve thunk-args
)
528 (type-analysis-declared-encoded-type analysis
)
533 (type-analysis-encoded-type analysis
))
534 (type-specifier-encode
535 (apply thunk
(mapcar #'binding-resolve
537 (setf (type-analysis-encoded-type analysis
)
542 (type-analysis-declared-encoded-type analysis
))
546 (type-analysis-encoded-type analysis
))
547 (type-specifier-encode
548 (apply thunk
(mapcar #'binding-resolve
550 (setf more-thunks-p t
))))
553 (when *compiler-trust-user-type-declarations-p
*
554 ;; For each unresolved binding, just use the declared type.
555 (maphash (lambda (binding analysis
)
556 (declare (ignore binding
))
557 (when (and (not (null (type-analysis-thunks analysis
)))
558 (not (apply #'encoded-allp
559 (type-analysis-declared-encoded-type analysis
))))
561 (warn "Trusting ~S, was ~S, because ~S [~S]"
563 (type-analysis-encoded-type analysis
)
564 (type-analysis-thunks analysis
)
565 (loop for
(thunk . thunk-args
) in
(type-analysis-thunks analysis
)
566 collect
(mapcar #'binding-resolved-p thunk-args
)))
567 (setf (type-analysis-encoded-type analysis
)
568 (type-analysis-declared-encoded-type analysis
))
569 (setf (type-analysis-thunks analysis
) nil
))) ; Ignore remaining thunks.
571 ;; Try one more time to resolve thunks.
574 (maphash (lambda (binding analysis
)
575 (when (type-analysis-thunks analysis
)
576 (warn "Unable to infer type for ~S: ~S" binding
577 (type-analysis-thunks analysis
))))
580 (maphash (lambda (binding analysis
)
581 (setf (binding-store-type binding
)
583 ((and (not (null (type-analysis-thunks analysis
)))
584 *compiler-trust-user-type-declarations-p
*
585 (movitz-env-get (binding-name binding
) :variable-type nil
586 (binding-env binding
) nil
))
588 (type-specifier-encode (movitz-env-get (binding-name binding
) :variable-type
589 t
(binding-env binding
) nil
))))
590 ((and *compiler-trust-user-type-declarations-p
*
591 (movitz-env-get (binding-name binding
) :variable-type nil
592 (binding-env binding
) nil
))
594 (multiple-value-call #'encoded-types-and
595 (type-specifier-encode (movitz-env-get (binding-name binding
) :variable-type
596 t
(binding-env binding
) nil
))
597 (values-list (type-analysis-encoded-type analysis
)))))
598 ((not (null (type-analysis-thunks analysis
)))
599 (multiple-value-list (type-specifier-encode t
)))
600 (t (type-analysis-encoded-type analysis
))))
601 #+ignore
(warn "Finally: ~S" binding
))
605 (defun resolve-borrowed-bindings (toplevel-funobj)
606 "For <funobj>'s code, for every non-local binding used we create
607 a borrowing-binding in the funobj-env. This process must be done
608 recursively, depth-first wrt. sub-functions. Also, return a plist
609 of all function-bindings seen."
610 (check-type toplevel-funobj movitz-funobj
)
611 (let ((function-binding-usage ()))
612 (labels ((process-binding (funobj binding usages
)
614 ((typep binding
'constant-object-binding
))
615 ((not (eq funobj
(binding-funobj binding
)))
616 (let ((borrowing-binding
617 (or (find binding
(borrowed-bindings funobj
)
618 :key
#'borrowed-binding-target
)
619 (car (push (movitz-env-add-binding (funobj-env funobj
)
620 (make-instance 'borrowed-binding
621 :name
(binding-name binding
)
622 :target-binding binding
))
623 (borrowed-bindings funobj
))))))
624 ;; We don't want to borrow a forwarding-binding..
625 (when (typep (borrowed-binding-target borrowing-binding
)
627 (change-class (borrowed-binding-target borrowing-binding
)
629 ;;; (warn "binding ~S of ~S is not local to ~S, replacing with ~S of ~S."
630 ;;; binding (binding-env binding) funobj
631 ;;; borrowing-binding (binding-env borrowing-binding))
632 ;;; (pushnew borrowing-binding
633 ;;; (getf (binding-lended-p binding) :lended-to))
634 (dolist (usage usages
)
635 (pushnew usage
(borrowed-binding-usage borrowing-binding
)))
637 (t ; Binding is local to this funobj
640 (process-binding funobj
(forwarding-binding-target binding
) usages
)
642 (setf (forwarding-binding-target binding
)
643 (process-binding funobj
(forwarding-binding-target binding
) usages
)))
645 (dolist (usage usages
)
647 (getf (sub-function-binding-usage (function-binding-parent binding
))
649 (pushnew usage
(getf function-binding-usage binding
)))
652 (resolve-sub-funobj (funobj sub-funobj
)
653 (dolist (binding-we-lend (borrowed-bindings (resolve-funobj-borrowing sub-funobj
)))
655 (warn "Lending from ~S to ~S: ~S <= ~S"
657 (borrowed-binding-target binding-we-lend
)
659 (process-binding funobj
660 (borrowed-binding-target binding-we-lend
)
661 (borrowed-binding-usage binding-we-lend
))))
662 (resolve-code (funobj code
)
663 (dolist (instruction code
)
664 (when (listp instruction
)
665 (let ((store-binding (find-written-binding-and-type instruction
)))
667 (process-binding funobj store-binding
'(:write
))))
668 (dolist (load-binding (find-read-bindings instruction
))
669 (process-binding funobj load-binding
'(:read
)))
670 (case (car instruction
)
672 (process-binding funobj
(second instruction
) '(:call
)))
674 (destructuring-bind (proto-cons dynamic-scope
)
676 (push proto-cons
(dynamic-extent-scope-members dynamic-scope
))))
678 (destructuring-bind (lambda-binding lambda-result-mode capture-env
)
680 (declare (ignore lambda-result-mode
))
681 (assert (eq funobj
(binding-funobj lambda-binding
)) ()
682 "A non-local lambda doesn't make sense. There must be a bug.")
683 (let ((lambda-funobj (function-binding-funobj lambda-binding
)))
684 (let ((dynamic-scope (find-dynamic-extent-scope capture-env
)))
686 ;; (warn "Adding ~S to ~S/~S" lambda-funobj dynamic-extent dynamic-scope)
687 (setf (movitz-funobj-extent lambda-funobj
) :dynamic-extent
688 (movitz-allocation lambda-funobj
) dynamic-scope
)
689 (push lambda-funobj
(dynamic-extent-scope-members dynamic-scope
))
690 (process-binding funobj
(base-binding dynamic-scope
) '(:read
))))
691 (resolve-sub-funobj funobj lambda-funobj
)
692 (process-binding funobj lambda-binding
'(:read
))
693 ;; This funobj is effectively using every binding that the lambda
695 (map nil
(lambda (borrowed-binding)
696 (process-binding funobj
697 (borrowed-binding-target borrowed-binding
)
699 (borrowed-bindings (function-binding-funobj lambda-binding
))))))
700 (:local-function-init
701 (let ((function-binding (second instruction
)))
702 (assert (eq funobj
(binding-funobj function-binding
)) ()
703 "Initialization of a non-local function doesn't make sense.")
704 (resolve-sub-funobj funobj
(function-binding-funobj (second instruction
)))
705 (map nil
(lambda (borrowed-binding)
706 (process-binding funobj
707 (borrowed-binding-target borrowed-binding
)
709 (borrowed-bindings (function-binding-funobj (second instruction
)))))))
710 (resolve-code funobj
(instruction-sub-program instruction
)))))
711 (resolve-funobj-borrowing (funobj)
712 (let ((funobj (change-class funobj
'movitz-funobj
:borrowed-bindings nil
)))
713 (loop for
(nil . function-env
) in
(function-envs funobj
)
714 do
(resolve-code funobj
(extended-code function-env
)))
715 ;; (warn "~S borrows ~S." funobj (borrowed-bindings funobj))
717 (values (resolve-funobj-borrowing toplevel-funobj
)
718 function-binding-usage
))))
720 (defun resolve-sub-functions (toplevel-funobj function-binding-usage
)
721 (assert (null (borrowed-bindings toplevel-funobj
)) ()
722 "Can't deal with toplevel closures yet. Borrowed: ~S"
723 (borrowed-bindings toplevel-funobj
))
724 (setf (movitz-funobj-extent toplevel-funobj
) :indefinite-extent
)
725 (let ((sub-funobj-index 0))
726 (loop for
(function-binding usage
) on function-binding-usage by
#'cddr
727 do
(let ((sub-funobj (function-binding-funobj function-binding
)))
728 ;; (warn "USage: ~S => ~S" sub-funobj usage)
729 (case (car (movitz-funobj-name sub-funobj
))
731 (setf (movitz-funobj-name sub-funobj
)
732 (list 'muerte.cl
:lambda
733 (movitz-funobj-name toplevel-funobj
)
734 (post-incf sub-funobj-index
)))))
735 (loop for borrowed-binding in
(borrowed-bindings sub-funobj
)
736 do
(pushnew borrowed-binding
737 (getf (binding-lending (borrowed-binding-target borrowed-binding
))
739 ;; (warn "old extent: ~S" (movitz-funobj-extent sub-funobj))
742 (null (borrowed-bindings sub-funobj
)))
744 (warn "null usage for ~S" sub-funobj
))
745 (change-class function-binding
'funobj-binding
)
746 (setf (movitz-funobj-extent sub-funobj
)
748 ((equal usage
'(:call
))
749 (change-class function-binding
'closure-binding
)
750 (setf (movitz-funobj-extent sub-funobj
)
752 ((eq :dynamic-extent
(movitz-funobj-extent sub-funobj
))
753 (change-class function-binding
'closure-binding
))
754 (t (change-class function-binding
'closure-binding
)
755 (setf (movitz-funobj-extent sub-funobj
)
756 :indefinite-extent
))))))
757 (loop for function-binding in function-binding-usage by
#'cddr
758 do
(finalize-funobj (function-binding-funobj function-binding
)))
759 (finalize-funobj toplevel-funobj
))
761 (defun finalize-funobj (funobj)
762 "Calculate funobj's constants, jumpers."
763 (loop with all-key-args-constants
= nil
764 with all-constants-plist
= () and all-jumper-sets
= ()
765 for
(nil . function-env
) in
(function-envs funobj
)
766 ;; (borrowed-bindings body-code) in code-specs
767 as body-code
= (extended-code function-env
)
768 as
(const-plist jumper-sets key-args-constants
) =
769 (multiple-value-list (find-code-constants-and-jumpers body-code
))
770 do
(when key-args-constants
771 (assert (not all-key-args-constants
) ()
772 "only one &key parsing allowed per funobj.")
773 (setf all-key-args-constants key-args-constants
))
774 (loop for
(constant usage
) on const-plist by
#'cddr
775 do
(incf (getf all-constants-plist constant
0) usage
))
776 (loop for
(name set
) on jumper-sets by
#'cddr
777 do
(assert (not (getf all-jumper-sets name
)) ()
778 "Jumper-set ~S multiply defined." name
)
779 (setf (getf all-jumper-sets name
) set
))
781 (multiple-value-bind (const-list num-jumpers jumpers-map borrower-map
)
782 (layout-funobj-vector all-constants-plist
783 all-key-args-constants
784 #+ignore
(mapcar (lambda (x)
785 (cons (movitz-read x
) 1))
788 (borrowed-bindings funobj
))
789 (setf (movitz-funobj-num-jumpers funobj
) num-jumpers
790 (movitz-funobj-const-list funobj
) const-list
791 (movitz-funobj-num-constants funobj
) (length const-list
)
792 (movitz-funobj-jumpers-map funobj
) jumpers-map
)
793 (loop for
(binding . pos
) in borrower-map
794 do
(setf (borrowed-binding-reference-slot binding
) pos
))
797 (defun layout-stack-frames (funobj)
798 "Lay out the stack-frame (i.e. create a frame-map) for funobj
799 and all its local functions. This must be done breadth-first, because
800 a (lexical-extent) sub-function might care about its parent frame-map."
801 (loop for
(nil . function-env
) in
(function-envs funobj
)
802 do
(assert (not (slot-boundp function-env
'frame-map
)))
803 (setf (frame-map function-env
)
804 (funobj-assign-bindings (extended-code function-env
)
806 (loop for
(sub-function-binding) on
(sub-function-binding-usage funobj
) by
#'cddr
807 do
(layout-stack-frames (function-binding-funobj sub-function-binding
)))
810 (defun complete-funobj (funobj)
811 (case (funobj-entry-protocol funobj
)
813 (complete-funobj-1req1opt funobj
))
814 (t (complete-funobj-default funobj
)))
815 (loop for
(sub-function-binding) on
(sub-function-binding-usage funobj
) by
#'cddr
816 do
(complete-funobj (function-binding-funobj sub-function-binding
)))
817 (register-function-code-size funobj
))
819 (defun complete-funobj-1req1opt (funobj)
820 (assert (= 2 (length (function-envs funobj
))))
821 (let* ((function-env (cdr (assoc 'muerte.cl
::t
(function-envs funobj
))))
822 (optional-env (cdr (assoc :optional
(function-envs funobj
))))
823 (frame-map (frame-map function-env
))
824 (resolved-code (finalize-code (extended-code function-env
) funobj frame-map
))
825 (resolved-optional-code (finalize-code (extended-code optional-env
) funobj frame-map
))
826 (stack-frame-size (frame-map-size (frame-map function-env
)))
827 (use-stack-frame-p (or (plusp stack-frame-size
)
828 (tree-search resolved-code
829 '(:pushl
:popl
:ebp
:esp
:call
:leave
))
831 (and (not (equal '(:movl
(:ebp -
4) :esi
) x
))
832 (tree-search x
':esi
)))
834 (let* ((function-code
835 (let* ((req-binding (movitz-binding (first (required-vars function-env
))
837 (req-location (cdr (assoc req-binding frame-map
)))
838 (opt-binding (movitz-binding (first (optional-vars function-env
))
840 (opt-location (cdr (assoc opt-binding frame-map
)))
841 (optp-binding (movitz-binding (optional-function-argument-supplied-p-var opt-binding
)
843 (optp-location (cdr (assoc optp-binding frame-map
)))
845 (append `((:jmp
(:edi
,(global-constant-offset 'trampoline-cl-dispatch-1or2
))))
847 (unless (eql nil opt-location
)
848 resolved-optional-code
)
851 (:jmp
'optp-into-edx-ok
)))
854 `((,*compiler-global-segment-prefix
*
855 :movl
(:edi
,(global-constant-offset 't-symbol
)) :edx
)
857 (when use-stack-frame-p
858 +enter-stack-frame-code
+)
859 '(start-stack-frame-setup)
861 ((and (eql 1 req-location
)
862 (eql 2 opt-location
))
863 (incf stack-setup-pre
2)
866 ((and (eql 1 req-location
)
867 (eql nil opt-location
))
868 (incf stack-setup-pre
1)
870 ((and (member req-location
'(nil :eax
))
871 (eql 1 opt-location
))
872 (incf stack-setup-pre
1)
874 ((and (member req-location
'(nil :eax
))
875 (member opt-location
'(nil :ebx
)))
877 (t (error "Can't deal with req ~S opt ~S."
878 req-location opt-location
)))
881 (make-stack-setup-code (- stack-frame-size stack-setup-pre
)))
882 ((and (integerp optp-location
)
883 (= optp-location
(1+ stack-setup-pre
)))
884 (append `((:pushl
:edx
))
885 (make-stack-setup-code (- stack-frame-size stack-setup-pre
1))))
886 ((integerp optp-location
)
887 (append (make-stack-setup-code (- stack-frame-size stack-setup-pre
))
888 `((:movl
:edx
(:ebp
,(stack-frame-offset optp-location
))))))
889 (t (error "Can't deal with optional-p at ~S, after (~S ~S)."
890 optp-location req-location opt-location
)))
891 (flet ((make-lending (location lended-cons-position
)
892 (etypecase req-location
894 `((:movl
(:ebp
,(stack-frame-offset location
)) :edx
)
895 (:movl
:edi
(:ebp
,(stack-frame-offset lended-cons-position
))) ; cdr
896 (:movl
:edx
(:ebp
,(stack-frame-offset (1+ lended-cons-position
)))) ; car
897 (:leal
(:ebp
1 ,(stack-frame-offset (1+ lended-cons-position
)))
899 (:movl
:edx
(:ebp
,(stack-frame-offset location
))))))))
901 (when (binding-lended-p req-binding
)
902 (make-lending req-location
(getf (binding-lending req-binding
)
903 :stack-cons-location
)))
904 (when (binding-lended-p opt-binding
)
905 (make-lending opt-location
(getf (binding-lending opt-binding
)
906 :stack-cons-location
)))
907 (when (and optp-binding
(binding-lended-p optp-binding
))
908 (make-lending optp-location
(getf (binding-lending optp-binding
)
909 :stack-cons-location
)))))
911 (make-compiled-function-postlude funobj function-env
912 use-stack-frame-p
)))))
913 (let ((optimized-function-code
914 (optimize-code function-code
915 :keep-labels
(append (subseq (movitz-funobj-const-list funobj
)
916 0 (movitz-funobj-num-jumpers funobj
))
917 '(entry%
1op entry%
2op
)))))
918 (assemble-funobj funobj optimized-function-code
)))))
920 (defun complete-funobj-default (funobj)
922 (loop for
(numargs . function-env
) in
(function-envs funobj
)
924 (let* ((frame-map (frame-map function-env
))
925 (resolved-code (finalize-code (extended-code function-env
) funobj frame-map
))
926 (stack-frame-size (frame-map-size (frame-map function-env
)))
927 (use-stack-frame-p (or (plusp stack-frame-size
)
928 (tree-search resolved-code
929 '(:push
:pop
:ebp
:esp
:call
:leave
))
931 (and (not (equal '(:movl
(:ebp -
4) :esi
) x
))
932 (tree-search x
':esi
)))
934 (multiple-value-bind (prelude-code have-normalized-ecx-p
)
935 (make-compiled-function-prelude stack-frame-size function-env use-stack-frame-p
936 (need-normalized-ecx-p function-env
) frame-map
937 :do-check-stack-p
(or (<= 32 stack-frame-size
)
938 (tree-search resolved-code
941 (install-arg-cmp (append prelude-code
943 (make-compiled-function-postlude funobj function-env
945 have-normalized-ecx-p
)))
946 (let ((optimized-function-code
947 (optimize-code function-code
949 (subseq (movitz-funobj-const-list funobj
)
950 0 (movitz-funobj-num-jumpers funobj
))
954 (cons numargs optimized-function-code
))))))))
955 (let ((code1 (cdr (assoc 1 code-specs
)))
956 (code2 (cdr (assoc 2 code-specs
)))
957 (code3 (cdr (assoc 3 code-specs
)))
958 (codet (cdr (assoc 'muerte.cl
::t code-specs
))))
959 (assert codet
() "A default numargs-case is required.")
960 ;; (format t "codet:~{~&~A~}" codet)
962 (delete 'start-stack-frame-setup
967 ,@(unless (find 'entry%
1op code1
)
968 '(entry%
1op
(:movb
1 :cl
)))
974 ,@(unless (find 'entry%
2op code2
)
975 '(entry%
2op
(:movb
2 :cl
)))
980 (:jne
'not-three-args
)
981 ,@(unless (find 'entry%
3op code3
)
982 '(entry%
3op
(:movb
3 :cl
)))
985 (delete-if (lambda (x)
986 (or (and code1
(eq x
'entry%
1op
))
987 (and code2
(eq x
'entry%
2op
))
988 (and code3
(eq x
'entry%
3op
))))
990 ;; (print-code funobj combined-code)
991 (assemble-funobj funobj combined-code
))))
994 (defun assemble-funobj (funobj combined-code
)
995 (multiple-value-bind (code-vector code-symtab
)
996 (let ((asm:*instruction-compute-extra-prefix-map
*
997 '((:call . compute-call-extra-prefix
))))
998 (asm:assemble-proglist combined-code
999 :symtab
(list* (cons :nil-value
(image-nil-word *image
*))
1000 (loop for
(label . set
) in
(movitz-funobj-jumpers-map funobj
)
1002 (* 4 (or (search set
(movitz-funobj-const-list funobj
)
1003 :end2
(movitz-funobj-num-jumpers funobj
))
1004 (error "Jumper for ~S missing." label
))))))))
1005 (setf (movitz-funobj-symtab funobj
) code-symtab
)
1006 (let* ((code-length (- (length code-vector
) 3 -
3))
1007 (code-vector (make-array code-length
1008 :initial-contents code-vector
1010 (setf (fill-pointer code-vector
) code-length
)
1012 (setf (ldb (byte 1 5) (slot-value funobj
'debug-info
))
1013 1 #+ignore
(if use-stack-frame-p
1 0))
1014 (let ((x (cdr (assoc 'start-stack-frame-setup code-symtab
))))
1017 #+ignore
(warn "No start-stack-frame-setup label for ~S." name
))
1019 (setf (ldb (byte 5 0) (slot-value funobj
'debug-info
)) x
))
1020 (t (warn "Can't encode start-stack-frame-setup label ~D into debug-info for ~S."
1021 x
(movitz-funobj-name funobj
)))))
1022 (let* ((a (or (cdr (assoc 'entry%
1op code-symtab
)) 0))
1023 (b (or (cdr (assoc 'entry%
2op code-symtab
)) a
))
1024 (c (or (cdr (assoc 'entry%
3op code-symtab
)) b
)))
1026 (warn "Weird code-entries: ~D, ~D, ~D." a b c
))
1027 (unless (<= 0 a
255)
1028 (break "entry%1: ~D" a
))
1029 (unless (<= 0 b
2047)
1030 (break "entry%2: ~D" b
))
1031 (unless (<= 0 c
4095)
1032 (break "entry%3: ~D" c
)))
1033 (loop for
(entry-label slot-name
) in
'((entry%
1op code-vector%
1op
)
1034 (entry%
2op code-vector%
2op
)
1035 (entry%
3op code-vector%
3op
))
1036 do
(when (assoc entry-label code-symtab
)
1037 (let ((offset (cdr (assoc entry-label code-symtab
))))
1038 (setf (slot-value funobj slot-name
)
1039 (cons offset funobj
)))))
1040 (check-locate-concistency code-vector
)
1041 (setf (movitz-funobj-code-vector funobj
)
1042 (make-movitz-vector (length code-vector
)
1043 :fill-pointer code-length
1045 :initial-contents code-vector
))))
1048 (defun check-locate-concistency (code-vector)
1049 (loop for x from
0 below
(length code-vector
) by
8
1050 do
(when (and (= (tag :basic-vector
) (aref code-vector x
))
1051 (= (enum-value 'movitz-vector-element-type
:code
) (aref code-vector
(1+ x
)))
1052 (or (<= #x4000
(length code-vector
))
1053 (and (= (ldb (byte 8 0) (length code-vector
))
1054 (aref code-vector
(+ x
2)))
1055 (= (ldb (byte 8 8) (length code-vector
))
1056 (aref code-vector
(+ x
3))))))
1057 (break "Code-vector (length #x~X) can break %find-code-vector at ~D: #x~2,'0X~2,'0X ~2,'0X~2,'0X."
1058 (length code-vector
) x
1059 (aref code-vector
(+ x
0))
1060 (aref code-vector
(+ x
1))
1061 (aref code-vector
(+ x
2))
1062 (aref code-vector
(+ x
3)))))
1066 (defun make-2req (binding0 binding1 frame-map
)
1067 (let ((location-0 (new-binding-location binding0 frame-map
))
1068 (location-1 (new-binding-location binding1 frame-map
)))
1070 ((and (eq :eax location-0
)
1071 (eq :ebx location-1
))
1073 ((and (eq :ebx location-0
)
1074 (eq :eax location-1
))
1075 (values '((:xchgl
:eax
:ebx
)) 0))
1076 ((and (eql 1 location-0
)
1078 (values '((:pushl
:eax
)
1081 ((and (eq :eax location-0
)
1083 (values '((:pushl
:ebx
))
1085 (t (error "make-2req confused by loc0: ~W, loc1: ~W" location-0 location-1
)))))
1088 (defun movitz-compile-file (path &key
((:image
*image
*) *image
*)
1090 (delete-file-p nil
))
1092 (#+sbcl
(sb-ext:defconstant-uneql
#'continue
))
1094 (let ((*movitz-host-features
* *features
*)
1095 (*features
* (image-movitz-features *image
*)))
1096 (multiple-value-prog1
1097 (movitz-compile-file-internal path load-priority
)
1098 (unless (equalp *features
* (image-movitz-features *image
*))
1099 (warn "*features* changed from ~S to ~S." (image-movitz-features *image
*) *features
*)
1100 (setf (image-movitz-features *image
*) *features
*))))
1102 (assert (equal (pathname-directory "/tmp/")
1103 (pathname-directory path
))
1105 "Refusing to delete file not in /tmp.")
1106 (delete-file path
)))))
1108 (defun movitz-compile-file-internal (path &optional
(*default-load-priority
*
1109 (and (boundp '*default-load-priority
*)
1110 (symbol-value '*default-load-priority
*)
1111 (1+ (symbol-value '*default-load-priority
*)))))
1112 (declare (special *default-load-priority
*))
1113 (with-simple-restart (continue "Skip Movitz compilation of ~S." path
)
1114 (with-retries-until-true (retry "Restart Movitz compilation of ~S." path
)
1115 (with-open-file (stream path
:direction
:input
)
1116 (let ((*package
* (find-package :muerte
)))
1117 (movitz-compile-stream-internal stream
:path path
))))))
1119 (defun movitz-compile-stream (stream &key
(path "unknown-toplevel.lisp") (package :muerte
))
1121 (#+sbcl
(sb-ext:defconstant-uneql
#'continue
))
1123 (let ((*package
* (find-package package
))
1124 (*movitz-host-features
* *features
*)
1125 (*features
* (image-movitz-features *image
*)))
1126 (multiple-value-prog1
1127 (movitz-compile-stream-internal stream
:path path
)
1128 (unless (equalp *features
* (image-movitz-features *image
*))
1129 (warn "*features* changed from ~S to ~S." (image-movitz-features *image
*) *features
*)
1130 (setf (image-movitz-features *image
*) *features
*)))))))
1132 (defun movitz-compile-stream-internal (stream &key
(path "unknown-toplevel.lisp"))
1133 (let* ((muerte.cl
::*compile-file-pathname
* path
)
1134 (funobj (make-instance 'movitz-funobj-pass1
1135 :name
(intern (format nil
"~A" path
) :muerte
)
1136 :lambda-list
(movitz-read nil
)))
1137 (funobj-env (make-local-movitz-environment nil funobj
1139 :declaration-context
:funobj
))
1140 (function-env (make-local-movitz-environment funobj-env funobj
1142 :declaration-context
:funobj
))
1144 (with-compilation-unit ()
1145 (add-bindings-from-lambda-list () function-env
)
1146 (setf (funobj-env funobj
) funobj-env
)
1147 (loop for form
= (with-movitz-syntax ()
1148 (read stream nil
'#0=#:eof
))
1149 until
(eq form
'#0#)
1151 (with-simple-restart (skip-toplevel-form
1152 "Skip the compilation of top-level form~{ ~A~}."
1156 ((symbolp (car form
))
1159 (when *compiler-verbose-p
*
1160 (format *query-io
* "~&Movitz Compiling ~S..~%"
1162 ((symbolp form
) form
)
1163 ((symbolp (car form
))
1164 (xsubseq form
0 2)))))
1165 (compiler-call #'compile-form
1170 :result-mode
:ignore
))))))
1173 (setf (image-load-time-funobjs *image
*)
1174 (delete funobj
(image-load-time-funobjs *image
*) :key
#'first
))
1175 'muerte
::constantly-true
)
1176 (t (setf (extended-code function-env
) file-code
1177 (need-normalized-ecx-p function-env
) nil
1178 (function-envs funobj
) (list (cons 'muerte.cl
::t function-env
))
1179 (funobj-env funobj
) funobj-env
)
1180 (make-compiled-funobj-pass2 funobj
)
1181 (let ((name (funobj-name funobj
)))
1182 (setf (movitz-env-named-function name
) funobj
)
1187 (defun print-code (x code
)
1188 (let ((*print-level
* 4))
1189 (format t
"~&~A code:~{~& ~A~}" x code
))
1192 (defun layout-program (pc)
1193 "For the program in pc, layout sub-programs at the top-level program."
1194 (do ((previous-subs nil
)
1198 (assert (not pending-subs
) ()
1199 "pending sub-programs: ~S" pending-subs
)
1200 (nreverse new-program
))
1202 (multiple-value-bind (sub-prg sub-opts
)
1203 (instruction-sub-program i
)
1205 (push i new-program
)
1206 (destructuring-bind (&optional
(label (gensym "sub-prg-label-")))
1208 (let ((x (cons label sub-prg
)))
1209 (unless (find x previous-subs
:test
#'equal
)
1210 (push x pending-subs
)
1211 (push x previous-subs
)))
1212 (unless (instruction-is i
:jnever
)
1213 (push `(,(car i
) ',label
)
1215 (when (or (instruction-uncontinues-p i
)
1217 (let* ((match-label (and (eq (car i
) :jmp
)
1219 (eq (car (second i
)) 'quote
)
1220 (symbolp (second (second i
)))
1221 (second (second i
))))
1222 (matching-sub (assoc match-label pending-subs
)))
1223 (unless (and match-label
1224 (or (eq match-label
(first pc
))
1225 (and (symbolp (first pc
))
1226 (eq match-label
(second pc
)))))
1228 (setf pc
(append (cdr matching-sub
) pc
)
1229 pending-subs
(delete matching-sub pending-subs
))
1230 (setf pc
(append (reduce #'append
(nreverse pending-subs
)) pc
)
1231 pending-subs nil
)))))))))
1234 (defun optimize-code (unoptimized-code &rest args
)
1235 #+ignore
(print-code 'to-optimize unoptimized-code
)
1236 (if (not *compiler-do-optimize
*)
1237 (layout-program (optimize-code-unfold-branches unoptimized-code
))
1238 (apply #'optimize-code-internal
1239 (optimize-code-dirties
1240 (layout-program (optimize-code-unfold-branches unoptimized-code
)))
1243 (defun optimize-code-unfold-branches (unoptimized-code)
1244 "This particular optimization should be done before code layout:
1245 (:jcc 'label) (:jmp 'foo) label => (:jncc 'foo) label"
1246 (flet ((explain (always format
&rest args
)
1247 (when (or always
*explain-peephole-optimizations
*)
1248 (warn "Peephole: ~?~&----------------------------" format args
)))
1249 (branch-instruction-label (i &optional jmp
(branch-types '(:je
:jne
:jb
:jnb
:jbe
:jz
1250 :jl
:jnz
:jle
:ja
:jae
:jg
1251 :jge
:jnc
:jc
:js
:jns
)))
1252 "If i is a branch, return the label."
1253 (when jmp
(push :jmp branch-types
))
1254 (let ((i (ignore-instruction-prefixes i
)))
1255 (or (and (listp i
) (member (car i
) branch-types
)
1256 (listp (second i
)) (member (car (second i
)) '(quote muerte.cl
::quote
))
1257 (second (second i
))))))
1258 (negate-branch (branch-type)
1260 (:jb
:jnb
) (:jnb
:jb
)
1261 (:jbe
:ja
) (:ja
:jbe
)
1262 (:jz
:jnz
) (:jnz
:jz
)
1263 (:je
:jne
) (:jne
:je
)
1264 (:jc
:jnc
) (:jnc
:jc
)
1265 (:jl
:jge
) (:jge
:jl
)
1266 (:jle
:jg
) (:jg
:jle
))))
1267 (loop with next-pc
= 'auto-next
1268 ;; initially (warn "opt: ~{ ~A~%~}" unoptimized-code)
1269 for pc
= unoptimized-code then
(prog1 (if (eq 'auto-next next-pc
) auto-next-pc next-pc
)
1270 (setq next-pc
'auto-next
))
1271 as auto-next-pc
= (cdr unoptimized-code
) then
(cdr pc
)
1272 as p
= (list (car pc
)) ; will be appended.
1273 as i1
= (first pc
) ; current instruction, collected by default.
1274 and i2
= (second pc
) and i3
= (third pc
)
1276 do
(when (and (branch-instruction-label i1
)
1277 (branch-instruction-label i2 t nil
)
1279 (eq i3
(branch-instruction-label i1
)))
1280 (setf p
(list `(,(negate-branch (car i1
)) ',(branch-instruction-label i2 t nil
))
1282 next-pc
(nthcdr 3 pc
))
1283 (explain nil
"Got a sit: ~{~&~A~} => ~{~&~A~}" (subseq pc
0 3) p
))
1286 (defun optimize-code-dirties (unoptimized-code)
1287 "These optimizations may rearrange register usage in a way that is incompatible
1288 with other optimizations that track register usage. So this is performed just once,
1292 (labels ; This stuff doesn't work..
1293 ((explain (always format
&rest args
)
1294 (when (or always
*explain-peephole-optimizations
*)
1295 (warn "Peephole: ~?~&----------------------------" format args
)))
1296 (twop-p (c &optional op
)
1297 (let ((c (ignore-instruction-prefixes c
)))
1298 (and (listp c
) (= 3 (length c
))
1299 (or (not op
) (eq op
(first c
)))
1301 (twop-dst (c &optional op src
)
1302 (let ((c (ignore-instruction-prefixes c
)))
1304 (equal src
(first (twop-p c op
))))
1305 (second (twop-p c op
)))))
1306 (twop-src (c &optional op dest
)
1307 (let ((c (ignore-instruction-prefixes c
)))
1309 (equal dest
(second (twop-p c op
))))
1310 (first (twop-p c op
)))))
1311 (register-operand (op)
1312 (and (member op
'(:eax
:ebx
:ecx
:edx
:edi
))
1314 (loop with next-pc
= 'auto-next
1315 ;; initially (warn "opt: ~{ ~A~%~}" unoptimized-code)
1316 for pc
= unoptimized-code then
(prog1 (if (eq 'auto-next next-pc
) auto-next-pc next-pc
)
1317 (setq next-pc
'auto-next
))
1318 as auto-next-pc
= (cdr unoptimized-code
) then
(cdr pc
)
1319 as p
= (list (car pc
)) ; will be appended.
1320 as i1
= (first pc
) ; current instruction, collected by default.
1321 and i2
= (second pc
) and i3
= (third pc
)
1323 do
(let ((regx (register-operand (twop-src i1
:movl
)))
1324 (regy (register-operand (twop-dst i1
:movl
))))
1325 (when (and regx regy
1326 (eq regx
(twop-dst i2
:movl
))
1327 (eq regx
(twop-src i3
:cmpl
))
1328 (eq regy
(twop-dst i3
:cmpl
)))
1329 (setq p
(list `(:cmpl
,(twop-src i2
) ,regx
) i1
)
1330 next-pc
(nthcdr 3 pc
))
1331 (explain t
"4: ~S for ~S [regx ~S, regy ~S]" p
(subseq pc
0 5) regx regy
)))
1334 (defun xsubseq (sequence start end
)
1335 (subseq sequence start
(min (length sequence
) end
)))
1337 (defun optimize-code-internal (unoptimized-code recursive-count
&rest key-args
1338 &key keep-labels stack-frame-size
)
1339 "Peephole optimizer. Based on a lot of rather random heuristics."
1340 (declare (ignore stack-frame-size
))
1341 (when (<= 20 recursive-count
)
1342 (error "Peephole-optimizer recursive count reached ~D.
1343 There is (propably) a bug in the peephole optimizer." recursive-count
))
1344 ;; (warn "==================OPTIMIZE: ~{~&~A~}" unoptimized-code)
1345 (macrolet ((explain (always format
&rest args
)
1346 `(when (or *explain-peephole-optimizations
* ,always
)
1347 (warn "Peephole: ~@?~&----------------------------" ,format
,@args
))))
1350 (explain (always format
&rest args
)
1351 (when (or always
*explain-peephole-optimizations
*)
1352 (warn "Peephole: ~?~&----------------------------" format args
)))
1353 (twop-p (c &optional op
)
1354 (let ((c (ignore-instruction-prefixes c
)))
1355 (and (listp c
) (= 3 (length c
))
1356 (or (not op
) (eq op
(first c
)))
1358 (twop-dst (c &optional op src
)
1359 (let ((c (ignore-instruction-prefixes c
)))
1361 (equal src
(first (twop-p c op
))))
1362 (second (twop-p c op
)))))
1363 (twop-src (c &optional op dest
)
1364 (let ((c (ignore-instruction-prefixes c
)))
1366 (equal dest
(second (twop-p c op
))))
1367 (first (twop-p c op
)))))
1369 (let ((c (ignore-instruction-prefixes c
)))
1370 (ecase (length (cdr c
))
1375 (let ((c (ignore-instruction-prefixes c
)))
1376 (ecase (length (cdr c
))
1380 (non-destructive-p (c)
1381 (let ((c (ignore-instruction-prefixes c
)))
1383 (member (car c
) '(:testl
:testb
:cmpl
:cmpb
:frame-map
:std
)))))
1384 (simple-instruction-p (c)
1385 (let ((c (ignore-instruction-prefixes c
)))
1388 '(:movl
:xorl
:popl
:pushl
:cmpl
:leal
:andl
:addl
:subl
)))))
1389 (register-indirect-operand (op base
)
1390 (multiple-value-bind (reg off
)
1393 if
(integerp x
) sum x into off
1394 else collect x into reg
1395 finally
(return (values reg off
))))
1396 (and (eq base
(car reg
))
1399 (stack-frame-operand (op)
1400 (register-indirect-operand op
:ebp
))
1401 (funobj-constant-operand (op)
1402 (register-indirect-operand op
:esi
))
1403 (global-constant-operand (op)
1404 (register-indirect-operand op
:edi
))
1405 (global-funcall-p (op &optional funs
)
1406 (let ((op (ignore-instruction-prefixes op
)))
1407 (when (instruction-is op
:call
)
1408 (let ((x (global-constant-operand (second op
))))
1410 (and (eql x
(slot-offset 'movitz-run-time-context name
))
1415 ((atom funs
) (try funs
))
1416 (t (some #'try funs
))))))))
1417 (preserves-stack-location-p (i stack-location
)
1418 (let ((i (ignore-instruction-prefixes i
)))
1420 (or (global-funcall-p i
)
1421 (instruction-is i
:frame-map
)
1422 (branch-instruction-label i
)
1423 (non-destructive-p i
)
1424 (and (simple-instruction-p i
)
1425 (not (eql stack-location
(stack-frame-operand (idst i
)))))))))
1426 (preserves-register-p (i register
)
1427 (let ((i (ignore-instruction-prefixes i
)))
1429 (not (and (eq register
:esp
)
1430 (member (instruction-is i
)
1432 (or (and (simple-instruction-p i
)
1433 (not (eq register
(idst i
))))
1434 (instruction-is i
:frame-map
)
1435 (branch-instruction-label i
)
1436 (non-destructive-p i
)
1437 (and (member register
'(:edx
))
1438 (member (global-funcall-p i
)
1439 '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx
)))
1440 (and (not (eq register
:esp
))
1441 (instruction-is i
:pushl
))))))
1442 (operand-register-indirect-p (operand register
)
1443 (and (consp operand
)
1444 (tree-search operand register
)))
1445 (doesnt-read-register-p (i register
)
1446 (let ((i (ignore-instruction-prefixes i
)))
1448 (and (simple-instruction-p i
)
1449 (if (member (instruction-is i
) '(:movl
))
1450 (and (not (eq register
(twop-src i
)))
1451 (not (operand-register-indirect-p (twop-src i
) register
))
1452 (not (operand-register-indirect-p (twop-dst i
) register
)))
1453 (not (or (eq register
(isrc i
))
1454 (operand-register-indirect-p (isrc i
) register
)
1455 (eq register
(idst i
))
1456 (operand-register-indirect-p (idst i
) register
)))))
1457 (instruction-is i
:frame-map
)
1458 (and (member register
'(:edx
))
1459 (member (global-funcall-p i
)
1460 '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx
))))))
1461 (register-operand (op)
1462 (and (member op
'(:eax
:ebx
:ecx
:edx
:edi
))
1464 (true-and-equal (x &rest more
)
1465 (declare (dynamic-extent more
))
1466 (and x
(dolist (y more t
)
1469 (uses-stack-frame-p (c)
1471 (some #'stack-frame-operand
(cdr (ignore-instruction-prefixes c
)))))
1472 (load-stack-frame-p (c &optional
(op :movl
))
1473 (stack-frame-operand (twop-src c op
)))
1474 (store-stack-frame-p (c &optional
(op :movl
))
1475 (stack-frame-operand (twop-dst c op
)))
1476 (read-stack-frame-p (c)
1477 (or (load-stack-frame-p c
:movl
)
1478 (load-stack-frame-p c
:addl
)
1479 (load-stack-frame-p c
:subl
)
1480 (load-stack-frame-p c
:cmpl
)
1481 (store-stack-frame-p c
:cmpl
)
1484 (stack-frame-operand (second c
)))))
1485 (in-stack-frame-p (c reg
)
1486 "Does c ensure that reg is in some particular stack-frame location?"
1487 (or (and (load-stack-frame-p c
)
1488 (eq reg
(twop-dst c
))
1489 (stack-frame-operand (twop-src c
)))
1490 (and (store-stack-frame-p c
)
1491 (eq reg
(twop-src c
))
1492 (stack-frame-operand (twop-dst c
)))))
1493 (load-funobj-constant-p (c)
1494 (funobj-constant-operand (twop-src c
:movl
)))
1496 (sub-program-label-p (l)
1498 (eq :sub-program
(car l
))))
1500 (if (or (load-stack-frame-p c
)
1501 (load-funobj-constant-p c
))
1504 (label-here-p (label code
)
1505 "Is <label> at this point in <code>?"
1507 while
(or (symbolp i
)
1508 (instruction-is i
:frame-map
))
1509 thereis
(eq label i
)))
1510 (negate-branch (branch-type)
1512 (:jbe
:ja
) (:ja
:jbe
)
1513 (:jz
:jnz
) (:jnz
:jz
)
1514 (:je
:jne
) (:jne
:je
)
1515 (:jc
:jnc
) (:jnc
:jc
)
1516 (:jl
:jge
) (:jge
:jl
)
1517 (:jle
:jg
) (:jg
:jle
)))
1518 (branch-instruction-label (i &optional jmp
(branch-types '(:je
:jne
:jb
:jnb
:jbe
:jz
:jl
:jnz
1519 :jle
:ja
:jae
:jg
:jge
:jnc
:jc
:js
:jns
)))
1520 "If i is a branch, return the label."
1521 (when jmp
(push :jmp branch-types
))
1522 (let ((i (ignore-instruction-prefixes i
)))
1525 (member (car (second i
)) '(quote muerte.cl
::quote
))
1526 (member (car i
) branch-types
)
1527 (second (second i
)))
1532 (not (member (car i
) '(:jmp
:jecxz
)))
1533 (char= #\J
(char (symbol-name (car i
)) 0))
1534 (warn "Not a branch: ~A / ~A [~A]" i
(symbol-package (caadr i
)) branch-types
)))))
1535 (find-branches-to-label (start-pc label
&optional
(context-size 0))
1536 "Context-size is the number of instructions _before_ the branch you want returned."
1537 (dotimes (i context-size
)
1538 (push nil start-pc
))
1539 (loop for pc on start-pc
1540 as i
= (nth context-size pc
)
1541 as i-label
= (branch-instruction-label i t
)
1542 if
(or (eq label i-label
)
1543 (and (consp i-label
)
1544 (eq :label-plus-one
(car i-label
))))
1546 else if
(let ((sub-program i-label
))
1547 (and (consp sub-program
)
1548 (eq :sub-program
(car sub-program
))))
1549 nconc
(find-branches-to-label (cddr (branch-instruction-label i t
))
1551 else if
(and (not (atom i
))
1552 (tree-search i label
))
1553 nconc
(list 'unknown-label-usage
)))
1554 (optimize-trim-stack-frame (unoptimized-code)
1555 "Any unused local variables on the stack-frame?"
1557 ;; BUILD A MAP OF USED STACK-VARS AND REMAP THEM!
1558 #+ignore
(if (not (and stack-frame-size
1559 (find 'start-stack-frame-setup unoptimized-code
)))
1561 (let ((old-code unoptimized-code
)
1563 ;; copy everything upto start-stack-frame-setup
1564 (loop for i
= (pop old-code
)
1565 do
(push i new-code
)
1567 until
(eq i
'start-stack-frame-setup
))
1568 (assert (eq (car new-code
) 'start-stack-frame-setup
) ()
1569 "no start-stack-frame-setup label, but we already checked!")
1570 (loop for pos downfrom -
8 by
4
1571 as i
= (pop old-code
)
1572 if
(and (consp i
) (eq :pushl
(car i
)) (symbolp (cadr i
)))
1573 collect
(cons pos
(cadr i
))
1574 and do
(unless (find pos old-code
:key
#'read-stack-frame-p
)
1576 ((find pos old-code
:key
#'store-stack-frame-p
)
1577 (warn "Unused local but stored var: ~S" pos
))
1578 ((find pos old-code
:key
#'uses-stack-frame-p
)
1579 (warn "Unused BUT USED local var: ~S" pos
))
1580 (t (warn "Unused local var: ~S" pos
))))
1585 (frame-map-code (unoptimized-code)
1586 "After each label in unoptimized-code, insert a (:frame-map <full-map> <branch-map> <sticky>)
1587 that says which registers are known to hold which stack-frame-locations.
1588 A branch-map is the map that is guaranteed after every branch to the label, i.e. not including
1589 falling below the label."
1590 #+ignore
(warn "unmapped:~{~&~A~}" unoptimized-code
)
1591 (flet ((rcode-map (code)
1592 #+ignore
(when (instruction-is (car code
) :testb
)
1593 (warn "rcoding ~A" code
))
1594 (loop with modifieds
= nil
1595 with registers
= (list :eax
:ebx
:ecx
:edx
)
1596 with local-map
= nil
1599 do
(flet ((add-map (stack reg
)
1600 (when (and (not (member stack modifieds
))
1601 (member reg registers
))
1602 (push (cons stack reg
)
1604 (cond ((instruction-is ii
:frame-map
)
1605 (dolist (m (second ii
))
1606 (add-map (car m
) (cdr m
))))
1607 ((load-stack-frame-p ii
)
1608 (add-map (load-stack-frame-p ii
)
1610 ((store-stack-frame-p ii
)
1611 (add-map (store-stack-frame-p ii
)
1613 (pushnew (store-stack-frame-p ii
)
1615 ((non-destructive-p ii
))
1616 ((branch-instruction-label ii
))
1617 ((simple-instruction-p ii
)
1618 (let ((op (idst ii
)))
1620 ((stack-frame-operand op
)
1621 (pushnew (stack-frame-operand op
) modifieds
))
1623 (setf registers
(delete op registers
))))))
1624 (t #+ignore
(when (instruction-is (car code
) :testb
)
1625 (warn "stopped at ~A" ii
))
1628 (delete-if (lambda (r)
1629 (not (preserves-register-p ii r
)))
1632 #+ignore
(when (instruction-is (car code
) :testb
)
1633 (warn "..map ~A" local-map
))
1634 (return local-map
))))
1635 (loop with next-pc
= 'auto-next
1636 ;; initially (warn "opt: ~{ ~A~%~}" unoptimized-code)
1637 for pc
= unoptimized-code then
(prog1 (if (eq 'auto-next next-pc
) auto-next-pc next-pc
)
1638 (setq next-pc
'auto-next
))
1639 as auto-next-pc
= (cdr unoptimized-code
) then
(cdr pc
)
1640 as p
= (list (car pc
)) ; will be appended.
1641 as i1
= (first pc
) ; current instruction, collected by default.
1642 and i2
= (second pc
)
1644 do
(when (and (symbolp i1
)
1645 (not (and (instruction-is i2
:frame-map
)
1648 (branch-map (reduce (lambda (&optional x y
)
1649 (intersection x y
:test
#'equal
))
1650 (mapcar (lambda (lpc)
1651 (if (eq 'unknown-label-usage lpc
)
1653 (rcode-map (nreverse (xsubseq lpc
0 9)))))
1654 (find-branches-to-label unoptimized-code label
9))))
1655 (full-map (let ((rcode (nreverse (let* ((pos (loop for x on unoptimized-code
1658 finally
(return pos
)))
1659 (back9 (max 0 (- pos
9))))
1660 (subseq unoptimized-code
1662 (if (instruction-uncontinues-p (car rcode
))
1664 (intersection branch-map
(rcode-map rcode
) :test
#'equal
)))))
1665 (when (or full-map branch-map nil
)
1667 (explain nil
"Inserting at ~A frame-map ~S branch-map ~S."
1668 label full-map branch-map
))
1669 (setq p
(list label
`(:frame-map
,full-map
,branch-map
))
1670 next-pc
(if (instruction-is i2
:frame-map
)
1674 (optimize-stack-frame-init (unoptimized-code)
1675 "Look at the function's stack-frame initialization code, and see
1676 if we can optimize that, and/or immediately subsequent loads/stores."
1677 (if (not (find 'start-stack-frame-setup unoptimized-code
))
1679 (let ((old-code unoptimized-code
)
1681 ;; copy everything upto start-stack-frame-setup
1682 (loop for i
= (pop old-code
)
1683 do
(push i new-code
)
1685 until
(eq i
'start-stack-frame-setup
))
1686 (assert (eq (car new-code
) 'start-stack-frame-setup
) ()
1687 "no start-stack-frame-setup label, but we already checked!")
1688 (let* ((frame-map (loop with pos
= -
8
1689 as i
= (pop old-code
)
1690 if
(instruction-is i
:frame-map
)
1693 (and (consp i
) (eq :pushl
(car i
)) (symbolp (cadr i
)))
1702 (mod-p (loop with mod-p
= nil
1703 for i
= `(:frame-map
,(copy-list frame-map
) nil t
)
1706 do
(let ((new-i (cond
1707 ((let ((store-pos (store-stack-frame-p i
)))
1709 (eq (cdr (assoc store-pos frame-map
))
1711 (explain nil
"removed stack-init store: ~S" i
)
1713 ((let ((load-pos (load-stack-frame-p i
)))
1715 (eq (cdr (assoc load-pos frame-map
))
1717 (explain nil
"removed stack-init load: ~S" i
)
1719 ((and (load-stack-frame-p i
)
1720 (assoc (load-stack-frame-p i
) frame-map
))
1721 (let ((old-reg (cdr (assoc (load-stack-frame-p i
)
1723 (explain nil
"load ~S already in ~S."
1725 `(:movl
,old-reg
,(twop-dst i
))))
1726 ((and (instruction-is i
:pushl
)
1727 (stack-frame-operand (idst i
))
1728 (assoc (stack-frame-operand (idst i
))
1731 (cdr (assoc (stack-frame-operand (idst i
))
1733 (explain nil
"push ~S already in ~S."
1735 `(:pushl
,old-reg
)))
1737 (unless (eq new-i i
)
1739 (when (branch-instruction-label new-i t
)
1741 (push `(:frame-map
,(copy-list frame-map
) nil t
)
1744 (push new-i new-code
)
1745 ;; (warn "new-i: ~S, fm: ~S" new-i frame-map)
1747 (delete-if (lambda (map)
1748 ;; (warn "considering: ~S" map)
1749 (not (and (preserves-register-p new-i
(cdr map
))
1750 (preserves-stack-location-p new-i
1753 ;; (warn "Frame-map now: ~S" frame-map)
1754 (when (store-stack-frame-p new-i
)
1755 (loop for map in frame-map
1756 do
(when (= (store-stack-frame-p new-i
)
1758 (setf (cdr map
) (twop-src new-i
)))))))
1760 finally
(return mod-p
))))
1763 (append (nreverse new-code
)
1765 (remove-frame-maps (code)
1766 (remove-if (lambda (x)
1767 (typep x
'(cons (eql :frame-map
) *)))
1769 (let* ((unoptimized-code (frame-map-code (optimize-stack-frame-init unoptimized-code
)))
1770 (code-modified-p nil
)
1771 (stack-frame-used-map (loop with map
= nil
1772 for i in unoptimized-code
1773 do
(let ((x (read-stack-frame-p i
)))
1774 (when x
(pushnew x map
)))
1775 (when (and (instruction-is i
:leal
)
1776 (stack-frame-operand (twop-src i
)))
1777 (let ((x (stack-frame-operand (twop-src i
))))
1778 (when (= (tag :cons
) (ldb (byte 2 0) x
))
1779 (pushnew (+ x -
1) map
)
1780 (pushnew (+ x
3) map
))))
1781 finally
(return map
)))
1783 ;; This loop applies a set of (hard-coded) heuristics on unoptimized-code.
1784 (loop with next-pc
= 'auto-next
1785 ;; initially (warn "opt: ~{ ~A~%~}" unoptimized-code)
1786 for pc
= unoptimized-code then
(prog1 (if (eq 'auto-next next-pc
) auto-next-pc next-pc
)
1787 (setq next-pc
'auto-next
))
1788 as auto-next-pc
= (cdr unoptimized-code
) then
(cdr pc
)
1789 as p
= (list (car pc
)) ; will be appended.
1791 as i
= (first pc
) ; current instruction, collected by default.
1792 and i2
= (second pc
) and i3
= (third pc
) and i4
= (fourth pc
) and i5
= (fifth pc
)
1795 ((and (instruction-is i
:frame-map
)
1796 (instruction-is i2
:frame-map
)
1799 (let ((map (union (second i
) (second i2
) :test
#'equal
)))
1800 (explain nil
"Merged maps:~%~A + ~A~% => ~A"
1801 (second i
) (second i2
) map
)
1802 (setq p
`((:frame-map
,map
))
1803 next-pc
(cddr pc
))))
1804 ((let ((x (store-stack-frame-p i
)))
1805 (and x
(not (member x stack-frame-used-map
))))
1807 (explain nil
"Removed store of unused local var: ~S" i
))
1808 ((and (global-funcall-p i2
'(fast-car))
1809 (global-funcall-p i5
'(fast-cdr))
1810 (true-and-equal (in-stack-frame-p i
:eax
)
1811 (in-stack-frame-p i4
:eax
)))
1812 (let ((call-prefix (if (consp (car i2
)) (car i2
) nil
)))
1814 ((equal i3
'(:pushl
:eax
))
1815 (explain nil
"merge car,push,cdr to cdr-car,push")
1817 `(,call-prefix
:call
1818 (:edi
,(global-constant-offset 'fast-cdr-car
)))
1820 next-pc
(nthcdr 5 pc
)))
1821 ((and (store-stack-frame-p i3
)
1822 (eq :eax
(twop-src i3
)))
1823 (explain nil
"merge car,store,cdr to cdr-car,store")
1825 `(,call-prefix
:call
1826 (:edi
,(global-constant-offset 'fast-cdr-car
)))
1827 `(:movl
:ebx
,(twop-dst i3
)))
1828 next-pc
(nthcdr 5 pc
)))
1829 (t (error "can't deal with cdr-car here: ~{~&~A~}" (subseq pc
0 8))))))
1830 ((flet ((try (place register
&optional map reason
)
1831 "See if we can remove a stack-frame load below current pc,
1832 given the knowledge that <register> is equal to <place>."
1835 (dolist (si (cdr pc
))
1836 (when (and (twop-p si
:cmpl
)
1837 (equal place
(twop-src si
)))
1838 (warn "Reverse cmp not yet dealed with.."))
1840 ((and (twop-p si
:cmpl
)
1841 (equal place
(twop-dst si
)))
1843 ((equal place
(local-load-p si
))
1845 ((or (not (consp si
))
1846 (not (preserves-register-p si register
))
1847 (equal place
(twop-dst si
)))
1850 (remove-if (lambda (m)
1851 (not (preserves-register-p si
(cdr m
))))
1853 (case (instruction-is next-load
)
1855 (let ((pos (position next-load pc
)))
1856 (setq p
(nconc (subseq pc
0 pos
)
1857 (if (or (eq register
(twop-dst next-load
))
1858 (find-if (lambda (m)
1859 (and (eq (twop-dst next-load
) (cdr m
))
1860 (= (car m
) (stack-frame-operand place
))))
1863 (list `(:movl
,register
,(twop-dst next-load
)))))
1864 next-pc
(nthcdr (1+ pos
) pc
))
1865 (explain nil
"preserved load/store .. load ~S of place ~S because ~S."
1866 next-load place reason
)))
1868 (let ((pos (position next-load pc
)))
1869 (setq p
(nconc (subseq pc
0 pos
)
1870 (list `(:cmpl
,(twop-src next-load
) ,register
)))
1871 next-pc
(nthcdr (1+ pos
) pc
))
1872 (explain nil
"preserved load/store..cmp: ~S" p next-load
))))
1873 (if next-load t nil
))))
1874 (or (when (instruction-is i
:frame-map
)
1875 (loop for
(place . register
) in
(second i
)
1876 ;;; do (warn "map try ~S ~S: ~S" place register
1877 ;;; (try place register))
1878 thereis
(try `(:ebp
,place
) register
(second i
) :frame-map
)))
1879 (try (or (local-load-p i
)
1880 (and (store-stack-frame-p i
)
1882 (if (store-stack-frame-p i
)
1887 (instruction-is i2
:frame-map
)
1888 (load-stack-frame-p i3
)
1890 (cdr (assoc (load-stack-frame-p i3
) (third i2
))))
1891 (not (assoc (load-stack-frame-p i3
) (second i2
))))
1892 (let ((reg (cdr (assoc (load-stack-frame-p i3
) (third i2
)))))
1893 (explain nil
"factor out load from loop: ~S" i3
)
1894 (assert (eq reg
(twop-dst i3
)))
1895 (setq p
(if (eq reg
(twop-dst i3
))
1897 (append (list i3 i i2
)
1898 `((:movl
,reg
,(twop-dst i3
)))))
1899 next-pc
(cdddr pc
))))
1900 ;; ((:movl <foo> <bar>) label (:movl <zot> <bar>))
1901 ;; => (label (:movl <zot> <bar>))
1902 ((and (instruction-is i
:movl
)
1904 (and (not (branch-instruction-label i2
))
1905 (symbolp (twop-dst i
))
1906 (doesnt-read-register-p i2
(twop-dst i
))))
1907 (instruction-is i3
:frame-map
)
1908 (instruction-is i4
:movl
)
1909 (equal (twop-dst i
) (twop-dst i4
))
1910 (not (and (symbolp (twop-dst i
))
1911 (operand-register-indirect-p (twop-src i4
)
1913 (setq p
(list i2 i3 i4
)
1914 next-pc
(nthcdr 4 pc
))
1915 (explain nil
"Removed redundant store before ~A: ~A"
1916 i2
(subseq pc
0 4)))
1917 ((and (instruction-is i
:movl
)
1918 (not (branch-instruction-label i2
))
1919 (symbolp (twop-dst i
))
1920 (doesnt-read-register-p i2
(twop-dst i
))
1921 (instruction-is i3
:movl
)
1922 (equal (twop-dst i
) (twop-dst i3
))
1923 (not (and (symbolp (twop-dst i
))
1924 (operand-register-indirect-p (twop-src i3
)
1926 (setq p
(list i2 i3
)
1927 next-pc
(nthcdr 3 pc
))
1928 (explain nil
"Removed redundant store before ~A: ~A"
1929 i2
(subseq pc
0 3)))
1931 ((let ((stack-pos (store-stack-frame-p i
)))
1933 (loop with search-pc
= (cdr pc
)
1936 for ii
= (pop search-pc
)
1937 thereis
(eql stack-pos
1938 (store-stack-frame-p ii
))
1939 while
(or (global-funcall-p ii
)
1940 (and (simple-instruction-p ii
)
1942 (uses-stack-frame-p ii
))))))
1945 (store-stack-frame-p i4
))
1948 (or (global-funcall-p ii
)
1949 (and (simple-instruction-p ii
)
1951 (uses-stack-frame-p ii
))))))
1955 (explain t
"removing redundant store at ~A"
1956 (subseq pc
0 (min 10 (length pc
)))))
1957 ((and (member (instruction-is i
)
1958 '(:cmpl
:cmpb
:cmpw
:testl
:testb
:testw
))
1959 (member (instruction-is i2
)
1960 '(:cmpl
:cmpb
:cmpw
:testl
:testb
:testw
)))
1962 next-pc
(nthcdr 2 pc
))
1963 (explain nil
"Trimmed double test: ~A" (subseq pc
0 4)))
1964 ;; ((:jmp x) ...(no labels).... x ..)
1966 ((let ((x (branch-instruction-label i t nil
)))
1967 (and (position x
(cdr pc
))
1968 (not (find-if #'symbolp
(cdr pc
) :end
(position x
(cdr pc
))))))
1969 (explain nil
"jmp x .. x: ~W"
1970 (subseq pc
0 (1+ (position (branch-instruction-label i t nil
)
1973 next-pc
(member (branch-instruction-label i t nil
) pc
)))
1974 ;; (:jcc 'x) .... x (:jmp 'y) ..
1975 ;; => (:jcc 'y) .... x (:jmp 'y) ..
1976 ((let* ((from (branch-instruction-label i t
))
1977 (dest (member (branch-instruction-label i t
)
1979 (to (branch-instruction-label (if (instruction-is (second dest
) :frame-map
)
1983 (when (and from to
(not (eq from to
)))
1984 (setq p
(list `(,(car i
) ',to
)))
1985 (explain nil
"branch redirect from ~S to ~S" from to
)
1987 ;; remove back-to-back std/cld
1988 ((and (instruction-is i
:cld
)
1989 (instruction-is i2
:std
))
1990 (explain nil
"removing back-to-back cld, std.")
1991 (setq p nil next-pc
(cddr pc
)))
1992 ;; remove branch no-ops.
1993 ((and (branch-instruction-label i t
)
1994 (label-here-p (branch-instruction-label i t
)
1996 (explain nil
"branch no-op: ~A" i
)
1999 (null (symbol-package i
))
2000 (null (find-branches-to-label unoptimized-code i
))
2001 (not (member i keep-labels
)))
2003 next-pc
(if (instruction-is i2
:frame-map
)
2006 (explain nil
"unused label: ~S" i
))
2007 ;; ((:jcc 'label) (:jmp 'y) label) => ((:jncc 'y) label)
2008 ((and (branch-instruction-label i
)
2009 (branch-instruction-label i2 t nil
)
2011 (eq (branch-instruction-label i
) i3
))
2012 (setq p
(list `(,(negate-branch (first i
))
2013 ',(branch-instruction-label i2 t nil
)))
2014 next-pc
(nthcdr 2 pc
))
2015 (explain nil
"collapsed double negative branch to ~S: ~A." i3 p
))
2016 ((and (branch-instruction-label i
)
2017 (instruction-is i2
:frame-map
)
2018 (branch-instruction-label i3 t nil
)
2020 (eq (branch-instruction-label i
) i4
))
2021 (setq p
(list `(,(negate-branch (first i
))
2022 ',(branch-instruction-label i3 t nil
)))
2023 next-pc
(nthcdr 3 pc
))
2024 (explain nil
"collapsed double negative branch to ~S: ~A." i4 p
))
2025 ((and (twop-p i
:movl
)
2026 (register-operand (twop-src i
))
2027 (register-operand (twop-dst i
))
2029 (eq (twop-dst i
) (twop-dst i2
))
2030 (register-indirect-operand (twop-src i2
) (twop-dst i
)))
2031 (setq p
(list `(:movl
(,(twop-src i
)
2032 ,(register-indirect-operand (twop-src i2
)
2035 next-pc
(nthcdr 2 pc
))
2036 (explain nil
"(movl edx eax) (movl (eax <z>) eax) => (movl (edx <z>) eax: ~S"
2038 ((and (twop-p i
:movl
)
2039 (instruction-is i2
:pushl
)
2040 (eq (twop-dst i
) (second i2
))
2042 (eq (twop-dst i
) (twop-dst i3
)))
2043 (setq p
(list `(:pushl
,(twop-src i
)))
2044 next-pc
(nthcdr 2 pc
))
2045 (explain nil
"(movl <z> :eax) (pushl :eax) => (pushl <z>): ~S" p
))
2046 ((and (instruction-uncontinues-p i
)
2047 (not (or (symbolp i2
)
2048 #+ignore
(member (instruction-is i2
) '(:foobar
)))))
2049 (do ((x (cdr pc
) (cdr x
)))
2052 ((not (or (symbolp (car x
))
2053 #+ignore
(member (instruction-is (car x
)) '(:foobar
))))
2054 (explain nil
"Removing unreachable code ~A after ~A." (car x
) i
))
2058 ((and (store-stack-frame-p i
)
2059 (load-stack-frame-p i2
)
2060 (load-stack-frame-p i3
)
2061 (= (store-stack-frame-p i
)
2062 (load-stack-frame-p i3
))
2063 (not (eq (twop-dst i2
) (twop-dst i3
))))
2064 (setq p
(list i
`(:movl
,(twop-src i
) ,(twop-dst i3
)) i2
)
2065 next-pc
(nthcdr 3 pc
))
2066 (explain nil
"store, z, load => store, move, z: ~A" p
))
2067 ((and (instruction-is i
:movl
)
2068 (member (twop-dst i
) '(:eax
:ebx
:ecx
:edx
))
2069 (instruction-is i2
:pushl
)
2070 (not (member (second i2
) '(:eax
:ebx
:ecx
:edx
)))
2071 (equal (twop-src i
) (second i2
)))
2072 (setq p
(list i
`(:pushl
,(twop-dst i
)))
2073 next-pc
(nthcdr 2 pc
))
2074 (explain t
"load, push => load, push reg."))
2075 ((and (instruction-is i
:movl
)
2076 (member (twop-src i
) '(:eax
:ebx
:ecx
:edx
))
2077 (instruction-is i2
:pushl
)
2078 (not (member (second i2
) '(:eax
:ebx
:ecx
:edx
)))
2079 (equal (twop-dst i
) (second i2
)))
2080 (setq p
(list i
`(:pushl
,(twop-src i
)))
2081 next-pc
(nthcdr 2 pc
))
2082 (explain nil
"store, push => store, push reg: ~S ~S" i i2
))
2083 ;;; ((and (instruction-is i :cmpl)
2084 ;;; (true-and-equal (stack-frame-operand (twop-dst i))
2085 ;;; (load-stack-frame-p i3))
2086 ;;; (branch-instruction-label i2))
2087 ;;; (setf p (list i3
2088 ;;; `(:cmpl ,(twop-src i) ,(twop-dst i3))
2090 ;;; next-pc (nthcdr 3 pc))
2091 ;;; (explain t "~S ~S ~S => ~S" i i2 i3 p))
2092 ((and (instruction-is i
:pushl
)
2093 (instruction-is i3
:popl
)
2094 (store-stack-frame-p i2
)
2095 (store-stack-frame-p i4
)
2096 (eq (idst i3
) (twop-src i4
)))
2098 `(:movl
,(idst i
) ,(twop-dst i4
))
2099 `(:movl
,(idst i
) ,(idst i3
)))
2100 next-pc
(nthcdr 4 pc
))
2101 (explain nil
"~S => ~S" (subseq pc
0 4) p
))
2103 ((let ((i6 (nth 6 pc
)))
2104 (and (global-funcall-p i2
'(fast-car))
2105 (global-funcall-p i6
'(fast-cdr))
2106 (load-stack-frame-p i
)
2107 (eq :eax
(twop-dst i
))
2109 ((and (equal i
'(:movl
:ebx
:eax
))
2110 (global-funcall-p i2
'(fast-car fast-cdr
)))
2111 (let ((newf (ecase (global-funcall-p i2
'(fast-car fast-cdr
))
2112 (fast-car 'fast-car-ebx
)
2113 (fast-cdr 'fast-cdr-ebx
))))
2114 (setq p
`((:call
(:edi
,(global-constant-offset newf
))))
2115 next-pc
(nthcdr 2 pc
))
2116 (explain nil
"Changed [~S ~S] to ~S" i i2 newf
)))
2117 ((and (equal i
'(:movl
:eax
:ebx
))
2118 (global-funcall-p i2
'(fast-car-ebx fast-cdr-ebx
)))
2119 (let ((newf (ecase (global-funcall-p i2
'(fast-car-ebx fast-cdr-ebx
))
2120 (fast-car-ebx 'fast-car
)
2121 (fast-cdr-ebx 'fast-cdr
))))
2122 (setq p
`((:call
(:edi
,(global-constant-offset newf
))))
2123 next-pc
(nthcdr 2 pc
))
2124 (explain nil
"Changed [~S ~S] to ~S" i i2 newf
)))
2126 ((and (global-funcall-p i
'(fast-cdr))
2127 (global-funcall-p i2
'(fast-cdr))
2128 (global-funcall-p i3
'(fast-cdr)))
2129 (setq p
`((:call
(:edi
,(global-constant-offset 'fast-cdddr
))))
2130 next-pc
(nthcdr 3 pc
))
2131 (explain nil
"Changed (cdr (cdr (cdr :eax))) to (cdddr :eax)."))
2132 ((and (global-funcall-p i
'(fast-cdr))
2133 (global-funcall-p i2
'(fast-cdr)))
2134 (setq p
`((:call
(:edi
,(global-constant-offset 'fast-cddr
))))
2135 next-pc
(nthcdr 2 pc
))
2136 (explain nil
"Changed (cdr (cdr :eax)) to (cddr :eax)."))
2137 ((and (load-stack-frame-p i
) (eq :eax
(twop-dst i
))
2138 (global-funcall-p i2
'(fast-car fast-cdr
))
2139 (preserves-stack-location-p i3
(load-stack-frame-p i
))
2140 (preserves-register-p i3
:ebx
)
2141 (eql (load-stack-frame-p i
)
2142 (load-stack-frame-p i4
)))
2143 (let ((newf (ecase (global-funcall-p i2
'(fast-car fast-cdr
))
2144 (fast-car 'fast-car-ebx
)
2145 (fast-cdr 'fast-cdr-ebx
))))
2146 (setq p
`((:movl
,(twop-src i
) :ebx
)
2147 (:call
(:edi
,(global-constant-offset newf
)))
2149 ,@(unless (eq :ebx
(twop-dst i4
))
2150 `((:movl
:ebx
,(twop-dst i4
)))))
2151 next-pc
(nthcdr 4 pc
))
2152 (explain nil
"load around ~A: ~{~&~A~}~%=>~% ~{~&~A~}"
2153 newf
(subseq pc
0 5) p
))))
2154 do
(unless (eq p original-p
) ; auto-detect whether any heuristic fired..
2155 #+ignore
(warn "at ~A, ~A inserted ~A" i i2 p
)
2156 #+ignore
(warn "modified at ~S ~S ~S" i i2 i3
)
2157 (setf code-modified-p t
))
2160 (apply #'optimize-code-internal optimized-code
(1+ recursive-count
) key-args
)
2161 (optimize-trim-stack-frame (remove-frame-maps unoptimized-code
)))))))
2162 ;;;; Compiler internals
2164 (defclass binding
()
2167 :accessor binding-name
)
2169 :accessor binding-env
)
2171 :initarg
:declarations
2172 :accessor binding-declarations
)
2174 :accessor binding-extent-env
2177 (defmethod (setf binding-env
) :after
(env (binding binding
))
2178 (unless (binding-extent-env binding
)
2179 (setf (binding-extent-env binding
) env
)))
2181 (defmethod print-object ((object binding
) stream
)
2182 (print-unreadable-object (object stream
:type t
:identity t
)
2183 (when (slot-boundp object
'name
)
2184 (format stream
"name: ~S~@[->~S~]~@[ %~A~]"
2185 (and (slot-boundp object
'name
)
2186 (binding-name object
))
2187 (when (and (binding-target object
)
2188 (not (eq object
(binding-target object
))))
2189 (binding-name (forwarding-binding-target object
)))
2190 (when (and (slot-exists-p object
'store-type
)
2191 (slot-boundp object
'store-type
)
2192 (binding-store-type object
))
2193 (or (apply #'encoded-type-decode
2194 (binding-store-type object
))
2197 (defclass constant-object-binding
(binding)
2200 :reader constant-object
)))
2202 (defmethod binding-lended-p ((binding constant-object-binding
)) nil
)
2203 (defmethod binding-store-type ((binding constant-object-binding
))
2204 (multiple-value-list (type-specifier-encode `(eql ,(constant-object binding
)))))
2207 (defclass operator-binding
(binding) ())
2209 (defclass macro-binding
(operator-binding)
2212 :accessor macro-binding-expander
)))
2214 (defclass symbol-macro-binding
(binding)
2217 :accessor macro-binding-expander
)))
2219 (defclass variable-binding
(binding)
2220 ((lending ; a property-list
2222 :accessor binding-lending
)
2223 (store-type ; union of all types ever stored here
2225 ;; :initarg :store-type
2226 :accessor binding-store-type
)))
2228 (defmethod binding-lended-p ((binding variable-binding
))
2229 (and (getf (binding-lending binding
) :lended-to
)
2230 (not (eq :unused
(getf (binding-lending binding
) :lended-to
)))))
2232 (defclass lexical-binding
(variable-binding) ())
2233 (defclass located-binding
(lexical-binding) ())
2235 (defclass function-binding
(operator-binding located-binding
)
2238 :accessor function-binding-funobj
)
2240 :initarg
:parent-funobj
2241 :reader function-binding-parent
)))
2243 (defclass funobj-binding
(function-binding) ())
2244 (defclass closure-binding
(function-binding located-binding
) ())
2245 (defclass lambda-binding
(function-binding) ())
2247 (defclass temporary-name
(located-binding)
2250 (defclass borrowed-binding
(located-binding)
2252 :initarg
:reference-slot
2253 :accessor borrowed-binding-reference-slot
)
2255 :initarg
:target-binding
2256 :reader borrowed-binding-target
)
2260 :accessor borrowed-binding-usage
)))
2262 (defclass lexical-borrowed-binding
(borrowed-binding)
2263 ((stack-frame-distance
2264 :initarg
:stack-frame-distance
2265 :reader stack-frame-distance
))
2266 (:documentation
"A closure with lexical extent borrows bindings using this class."))
2268 (defclass indefinite-borrowed-binding
(borrowed-binding)
2270 :initarg
:reference-slot
2271 :reader borrowed-binding-reference-slot
)))
2274 (defclass constant-reference-binding
(lexical-binding)
2277 :reader constant-reference-object
)))
2280 (defmethod print-object ((object constant-reference-binding
) stream
)
2281 (print-unreadable-object (object stream
:type t
:identity t
)
2282 (format stream
"object: ~S" (constant-reference-object object
)))
2285 (defclass forwarding-binding
(lexical-binding)
2287 :initarg
:target-binding
2288 :accessor forwarding-binding-target
)))
2290 (defmethod binding-funobj ((binding binding
))
2291 (movitz-environment-funobj (binding-env binding
)))
2293 (defmethod binding-funobj ((binding forwarding-binding
))
2294 (movitz-environment-funobj (binding-env (forwarding-binding-target binding
))))
2296 (defclass function-argument
(located-binding) ())
2297 (defclass edx-function-argument
(function-argument) ())
2299 (defclass positional-function-argument
(function-argument)
2302 :reader function-argument-argnum
)))
2304 (defclass required-function-argument
(positional-function-argument) ())
2306 (defclass register-required-function-argument
(required-function-argument) ())
2307 (defclass fixed-required-function-argument
(required-function-argument)
2310 :reader binding-numargs
)))
2311 (defclass floating-required-function-argument
(required-function-argument) ())
2313 (defclass non-required-function-argument
(function-argument)
2316 :reader optional-function-argument-init-form
)
2318 :initarg supplied-p-var
2319 :reader optional-function-argument-supplied-p-var
)))
2321 (defclass optional-function-argument
(non-required-function-argument positional-function-argument
) ())
2323 (defclass supplied-p-function-argument
(function-argument) ())
2325 (defclass rest-function-argument
(positional-function-argument) ())
2327 (defclass keyword-function-argument
(non-required-function-argument)
2329 :initarg
:keyword-name
2330 :reader keyword-function-argument-keyword-name
)))
2332 (defclass dynamic-binding
(variable-binding) ())
2334 (defclass shadowing-binding
(binding) ())
2336 (defclass shadowing-dynamic-binding
(dynamic-binding shadowing-binding
)
2338 :initarg
:shadowed-variable
2339 :reader shadowed-variable
)
2341 :initarg
:shadowing-variable
2342 :reader shadowing-variable
)))
2344 (defmethod binding-store-type ((binding dynamic-binding
))
2345 (multiple-value-list (type-specifier-encode t
)))
2347 (defun stack-frame-offset (stack-frame-position)
2348 (* -
4 (1+ stack-frame-position
)))
2350 (defun argument-stack-offset (binding)
2351 (check-type binding fixed-required-function-argument
)
2352 (argument-stack-offset-shortcut (binding-numargs binding
)
2353 (function-argument-argnum binding
)))
2355 (defun argument-stack-offset-shortcut (numargs argnum
)
2356 "For a function of <numargs> arguments, locate the ebp-relative position
2357 of argument <argnum>."
2358 (* 4 (- numargs -
1 argnum
)))
2362 ;;; New style of locating bindings. The point is to not side-effect the binding objects.
2364 (defun new-binding-location (binding map
&key
(default nil default-p
))
2365 (check-type binding
(or binding
(cons keyword binding
)))
2366 (let ((x (assoc binding map
)))
2370 (t (error "No location for ~S." binding
)))))
2372 (defun make-binding-map () nil
)
2374 (defun new-binding-located-p (binding map
)
2375 (check-type binding
(or null binding
(cons keyword binding
)))
2376 (and (assoc binding map
) t
))
2378 (defun frame-map-size (map)
2382 (if (integerp (cdr x
))
2386 (defun frame-map-next-free-location (frame-map env
&optional
(size 1))
2387 (labels ((stack-location (binding)
2388 (if (typep binding
'forwarding-binding
)
2389 (stack-location (forwarding-binding-target binding
))
2390 (new-binding-location binding frame-map
:default nil
)))
2391 (env-extant (env1 env2
)
2392 "Is env1 active whenever env2 is active?"
2397 ;; (warn "~S shadowed by ~S" env env2)
2399 (t (env-extant env1
(movitz-environment-extent-uplink env2
))))))
2400 (let ((frame-size (frame-map-size frame-map
)))
2401 (or (loop for location from
1 to frame-size
2403 (loop for sub-location from location below
(+ location size
)
2405 (find-if (lambda (b-loc)
2406 (destructuring-bind (binding . binding-location
)
2408 (or (and (eq binding nil
) ; nil means "back off!"
2409 (eql sub-location binding-location
))
2410 (and (not (bindingp binding
))
2411 (eql sub-location binding-location
))
2412 (and (bindingp binding
)
2413 (eql sub-location
(stack-location binding
))
2417 (or (env-extant (binding-env b
) env
)
2418 (env-extant env
(binding-env b
))
2419 (when (typep b
'forwarding-binding
)
2420 (z (forwarding-binding-target b
)))))))
2424 (1+ frame-size
))))) ; no free location found, so grow frame-size.
2426 (define-setf-expander new-binding-location
(binding map-place
&environment env
)
2427 (multiple-value-bind (temps values stores setter getter
)
2428 (get-setf-expansion map-place env
)
2429 (let ((new-value (gensym))
2430 (binding-var (gensym)))
2431 (values (append temps
(list binding-var
))
2432 (append values
(list binding
))
2434 `(let ((,(car stores
) (progn
2435 (assert (or (null binding
)
2436 (not (new-binding-located-p ,binding-var
,getter
))))
2437 (check-type ,new-value
(or keyword
2440 (cons (eql :argument-stack
) *)))
2441 (acons ,binding-var
,new-value
,getter
))))
2444 `(new-binding-location ,binding-var
,getter
)))))
2446 ;;; Objects with dynamic extent may be located on the stack-frame, which at
2447 ;;; compile-time is represented with this structure.
2449 ;;;(defclass stack-allocated-object ()
2451 ;;; ;; Size in words (4 octets) this object occupies in the stack-frame.
2455 ;;; ;; Stack-frame offset (in words) this object is allocated to.
2456 ;;; :accessor location)))
2462 (defun ignore-instruction-prefixes (instruction)
2463 (if (and (consp instruction
)
2464 (listp (car instruction
)))
2468 (defun instruction-sub-program (instruction)
2469 "When an instruction contains a sub-program, return that program, and
2470 the sub-program options (&optional label) as secondary value."
2471 (let ((instruction (ignore-instruction-prefixes instruction
)))
2472 (and (consp instruction
)
2473 (consp (second instruction
))
2474 (symbolp (car (second instruction
)))
2475 (string= 'quote
(car (second instruction
)))
2476 (let ((x (second (second instruction
))))
2478 (eq :sub-program
(car x
))
2482 (defun instruction-is (instruction &optional operator
)
2483 (and (listp instruction
)
2484 (if (member (car instruction
) '(:globally
:locally
))
2485 (instruction-is (second instruction
) operator
)
2486 (let ((instruction (ignore-instruction-prefixes instruction
)))
2488 (eq operator
(car instruction
))
2489 (car instruction
))))))
2491 (defun instruction-uncontinues-p (instruction)
2492 "Is it impossible for control to return after instruction?"
2493 (or (member (instruction-is instruction
)
2499 #+ignore
(defun sub-environment-p (env1 env2
)
2503 (t (sub-environment-p (movitz-environment-uplink env1
) env2
))))
2505 (defun find-code-constants-and-jumpers (code &key include-programs
)
2506 "Return code's constants (a plist of constants and their usage-counts) and jumper-sets."
2507 (let (jumper-sets constants key-args-set
)
2508 (labels ((process-binding (binding)
2509 "Some bindings are really references to constants."
2511 (constant-object-binding
2512 (let ((object (movitz-read (constant-object binding
))))
2513 (when (typep object
'movitz-heap-object
)
2514 (incf (getf constants object
0)))))
2516 (process-binding (forwarding-binding-target binding
)))
2518 (let ((funobj (function-binding-funobj binding
)))
2519 (incf (getf constants funobj
0))))
2522 (error "No function-binding now..: ~S" binding
))))
2524 "This local function side-effects the variables jumper-sets and constants."
2525 (loop for instruction in sub-code
2526 do
(case (instruction-is instruction
)
2527 ((:local-function-init
:load-lambda
)
2528 (let* ((binding (second instruction
))
2529 (funobj (function-binding-funobj binding
)))
2530 (unless (eq :unused
(movitz-funobj-extent funobj
))
2531 (incf (getf constants funobj
0))
2532 (dolist (binding (borrowed-bindings funobj
))
2533 (process-binding binding
)))))
2534 ((:load-lexical
:lend-lexical
:call-lexical
)
2535 (process-binding (second instruction
)))
2537 (let ((object (movitz-read (second instruction
))))
2538 (when (typep object
'movitz-heap-object
)
2539 (incf (getf constants object
0)))))
2541 (destructuring-bind (name set
)
2543 (assert (not (getf jumper-sets name
)) ()
2544 "Duplicate jumper declaration for ~S." name
)
2545 (setf (getf jumper-sets name
) set
)))
2546 (:declare-key-arg-set
2547 (setf key-args-set
(cdr instruction
)))
2548 (t (when (listp instruction
)
2549 (dolist (binding (find-read-bindings instruction
))
2550 (process-binding binding
)))))
2551 do
(let ((sub (instruction-sub-program instruction
)))
2552 (when sub
(process sub
))))))
2554 (map nil
#'process include-programs
))
2555 (loop for key-arg in key-args-set
2556 do
(remf constants key-arg
))
2557 (values constants jumper-sets key-args-set
)))
2559 (defun layout-funobj-vector (constants key-args-constants jumper-sets borrowing-bindings
)
2560 (let* ((jumpers (loop with x
2561 for set in
(cdr jumper-sets
) by
#'cddr
2562 unless
(search set x
)
2563 do
(setf x
(nconc x
(copy-list set
)))
2564 finally
(return x
)))
2565 (num-jumpers (length jumpers
))
2566 (stuff (append (mapcar (lambda (c)
2569 (when key-args-constants
2570 (list (cons (movitz-read 0)
2572 (sort (loop for
(constant count
) on constants by
#'cddr
2573 unless
(or (eq constant
*movitz-nil
*)
2574 (eq constant
(image-t-symbol *image
*)))
2575 collect
(cons constant count
))
2577 (values (append jumpers
2579 (movitz-read (car x
)))
2581 (make-list (length borrowing-bindings
)
2582 :initial-element
*movitz-nil
*))
2584 (loop for
(name set
) on jumper-sets by
#'cddr
2585 collect
(cons name set
))
2586 (loop for borrowing-binding in borrowing-bindings
2587 as pos upfrom
(+ num-jumpers
(length stuff
))
2588 collect
(cons borrowing-binding pos
)))))
2590 (defun movitz-funobj-intern-constant (funobj obj
)
2592 (let ((cobj (movitz-read obj
)))
2593 (+ (slot-offset 'movitz-funobj
'constant0
)
2595 (let* ((pos (position cobj
(movitz-funobj-const-list funobj
)
2596 :start
(movitz-funobj-num-jumpers funobj
))))
2598 "Couldn't find constant ~S in ~S's set of constants ~S."
2599 obj funobj
(movitz-funobj-const-list funobj
))
2602 (defun compute-free-registers (pc distance funobj frame-map
2603 &key
(free-registers '(:ecx
:eax
:ebx
:edx
)))
2604 "Return set of free register, and whether there may be more registers
2605 free later, with a more specified frame-map."
2606 (loop with free-so-far
= free-registers
2607 repeat distance for i in pc
2608 while
(not (null free-so-far
))
2611 ((and (instruction-is i
:init-lexvar
)
2612 (typep (second i
) 'required-function-argument
)) ; XXX
2613 (destructuring-bind (binding &key init-with-register init-with-type
2614 protect-registers protect-carry
)
2616 (declare (ignore protect-carry init-with-type
))
2617 (when init-with-register
2618 (setf free-so-far
(remove-if (lambda (x)
2619 (if (new-binding-located-p binding frame-map
)
2620 (eq x
(new-binding-location binding frame-map
))
2621 (or (eq x init-with-register
)
2622 (member x protect-registers
))))
2624 (t (case (instruction-is i
)
2626 (return nil
)) ; a label, most likely
2627 ((:declare-key-arg-set
:declare-label-set
)
2629 ((:lexical-control-transfer
:load-lambda
)
2630 (return nil
)) ; not sure about these.
2633 (remove-if (lambda (r)
2638 (remove :ecx free-so-far
)))
2641 (set-difference free-so-far
'(:eax
:edx
))))
2642 ((:into
:clc
:stc
:int
))
2643 ((:jmp
:jnz
:je
:jne
:jz
:jge
:jae
:jnc
:jbe
)
2645 (remove :push free-so-far
)))
2648 (remove-if (lambda (r)
2654 (set-difference free-so-far
'(:eax
:edx
))))
2655 ((:movb
:testb
:andb
:cmpb
)
2657 (remove-if (lambda (r)
2658 (and (not (eq r
:push
))
2659 (or (tree-search i r
)
2660 (tree-search i
(register32-to-low8 r
)))))
2662 ((:sarl
:shrl
:shll
:xorl
:cmpl
:leal
:btl
:sbbl
:cdq
2663 :movl
:movzxw
:movzxb
:testl
:andl
:addl
:subl
:imull
:idivl
)
2665 (remove-if (lambda (r)
2668 ((:load-constant
:load-lexical
:store-lexical
:cons-get
:endp
:incf-lexvar
:init-lexvar
)
2669 (assert (gethash (instruction-is i
) *extended-code-expanders
*))
2671 ((and (instruction-is i
:init-lexvar
) ; special case..
2672 (typep (second i
) 'forwarding-binding
)))
2673 (t (unless (can-expand-extended-p i frame-map
)
2674 ;; (warn "can't expand ~A from ~A" i frame-map)
2675 (return (values nil t
)))
2676 (let ((exp (expand-extended-code i funobj frame-map
)))
2677 (when (tree-search exp
'(:call
:local-function-init
))
2679 (remove-if (lambda (r)
2683 (remove-if (lambda (r)
2684 (and (not (eq r
:push
))
2685 (or (tree-search exp r
)
2686 (tree-search exp
(register32-to-low8 r
)))))
2688 ((:local-function-init
)
2689 (destructuring-bind (binding)
2691 (unless (typep binding
'funobj-binding
)
2693 (t #+ignore
(warn "Dist ~D stopped by ~A"
2696 ;; do (warn "after ~A: ~A" i free-so-far)
2697 finally
(return free-so-far
)))
2699 (defun try-locate-in-register (binding var-counts funobj frame-map
)
2700 "Try to locate binding in a register. Return a register, or
2701 nil and :not-now, or :never.
2702 This function is factored out from assign-bindings."
2703 (assert (not (typep binding
'forwarding-binding
)))
2704 (let* ((count-init-pc (gethash binding var-counts
))
2705 (count (car count-init-pc
))
2706 (init-pc (second count-init-pc
)))
2707 #+ignore
(warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc
)
2709 ((and (not *compiler-allow-transients
*)
2710 (typep binding
'function-argument
))
2711 (values nil
:never
))
2712 ((binding-lended-p binding
)
2713 ;; We can't lend a register.
2714 (values nil
:never
))
2717 (assert (instruction-is (first init-pc
) :init-lexvar
))
2718 (destructuring-bind (init-binding &key init-with-register init-with-type
2719 protect-registers protect-carry
)
2720 (cdr (first init-pc
))
2721 (declare (ignore protect-registers protect-carry init-with-type
))
2722 (assert (eq binding init-binding
))
2723 (multiple-value-bind (load-instruction binding-destination distance
)
2724 (loop for i in
(cdr init-pc
) as distance upfrom
0
2725 do
(when (not (instruction-is i
:init-lexvar
))
2726 (multiple-value-bind (read-bindings read-destinations
)
2727 (find-read-bindings i
)
2728 (let ((pos (position binding read-bindings
:test
#'binding-eql
)))
2730 (return (values i
(nth pos read-destinations
) distance
)))))))
2731 (declare (ignore load-instruction
))
2732 (multiple-value-bind (free-registers more-later-p
)
2733 (and distance
(compute-free-registers (cdr init-pc
) distance funobj frame-map
))
2735 (when (string= 'num-jumpers
(binding-name binding
))
2736 (warn "load: ~S, dist: ~S, dest: ~S" load-instruction distance binding-destination
)
2737 (warn "free: ~S, more: ~S" free-registers more-later-p
))
2738 (let ((free-registers-no-ecx (remove :ecx free-registers
)))
2740 ((member binding-destination free-registers-no-ecx
)
2741 binding-destination
)
2742 ((and (not (typep binding
'(or fixed-required-function-argument
2743 register-required-function-argument
)))
2744 (member binding-destination free-registers
))
2745 binding-destination
)
2746 ((member init-with-register free-registers
)
2748 ((and (member :ecx free-registers
)
2749 (not (typep binding
'function-argument
))
2750 (or (eq :untagged-fixnum-ecx binding-destination
)
2751 (eq :untagged-fixnum-ecx init-with-register
)))
2752 :untagged-fixnum-ecx
)
2753 ((and (binding-store-type binding
)
2754 (member :ecx free-registers
)
2755 (not (typep binding
'(or fixed-required-function-argument
2756 register-required-function-argument
)))
2757 (multiple-value-call #'encoded-subtypep
2758 (values-list (binding-store-type binding
))
2759 (type-specifier-encode '(or integer character
))))
2761 ((not (null free-registers-no-ecx
))
2762 (first free-registers-no-ecx
))
2764 (values nil
:not-now
))
2765 ((and distance
(typep binding
'temporary-name
))
2766 ;; We might push/pop this variable
2767 (multiple-value-bind (push-available-p maybe-later
)
2768 (compute-free-registers (cdr init-pc
) distance funobj frame-map
2769 :free-registers
'(:push
))
2770 ;; (warn "pushing.. ~S ~A ~A" binding push-available-p maybe-later)
2775 (values nil
:not-now
))
2776 (t (values nil
:never
)))))
2777 (t (values nil
:never
))))))))
2778 (t (values nil
:never
)))))
2780 (defun discover-variables (code function-env
)
2781 "Iterate over CODE, and take note in the hash-table VAR-COUNTER which ~
2782 variables CODE references that are lexically bound in ENV."
2783 (check-type function-env function-env
)
2784 ;; (print-code 'discover code)
2785 (let ((var-counter (make-hash-table :test
#'eq
:size
40)))
2786 (labels ((record-binding-used (binding)
2787 (let ((count-init-pc (or (gethash binding var-counter
)
2788 (setf (gethash binding var-counter
)
2790 (setf (third count-init-pc
) t
)
2791 (when (typep binding
'forwarding-binding
)
2792 (record-binding-used (forwarding-binding-target binding
)))))
2793 (take-note-of-binding (binding &optional storep init-pc
)
2794 (let ((count-init-pc (or (gethash binding var-counter
)
2795 (setf (gethash binding var-counter
)
2796 (list 0 nil
(not storep
))))))
2798 (assert (not (second count-init-pc
)))
2799 (setf (second count-init-pc
) init-pc
))
2801 (unless (eq binding
(binding-target binding
))
2802 ;; (break "ewfew: ~S" (gethash (binding-target binding) var-counter))
2803 (take-note-of-binding (binding-target binding
)))
2804 (setf (third count-init-pc
) t
)
2805 (incf (car count-init-pc
))))
2807 (when (typep binding
'forwarding-binding
)
2808 (take-note-of-binding (forwarding-binding-target binding
) storep
)))
2809 (take-note-of-init (binding init-pc
)
2810 (let ((count-init-pc (or (gethash binding var-counter
)
2811 (setf (gethash binding var-counter
)
2812 (list 0 nil nil
)))))
2813 (assert (not (second count-init-pc
)))
2814 (setf (second count-init-pc
) init-pc
)))
2815 (do-discover-variables (code env
)
2816 (loop for pc on code as instruction in code
2817 when
(listp instruction
)
2818 do
(flet ((lend-lexical (borrowing-binding dynamic-extent-p
)
2819 (let ((lended-binding
2820 (borrowed-binding-target borrowing-binding
)))
2821 (assert (not (typep lended-binding
'forwarding-binding
)) ()
2822 "Can't lend a forwarding-binding.")
2823 (pushnew lended-binding
2824 (potentially-lended-bindings function-env
))
2825 (take-note-of-binding lended-binding
)
2826 (symbol-macrolet ((p (binding-lending lended-binding
)))
2827 (incf (getf p
:lended-count
0))
2828 (setf (getf p
:dynamic-extent-p
) (and (getf p
:dynamic-extent-p t
)
2829 dynamic-extent-p
))))))
2830 (case (instruction-is instruction
)
2831 ((:local-function-init
:load-lambda
)
2832 (let ((function-binding (second instruction
)))
2833 (take-note-of-binding function-binding
)
2834 (let ((sub-funobj (function-binding-funobj function-binding
)))
2836 (warn "fun-ext: ~S ~S ~S"
2838 (movitz-funobj-extent sub-funobj
)
2839 (movitz-allocation sub-funobj
))
2840 (when (typep (movitz-allocation sub-funobj
)
2841 'with-dynamic-extent-scope-env
)
2842 (take-note-of-binding (base-binding (movitz-allocation sub-funobj
)))))
2843 (let ((closure-funobj (function-binding-funobj function-binding
)))
2844 (dolist (borrowing-binding (borrowed-bindings closure-funobj
))
2845 (lend-lexical borrowing-binding nil
)))))
2847 (destructuring-bind (binding num-args
)
2849 (declare (ignore num-args
))
2852 (take-note-of-binding binding
))
2855 (destructuring-bind (binding &key init-with-register init-with-type
2856 protect-registers protect-carry
2859 (declare (ignore protect-registers protect-carry init-with-type
2860 shared-reference-p
))
2862 ((not init-with-register
)
2863 (take-note-of-init binding pc
))
2865 (take-note-of-binding binding t pc
)
2866 (when (and (typep init-with-register
'binding
)
2867 (not (typep binding
'forwarding-binding
))
2868 (not (typep binding
'keyword-function-argument
))) ; XXX
2869 (take-note-of-binding init-with-register
))))))
2870 (t (mapcar #'take-note-of-binding
2871 (find-read-bindings instruction
))
2872 (mapcar #'record-binding-used
; This is just concerning "unused variable"
2873 (find-used-bindings instruction
)) ; warnings!
2874 (let ((store-binding (find-written-binding-and-type instruction
)))
2876 (take-note-of-binding store-binding t
)))
2877 (do-discover-variables (instruction-sub-program instruction
) env
)))))))
2878 (do-discover-variables code function-env
))
2879 (values var-counter
)))
2881 (defun assign-bindings (code function-env
&optional
(initial-stack-frame-position 1)
2882 (frame-map (make-binding-map)))
2883 "Assign locations to all lexical variables in CODE. Recurses into any
2884 sub-environments found in CODE. A frame-map which is an assoc from
2885 bindings to stack-frame locations."
2886 ;; Then assign them to locations in the stack-frame.
2887 #+ignore
(warn "assigning code:~%~{~& ~A~}" code
)
2888 (check-type function-env function-env
)
2889 (assert (= initial-stack-frame-position
2890 (1+ (frame-map-size frame-map
))))
2891 (let* ((env-assigned-p nil
) ; memoize result of assign-env-bindings
2893 (var-counts (discover-variables flat-program function-env
)))
2895 ((assign-env-bindings (env)
2896 (unless (member env env-assigned-p
)
2897 (unless (eq env function-env
)
2898 (assign-env-bindings (movitz-environment-extent-uplink env
)))
2899 (let* ((bindings-to-locate
2900 (loop for binding being the hash-keys of var-counts
2902 (and (eq env
(binding-extent-env binding
))
2903 (not (let ((variable (binding-name binding
)))
2905 ((not (typep binding
'lexical-binding
)))
2906 ((typep binding
'lambda-binding
))
2907 ((typep binding
'constant-object-binding
))
2908 ((typep binding
'forwarding-binding
)
2909 (when (plusp (or (car (gethash binding var-counts
)) 0))
2910 (assert (new-binding-located-p binding frame-map
)))
2912 ((typep binding
'borrowed-binding
))
2913 ((typep binding
'funobj-binding
))
2914 ((and (typep binding
'fixed-required-function-argument
)
2915 (plusp (or (car (gethash binding var-counts
)) 0)))
2916 (prog1 nil
; may need lending-cons
2917 (setf (new-binding-location binding frame-map
)
2918 `(:argument-stack
,(function-argument-argnum binding
)))))
2919 ((unless (or (movitz-env-get variable
'ignore nil
2920 (binding-env binding
) nil
)
2921 (movitz-env-get variable
'ignorable nil
2922 (binding-env binding
) nil
)
2923 (third (gethash binding var-counts
)))
2924 (warn "Unused variable: ~S"
2925 (binding-name binding
))))
2926 ((not (plusp (or (car (gethash binding var-counts
)) 0))))))))
2928 (bindings-fun-arg-sorted
2929 (when (eq env function-env
)
2930 (sort (copy-list bindings-to-locate
) #'<
2931 :key
(lambda (binding)
2933 (edx-function-argument 3)
2934 (positional-function-argument
2935 (* 2 (function-argument-argnum binding
)))
2936 (binding 100000))))))
2937 (bindings-register-goodness-sort
2938 (sort (copy-list bindings-to-locate
) #'<
2939 ;; Sort so as to make the most likely
2940 ;; candidates for locating to registers
2941 ;; be assigned first (i.e. maps to
2942 ;; a smaller value).
2945 ((or constant-object-binding
2949 (fixed-required-function-argument
2950 (+ 100 (function-argument-argnum b
)))
2952 (let* ((count-init (gethash b var-counts
))
2953 (count (car count-init
))
2954 (init-pc (second count-init
)))
2955 (if (not (and count init-pc
))
2958 (or (position-if (lambda (i)
2959 (member b
(find-read-bindings i
)))
2963 ;; First, make several passes while trying to locate bindings
2965 (loop repeat
100 with try-again
= t and did-assign
= t
2966 do
(unless (and try-again did-assign
)
2968 do
(setf try-again nil did-assign nil
)
2969 (loop for binding in bindings-fun-arg-sorted
2970 while
(or (typep binding
'register-required-function-argument
)
2971 (typep binding
'floating-required-function-argument
)
2972 (and (typep binding
'positional-function-argument
)
2973 (< (function-argument-argnum binding
)
2975 do
(unless (new-binding-located-p binding frame-map
)
2976 (multiple-value-bind (register status
)
2977 (try-locate-in-register binding var-counts
2978 (movitz-environment-funobj function-env
)
2982 (setf (new-binding-location binding frame-map
)
2984 (setf did-assign t
))
2985 ((eq status
:not-now
)
2986 ;; (warn "Wait for ~S map ~A" binding frame-map)
2988 (t (assert (eq status
:never
)))))))
2989 (dolist (binding bindings-register-goodness-sort
)
2990 (unless (and (binding-lended-p binding
)
2991 (not (typep binding
'borrowed-binding
))
2992 (not (getf (binding-lending binding
) :stack-cons-location
)))
2993 (unless (new-binding-located-p binding frame-map
)
2994 (check-type binding located-binding
)
2995 (multiple-value-bind (register status
)
2996 (try-locate-in-register binding var-counts
2997 (movitz-environment-funobj function-env
)
3001 (setf (new-binding-location binding frame-map
)
3003 (setf did-assign t
))
3004 ((eq status
:not-now
)
3006 (t (assert (eq status
:never
))))))))
3007 do
(when (and try-again
(not did-assign
))
3008 (let ((binding (or (find-if (lambda (b)
3009 (and (typep b
'positional-function-argument
)
3010 (= 0 (function-argument-argnum b
))
3011 (not (new-binding-located-p b frame-map
))))
3012 bindings-fun-arg-sorted
)
3013 (find-if (lambda (b)
3014 (and (typep b
'positional-function-argument
)
3015 (= 1 (function-argument-argnum b
))
3016 (not (new-binding-located-p b frame-map
))))
3017 bindings-fun-arg-sorted
)
3018 (find-if (lambda (b)
3019 (and (not (new-binding-located-p b frame-map
))
3020 (not (typep b
'function-argument
))))
3021 bindings-register-goodness-sort
3024 (setf (new-binding-location binding frame-map
)
3025 (frame-map-next-free-location frame-map
(binding-env binding
)))
3026 (setf did-assign t
))))
3027 finally
(break "100 iterations didn't work"))
3028 ;; Then, make one pass assigning bindings to stack-frame.
3029 (loop for binding in bindings-fun-arg-sorted
3030 while
(or (typep binding
'register-required-function-argument
)
3031 (typep binding
'floating-required-function-argument
)
3032 (and (typep binding
'positional-function-argument
)
3033 (< (function-argument-argnum binding
)
3035 do
(unless (new-binding-located-p binding frame-map
)
3036 (setf (new-binding-location binding frame-map
)
3037 (frame-map-next-free-location frame-map
(binding-env binding
)))))
3038 (dolist (binding bindings-register-goodness-sort
)
3039 (when (and (binding-lended-p binding
)
3040 (not (typep binding
'borrowed-binding
))
3041 (not (getf (binding-lending binding
) :stack-cons-location
)))
3043 (assert (not (typep binding
'keyword-function-argument
)) ()
3044 "Can't lend keyword binding ~S." binding
)
3045 ;; (warn "assigning lending-cons for ~W at ~D" binding stack-frame-position)
3046 (let ((cons-pos (frame-map-next-free-location frame-map function-env
2)))
3047 (setf (new-binding-location (cons :lended-cons binding
) frame-map
)
3049 (setf (new-binding-location (cons :lended-cons binding
) frame-map
)
3051 (setf (getf (binding-lending binding
) :stack-cons-location
)
3053 (unless (new-binding-located-p binding frame-map
)
3055 (constant-object-binding) ; no location needed.
3056 (forwarding-binding) ; will use the location of target binding.
3057 (borrowed-binding) ; location is predetermined
3058 (fixed-required-function-argument
3059 (setf (new-binding-location binding frame-map
)
3060 `(:argument-stack
,(function-argument-argnum binding
))))
3062 (setf (new-binding-location binding frame-map
)
3063 (frame-map-next-free-location frame-map
(binding-env binding
)))))))
3064 (push env env-assigned-p
)))))
3065 ;; First, "assign" each forwarding binding to their target.
3066 (loop for binding being the hash-keys of var-counts
3067 do
(when (and (typep binding
'forwarding-binding
)
3068 (plusp (car (gethash binding var-counts
'(0)))))
3069 (setf (new-binding-location binding frame-map
)
3070 (forwarding-binding-target binding
))))
3072 (flet ((set-exclusive-location (binding location
)
3073 (assert (not (rassoc location frame-map
))
3074 () "Fixed location ~S for ~S is taken by ~S."
3075 location binding
(rassoc location frame-map
))
3076 (setf (new-binding-location binding frame-map
) location
)))
3077 (when (key-vars-p function-env
)
3078 (when (= 0 (rest-args-position function-env
))
3079 (set-exclusive-location (loop for var in
(required-vars function-env
)
3080 as binding
= (movitz-binding var function-env nil
)
3081 thereis
(when (= 0 (function-argument-argnum binding
))
3084 (when (>= 1 (rest-args-position function-env
))
3085 (set-exclusive-location (loop for var in
(required-vars function-env
)
3086 as binding
= (movitz-binding var function-env nil
)
3087 thereis
(when (= 1 (function-argument-argnum binding
))
3090 (loop for key-var in
(key-vars function-env
)
3091 as key-binding
= (or (movitz-binding key-var function-env nil
)
3092 (error "No binding for key-var ~S." key-var
))
3093 as used-key-binding
=
3094 (when (plusp (car (gethash key-binding var-counts
'(0))))
3096 as used-supplied-p-binding
=
3097 (when (optional-function-argument-supplied-p-var key-binding
)
3098 (let ((b (or (movitz-binding (optional-function-argument-supplied-p-var key-binding
)
3100 (error "No binding for supplied-p-var ~S."
3101 (optional-function-argument-supplied-p-var key-binding
)))))
3102 (when (plusp (car (gethash key-binding var-counts
'(0))))
3104 as location upfrom
3 by
2
3105 do
(set-exclusive-location used-key-binding location
)
3106 (set-exclusive-location used-supplied-p-binding
(1+ location
))))
3107 ;; Now, use assing-env-bindings on the remaining bindings.
3110 for b being the hash-keys of var-counts using
(hash-value c
)
3111 as env
= (binding-env b
)
3112 when
(sub-env-p env function-env
)
3113 do
(incf (getf z env
0) (car c
))
3115 (return (sort (loop for x in z by
#'cddr
3120 do
(assign-env-bindings env
))
3121 #+ignore
(warn "Frame-map ~D:~{~&~A~}"
3122 (frame-map-size frame-map
)
3123 (stable-sort (sort (loop for
(b . l
) in frame-map
3124 collect
(list b l
(car (gethash b var-counts nil
))))
3127 (and (bindingp (car x
))
3128 (binding-name (car x
)))))
3131 (if (integerp (cadr x
))
3137 (defun operators-present-in-code-p (code operators operands
&key
(operand-test #'eql
)
3139 "A simple tree search for `(<one of operators> ,operand) in CODE."
3140 ;; (break "Deprecated operators-present-in-code-p")
3144 ((and (member (first code
) operators
)
3147 (funcall operand-test
(second code
) operands
)
3148 (member (second code
) operands
:test operand-test
)))
3151 (t (or (operators-present-in-code-p (car code
) operators operands
3152 :operand-test operand-test
3154 (operators-present-in-code-p (cdr code
) operators operands
3155 :operand-test operand-test
3159 (defun code-uses-binding-p (code binding
&key
(load t
) store call
)
3160 "Does extended <code> potentially read/write/call <binding>?"
3161 (labels ((search-funobj (funobj binding load store call
)
3162 ;; If this is a recursive lexical call (i.e. labels),
3163 ;; the function-envs might not be bound, but then this
3164 ;; code is searched already.
3165 (when (slot-boundp funobj
'function-envs
)
3166 (some (lambda (function-env-spec)
3167 (code-search (extended-code (cdr function-env-spec
)) binding
3169 (function-envs funobj
))))
3170 (code-search (code binding load store call
)
3171 (dolist (instruction code
)
3172 (when (consp instruction
)
3173 (let ((x (or (when load
3174 (some (lambda (read-binding)
3175 (binding-eql read-binding binding
))
3176 (find-read-bindings instruction
)))
3178 (let ((store-binding (find-written-binding-and-type instruction
)))
3180 (binding-eql binding store-binding
))))
3181 (case (car instruction
)
3182 (:local-function-init
3183 (search-funobj (function-binding-funobj (second instruction
))
3184 binding load store call
))
3187 (binding-eql binding
(second instruction
)))
3188 (let ((allocation (movitz-allocation
3189 (function-binding-funobj (second instruction
)))))
3191 (typep allocation
'with-dynamic-extent-scope-env
))
3192 (binding-eql binding
(base-binding allocation
))))
3193 (search-funobj (function-binding-funobj (second instruction
))
3194 binding load store call
)))
3197 (binding-eql binding
(second instruction
)))
3198 (search-funobj (function-binding-funobj (second instruction
))
3199 binding load store call
))))
3200 (code-search (instruction-sub-program instruction
)
3201 binding load store call
))))
3202 (when x
(return t
)))))))
3203 (code-search code binding load store call
)))
3208 (defun binding-target (binding)
3209 "Resolve a binding in terms of forwarding."
3212 (binding-target (forwarding-binding-target binding
)))
3216 (defun binding-eql (x y
)
3217 (check-type x binding
)
3218 (check-type y binding
)
3220 (and (typep x
'forwarding-binding
)
3221 (binding-eql (forwarding-binding-target x
) y
))
3222 (and (typep y
'forwarding-binding
)
3223 (binding-eql x
(forwarding-binding-target y
)))))
3225 (defun tree-search (tree items
)
3226 (if (and (atom items
) ; make common case fast(er), hopefully.
3227 (not (numberp items
)))
3228 (labels ((tree-search* (tree item
)
3232 (or (tree-search* (car tree
) item
)
3233 (tree-search* (cdr tree
) item
)))
3234 (t (eq tree item
)))))
3235 (tree-search* tree items
))
3240 (member tree items
)))
3242 (or (tree-search (car tree
) items
)
3243 (tree-search (cdr tree
) items
))))))
3246 (if (atom x
) x
(car x
)))
3248 (defun result-mode-type (x)
3252 (constant-object-binding :constant-binding
)
3253 (lexical-binding :lexical-binding
)
3254 (dynamic-binding :dynamic-binding
)))
3257 (if (symbolp x
) nil
(cdr x
)))
3259 (defun funobj-assign-bindings (code env
&optional
(stack-frame-position 1)
3260 (frame-map (make-binding-map)))
3261 "This wrapper around assign-bindings checks if the first instructions of CODE
3262 are load-lexicals of the first two function arguments, and if possible these
3263 bindings are located in the appropriate register, so no stack location is needed."
3264 (check-type env function-env
)
3265 (assign-bindings (append (when (first (required-vars env
))
3266 (let ((binding (movitz-binding (first (required-vars env
))
3268 (check-type binding required-function-argument
)
3269 `((:init-lexvar
,binding
:init-with-register
:eax
:init-with-type t
))))
3270 (when (second (required-vars env
))
3271 (let ((binding (movitz-binding (second (required-vars env
))
3273 (check-type binding required-function-argument
)
3274 `((:init-lexvar
,binding
:init-with-register
:ebx
:init-with-type t
))))
3276 env stack-frame-position frame-map
))
3278 (defun single-value-register (mode)
3280 ((:eax
:single-value
:multiple-values
:function
) :eax
)
3281 ((:ebx
:ecx
:edx
:esi
:esp
:ebp
) mode
)))
3283 (defun result-mode-register (mode)
3285 ((:eax
:single-value
) :eax
)
3286 ((:ebx
:ecx
:edx
:esi
:esp
) mode
)
3289 (defun accept-register-mode (mode &optional
(default-mode :eax
))
3291 ((:eax
:ebx
:ecx
:edx
)
3295 (defun chose-free-register (unfree-registers &optional
(preferred-register :eax
))
3297 ((not (member preferred-register unfree-registers
))
3299 ((find-if (lambda (r) (not (member r unfree-registers
)))
3300 '(:eax
:ebx
:ecx
:edx
)))
3301 (t (error "Unable to find a free register."))))
3303 (defun make-indirect-reference (base-register offset
)
3304 "Make the shortest possible assembly indirect reference, explointing the constant edi register."
3305 (if (<= #x-80 offset
#x7f
)
3306 (list base-register offset
)
3307 (let ((edi (image-nil-word *image
*)))
3309 ((<= #x-80
(- offset edi
) #x7f
)
3310 `(,base-register
:edi
,(- offset edi
)))
3311 ((<= #x-80
(- offset
(* 2 edi
)) #x7f
)
3312 `(,base-register
(:edi
2) ,(- offset
(* 2 edi
))))
3313 ((<= #x-80
(- offset
(* 4 edi
)) #x7f
)
3314 `(,base-register
(:edi
4) ,(- offset
(* 4 edi
))))
3315 ((<= #x-80
(- offset
(* 8 edi
)) #x7f
)
3316 `(,base-register
(:edi
8) ,(- offset
(* 8 edi
))))
3317 (t (list base-register offset
))))))
3319 (defun make-load-lexical (binding result-mode funobj shared-reference-p frame-map
3320 &key tmp-register protect-registers override-binding-type
)
3321 "When tmp-register is provided, use that for intermediate storage required when
3322 loading borrowed bindings."
3324 (when (eq :ecx result-mode
)
3325 ;; (warn "loading to ecx: ~S" binding)
3326 (unless (or (null (binding-store-type binding
))
3327 (movitz-subtypep (apply #'encoded-type-decode
3328 (binding-store-type binding
))
3330 (warn "ecx from ~S" binding
)))
3331 (when (movitz-env-get (binding-name binding
) 'ignore nil
(binding-env binding
))
3332 (break "The variable ~S is used even if it was declared ignored."
3333 (binding-name binding
)))
3334 (let ((binding (ensure-local-binding binding funobj
))
3335 (protect-registers (cons :edx protect-registers
)))
3336 (labels ((chose-tmp-register (&optional preferred
)
3338 (unless (member preferred protect-registers
)
3340 (first (set-difference '(:eax
:ebx
:edx
)
3342 (error "Unable to chose a temporary register.")))
3343 (install-for-single-value (lexb lexb-location result-mode indirect-p
3344 &optional binding-type
)
3345 (let ((decoded-type (when binding-type
3346 (apply #'encoded-type-decode binding-type
))))
3348 ((and (eq result-mode
:untagged-fixnum-ecx
)
3349 (integerp lexb-location
))
3352 (type-specifier-singleton decoded-type
))
3353 #+ignore
(warn "Immloadlex: ~S"
3354 (type-specifier-singleton decoded-type
))
3355 (make-immediate-move (movitz-fixnum-value
3356 (car (type-specifier-singleton decoded-type
)))
3359 (movitz-subtypep decoded-type
'(and fixnum
(unsigned-byte 32))))
3360 (assert (not indirect-p
))
3361 (append (install-for-single-value lexb lexb-location
:ecx nil
)
3362 `((:shrl
,+movitz-fixnum-shift
+ :ecx
))))
3363 #+ignore
((warn "utecx ~S bt: ~S" lexb decoded-type
))
3365 (assert (not indirect-p
))
3366 (assert (not (member :eax protect-registers
)))
3367 (append (install-for-single-value lexb lexb-location
:eax nil
)
3368 `((,*compiler-global-segment-prefix
*
3369 :call
(:edi
,(global-constant-offset 'unbox-u32
))))))))
3370 ((integerp lexb-location
)
3371 (append `((:movl
,(make-indirect-reference :ebp
(stack-frame-offset lexb-location
))
3372 ,(single-value-register result-mode
)))
3374 `((:movl
(-1 ,(single-value-register result-mode
))
3375 ,(single-value-register result-mode
))))))
3376 ((eq lexb-location result-mode
)
3378 (t (when (and (eq result-mode
:untagged-fixnum-ecx
)
3380 (type-specifier-singleton decoded-type
))
3381 (break "xxx Immloadlex: ~S ~S"
3382 (operator lexb-location
)
3383 (type-specifier-singleton decoded-type
)))
3384 (ecase (operator lexb-location
)
3386 (assert (member result-mode
'(:eax
:ebx
:ecx
:edx
)))
3387 (assert (not indirect-p
))
3388 `((:popl
,result-mode
)))
3390 (assert (not indirect-p
))
3392 ((:ebx
:ecx
:edx
:esi
) `((:movl
:eax
,result-mode
)))
3393 ((:eax
:single-value
) nil
)
3394 (:untagged-fixnum-ecx
3395 `((,*compiler-global-segment-prefix
*
3396 :call
(:edi
,(global-constant-offset 'unbox-u32
)))))))
3398 (assert (not indirect-p
))
3399 (unless (eq result-mode lexb-location
)
3401 ((:eax
:single-value
) `((:movl
,lexb-location
:eax
)))
3402 ((:ebx
:ecx
:edx
:esi
) `((:movl
,lexb-location
,result-mode
)))
3403 (:untagged-fixnum-ecx
3404 `((:movl
,lexb-location
:ecx
)
3405 (:sarl
,movitz
:+movitz-fixnum-shift
+ :ecx
))))))
3407 (assert (<= 2 (function-argument-argnum lexb
)) ()
3408 "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb
))
3410 ((eq result-mode
:untagged-fixnum-ecx
)
3411 (assert (not indirect-p
))
3412 `((:movl
(:ebp
,(argument-stack-offset lexb
)) :ecx
)
3413 (:sarl
,+movitz-fixnum-shift
+ :ecx
)))
3414 (t (append `((:movl
(:ebp
,(argument-stack-offset lexb
))
3415 ,(single-value-register result-mode
)))
3417 `((:movl
(-1 ,(single-value-register result-mode
))
3418 ,(single-value-register result-mode
))))))))
3419 (:untagged-fixnum-ecx
3421 ((:eax
:ebx
:ecx
:edx
)
3422 `((:leal
((:ecx
,+movitz-fixnum-factor
+)) ,result-mode
)))
3423 (:untagged-fixnum-ecx
3427 (assert (not (binding-lended-p binding
)) (binding)
3428 "Can't lend a forwarding-binding ~S." binding
)
3429 (make-load-lexical (forwarding-binding-target binding
)
3430 result-mode funobj shared-reference-p frame-map
3431 :override-binding-type
(binding-store-type binding
)))
3432 (constant-object-binding
3433 (assert (not (binding-lended-p binding
)) (binding)
3434 "Can't lend a constant-reference-binding ~S." binding
)
3435 (make-load-constant (constant-object binding
)
3439 (make-load-constant (function-binding-funobj binding
)
3440 result-mode funobj frame-map
))
3442 (let ((slot (borrowed-binding-reference-slot binding
)))
3445 (ecase (result-mode-type result-mode
)
3446 ((:eax
:ebx
:ecx
:edx
)
3447 `((:movl
(:esi
,(+ (slot-offset 'movitz-funobj
'constant0
) (* 4 slot
)))
3448 ,(result-mode-type result-mode
))))))
3449 ((not shared-reference-p
)
3451 ((:single-value
:eax
:ebx
:ecx
:edx
:esi
)
3452 (let ((tmp-register (chose-tmp-register (single-value-register result-mode
))))
3453 `((:movl
(:esi
,(+ (slot-offset 'movitz-funobj
'constant0
) (* 4 slot
)))
3455 (:movl
(,tmp-register -
1)
3456 ,(single-value-register result-mode
)))))
3458 (let ((tmp-register (chose-tmp-register :eax
)))
3459 `((:movl
(:esi
,(+ (slot-offset 'movitz-funobj
'constant0
) (* 4 slot
)))
3461 (:pushl
(,tmp-register -
1)))))
3462 (t (let ((tmp-register (chose-tmp-register :eax
)))
3463 (make-result-and-returns-glue
3464 result-mode tmp-register
3465 `((:movl
(:esi
,(+ (slot-offset 'movitz-funobj
'constant0
) (* 4 slot
)))
3467 (:movl
(,tmp-register -
1) ,tmp-register
))))))))))
3469 (let ((binding-type (or override-binding-type
3470 (binding-store-type binding
)))
3471 (binding-location (new-binding-location binding frame-map
)))
3472 #+ignore
(warn "~S type: ~S ~:[~;lended~]"
3475 (binding-lended-p binding
))
3477 ((and (binding-lended-p binding
)
3478 (not shared-reference-p
))
3479 (case (result-mode-type result-mode
)
3480 ((:single-value
:eax
:ebx
:ecx
:edx
:esi
:esp
)
3481 (install-for-single-value binding binding-location
3482 (single-value-register result-mode
) t
))
3484 (if (integerp binding-location
)
3485 `((:movl
(:ebp
,(stack-frame-offset binding-location
)) :eax
)
3487 (ecase (operator binding-location
)
3489 (assert (<= 2 (function-argument-argnum binding
)) ()
3490 ":load-lexical argnum can't be ~A." (function-argument-argnum binding
))
3491 `((:movl
(:ebp
,(argument-stack-offset binding
)) :eax
)
3492 (:pushl
(:eax -
1)))))))
3493 (t (make-result-and-returns-glue
3495 (install-for-single-value binding binding-location
:eax t
)))))
3496 (t (when (integerp result-mode
)
3497 (break "result-mode: ~S" result-mode
))
3498 (case (result-mode-type result-mode
)
3499 ((:single-value
:eax
:ebx
:ecx
:edx
:esi
:esp
:ebp
)
3500 (install-for-single-value binding binding-location
3501 (single-value-register result-mode
) nil
))
3503 (if (integerp binding-location
)
3504 `((:pushl
(:ebp
,(stack-frame-offset binding-location
))))
3505 (ecase (operator binding-location
)
3506 ((:eax
:ebx
:ecx
:edx
)
3507 `((:pushl
,binding-location
)))
3508 (:untagged-fixnum-ecx
3509 `((,*compiler-local-segment-prefix
*
3510 :call
(:edi
,(global-constant-offset 'box-u32-ecx
)))
3513 (assert (<= 2 (function-argument-argnum binding
)) ()
3514 ":load-lexical argnum can't be ~A." (function-argument-argnum binding
))
3515 `((:pushl
(:ebp
,(argument-stack-offset binding
))))))))
3516 (:boolean-branch-on-true
3517 (if (integerp binding-location
)
3518 `((:cmpl
:edi
(:ebp
,(stack-frame-offset binding-location
)))
3519 (:jne
',(operands result-mode
)))
3520 (ecase (operator binding-location
)
3522 `((:cmpl
:edi
,binding-location
)
3523 (:jne
',(operands result-mode
))))
3525 `((:cmpl
:edi
(:ebp
,(argument-stack-offset binding
)))
3526 (:jne
',(operands result-mode
)))))))
3527 (:boolean-branch-on-false
3528 (if (integerp binding-location
)
3529 `((:cmpl
:edi
(:ebp
,(stack-frame-offset binding-location
)))
3530 (:je
',(operands result-mode
)))
3531 (ecase (operator binding-location
)
3533 `((:cmpl
:edi
,binding-location
)
3534 (:je
',(operands result-mode
))))
3536 `((:cmpl
:edi
(:ebp
,(argument-stack-offset binding
)))
3537 (:je
',(operands result-mode
)))))))
3538 (:untagged-fixnum-ecx
3539 (install-for-single-value binding binding-location
:untagged-fixnum-ecx nil
3542 (let* ((destination result-mode
)
3543 (dest-location (new-binding-location destination frame-map
:default nil
)))
3545 ((not dest-location
) ; unknown, e.g. a borrowed-binding.
3546 (append (install-for-single-value binding binding-location
:edx nil
)
3547 (make-store-lexical result-mode
:edx nil funobj frame-map
)))
3548 ((equal binding-location dest-location
)
3550 ((member binding-location
'(:eax
:ebx
:ecx
:edx
))
3551 (make-store-lexical destination binding-location nil funobj frame-map
))
3552 ((member dest-location
'(:eax
:ebx
:ecx
:edx
))
3553 (install-for-single-value binding binding-location dest-location nil
))
3554 (t #+ignore
(warn "binding => binding: ~A => ~A~% => ~A ~A"
3559 (append (install-for-single-value binding binding-location
:eax nil
)
3560 (make-store-lexical result-mode
:eax nil funobj frame-map
))))))
3561 (t (make-result-and-returns-glue
3563 (install-for-single-value binding binding-location
:eax nil
)))
3566 (defun make-store-lexical (binding source shared-reference-p funobj frame-map
3567 &key protect-registers
)
3568 (let ((binding (ensure-local-binding binding funobj
)))
3569 (assert (not (and shared-reference-p
3570 (not (binding-lended-p binding
))))
3572 "funny binding: ~W" binding
)
3573 (if (and nil
(typep source
'constant-object-binding
))
3574 (make-load-constant (constant-object source
) binding funobj frame-map
)
3575 (let ((protect-registers (cons source protect-registers
)))
3577 ((eq :untagged-fixnum-ecx source
)
3578 (if (eq :untagged-fixnum-ecx
3579 (new-binding-location binding frame-map
))
3581 (append (make-result-and-returns-glue :ecx
:untagged-fixnum-ecx
)
3582 (make-store-lexical binding
:ecx shared-reference-p funobj frame-map
3583 :protect-registers protect-registers
))))
3584 ((typep binding
'borrowed-binding
)
3585 (let ((slot (borrowed-binding-reference-slot binding
)))
3586 (if (not shared-reference-p
)
3587 (let ((tmp-reg (chose-free-register protect-registers
)
3588 #+ignore
(if (eq source
:eax
) :ebx
:eax
)))
3589 (when (eq :ecx source
)
3590 (break "loading a word from ECX?"))
3591 `((:movl
(:esi
,(+ (slot-offset 'movitz-funobj
'constant0
) (* 4 slot
)))
3593 (:movl
,source
(-1 ,tmp-reg
))))
3594 `((:movl
,source
(:esi
,(+ (slot-offset 'movitz-funobj
'constant0
) (* 4 slot
))))))))
3595 ((typep binding
'forwarding-binding
)
3596 (assert (not (binding-lended-p binding
)) (binding))
3597 (make-store-lexical (forwarding-binding-target binding
)
3598 source shared-reference-p funobj frame-map
))
3599 ((not (new-binding-located-p binding frame-map
))
3600 ;; (warn "Can't store to unlocated binding ~S." binding)
3602 ((and (binding-lended-p binding
)
3603 (not shared-reference-p
))
3604 (let ((tmp-reg (chose-free-register protect-registers
)
3605 #+ignore
(if (eq source
:eax
) :ebx
:eax
))
3606 (location (new-binding-location binding frame-map
)))
3607 (if (integerp location
)
3608 `((:movl
(:ebp
,(stack-frame-offset location
)) ,tmp-reg
)
3609 (:movl
,source
(,tmp-reg -
1)))
3610 (ecase (operator location
)
3612 (assert (<= 2 (function-argument-argnum binding
)) ()
3613 "store-lexical argnum can't be ~A." (function-argument-argnum binding
))
3614 `((:movl
(:ebp
,(argument-stack-offset binding
)) ,tmp-reg
)
3615 (:movl
,source
(,tmp-reg -
1))))))))
3616 (t (let ((location (new-binding-location binding frame-map
)))
3618 ((member source
'(:eax
:ebx
:ecx
:edx
:edi
:esp
))
3619 (if (integerp location
)
3620 `((:movl
,source
(:ebp
,(stack-frame-offset location
))))
3621 (ecase (operator location
)
3623 `((:pushl
,source
)))
3624 ((:eax
:ebx
:ecx
:edx
)
3625 (unless (eq source location
)
3626 `((:movl
,source
,location
))))
3628 (assert (<= 2 (function-argument-argnum binding
)) ()
3629 "store-lexical argnum can't be ~A." (function-argument-argnum binding
))
3630 `((:movl
,source
(:ebp
,(argument-stack-offset binding
)))))
3631 (:untagged-fixnum-ecx
3632 (assert (not (eq source
:edi
)))
3634 ((eq source
:untagged-fixnum-ecx
)
3637 `((,*compiler-global-segment-prefix
*
3638 :call
(:edi
,(global-constant-offset 'unbox-u32
)))))
3639 (t `((:movl
,source
:eax
)
3640 (,*compiler-global-segment-prefix
*
3641 :call
(:edi
,(global-constant-offset 'unbox-u32
))))))))))
3642 ((eq source
:boolean-cf
=1)
3643 (let ((tmp (chose-free-register protect-registers
)))
3645 (,*compiler-local-segment-prefix
*
3646 :movl
(:edi
(:ecx
4) ,(global-constant-offset 'not-not-nil
)) ,tmp
)
3647 ,@(make-store-lexical binding tmp shared-reference-p funobj frame-map
3648 :protect-registers protect-registers
))))
3649 ((eq source
:boolean-cf
=0)
3650 (let ((tmp (chose-free-register protect-registers
)))
3652 (,*compiler-local-segment-prefix
*
3653 :movl
(:edi
(:ecx
4) ,(global-constant-offset 'boolean-zero
)) ,tmp
)
3654 ,@(make-store-lexical binding tmp shared-reference-p funobj frame-map
3655 :protect-registers protect-registers
))))
3656 ((and *compiler-use-cmov-p
*
3657 (member source
+boolean-modes
+))
3658 (let ((tmp (chose-free-register protect-registers
)))
3659 (append `((:movl
:edi
,tmp
))
3660 (list (cons *compiler-local-segment-prefix
*
3661 (make-cmov-on-boolean source
3662 `(:edi
,(global-constant-offset 't-symbol
))
3664 (make-store-lexical binding tmp shared-reference-p funobj frame-map
3665 :protect-registers protect-registers
))))
3666 ((member source
+boolean-modes
+)
3667 (let ((tmp (chose-free-register protect-registers
))
3668 (label (gensym "store-lexical-bool-")))
3669 (append `((:movl
:edi
,tmp
))
3670 (list (make-branch-on-boolean source label
:invert t
))
3671 `((,*compiler-local-segment-prefix
*
3672 :movl
(:edi
,(global-constant-offset 't-symbol
)) ,tmp
))
3674 (make-store-lexical binding tmp shared-reference-p funobj frame-map
3675 :protect-registers protect-registers
))))
3676 ((not (bindingp source
))
3677 (error "Unknown source for store-lexical: ~S" source
))
3678 ((binding-singleton source
)
3679 (assert (not shared-reference-p
))
3680 (let ((value (car (binding-singleton source
))))
3683 (let ((immediate (movitz-immediate-value value
)))
3684 (if (integerp location
)
3685 (let ((tmp (chose-free-register protect-registers
)))
3686 (append (make-immediate-move immediate tmp
)
3687 `((:movl
,tmp
(:ebp
,(stack-frame-offset location
))))))
3688 #+ignore
(if (= 0 immediate
)
3689 (let ((tmp (chose-free-register protect-registers
)))
3691 (:movl
,tmp
(:ebp
,(stack-frame-offset location
)))))
3692 `((:movl
,immediate
(:ebp
,(stack-frame-offset location
)))))
3693 (ecase (operator location
)
3695 `((:movl
,immediate
(:ebp
,(argument-stack-offset binding
)))))
3696 ((:eax
:ebx
:ecx
:edx
)
3697 (make-immediate-move immediate location
))
3698 ((:untagged-fixnum-ecx
)
3699 (make-immediate-move (movitz-fixnum-value value
) :ecx
))))))
3701 (let ((immediate (movitz-immediate-value value
)))
3702 (if (integerp location
)
3703 (let ((tmp (chose-free-register protect-registers
)))
3704 (append (make-immediate-move immediate tmp
)
3705 `((:movl
,tmp
(:ebp
,(stack-frame-offset location
))))))
3706 (ecase (operator location
)
3708 `((:movl
,immediate
(:ebp
,(argument-stack-offset binding
)))))
3709 ((:eax
:ebx
:ecx
:edx
)
3710 (make-immediate-move immediate location
))))))
3713 ((member :eax
:ebx
:edx
)
3714 (make-load-constant value location funobj frame-map
))
3716 (let ((tmp (chose-free-register protect-registers
)))
3717 (append (make-load-constant value tmp funobj frame-map
)
3718 (make-store-lexical binding tmp shared-reference-p
3720 :protect-registers protect-registers
))))
3721 ((eql :untagged-fixnum-ecx
)
3722 (check-type value movitz-bignum
)
3723 (let ((immediate (movitz-bignum-value value
)))
3724 (check-type immediate
(unsigned-byte 32))
3725 (make-immediate-move immediate
:ecx
)))
3727 (t (error "Generalized lexb source for store-lexical not implemented: ~S" source
))))))))))
3729 (defun finalize-code (code funobj frame-map
)
3730 ;; (print-code 'to-be-finalized code)
3731 ;; (warn "frame-map: ~A" frame-map)
3732 (labels ((actual-binding (b)
3733 (if (typep b
'borrowed-binding
)
3734 (borrowed-binding-target b
)
3736 (make-lend-lexical (borrowing-binding funobj-register dynamic-extent-p
)
3737 (let ((lended-binding (ensure-local-binding
3738 (borrowed-binding-target borrowing-binding
))))
3739 #+ignore
(warn "LB: in ~S ~S from ~S"
3741 lended-binding borrowing-binding
)
3742 (assert (eq funobj
(binding-funobj lended-binding
)))
3743 (assert (plusp (getf (binding-lending (actual-binding lended-binding
))
3744 :lended-count
0)) ()
3745 "Asked to lend ~S of ~S to ~S of ~S with no lended-count."
3746 lended-binding
(binding-env lended-binding
)
3747 borrowing-binding
(binding-env borrowing-binding
))
3748 (assert (eq funobj-register
:edx
))
3749 (when (getf (binding-lending lended-binding
) :dynamic-extent-p
)
3750 (assert dynamic-extent-p
))
3752 (warn "lending: ~W: ~S"
3754 (mapcar #'movitz-funobj-extent
3755 (mapcar #'binding-funobj
3756 (getf (binding-lending lended-binding
) :lended-to
))))
3757 (append (make-load-lexical lended-binding
:eax funobj t frame-map
)
3758 (unless (or (typep lended-binding
'borrowed-binding
)
3759 (getf (binding-lending lended-binding
) :dynamic-extent-p
)
3760 (every (lambda (borrower)
3761 (member (movitz-funobj-extent (binding-funobj borrower
))
3762 '(:lexical-extent
:dynamic-extent
)))
3763 (getf (binding-lending lended-binding
) :lended-to
)))
3764 (append `((:pushl
:edx
)
3765 (:globally
(:call
(:edi
(:edi-offset ensure-heap-cons-variable
))))
3767 (make-store-lexical lended-binding
:eax t funobj frame-map
)))
3770 ,(+ (slot-offset 'movitz-funobj
'constant0
)
3771 (* 4 (borrowed-binding-reference-slot borrowing-binding
)))))))))
3772 (ensure-local-binding (binding)
3773 (if (eq funobj
(binding-funobj binding
))
3775 (or (find binding
(borrowed-bindings funobj
)
3776 :key
#'borrowed-binding-target
)
3777 (error "Can't install non-local binding ~W." binding
)))))
3778 (labels ((fix-edi-offset (tree)
3782 ((eq :edi-offset
(car tree
))
3783 (check-type (cadr tree
) symbol
"a Movitz run-time-context label")
3784 (+ (global-constant-offset (cadr tree
))
3785 (reduce #'+ (cddr tree
))))
3786 (t (cons (fix-edi-offset (car tree
))
3787 (fix-edi-offset (cdr tree
)))))))
3788 (loop for instruction in code
3793 ((and (= 2 (length instruction
))
3794 (let ((operand (second instruction
)))
3795 (and (listp operand
)
3796 (symbolp (first operand
))
3797 (string= 'quote
(first operand
))
3798 (listp (second operand
)))))
3799 ;;(break "op: ~S" (second (second instruction)))
3800 ;; recurse into program-to-append..
3801 (list (list (first instruction
)
3802 (list 'quote
(finalize-code (second (second instruction
))
3803 funobj frame-map
)))))
3805 (t ;; (warn "finalizing ~S" instruction)
3806 (case (first instruction
)
3807 ((:locally
:globally
)
3808 (destructuring-bind (sub-instr)
3810 (let ((pf (ecase (first instruction
)
3811 (:locally
*compiler-local-segment-prefix
*)
3812 (:globally
*compiler-global-segment-prefix
*))))
3813 (list (fix-edi-offset
3817 ((consp (car sub-instr
))
3818 (list* (append pf
(car sub-instr
))
3820 (t (list* pf sub-instr
))))))))
3821 ((:declare-label-set
3822 :declare-key-arg-set
)
3824 (:local-function-init
3825 (destructuring-bind (function-binding)
3826 (operands instruction
)
3828 (warn "local-function-init: init ~S at ~S"
3830 (new-binding-location function-binding frame-map
))
3832 (let* ((sub-funobj (function-binding-funobj function-binding
)))
3834 ((eq (movitz-funobj-extent sub-funobj
) :unused
)
3835 (unless (or (movitz-env-get (binding-name function-binding
)
3837 (binding-env function-binding
) nil
)
3838 (movitz-env-get (binding-name function-binding
)
3840 (binding-env function-binding
) nil
))
3841 (warn "Unused local function: ~S"
3842 (binding-name function-binding
)))
3844 ((typep function-binding
'funobj-binding
)
3847 ((member (movitz-funobj-extent sub-funobj
)
3848 '(:dynamic-extent
:lexical-extent
))
3849 (check-type function-binding closure-binding
)
3850 (when (plusp (movitz-funobj-num-jumpers sub-funobj
))
3851 (break "Don't know yet how to stack a funobj with jumpers."))
3852 (let ((words (+ (movitz-funobj-num-constants sub-funobj
)
3853 (/ (sizeof 'movitz-funobj
) 4))))
3854 (break "words for ~S: ~S" words sub-funobj
)
3855 (append `((:movl
:esp
:eax
)
3857 (:jz
'no-alignment-needed
)
3859 no-alignment-needed
)
3860 (make-load-constant sub-funobj
:eax funobj frame-map
)
3862 (t (assert (not (null (borrowed-bindings sub-funobj
))))
3863 (append (make-load-constant sub-funobj
:eax funobj frame-map
)
3864 `((:movl
(:edi
,(global-constant-offset 'copy-funobj
)) :esi
)
3865 (:call
(:esi
,(bt:slot-offset
'movitz-funobj
'code-vector%
1op
)))
3867 (make-store-lexical function-binding
:eax nil funobj frame-map
)
3868 (loop for bb in
(borrowed-bindings sub-funobj
)
3869 append
(make-lend-lexical bb
:edx nil
))))))
3872 (destructuring-bind (function-binding register capture-env
)
3873 (operands instruction
)
3874 (declare (ignore capture-env
))
3876 (let* ((sub-funobj (function-binding-funobj function-binding
))
3877 (lend-code (loop for bb in
(borrowed-bindings sub-funobj
)
3879 (make-lend-lexical bb
:edx nil
))))
3882 ;; (warn "null lambda lending")
3883 (append (make-load-constant sub-funobj register funobj frame-map
)))
3884 ((typep (movitz-allocation sub-funobj
)
3885 'with-dynamic-extent-scope-env
)
3886 (setf (headers-on-stack-frame-p funobj
) t
)
3887 (let ((dynamic-scope (movitz-allocation sub-funobj
)))
3888 (append (make-load-lexical (base-binding dynamic-scope
) :edx
3889 funobj nil frame-map
)
3890 `((:leal
(:edx
,(tag :other
)
3891 ,(dynamic-extent-object-offset dynamic-scope
3895 `((:movl
:edx
,register
)))))
3896 (t (append (make-load-constant sub-funobj
:eax funobj frame-map
)
3897 `((:movl
(:edi
,(global-constant-offset 'copy-funobj
)) :esi
)
3898 (:call
(:esi
,(bt:slot-offset
'movitz-funobj
'code-vector%
1op
)))
3901 `((:movl
:edx
,register
))))))
3904 (destructuring-bind (object result-mode
&key
(op :movl
))
3906 (make-load-constant object result-mode funobj frame-map
:op op
)))
3907 (:lexical-control-transfer
3908 (destructuring-bind (return-code return-mode from-env to-env
&optional to-label
)
3910 (declare (ignore return-code
))
3911 (let ((x (apply #'make-compiled-lexical-control-transfer
3913 return-mode from-env to-env
3914 (when to-label
(list to-label
)))))
3915 (finalize-code x funobj frame-map
))))
3917 (destructuring-bind (binding num-args
)
3918 (operands instruction
)
3919 (append (etypecase binding
3921 (make-load-lexical (ensure-local-binding binding
)
3922 :esi funobj nil frame-map
3923 :tmp-register
:edx
))
3925 (make-load-constant (function-binding-funobj binding
)
3926 :esi funobj frame-map
)))
3927 (make-compiled-funcall-by-esi num-args
))))
3928 (t (expand-extended-code instruction funobj frame-map
)))))))))
3931 (defun image-t-symbol-p (x)
3932 (eq x
(image-t-symbol *image
*)))
3934 (deftype movitz-t
()
3935 `(satisfies image-t-symbol-p
))
3937 (defun make-load-constant (object result-mode funobj frame-map
&key
(op :movl
))
3938 (let ((movitz-obj (movitz-read object
)))
3941 (etypecase movitz-obj
3943 (ecase (result-mode-type result-mode
)
3945 (make-store-lexical result-mode
:edi nil funobj frame-map
))
3948 ((:eax
:ebx
:ecx
:edx
)
3949 `((:movl
:edi
,result-mode
)))
3950 (:boolean-branch-on-true
3951 ;; (warn "branch-on-true for nil!")
3953 (:boolean-branch-on-false
3954 ;; (warn "branch-on-false for nil!")
3955 `((:jmp
',(operands result-mode
))))
3956 ((:multiple-values
:function
)
3960 (t (when (eq :boolean result-mode
)
3961 (warn "Compiling ~S for mode ~S." object result-mode
))
3962 (make-result-and-returns-glue result-mode
:edi nil
)
3963 #+ignore
'((:movl
:edi
:eax
)))))
3965 (ecase (result-mode-type result-mode
)
3967 `((:pushl
(:edi
,(global-constant-offset 't-symbol
)))))
3968 ((:eax
:ebx
:ecx
:edx
)
3969 `((:movl
(:edi
,(global-constant-offset 't-symbol
)) ,result-mode
)))
3970 (:boolean-branch-on-false
3971 ;; (warn "boolean-branch-on-false T")
3973 (:boolean-branch-on-true
3974 ;; (warn "boolean-branch-on-true T")
3975 `((:jmp
',(operands result-mode
))))
3976 ((:multiple-values
:function
)
3977 `((:movl
(:edi
,(global-constant-offset 't-symbol
))
3981 (append `((:movl
(:edi
,(global-constant-offset 't-symbol
))
3983 (make-store-lexical result-mode
:eax nil funobj frame-map
)))
3985 (t (when (eq :boolean result-mode
)
3986 (warn "Compiling ~S for mode ~S." object result-mode
))
3987 (make-result-and-returns-glue result-mode
:eax
3988 `((:movl
(:edi
,(global-constant-offset 't-symbol
))
3990 (movitz-immediate-object
3991 (let ((x (movitz-immediate-value movitz-obj
)))
3992 (ecase (result-mode-type result-mode
)
3994 (append (make-immediate-move x
:eax
)
3995 (make-store-lexical result-mode
:eax nil funobj frame-map
)))
3996 (:untagged-fixnum-ecx
3997 (let ((value (movitz-fixnum-value object
)))
3998 (check-type value
(unsigned-byte 32))
3999 (make-immediate-move value
:ecx
)))
4002 ((:eax
:ebx
:ecx
:edx
)
4003 (make-immediate-move x result-mode
))
4004 ((:multiple-values
:function
)
4005 (append (make-immediate-move x
:eax
)
4008 (ecase (result-mode-type result-mode
)
4009 (:untagged-fixnum-ecx
4010 (let ((value (movitz-bignum-value object
)))
4011 (make-immediate-move (ldb (byte 32 0) value
) :ecx
)))
4014 ((and (typep movitz-obj
'movitz-bignum
)
4015 (eq :untagged-fixnum-ecx
4016 (new-binding-location result-mode frame-map
:default nil
)))
4017 (unless (typep (movitz-bignum-value movitz-obj
) '(unsigned-byte 32))
4018 (warn "Loading non-u32 ~S into ~S."
4019 (movitz-bignum-value movitz-obj
)
4021 (make-immediate-move (ldb (byte 32 0) (movitz-bignum-value movitz-obj
))
4023 (t (when (member (new-binding-location result-mode frame-map
:default nil
)
4024 '(:ebx
:ecx
:edx
:esi
))
4025 (warn "load to ~S at ~S from ~S"
4026 result-mode
(new-binding-location result-mode frame-map
) movitz-obj
))
4027 (append `((:movl
,(new-make-compiled-constant-reference movitz-obj funobj
)
4029 (make-store-lexical result-mode
:eax nil funobj frame-map
)))))
4031 `((:pushl
,(new-make-compiled-constant-reference movitz-obj funobj
))))
4032 ((:eax
:ebx
:ecx
:edx
:esi
)
4033 `((,op
,(new-make-compiled-constant-reference movitz-obj funobj
)
4036 (assert (eq op
:cmpl
))
4037 `((,op
,(new-make-compiled-constant-reference movitz-obj funobj
)
4039 ((:function
:multiple-values
)
4040 (assert (eq op
:movl
))
4041 `((,op
,(new-make-compiled-constant-reference movitz-obj funobj
)
4044 (t (ecase result-mode
4045 ((:eax
:ebx
:ecx
:edx
:esi
)
4046 `((,op
,(new-make-compiled-constant-reference movitz-obj funobj
)
4049 (assert (eq op
:cmpl
))
4050 `((,op
,(new-make-compiled-constant-reference movitz-obj funobj
)
4051 ,result-mode
))))))))
4053 (defparameter +movitz-lambda-list-keywords
+
4054 '(muerte.cl
:&OPTIONAL
4060 muerte.cl
:&ALLOW-OTHER-KEYS
4061 muerte.cl
:&ENVIRONMENT
))
4063 (defun add-bindings-from-lambda-list (lambda-list env
)
4064 "From a (normal) <lambda-list>, add bindings to <env>."
4066 (multiple-value-bind (required-vars optional-vars rest-var key-vars auxes allow-p min-args max-args edx-var oddeven key-vars-p
)
4067 (decode-normal-lambda-list lambda-list
)
4068 (setf (min-args env
) min-args
4069 (max-args env
) max-args
4070 (oddeven-args env
) oddeven
4071 (aux-vars env
) auxes
4072 (allow-other-keys-p env
) allow-p
)
4073 (flet ((shadow-when-special (formal env
)
4074 "Iff <formal> is special, return a fresh variable-name that takes <formal>'s place
4075 as the lexical variable-name, and add a new shadowing dynamic binding for <formal> in <env>."
4076 (if (not (movitz-env-get formal
'special nil env
))
4078 (let* ((shadowed-formal (gensym (format nil
"shady-~A-" formal
)))
4079 (shadowing-binding (make-instance 'shadowing-dynamic-binding
4080 :name shadowed-formal
4081 :shadowing-variable formal
4082 :shadowed-variable shadowed-formal
)))
4083 (movitz-env-add-binding env shadowing-binding formal
)
4084 (push (list formal shadowed-formal
)
4085 (special-variable-shadows env
))
4088 (movitz-env-add-binding env
4090 (make-instance 'edx-function-argument
4092 (setf (required-vars env
)
4093 (loop for formal in required-vars
4094 do
(check-type formal symbol
)
4096 (shadow-when-special formal env
))
4097 do
(movitz-env-add-binding env
(cond
4099 (make-instance 'register-required-function-argument
4102 ((and max-args
(= min-args max-args
))
4103 (make-instance 'fixed-required-function-argument
4107 (t (make-instance 'floating-required-function-argument
4112 (setf (optional-vars env
)
4113 (loop for spec in optional-vars
4115 (multiple-value-bind (formal init-form supplied-p-parameter
)
4116 (decode-optional-formal spec
)
4117 (setf formal
(shadow-when-special formal env
))
4118 (movitz-env-add-binding env
(make-instance 'optional-function-argument
4120 :argnum
(post-incf arg-pos
)
4121 'init-form init-form
4122 'supplied-p-var supplied-p-parameter
))
4123 (when supplied-p-parameter
4124 (setf supplied-p-parameter
4125 (shadow-when-special supplied-p-parameter env
))
4126 (movitz-env-add-binding env
(make-instance 'supplied-p-function-argument
4127 :name supplied-p-parameter
)))
4129 (when (or rest-var key-vars-p
)
4130 (setf (rest-args-position env
) arg-pos
))
4132 (check-type rest-var symbol
)
4133 (let ((formal (shadow-when-special rest-var env
)))
4134 (setf (rest-var env
) formal
)
4135 (movitz-env-add-binding env
(make-instance 'rest-function-argument
4137 :argnum
(post-incf arg-pos
)))))
4139 (setf (key-vars-p env
) t
)
4140 (when (>= 1 (rest-args-position env
))
4141 (let ((name (gensym "save-ebx-for-keyscan")))
4142 (setf (required-vars env
)
4143 (append (required-vars env
)
4145 (movitz-env-add-binding env
(make-instance 'register-required-function-argument
4148 :declarations
'(muerte.cl
:ignore
)))
4149 (setf (movitz-env-get name
'ignore nil env
) t
)))
4150 (when (= 0 (rest-args-position env
))
4151 (let ((name (gensym "save-eax-for-keyscan")))
4152 (push name
(required-vars env
))
4153 (movitz-env-add-binding env
(make-instance 'register-required-function-argument
4156 (setf (movitz-env-get name
'ignore nil env
) t
))))
4157 (setf (key-vars env
)
4158 (loop for spec in key-vars
4160 (multiple-value-bind (formal keyword-name init-form supplied-p
)
4161 (decode-keyword-formal spec
)
4162 (let ((formal (shadow-when-special formal env
))
4163 (supplied-p-parameter supplied-p
))
4164 (movitz-env-add-binding env
(make-instance 'keyword-function-argument
4166 'init-form init-form
4167 'supplied-p-var supplied-p-parameter
4168 :keyword-name keyword-name
))
4169 (when supplied-p-parameter
4170 (movitz-env-add-binding env
(make-instance 'supplied-p-function-argument
4171 :name
(shadow-when-special supplied-p-parameter env
))))
4174 (multiple-value-bind (key-decode-map key-decode-shift
)
4175 (best-key-encode (key-vars env
))
4176 (setf (key-decode-map env
) key-decode-map
4177 (key-decode-shift env
) key-decode-shift
))
4180 (warn "~D waste, keys: ~S, shift ~D, map: ~S"
4181 (- (length (key-decode-map env
))
4184 (key-decode-shift env
)
4185 (key-decode-map env
))))))
4188 (defun make-compiled-function-prelude-numarg-check (min-args max-args
)
4189 "The prelude is compiled after the function's body."
4190 (assert (or (not max-args
) (<= 0 min-args max-args
)))
4191 (assert (<= 0 min-args
(or max-args min-args
) #xffff
) ()
4192 "Lambda lists longer than #xffff are not yet implemented.")
4193 (let ((wrong-numargs (make-symbol "wrong-numargs")))
4195 ((and (zerop min-args
) ; any number of arguments is
4196 (not max-args
)) ; acceptable, no check necessary.
4200 (if (< min-args
#x80
)
4201 `((:cmpb
,min-args
:cl
)
4202 (:jb
'(:sub-program
(,wrong-numargs
) (:int
100))))
4203 `((:cmpl
,(dpb min-args
(byte 24 8) #x80
) :ecx
)
4204 (:jb
'(:sub-program
(,wrong-numargs
) (:int
100))))))
4205 ((and max-args
(= 0 min-args max-args
))
4208 (:jnz
'(:sub-program
(,wrong-numargs
) (:int
100)))))
4209 ((and max-args
(= min-args max-args
))
4212 ((= 1 min-args max-args
)
4213 `((:call
(:edi
,(global-constant-offset 'assert-1arg
)))))
4214 ((= 2 min-args max-args
)
4215 `((:call
(:edi
,(global-constant-offset 'assert-2args
)))))
4216 ((= 3 min-args max-args
)
4217 `((:call
(:edi
,(global-constant-offset 'assert-3args
)))))
4219 `((:cmpb
,min-args
:cl
)
4220 (:jne
'(:sub-program
(,wrong-numargs
) (:int
100)))))
4221 (t `((:cmpl
,(dpb min-args
(byte 24 8) #x80
) :ecx
)
4222 (:jne
'(:sub-program
(,wrong-numargs
) (:int
100)))))))
4223 ((and max-args
(/= min-args max-args
) (= 0 min-args
))
4225 (if (< max-args
#x80
)
4226 `((:cmpb
,max-args
:cl
)
4227 (:ja
'(:sub-program
(,wrong-numargs
) (:int
100))))
4228 `((:cmpl
,(dpb max-args
(byte 24 8) #x80
) :ecx
)
4229 (:ja
'(:sub-program
(,wrong-numargs
) (:int
100))))))
4230 ((and max-args
(/= min-args max-args
))
4232 (append (if (< min-args
#x80
)
4233 `((:cmpb
,min-args
:cl
)
4234 (:jb
'(:sub-program
(,wrong-numargs
) (:int
100))))
4235 `((:cmpl
,(dpb min-args
(byte 24 8) #x80
) :ecx
)
4236 (:jb
'(:sub-program
(,wrong-numargs
) (:int
100)))))
4237 (if (< max-args
#x80
)
4238 `((:cmpb
,max-args
:cl
)
4239 (:ja
'(:sub-program
(,wrong-numargs
) (:int
100))))
4240 `((:cmpl
,(dpb max-args
(byte 24 8) #x80
) :ecx
)
4241 (:ja
'(:sub-program
(,wrong-numargs
) (:int
100)))))))
4242 (t (error "Don't know how to compile checking for ~A to ~A arguments."
4243 min-args max-args
)))))
4245 (defun make-stack-setup-code (stack-setup-size)
4246 (loop repeat stack-setup-size
4247 collect
'(:pushl
:edi
))
4249 (case stack-setup-size
4251 (1 '((:pushl
:edi
)))
4252 (2 '((:pushl
:edi
) (:pushl
:edi
)))
4253 (3 '((:pushl
:edi
) (:pushl
:edi
) (:pushl
:edi
)))
4254 (t `((:subl
,(* 4 stack-setup-size
) :esp
)))))
4256 (defun make-compiled-function-prelude (stack-frame-size env use-stack-frame-p
4257 need-normalized-ecx-p frame-map
4258 &key do-check-stack-p
)
4259 "The prelude is compiled after the function's body is."
4260 (when (without-function-prelude-p env
)
4261 (return-from make-compiled-function-prelude
4262 (when use-stack-frame-p
4266 (let ((required-vars (required-vars env
))
4267 (min-args (min-args env
))
4268 (max-args (max-args env
)))
4269 (let ((stack-setup-size stack-frame-size
)
4270 (edx-needs-saving-p (and (edx-var env
)
4271 (new-binding-location (edx-var env
) frame-map
:default nil
))))
4272 (multiple-value-bind (eax-ebx-code eax-ebx-code-post-stackframe
)
4273 (let* ((map0 (find-if (lambda (bb)
4274 (and (typep (car bb
) '(or required-function-argument
4275 optional-function-argument
))
4276 (= 0 (function-argument-argnum (car bb
)))))
4278 (location-0 (cdr map0
))
4279 (map1 (find-if (lambda (bb)
4280 (and (typep (car bb
) '(or required-function-argument
4281 optional-function-argument
))
4282 (= 1 (function-argument-argnum (car bb
)))))
4284 (location-1 (cdr map1
))
4287 (new-binding-location (edx-var env
) frame-map
:default nil
))))
4288 #+ignore
(warn "l0: ~S, l1: ~S" location-0 location-1
)
4289 (assert (not (and location-0
4290 (eql location-0 location-1
))) ()
4291 "Compiler bug: two bindings in same location.")
4293 ((and (eq :ebx location-0
) (eq :eax location-1
))
4294 `((:xchgl
:eax
:ebx
)))
4295 ((and (eql 1 location-0
) (eql 2 location-1
))
4296 (decf stack-setup-size
2)
4297 (when (eql 3 edx-location
)
4298 (decf stack-setup-size
1)
4299 (setf edx-needs-saving-p nil
))
4300 (let (before-code after-code
)
4305 (when (eql 3 edx-location
)
4307 ;; Keep pushing any sequentially following floating requireds.
4308 ;; NB: Fixed-floats are used in-place, e.g above the stack-frame,
4309 ;; so no need to worry about them.
4310 (loop with expected-location
= 2
4311 for var in
(cddr required-vars
)
4312 as binding
= (movitz-binding var env
)
4313 if
(and expected-location
4314 (typep binding
'floating-required-function-argument
)
4315 (new-binding-located-p binding frame-map
)
4316 (= expected-location
4317 (new-binding-location binding frame-map
)))
4318 do
(decf stack-setup-size
)
4319 and do
(incf expected-location
)
4320 and do
(setq need-normalized-ecx-p t
)
4322 `(:pushl
(:ebp
(:ecx
4)
4323 ,(* -
4 (1- (function-argument-argnum binding
)))))
4324 else do
(setf expected-location nil
)
4325 and do
(when (and (typep binding
'floating-required-function-argument
)
4326 (new-binding-located-p binding frame-map
))
4327 (setq need-normalized-ecx-p t
)
4331 `((:movl
(:ebp
(:ecx
4)
4332 ,(* -
4 (1- (function-argument-argnum binding
))))
4334 (:movl
:edx
(:ebp
,(stack-frame-offset
4335 (new-binding-location binding frame-map
)))))))))))
4336 (values before-code after-code
)))
4339 ((and (eq :ebx location-0
)
4341 (decf stack-setup-size
)
4343 (:xchgl
:eax
:ebx
)))
4344 ((and (eq :ebx location-0
)
4345 (eq :edx location-1
))
4351 (decf stack-setup-size
)
4353 (t (ecase location-0
4355 (:ebx
(assert (not location-1
))
4356 '((:movl
:eax
:ebx
)))
4357 (:edx
(assert (not edx-location
))
4358 '((:movl
:eax
:edx
))))))
4361 (decf stack-setup-size
)
4363 (t (ecase location-1
4365 (:edx
'((:movl
:ebx
:edx
)))
4366 (:eax
`((:movl
:ebx
:eax
)))))))))
4368 ((or (and (or (eql 1 location-0
)
4370 (eql 2 edx-location
))
4371 (and (not (integerp location-0
))
4372 (not (integerp location-1
))
4373 (eql 1 edx-location
)))
4374 (decf stack-setup-size
)
4375 (setf edx-needs-saving-p nil
)
4377 (loop for var in
(cddr required-vars
)
4378 as binding
= (movitz-binding var env
)
4379 when
(and (typep binding
'floating-required-function-argument
)
4380 (new-binding-located-p binding frame-map
))
4382 `((:movl
(:ebp
(:ecx
4)
4383 ,(* -
4 (1- (function-argument-argnum binding
))))
4385 (:movl
:edx
(:ebp
,(stack-frame-offset
4386 (new-binding-location binding frame-map
)))))
4388 (setq need-normalized-ecx-p t
))))))
4389 (assert (not (minusp stack-setup-size
)))
4390 (let ((stack-frame-init-code
4391 (append (when (and do-check-stack-p use-stack-frame-p
4392 *compiler-auto-stack-checks-p
*
4393 (not (without-check-stack-limit-p env
)))
4394 `((,*compiler-local-segment-prefix
*
4395 :bound
(:edi
,(global-constant-offset 'stack-bottom
)) :esp
)))
4396 (when use-stack-frame-p
4403 ((and (eql 1 min-args
)
4405 (append (make-compiled-function-prelude-numarg-check min-args max-args
)
4407 stack-frame-init-code
))
4408 ((and (eql 2 min-args
)
4410 (append (make-compiled-function-prelude-numarg-check min-args max-args
)
4412 stack-frame-init-code
))
4413 ((and (eql 3 min-args
)
4415 (append (make-compiled-function-prelude-numarg-check min-args max-args
)
4417 stack-frame-init-code
))
4418 (t (append stack-frame-init-code
4419 (make-compiled-function-prelude-numarg-check min-args max-args
))))
4420 '(start-stack-frame-setup)
4422 (make-stack-setup-code stack-setup-size
)
4423 (when need-normalized-ecx-p
4425 ;; normalize arg-count in ecx..
4426 ((and max-args
(= min-args max-args
))
4428 ((and max-args
(<= 0 min-args max-args
#x7f
))
4429 `((:andl
#x7f
:ecx
)))
4432 (t (let ((normalize (make-symbol "normalize-ecx"))
4433 (normalize-done (make-symbol "normalize-ecx-done")))
4435 (:js
'(:sub-program
(,normalize
)
4437 (:jmp
',normalize-done
)))
4439 ,normalize-done
))))))
4440 (when edx-needs-saving-p
4441 `((:movl
:edx
(:ebp
,(stack-frame-offset (new-binding-location (edx-var env
) frame-map
))))))
4442 eax-ebx-code-post-stackframe
4443 (loop for binding in
(potentially-lended-bindings env
)
4444 as lended-cons-position
= (getf (binding-lending binding
) :stack-cons-location
)
4445 as location
= (new-binding-location binding frame-map
:default nil
)
4446 when
(and (not (typep binding
'borrowed-binding
))
4447 lended-cons-position
4451 (required-function-argument
4452 ;; (warn "lend: ~W => ~W" binding lended-cons-position)
4453 (etypecase (operator location
)
4455 (warn "lending EAX..")
4457 (:ebp
,(stack-frame-offset lended-cons-position
))) ; cdr
4459 (:ebp
,(stack-frame-offset (1+ lended-cons-position
)))) ; car
4460 (:leal
(:ebp
1 ,(stack-frame-offset (1+ lended-cons-position
)))
4462 ((eql :argument-stack
)
4463 `((:movl
(:ebp
,(argument-stack-offset binding
)) :edx
)
4465 (:ebp
,(stack-frame-offset lended-cons-position
))) ; cdr
4467 (:ebp
,(stack-frame-offset (1+ lended-cons-position
)))) ; car
4468 (:leal
(:ebp
1 ,(stack-frame-offset (1+ lended-cons-position
)))
4471 (:ebp
,(argument-stack-offset binding
)))))
4473 `((:movl
(:ebp
,(stack-frame-offset location
))
4476 (:ebp
,(stack-frame-offset lended-cons-position
))) ; cdr
4478 (:ebp
,(stack-frame-offset (1+ lended-cons-position
)))) ; car
4479 (:leal
(:ebp
1 ,(stack-frame-offset (1+ lended-cons-position
)))
4482 (:ebp
,(stack-frame-offset location
)))))))
4484 ;; (warn "lend closure-binding: ~W => ~W" binding lended-cons-position)
4485 (etypecase (operator location
)
4486 ((eql :argument-stack
)
4487 `((:movl
(:edi
,(global-constant-offset 'unbound-function
)) :edx
)
4488 (:movl
:edi
(:ebp
,(stack-frame-offset lended-cons-position
))) ; cdr
4489 (:movl
:edx
(:ebp
,(stack-frame-offset (1+ lended-cons-position
)))) ; car
4490 (:leal
(:ebp
1 ,(stack-frame-offset (1+ lended-cons-position
))) :edx
)
4491 (:movl
:edx
(:ebp
,(argument-stack-offset binding
)))))
4493 `((:movl
(:edi
,(global-constant-offset 'unbound-function
)) :edx
)
4494 (:movl
:edi
(:ebp
,(stack-frame-offset lended-cons-position
))) ; cdr
4495 (:movl
:edx
(:ebp
,(stack-frame-offset (1+ lended-cons-position
)))) ; car
4496 (:leal
(:ebp
1 ,(stack-frame-offset (1+ lended-cons-position
))) :edx
)
4497 (:movl
:edx
(:ebp
,(stack-frame-offset location
)))))))
4499 (t (etypecase location
4500 ((eql :argument-stack
)
4501 `((:movl
:edi
(:ebp
,(stack-frame-offset lended-cons-position
))) ; cdr
4502 (:movl
:edi
(:ebp
,(stack-frame-offset (1+ lended-cons-position
)))) ; car
4503 (:leal
(:ebp
1 ,(stack-frame-offset (1+ lended-cons-position
))) :edx
)
4504 (:movl
:edx
(:ebp
,(argument-stack-offset binding
)))))
4506 `((:movl
:edi
(:ebp
,(stack-frame-offset lended-cons-position
))) ; cdr
4507 (:movl
:edi
(:ebp
,(stack-frame-offset (1+ lended-cons-position
)))) ; car
4508 (:leal
(:ebp
1 ,(stack-frame-offset (1+ lended-cons-position
))) :edx
)
4509 (:movl
:edx
(:ebp
,(stack-frame-offset location
))))))))))
4510 need-normalized-ecx-p
))))))
4512 (defparameter *restify-stats
* (make-hash-table :test
#'eql
))
4514 (defparameter *ll
* (make-array 20 :initial-element
0))
4515 (defparameter *xx
* (make-array 20))
4517 (defun install-arg-cmp (code have-normalized-ecx-p
)
4520 (if (not (and (listp i
) (eq :arg-cmp
(car i
))))
4522 (let ((arg-count (second i
)))
4524 (have-normalized-ecx-p
4525 `(:cmpl
,arg-count
:ecx
))
4527 `(:cmpb
,arg-count
:cl
))
4528 (t `(:cmpl
,(dpb arg-count
(byte 24 8) #x80
) :ecx
)))))))
4530 (defun make-function-arguments-init (funobj env
)
4531 "The arugments-init is compiled before the function's body is.
4532 Return arg-init-code, need-normalized-ecx-p."
4533 (when (without-function-prelude-p env
)
4534 (return-from make-function-arguments-init
4536 (let ((need-normalized-ecx-p nil
)
4537 (required-vars (required-vars env
))
4538 (optional-vars (optional-vars env
))
4539 (rest-var (rest-var env
))
4540 (key-vars (key-vars env
)))
4543 (loop for optional in optional-vars
4544 as optional-var
= (decode-optional-formal optional
)
4545 as binding
= (movitz-binding optional-var env
)
4546 as last-optional-p
= (and (null key-vars
)
4548 (= 1 (- (+ (length optional-vars
) (length required-vars
))
4549 (function-argument-argnum binding
))))
4550 as supplied-p-var
= (optional-function-argument-supplied-p-var binding
)
4551 as supplied-p-binding
= (movitz-binding supplied-p-var env
)
4552 as not-present-label
= (make-symbol (format nil
"optional-~D-not-present"
4553 (function-argument-argnum binding
)))
4554 and optional-ok-label
= (make-symbol (format nil
"optional-~D-ok"
4555 (function-argument-argnum binding
)))
4556 unless
(movitz-env-get optional-var
'ignore nil env nil
) ; XXX
4559 ((= 0 (function-argument-argnum binding
))
4560 `((:init-lexvar
,binding
:init-with-register
:eax
:init-with-type t
)))
4561 ((= 1 (function-argument-argnum binding
))
4562 `((:init-lexvar
,binding
:init-with-register
:ebx
:init-with-type t
)))
4563 (t `((:init-lexvar
,binding
))))
4564 when supplied-p-binding
4565 append
`((:init-lexvar
,supplied-p-binding
))
4567 (compiler-values-bind (&code init-code-edx
&producer producer
)
4568 (compiler-call #'compile-form
4569 :form
(optional-function-argument-init-form binding
)
4574 ((and (eq 'compile-self-evaluating producer
)
4575 (member (function-argument-argnum binding
) '(0 1)))
4576 ;; The binding is already preset with EAX or EBX.
4577 (check-type binding lexical-binding
)
4579 (when supplied-p-var
4580 `((:load-constant
,(movitz-read t
) :edx
)
4581 (:store-lexical
,supplied-p-binding
:edx
:type
(member t
))))
4582 `((:arg-cmp
,(function-argument-argnum binding
))
4583 (:ja
',optional-ok-label
))
4584 (compiler-call #'compile-form
4585 :form
(optional-function-argument-init-form binding
)
4588 :result-mode binding
)
4589 (when supplied-p-var
4590 `((:store-lexical
,supplied-p-binding
:edi
:type null
)))
4591 `(,optional-ok-label
)))
4592 ((eq 'compile-self-evaluating producer
)
4593 `(,@(when supplied-p-var
4594 `((:store-lexical
,supplied-p-binding
:edi
:type null
)))
4595 ,@(if (optional-function-argument-init-form binding
)
4596 (append init-code-edx
`((:store-lexical
,binding
:edx
:type t
)))
4597 `((:store-lexical
,binding
:edi
:type null
)))
4598 (:arg-cmp
,(function-argument-argnum binding
))
4599 (:jbe
',not-present-label
)
4600 ,@(case (function-argument-argnum binding
)
4601 (0 `((:store-lexical
,binding
:eax
:type t
)))
4602 (1 `((:store-lexical
,binding
:ebx
:type t
)))
4605 `((:movl
(:ebp
,(* 4 (- (1+ (function-argument-argnum binding
))
4606 -
1 (function-argument-argnum binding
))))
4608 (:store-lexical
,binding
:eax
:type t
)))
4609 (t (setq need-normalized-ecx-p t
)
4610 `((:movl
(:ebp
(:ecx
4)
4611 ,(* -
4 (1- (function-argument-argnum binding
))))
4613 (:store-lexical
,binding
:eax
:type t
))))))
4614 ,@(when supplied-p-var
4615 `((:movl
(:edi
,(global-constant-offset 't-symbol
)) :eax
)
4616 (:store-lexical
,supplied-p-binding
:eax
4617 :type
(eql ,(image-t-symbol *image
*)))))
4618 ,not-present-label
))
4619 (t `((:arg-cmp
,(function-argument-argnum binding
))
4620 (:jbe
',not-present-label
)
4621 ,@(when supplied-p-var
4622 `((:movl
(:edi
,(global-constant-offset 't-symbol
)) :eax
)
4623 (:store-lexical
,supplied-p-binding
:eax
4624 :type
(eql ,(image-t-symbol *image
*)))))
4625 ,@(case (function-argument-argnum binding
)
4626 (0 `((:store-lexical
,binding
:eax
:type t
)))
4627 (1 `((:store-lexical
,binding
:ebx
:type t
)))
4630 `((:movl
(:ebp
,(* 4 (- (1+ (function-argument-argnum binding
))
4631 -
1 (function-argument-argnum binding
))))
4633 (:store-lexical
,binding
:eax
:type t
)))
4634 (t (setq need-normalized-ecx-p t
)
4635 `((:movl
(:ebp
(:ecx
4)
4636 ,(* -
4 (1- (function-argument-argnum binding
))))
4638 (:store-lexical
,binding
:eax
:type t
))))))
4639 (:jmp
',optional-ok-label
)
4641 ,@(when supplied-p-var
4642 `((:store-lexical
,supplied-p-binding
:edi
:type null
)))
4643 ,@(when (and (= 0 (function-argument-argnum binding
))
4644 (not last-optional-p
))
4645 `((:pushl
:ebx
))) ; protect ebx
4646 ,@(if (optional-function-argument-init-form binding
)
4647 (append `((:shll
,+movitz-fixnum-shift
+ :ecx
)
4649 (when (= 0 (function-argument-argnum binding
))
4652 `((:store-lexical
,binding
:edx
:type t
))
4653 (when (= 0 (function-argument-argnum binding
))
4656 (:shrl
,+movitz-fixnum-shift
+ :ecx
)))
4657 (progn (error "Unsupported situation.")
4658 #+ignore
`((:store-lexical
,binding
:edi
:type null
))))
4659 ,@(when (and (= 0 (function-argument-argnum binding
))
4660 (not last-optional-p
))
4661 `((:popl
:ebx
))) ; protect ebx
4662 ,optional-ok-label
)))))
4664 (let* ((rest-binding (movitz-binding rest-var env
)))
4665 `((:init-lexvar
,rest-binding
4666 :init-with-register
:edx
4667 :init-with-type list
))))
4669 (play-with-keys key-vars
))
4670 (when (key-vars-p env
)
4671 ;; &key processing..
4672 (setq need-normalized-ecx-p t
)
4674 `((:declare-key-arg-set
,@(mapcar (lambda (k)
4676 (keyword-function-argument-keyword-name
4677 (movitz-binding (decode-keyword-formal k
) env
))))
4679 (make-immediate-move (* +movitz-fixnum-factor
+
4680 (rest-args-position env
))
4682 `((:call
(:edi
,(global-constant-offset 'decode-keyargs-default
))))
4683 (unless (allow-other-keys-p env
)
4684 `((:testl
:eax
:eax
)
4685 (:jnz
'(:sub-program
(unknown-keyword)
4687 (loop for key-var in key-vars
4688 as key-location upfrom
3 by
2
4690 (decode-keyword-formal key-var
)
4692 (movitz-binding key-var-name env
)
4693 as supplied-p-binding
=
4694 (when (optional-function-argument-supplied-p-var binding
)
4695 (movitz-binding (optional-function-argument-supplied-p-var binding
)
4697 as keyword-ok-label
= (make-symbol (format nil
"keyword-~A-ok" key-var-name
))
4699 ;; (not (movitz-constantp (optional-function-argument-init-form binding)))
4701 (append `((:init-lexvar
,binding
4702 :init-with-register
,binding
4704 :shared-reference-p t
))
4705 (when supplied-p-binding
4706 `((:init-lexvar
,supplied-p-binding
4707 :init-with-register
,supplied-p-binding
4709 :shared-reference-p t
)))
4710 (when (optional-function-argument-init-form binding
)
4711 `((:cmpl
:edi
(:ebp
,(stack-frame-offset (1+ key-location
))))
4712 (:jne
',keyword-ok-label
)
4713 ,@(compiler-call #'compile-form
4714 :form
(optional-function-argument-init-form binding
)
4717 :result-mode binding
)
4718 ,keyword-ok-label
)))
4722 (append (when supplied-p-var
4723 `((:init-lexvar
,supplied-p-binding
4724 :init-with-register
:edi
4725 :init-with-type null
)))
4726 (compiler-call #'compile-form
4727 :form
(list 'muerte.cl
:quote
4728 (eval-form (optional-function-argument-init-form binding
)
4734 ,(movitz-read (keyword-function-argument-keyword-name binding
)) :ecx
)
4735 (:load-lexical
,rest-binding
:ebx
)
4736 (:call
(:edi
,(global-constant-offset 'keyword-search
))))
4737 (when supplied-p-var
4738 `((:jz
',keyword-not-supplied-label
)
4739 (:movl
(:edi
,(global-constant-offset 't-symbol
)) :ebx
)
4740 (:store-lexical
,supplied-p-binding
:ebx
4741 :type
(eql ,(image-t-symbol *image
*)))
4742 ,keyword-not-supplied-label
))
4743 `((:init-lexvar
,binding
4744 :init-with-register
:eax
4745 :init-with-type t
)))))))
4746 need-normalized-ecx-p
)))
4748 (defun old-key-encode (vars &key
(size (ash 1 (integer-length (1- (length vars
)))))
4750 (assert (<= (length vars
) size
))
4753 (loop with h
= (make-array size
)
4755 for var in
(sort (copy-list vars
) #'<
4757 (mod (ldb byte
(movitz-sxhash (movitz-read v
)))
4759 do
(let ((pos (mod (ldb byte
(movitz-sxhash (movitz-read var
)))
4761 (loop while
(aref h pos
)
4763 (setf pos
(mod (1+ pos
) (length h
))))
4764 (setf (aref h pos
) var
))
4765 finally
(return (values (subseq h
0 (1+ (position-if-not #'null h
:from-end t
)))
4768 (define-condition key-encoding-failed
() ())
4770 (defun key-cuckoo (x shift table
&optional path old-position
)
4772 (error 'key-encoding-failed
)
4773 (let* ((pos1 (mod (ash (movitz-sxhash (movitz-read x
)) (- shift
))
4775 (pos2 (mod (ash (movitz-sxhash (movitz-read x
)) (- 0 shift
9))
4777 (pos (if (eql pos1 old-position
) pos2 pos1
))
4778 (kickout (aref table pos
)))
4779 (setf (aref table pos
)
4782 (key-cuckoo kickout shift table
(cons x path
) pos
)))))
4784 (defun key-encode (vars &key
(size (ash 1 (integer-length (1- (length vars
)))))
4786 (declare (ignore byte
))
4787 (assert (<= (length vars
) size
))
4790 (loop with table
= (make-array size
)
4791 for var in
(sort (copy-list vars
) #'<
4793 (mod (movitz-sxhash (movitz-read v
))
4795 do
(key-cuckoo var shift table
)
4797 (return (values table
4799 (count-if (lambda (v)
4800 (eq v
(aref table
(mod (ash (movitz-sxhash (movitz-read v
))
4805 (defun best-key-encode (vars)
4807 (loop with best-encoding
= nil
4810 for size
= (ash 1 (integer-length (1- (length vars
))))
4812 ;; from (length vars) to (+ 8 (ash 1 (integer-length (1- (length vars)))))
4813 while
(<= size
(max 16 (ash 1 (integer-length (1- (length vars
))))))
4814 do
(loop for shift from
0 to
9 by
3
4816 (multiple-value-bind (encoding crashes
)
4817 (key-encode vars
:size size
:shift shift
)
4818 (when (or (not best-encoding
)
4819 (< crashes best-crashes
)
4820 (and (= crashes best-crashes
)
4821 (or (< shift best-shift
)
4822 (and (= shift best-shift
)
4823 (< (length encoding
)
4824 (length best-encoding
))))))
4825 (setf best-encoding encoding
4827 best-crashes crashes
)))
4828 (key-encoding-failed ())))
4830 (unless best-encoding
4831 (warn "Key-encoding failed for ~S: ~S."
4834 (list (movitz-sxhash (movitz-read v
))
4835 (ldb (byte (+ 3 (integer-length (1- (length vars
)))) 0)
4836 (movitz-sxhash (movitz-read v
)))
4837 (ldb (byte (+ 3 (integer-length (1- (length vars
)))) 9)
4838 (movitz-sxhash (movitz-read v
)))))
4841 (warn "~D waste for ~S"
4842 (- (length best-encoding
)
4845 (return (values best-encoding best-shift best-crashes
)))))
4849 (defun play-with-keys (key-vars)
4851 (let* ((vars (mapcar #'decode-keyword-formal key-vars
)))
4852 (multiple-value-bind (encoding shift crashes
)
4853 (best-key-encode vars
)
4854 (when (or (plusp crashes
)
4855 #+ignore
(>= shift
3)
4856 (>= (- (length encoding
) (length vars
))
4858 (warn "KEY vars: ~S, crash ~D, shift ~D, waste: ~D hash: ~S"
4860 (- (length encoding
) (length vars
))
4862 (movitz-sxhash (movitz-read s
)))
4866 (defun make-special-funarg-shadowing (env function-body
)
4867 "Wrap function-body in a let, if we need to.
4868 We need to when the function's lambda-list binds a special variable,
4869 or when there's a non-dynamic-extent &rest binding."
4870 (if (without-function-prelude-p env
)
4873 (append (special-variable-shadows env
)
4875 (when (and (rest-var env
)
4876 (not (movitz-env-get (rest-var env
) 'dynamic-extent nil env nil
))
4877 (not (movitz-env-get (rest-var env
) 'ignore nil env nil
)))
4878 (movitz-env-load-declarations `((muerte.cl
:dynamic-extent
,(rest-var env
)))
4880 `((,(rest-var env
) (muerte.cl
:copy-list
,(rest-var env
))))))))
4881 (if (null shadowing
)
4883 `(muerte.cl
::let
,shadowing
,function-body
)))))
4885 (defun make-compiled-function-postlude (funobj env use-stack-frame-p
)
4886 (declare (ignore funobj env
))
4887 (let ((p '((:movl
(:ebp -
4) :esi
)
4889 (if use-stack-frame-p
4893 (defun complement-boolean-result-mode (mode)
4897 (:boolean-greater
:boolean-less-equal
)
4898 (:boolean-less
:boolean-greater-equal
)
4899 (:boolean-greater-equal
:boolean-less
)
4900 (:boolean-less-equal
:boolean-greater
)
4901 (:boolean-below
:boolean-above-equal
)
4902 (:boolean-above
:boolean-below-equal
)
4903 (:boolean-below-equal
:boolean-above
)
4904 (:boolean-above-equal
:boolean-below
)
4905 (:boolean-zf
=1 :boolean-zf
=0)
4906 (:boolean-zf
=0 :boolean-zf
=1)
4907 (:boolean-cf
=1 :boolean-cf
=0)
4908 (:boolean-cf
=0 :boolean-cf
=1)))
4910 (let ((args (cdr mode
)))
4913 (list :boolean-ecx
(second args
) (first args
)))
4914 (:boolean-branch-on-true
4915 (cons :boolean-branch-on-false args
))
4916 (:boolean-branch-on-false
4917 (cons :boolean-branch-on-true args
)))))))
4919 (defun make-branch-on-boolean (mode label
&key invert
)
4920 (list (ecase (if invert
(complement-boolean-result-mode mode
) mode
)
4921 (:boolean-greater
:jg
) ; ZF=0 and SF=OF
4922 (:boolean-greater-equal
:jge
) ; SF=OF
4923 (:boolean-less
:jl
) ; SF!=OF
4924 (:boolean-less-equal
:jle
) ; ZF=1 or SF!=OF
4925 (:boolean-below
:jb
)
4926 (:boolean-above
:ja
)
4927 (:boolean-below-equal
:jbe
)
4928 (:boolean-above-equal
:jae
)
4930 (:boolean-zf
=0 :jnz
)
4932 (:boolean-cf
=0 :jnc
)
4933 (:boolean-true
:jmp
))
4934 (list 'quote label
)))
4937 (defun make-cmov-on-boolean (mode src dst
&key invert
)
4938 (list (ecase (if invert
(complement-boolean-result-mode mode
) mode
)
4939 (:boolean-greater
:cmovg
) ; ZF=0 and SF=OF
4940 (:boolean-greater-equal
:cmovge
) ; SF=OF
4941 (:boolean-less
:cmovl
) ; SF!=OF
4942 (:boolean-less-equal
:cmovle
) ; ZF=1 or SF!=OF
4943 (:boolean-zf
=1 :cmovz
)
4944 (:boolean-zf
=0 :cmovnz
)
4945 (:boolean-cf
=1 :cmovc
)
4946 (:boolean-cf
=0 :cmovnc
))
4949 (defun return-satisfies-result-p (desired-result returns-provided
)
4950 (or (eq desired-result returns-provided
)
4951 (case desired-result
4953 ((:eax
:single-value
)
4954 (member returns-provided
'(:eax
:multiple-values
:single-value
)))
4956 (member returns-provided
'(:multiple-values
:function
)))
4958 (member returns-provided
+boolean-modes
+)))))
4960 (defun make-result-and-returns-glue (desired-result returns-provided
4962 &key
(type t
) provider really-desired
)
4963 "Returns new-code and new-returns-provided, and glue-side-effects-p."
4964 (declare (optimize (debug 3)))
4965 (case returns-provided
4967 ;; when CODE does a non-local exit, we certainly don't need any glue.
4968 (return-from make-result-and-returns-glue
4969 (values code
:non-local-exit
))))
4970 (multiple-value-bind (new-code new-returns-provided glue-side-effects-p
)
4971 (case (result-mode-type desired-result
)
4973 (case (result-mode-type returns-provided
)
4975 (if (eq desired-result returns-provided
)
4976 (values code returns-provided
)
4977 (values (append code
`((:load-lexical
,returns-provided
,desired-result
)))
4979 ((:eax
:multiple-values
)
4980 (values (append code
4981 `((:store-lexical
,desired-result
:eax
4982 :type
,(type-specifier-primary type
))))
4986 (values (append code
4987 `((:store-lexical
,desired-result
4988 ,(result-mode-type returns-provided
)
4989 :type
,(type-specifier-primary type
))))
4992 (:ignore
(values code
:nothing
))
4994 (let ((true (first (operands desired-result
)))
4995 (false (second (operands desired-result
))))
4996 (etypecase (operator returns-provided
)
4998 (if (equal (operands desired-result
)
4999 (operands returns-provided
))
5000 (values code desired-result
)
5002 ((eql :boolean-cf
=1)
5004 ((and (= -
1 true
) (= 0 false
))
5005 (values (append code
5006 `((:sbbl
:ecx
:ecx
)))
5007 '(:boolean-ecx -
1 0)))
5008 ((and (= 0 true
) (= -
1 false
))
5009 (values (append code
5012 '(:boolean-ecx
0 -
1)))
5013 (t (error "Don't know modes ~S => ~S." returns-provided desired-result
))))
5015 (make-result-and-returns-glue desired-result
5018 `((:leal
(:eax
,(- (image-nil-word *image
*)))
5023 :really-desired desired-result
)))))
5024 (:boolean-branch-on-true
5025 ;; (warn "rm :b-true with ~S." returns-provided)
5026 (etypecase (operator returns-provided
)
5027 ((member :boolean-branch-on-true
)
5028 (assert (eq (operands desired-result
) (operands returns-provided
)))
5029 (values code returns-provided
))
5030 ((member :eax
:multiple-values
)
5031 (values (append code
5033 (:jne
',(operands desired-result
))))
5035 ((member :ebx
:ecx
:edx
)
5036 (values (append code
5037 `((:cmpl
:edi
,returns-provided
)
5038 (:jne
',(operands desired-result
))))
5041 ;; no branch, nothing is nil is false.
5042 (values code desired-result
))
5043 ((member .
#.
+boolean-modes
+)
5044 (values (append code
5045 (list (make-branch-on-boolean returns-provided
(operands desired-result
))))
5048 (values (append code
5049 `((:load-lexical
,returns-provided
,desired-result
)))
5051 (constant-object-binding
5052 (values (if (eq *movitz-nil
* (constant-object returns-provided
))
5054 `((:jmp
',(operands desired-result
))))
5056 (:boolean-branch-on-false
5057 (etypecase (operator returns-provided
)
5058 ((member :boolean-branch-on-false
)
5059 (assert (eq (operands desired-result
)
5060 (operands returns-provided
)))
5061 (values code desired-result
))
5063 (values (append code
5064 `((:jmp
',(operands desired-result
))))
5066 ((member .
#.
+boolean-modes
+)
5067 (values (append code
5068 (list (make-branch-on-boolean returns-provided
(operands desired-result
)
5071 ((member :ebx
:ecx
:edx
)
5072 (values (append code
5073 `((:cmpl
:edi
,returns-provided
)
5074 (:je
',(operands desired-result
))))
5076 ((member :eax
:multiple-values
)
5077 (values (append code
5079 (:je
',(operands desired-result
))))
5082 (values (append code
5083 `((:load-lexical
,returns-provided
,desired-result
)))
5085 (constant-object-binding
5086 (values (if (not (eq *movitz-nil
* (constant-object returns-provided
)))
5088 `((:jmp
',(operands desired-result
))))
5090 (:untagged-fixnum-ecx
5091 (case (result-mode-type returns-provided
)
5092 (:untagged-fixnum-ecx
5093 (values code
:untagged-fixnum-ecx
))
5094 ((:eax
:single-value
:multiple-values
:function
)
5095 (values (append code
5096 `((,*compiler-global-segment-prefix
*
5097 :call
(:edi
,(global-constant-offset 'unbox-u32
)))))
5098 :untagged-fixnum-ecx
))
5100 ;; In theory (at least..) ECX can only hold non-pointers, so don't check.
5101 (values (append code
5102 `((:shrl
,+movitz-fixnum-shift
+ :ecx
)))
5103 :untagged-fixnum-ecx
))
5105 (values (append code
5106 `((:movl
,returns-provided
:eax
)
5107 (,*compiler-global-segment-prefix
*
5108 :call
(:edi
,(global-constant-offset 'unbox-u32
)))))
5109 :untagged-fixnum-ecx
))
5111 (values (append code
5112 `((:load-lexical
,returns-provided
:untagged-fixnum-ecx
)))
5113 :untagged-fixnum-ecx
))))
5114 ((:single-value
:eax
)
5116 ((eq returns-provided
:eax
)
5118 ((typep returns-provided
'lexical-binding
)
5119 (values (append code
`((:load-lexical
,returns-provided
:eax
)))
5121 (t (case (operator returns-provided
)
5122 (:untagged-fixnum-eax
5123 (values (append code
`((:shll
,+movitz-fixnum-shift
+ :eax
))) :eax
))
5125 (case (first (operands returns-provided
))
5126 (0 (values (append code
'((:movl
:edi
:eax
)))
5128 (t (values code
:eax
))))
5129 ((:single-value
:eax
:function
:multiple-values
)
5132 (values (append code
'((:movl
:edi
:eax
)))
5134 ((:ebx
:ecx
:edx
:edi
)
5135 (values (append code
`((:movl
,returns-provided
:eax
)))
5138 (let ((true-false (operands returns-provided
)))
5140 ((equal '(0 1) true-false
)
5141 (values (append code
`((:movl
(:edi
(:ecx
4) ,(global-constant-offset 'boolean-zero
))
5144 ((equal '(1 0) true-false
)
5145 (values (append code
`((:movl
(:edi
(:ecx
4) ,(global-constant-offset 'boolean-one
))
5148 (t (error "Don't know ECX mode ~S." returns-provided
)))))
5150 (values (append code
5151 `((:sbbl
:ecx
:ecx
) ; T => -1, NIL => 0
5152 (:movl
(:edi
(:ecx
4) ,(global-constant-offset 'not-not-nil
))
5156 ;; (warn "bool for ~S" returns-provided)
5157 (let ((boolean-false-label (make-symbol "boolean-false-label")))
5158 (values (append code
5159 '((:movl
:edi
:eax
))
5160 (if *compiler-use-cmov-p
*
5161 `(,(make-cmov-on-boolean returns-provided
5162 `(:edi
,(global-constant-offset 't-symbol
))
5165 `(,(make-branch-on-boolean returns-provided
5168 (:movl
(:edi
,(global-constant-offset 't-symbol
))
5170 ,boolean-false-label
)))
5172 ((:ebx
:ecx
:edx
:esp
:esi
)
5174 ((eq returns-provided desired-result
)
5175 (values code returns-provided
))
5176 ((typep returns-provided
'lexical-binding
)
5177 (values (append code
`((:load-lexical
,returns-provided
,desired-result
)))
5179 (t (case (operator returns-provided
)
5181 (values (append code
5182 `((:movl
:edi
,desired-result
)))
5184 ((:ebx
:ecx
:edx
:esp
)
5185 (values (append code
5186 `((:movl
,returns-provided
,desired-result
)))
5188 ((:eax
:single-value
:multiple-values
:function
)
5189 (values (append code
5190 `((:movl
:eax
,desired-result
)))
5193 (let ((true-false (operands returns-provided
)))
5195 ((equal '(0 1) true-false
)
5196 (values (append code
`((:movl
(:edi
(:ecx
4) ,(global-constant-offset 'boolean-zero
))
5199 ((equal '(1 0) true-false
)
5200 (values (append code
`((:movl
(:edi
(:ecx
4) ,(global-constant-offset 'boolean-one
))
5203 (t (error "Don't know ECX mode ~S." returns-provided
)))))
5205 ;;; (values (append code `((:movl (:edi (:ecx 4) ,(global-constant-offset 'boolean-zero))
5206 ;;; ,desired-result)))
5207 ;;; desired-result))
5209 ;;; (values (append code `((:movl (:edi (:ecx 4) ,(global-constant-offset 'boolean-one))
5210 ;;; ,desired-result)))
5211 ;;; desired-result))
5213 (values (append code
5215 (:movl
(:edi
(:ecx
4) ,(global-constant-offset 'not-not-nil
))
5219 ;; (warn "bool to ~S for ~S" desired-result returns-provided)
5220 (values (append code
5222 (*compiler-use-cmov-p
*
5223 `((:movl
:edi
,desired-result
)
5224 ,(make-cmov-on-boolean returns-provided
5225 `(:edi
,(global-constant-offset 't-symbol
))
5227 ((not *compiler-use-cmov-p
*)
5228 (let ((boolean-false-label (make-symbol "boolean-false-label")))
5229 `((:movl
:edi
,desired-result
)
5230 ,(make-branch-on-boolean returns-provided
5233 (:movl
(:edi
,(global-constant-offset 't-symbol
))
5235 ,boolean-false-label
)))))
5236 desired-result
))))))
5238 (typecase returns-provided
5239 ((member :push
) (values code
:push
))
5241 (values (append code
'((:pushl
:edi
)))
5243 ((member :single-value
:eax
:multiple-values
:function
)
5244 (values (append code
`((:pushl
:eax
)))
5246 ((member :ebx
:ecx
:edx
)
5247 (values (append code
`((:pushl
,returns-provided
)))
5250 (values (append code
`((:load-lexical
,returns-provided
:push
)))
5253 (case (operator returns-provided
)
5255 (values code returns-provided
))
5257 (values code
:values
))
5258 (t (values (make-result-and-returns-glue :eax returns-provided code
5261 ((:multiple-values
:function
)
5262 (case (operator returns-provided
)
5263 ((:multiple-values
:function
)
5264 (values code
:multiple-values
))
5266 (case (first (operands returns-provided
))
5267 (0 (values (append code
'((:movl
:edi
:eax
) (:xorl
:ecx
:ecx
) (:stc
)))
5269 (1 (values (append code
'((:clc
)))
5271 ((nil) (values code
:multiple-values
))
5272 (t (values (append code
5273 (make-immediate-move (first (operands returns-provided
)) :ecx
)
5275 :multiple-values
))))
5276 (t (values (append (make-result-and-returns-glue :eax
5281 :really-desired desired-result
)
5283 :multiple-values
)))))
5284 (unless new-returns-provided
5285 (multiple-value-setq (new-code new-returns-provided glue-side-effects-p
)
5286 (ecase (result-mode-type returns-provided
)
5288 (case (result-mode-type desired-result
)
5289 ((:eax
:ebx
:ecx
:edx
:push
:lexical-binding
)
5290 (values (append code
5291 `((:load-constant
,(constant-object returns-provided
)
5295 (make-result-and-returns-glue desired-result
:eax
5296 (make-result-and-returns-glue :eax returns-provided code
5299 :really-desired desired-result
)
5301 :provider provider
))
5302 (:untagged-fixnum-ecx
5303 (let ((fixnump (subtypep type
`(integer 0 ,+movitz-most-positive-fixnum
+))))
5306 (member (result-mode-type desired-result
) '(:eax
:ebx
:ecx
:edx
)))
5307 (values (append code
5308 `((:leal
((:ecx
,+movitz-fixnum-factor
+))
5309 ,(result-mode-type desired-result
))))
5312 (member (result-mode-type desired-result
) '(:eax
:single-value
)))
5313 (values (append code
5314 `((:call
(:edi
,(global-constant-offset 'box-u32-ecx
)))))
5316 (t (make-result-and-returns-glue
5318 (make-result-and-returns-glue :eax
:untagged-fixnum-ecx code
5320 :really-desired desired-result
5325 (:untagged-fixnum-eax
5326 (make-result-and-returns-glue desired-result
:eax
5327 (make-result-and-returns-glue :eax
:untagged-fixnum-eax code
5329 :really-desired desired-result
)
5330 :provider provider
)))))
5331 (assert new-returns-provided
()
5332 "Don't know how to match desired-result ~S with returns-provided ~S~@[ from ~S~]."
5333 (or really-desired desired-result
) returns-provided provider
)
5334 (values new-code new-returns-provided glue-side-effects-p
)))
5336 (define-compiler compile-form
(&all form-info
&result-mode result-mode
)
5337 "3.1.2.1 Form Evaluation. Guaranteed to honor RESULT-MODE."
5338 (compiler-values-bind (&all unprotected-values
&code form-code
&returns form-returns
5339 &producer producer
&type form-type
&functional-p functional-p
)
5340 (compiler-call #'compile-form-unprotected
:forward form-info
)
5341 (multiple-value-bind (new-code new-returns-provided glue-side-effects-p
)
5342 (make-result-and-returns-glue result-mode form-returns form-code
5345 (compiler-values (unprotected-values)
5347 :functional-p
(and functional-p
(not glue-side-effects-p
))
5350 :returns new-returns-provided
))))
5352 (define-compiler compile-form-selected
(&all form-info
&result-mode result-modes
)
5353 "3.1.2.1 Form Evaluation. Guaranteed to honor one of RESULT-MODE, which
5354 for this call (exclusively!) is a list of the acceptable result-modes, where
5355 the first one takes preference. Note that :non-local-exit might also be returned."
5356 (check-type result-modes list
"a list of result-modes")
5357 (compiler-values-bind (&all unprotected-values
&code form-code
&returns form-returns
5358 &producer producer
&type form-type
)
5359 (compiler-call #'compile-form-unprotected
5360 :result-mode
(car result-modes
)
5362 (if (member form-returns result-modes
)
5363 (compiler-values (unprotected-values))
5364 (compiler-call #'compile-form
5365 :result-mode
(car result-modes
)
5366 :forward form-info
))))
5368 (define-compiler compile-form-to-register
(&all form-info
)
5369 (compiler-values-bind (&all unprotected-values
&code form-code
&returns form-returns
5370 &final-form final-form
&producer producer
&type form-type
)
5371 (compiler-call #'compile-form-unprotected
5376 ((and (typep final-form
'required-function-argument
)
5377 (= 1 (function-argument-argnum final-form
)))
5378 (compiler-call #'compile-form
5380 :forward form-info
))
5381 ((member form-returns
'(:eax
:ebx
:ecx
:edx
:edi
:untagged-fixnum-ecx
))
5382 (compiler-values (unprotected-values)))
5383 (t (compiler-call #'compile-form
5385 :forward form-info
)))))
5387 (define-compiler compile-form-unprotected
(&all downstream
&form form
&result-mode result-mode
5389 "3.1.2.1 Form Evaluation. May not honor RESULT-MODE.
5390 That is, RESULT-MODE is taken to be a suggestion, not an imperative."
5391 (compiler-values-bind (&all upstream
)
5393 (symbol (compiler-call #'compile-symbol
:forward downstream
))
5394 (cons (compiler-call #'compile-cons
:forward downstream
))
5395 (t (compiler-call #'compile-self-evaluating
:forward downstream
)))
5396 (when (typep (upstream :final-form
) 'lexical-binding
)
5397 (labels ((fix-extent (binding)
5399 ((sub-env-p extent
(binding-extent-env binding
))
5400 #+ignore
(warn "Binding ~S OK in ~S wrt. ~S."
5402 (binding-extent-env binding
)
5404 (t #+ignore
(break "Binding ~S escapes from ~S to ~S"
5405 binding
(binding-extent-env binding
)
5407 (setf (binding-extent-env binding
) extent
)))
5408 (when (typep binding
'forwarding-binding
)
5409 (fix-extent (forwarding-binding-target binding
)))))
5411 (fix-extent (upstream :final-form
)))))
5412 (compiler-values (upstream))))
5414 (defun lambda-form-p (form)
5416 (eq 'muerte.cl
:lambda
(first form
))))
5418 (defun function-name-p (operator)
5419 (or (and (symbolp operator
) operator
)
5420 (setf-name operator
)))
5422 (define-compiler compile-cons
(&all all
&form form
&env env
)
5423 "3.1.2.1.2 Conses as Forms"
5424 (let ((operator (car form
)))
5425 (if (and (symbolp operator
) (movitz-special-operator-p operator
))
5426 (compiler-call (movitz-special-operator-compiler operator
) :forward all
)
5427 (let* ((compiler-macro-function (movitz-compiler-macro-function operator env
))
5428 (compiler-macro-expansion (and compiler-macro-function
5430 (funcall *movitz-macroexpand-hook
*
5431 compiler-macro-function
5434 (warn "Compiler-macro for ~S failed: ~A" operator c
)
5437 ((and compiler-macro-function
5438 (not (movitz-env-get operator
'notinline nil env
))
5439 (not (eq form compiler-macro-expansion
)))
5440 (compiler-call #'compile-form-unprotected
:forward all
:form compiler-macro-expansion
))
5441 ((movitz-constantp form env
)
5442 (compiler-call #'compile-constant-compound
:forward all
))
5443 ((lambda-form-p operator
) ; 3.1.2.1.2.4
5444 (compiler-call #'compile-lambda-form
:forward all
))
5447 ((movitz-special-operator-p operator
)
5448 (compiler-call (movitz-special-operator-compiler operator
) :forward all
))
5449 ((movitz-macro-function operator env
)
5450 (compiler-call #'compile-macro-form
:forward all
))
5451 ((movitz-operator-binding operator env
)
5452 (compiler-call #'compile-apply-lexical-funobj
:forward all
))
5453 (t (compiler-call #'compile-apply-symbol
:forward all
))))
5454 (t (error "Don't know how to compile compound form ~A" form
)))))))
5456 (define-compiler compile-compiler-macro-form
(&all all
&form form
&env env
)
5457 (compiler-call #'compile-form-unprotected
5459 :form
(funcall *movitz-macroexpand-hook
*
5460 (movitz-compiler-macro-function (car form
) env
)
5463 (define-compiler compile-macro-form
(&all all
&form form
&env env
)
5464 "3.1.2.1.2.2 Macro Forms"
5465 (let* ((operator (car form
))
5466 (macro-function (movitz-macro-function operator env
)))
5467 (compiler-call #'compile-form-unprotected
5469 :form
(funcall *movitz-macroexpand-hook
* macro-function form env
))))
5471 (define-compiler compile-lexical-macro-form
(&all all
&form form
&env env
)
5472 "Compiles MACROLET and SYMBOL-MACROLET forms."
5473 (compiler-call #'compile-form-unprotected
5475 :form
(funcall *movitz-macroexpand-hook
*
5476 (macro-binding-expander (movitz-operator-binding form env
))
5479 (defun like-compile-macroexpand-form (form env
)
5481 ;; (symbol (compile-macroexpand-symbol form funobj env top-level-p result-mode))
5482 (cons (like-compile-macroexpand-cons form env
))
5483 (t (values form nil
))))
5485 (defun like-compile-macroexpand-cons (form env
)
5486 "3.1.2.1.2 Conses as Forms"
5487 (let* ((operator (car form
))
5488 (notinline (movitz-env-get operator
'notinline nil env
))
5489 (compiler-macro-function (movitz-compiler-macro-function operator env
))
5490 (compiler-macro-expansion (and compiler-macro-function
5491 (funcall *movitz-macroexpand-hook
*
5492 compiler-macro-function
5495 ((and (not notinline
)
5496 compiler-macro-function
5497 (not (eq form compiler-macro-expansion
)))
5498 (values compiler-macro-expansion t
))
5501 ((movitz-macro-function operator env
)
5502 (values (funcall *movitz-macroexpand-hook
*
5503 (movitz-macro-function operator env
)
5509 (defun make-compiled-stack-restore (stack-displacement result-mode returns
)
5510 "Return the code required to reset the stack according to stack-displacement,
5511 result-mode, and returns (which specify the returns-mode of the immediately
5512 preceding code). As secondary value, returns the new :returns value."
5513 (flet ((restore-by-pop (scratch)
5514 (case stack-displacement
5515 (1 `((:popl
,scratch
)))
5516 (2 `((:popl
,scratch
) (:popl
,scratch
))))))
5517 (if (zerop stack-displacement
)
5518 (values nil returns
)
5519 (ecase (result-mode-type result-mode
)
5521 (values nil returns
))
5522 ((:multiple-values
:values
)
5525 (values `((:leal
(:esp
,(* 4 stack-displacement
)) :esp
))
5527 ((:single-value
:eax
:ebx
)
5528 (values `((:addl
,(* 4 stack-displacement
) :esp
))
5529 :multiple-values
)))) ; assume this addl will set CF=0
5530 ((:single-value
:eax
:ebx
:ecx
:edx
:push
:lexical-binding
:untagged-fixnum-ecx
5531 :boolean
:boolean-branch-on-false
:boolean-branch-on-true
)
5534 (values (or (restore-by-pop :eax
)
5535 `((:leal
(:esp
,(* 4 stack-displacement
)) :esp
))) ; preserve all flags
5538 (values (or (restore-by-pop :eax
)
5539 `((:addl
,(* 4 stack-displacement
) :esp
)))
5541 ((:multiple-values
:single-value
:eax
)
5542 (values (or (restore-by-pop :ebx
)
5543 `((:addl
,(* 4 stack-displacement
) :esp
)))
5546 (values (or (restore-by-pop :eax
)
5547 `((:addl
,(* 4 stack-displacement
) :esp
)))
5550 (define-compiler compile-apply-symbol
(&form form
&funobj funobj
&env env
5551 &result-mode result-mode
)
5552 "3.1.2.1.2.3 Function Forms"
5553 (destructuring-bind (operator &rest arg-forms
)
5555 #+ignore
(when (and (eq result-mode
:function
)
5556 (eq operator
(movitz-print (movitz-funobj-name funobj
))))
5557 (warn "Tail-recursive call detected."))
5558 (when (eq operator
'muerte.cl
::declare
)
5559 (break "Compiling funcall to ~S" 'muerte.cl
::declare
))
5560 (pushnew (cons operator muerte.cl
::*compile-file-pathname
*)
5561 (image-called-functions *image
*)
5563 (multiple-value-bind (arguments-code stack-displacement arguments-modifies
)
5564 (make-compiled-argument-forms arg-forms funobj env
)
5565 (multiple-value-bind (stack-restore-code new-returns
)
5566 (make-compiled-stack-restore stack-displacement result-mode
:multiple-values
)
5568 :returns new-returns
5570 :modifies arguments-modifies
5571 :code
(append arguments-code
5572 (if (and (not *compiler-relink-recursive-funcall
*)
5573 (eq (movitz-read operator
)
5574 (movitz-read (movitz-funobj-name funobj
)))) ; recursive?
5575 (make-compiled-funcall-by-esi (length arg-forms
))
5576 (make-compiled-funcall-by-symbol operator
(length arg-forms
) funobj
))
5577 stack-restore-code
))))))
5579 (define-compiler compile-apply-lexical-funobj
(&all all
&form form
&funobj funobj
&env env
5580 &result-mode result-mode
)
5581 "3.1.2.1.2.3 Function Forms"
5582 (destructuring-bind (operator &rest arg-forms
)
5584 (let ((binding (movitz-operator-binding operator env
)))
5585 (multiple-value-bind (arguments-code stack-displacement
)
5586 (make-compiled-argument-forms arg-forms funobj env
)
5587 (multiple-value-bind (stack-restore-code new-returns
)
5588 (make-compiled-stack-restore stack-displacement result-mode
:multiple-values
)
5590 :returns new-returns
5592 :code
(append arguments-code
5593 (if (eq funobj
(function-binding-funobj binding
))
5594 (make-compiled-funcall-by-esi (length arg-forms
)) ; call ourselves
5595 `((:call-lexical
,binding
,(length arg-forms
))))
5596 stack-restore-code
)))))))
5598 (defun make-compiled-funcall-by-esi (num-args)
5600 (1 `((:call
(:esi
,(slot-offset 'movitz-funobj
'code-vector%
1op
)))))
5601 (2 `((:call
(:esi
,(slot-offset 'movitz-funobj
'code-vector%
2op
)))))
5602 (3 `((:call
(:esi
,(slot-offset 'movitz-funobj
'code-vector%
3op
)))))
5603 (t (append (if (< num-args
#x80
)
5604 `((:movb
,num-args
:cl
))
5605 (make-immediate-move (dpb num-args
(byte 24 8) #x80
) :ecx
))
5606 ; call new ESI's code-vector
5607 `((:call
(:esi
,(slot-offset 'movitz-funobj
'code-vector
))))))))
5609 (defun make-compiled-funcall-by-symbol (apply-symbol num-args funobj
)
5610 (declare (ignore funobj
))
5611 (check-type apply-symbol symbol
)
5612 `((:load-constant
,(movitz-read apply-symbol
) :edx
) ; put function symbol in EDX
5613 (:movl
(:edx
,(slot-offset 'movitz-symbol
'function-value
))
5614 :esi
) ; load new funobj from symbol into ESI
5615 ,@(make-compiled-funcall-by-esi num-args
)))
5617 (defun make-compiled-funcall-by-funobj (apply-funobj num-args funobj
)
5618 (declare (ignore funobj
))
5619 (check-type apply-funobj movitz-funobj
)
5621 :returns
:multiple-values
5623 :code
`( ; put function funobj in ESI
5624 (:load-constant
,apply-funobj
:esi
)
5625 ,@(make-compiled-funcall-by-esi num-args
))))
5627 (defun make-compiled-argument-forms (argument-forms funobj env
)
5628 "Return code as primary value, and stack displacement as secondary value.
5629 Return the set of modified lexical bindings third. Fourth, a list of the individual
5630 compile-time types of each argument. Fifth: The combined functional-p."
5631 ;; (incf (aref *args* (min (length argument-forms) 9)))
5632 (case (length argument-forms
) ;; "optimized" versions for 0, 1, 2, and 3 aruments.
5633 (0 (values nil
0 nil
() t
))
5634 (1 (compiler-values-bind (&code code
&type type
&functional-p functional-p
)
5635 (compiler-call #'compile-form
5636 :form
(first argument-forms
)
5640 (values code
0 t
(list (type-specifier-primary type
)) functional-p
)))
5641 (2 (multiple-value-bind (code functional-p modified first-values second-values
)
5642 (make-compiled-two-forms-into-registers (first argument-forms
) :eax
5643 (second argument-forms
) :ebx
5645 (values code
0 modified
5646 (list (type-specifier-primary (compiler-values-getf first-values
:type
))
5647 (type-specifier-primary (compiler-values-getf second-values
:type
)))
5649 (t (let* ((arguments-self-evaluating-p t
)
5650 (arguments-are-load-lexicals-p t
)
5651 (arguments-lexical-variables ())
5652 (arguments-modifies nil
)
5653 (arguments-functional-p t
)
5654 (arguments-types nil
)
5658 (loop for form in
(nthcdr 2 argument-forms
)
5660 (compiler-values-bind (&code code
&producer producer
&modifies modifies
&type type
5661 &functional-p functional-p
)
5662 (compiler-call #'compile-form
5667 :with-stack-used
(post-incf stack-pos
))
5668 ;; (incf (stack-used arg-env))
5669 (unless functional-p
5670 (setf arguments-functional-p nil
))
5671 (push producer producers
)
5672 (push (type-specifier-primary type
)
5674 (setf arguments-modifies
5675 (modifies-union arguments-modifies modifies
))
5677 (compile-self-evaluating)
5678 (compile-lexical-variable
5679 (setf arguments-self-evaluating-p nil
)
5680 (assert (eq :load-lexical
(caar code
)) ()
5681 "comp-lex-var produced for ~S~% ~S" form code
)
5682 (pushnew (cadar code
) arguments-lexical-variables
))
5683 (t (setf arguments-self-evaluating-p nil
5684 arguments-are-load-lexicals-p nil
)))
5686 (multiple-value-bind (code01 functionalp01 modifies01 all0 all1
)
5687 (make-compiled-two-forms-into-registers (first argument-forms
) :eax
5688 (second argument-forms
) :ebx
5690 (unless functionalp01
5691 (setf arguments-functional-p nil
))
5692 (let ((final0 (compiler-values-getf all0
:final-form
))
5693 (final1 (compiler-values-getf all1
:final-form
))
5694 (types (list* (type-specifier-primary (compiler-values-getf all0
:type
))
5695 (type-specifier-primary (compiler-values-getf all1
:type
))
5696 (nreverse arguments-types
))))
5698 ((or arguments-self-evaluating-p
5699 (and (typep final0
'lexical-binding
)
5700 (typep final1
'lexical-binding
)))
5701 (values (append arguments-code code01
)
5703 (+ -
2 (length argument-forms
))
5706 arguments-functional-p
))
5707 ((and arguments-are-load-lexicals-p
5708 (typep final0
'(or lexical-binding movitz-object
))
5709 (typep final1
'(or lexical-binding movitz-object
)))
5710 (values (append arguments-code code01
)
5711 (+ -
2 (length argument-forms
))
5714 arguments-functional-p
))
5715 ((and arguments-are-load-lexicals-p
5716 (not (some (lambda (arg-binding)
5717 (code-uses-binding-p code01 arg-binding
:store t
:load nil
))
5718 arguments-lexical-variables
)))
5719 (values (append arguments-code code01
)
5720 (+ -
2 (length argument-forms
))
5723 arguments-functional-p
))
5724 (t ;; (warn "fail: ~S by ~S" argument-forms (nreverse producers))
5725 (let ((stack-pos 0))
5726 (values (append (compiler-call #'compile-form
5727 :form
(first argument-forms
)
5732 :with-stack-used
(post-incf stack-pos
))
5733 ;; (prog1 nil (incf (stack-used arg-env)))
5734 (compiler-call #'compile-form
5735 :form
(second argument-forms
)
5740 :with-stack-used
(post-incf stack-pos
))
5741 ;; (prog1 nil (incf (stack-used arg-env)))
5742 (loop for form in
(nthcdr 2 argument-forms
)
5744 (compiler-call #'compile-form
5749 :with-stack-used
(post-incf stack-pos
)))
5750 `((:movl
(:esp
,(* 4 (- (length argument-forms
) 1))) :eax
)
5751 (:movl
(:esp
,(* 4 (- (length argument-forms
) 2))) :ebx
)))
5752 ;; restore-stack.. don't mess up CF!
5753 (prog1 (length argument-forms
)
5754 #+ignore
(assert (= (length argument-forms
) (stack-used arg-env
))))
5755 (modifies-union modifies01 arguments-modifies
)
5757 arguments-functional-p
))))))))))
5759 (defun program-is-load-lexical-of-binding (prg)
5760 (and (not (cdr prg
))
5761 (instruction-is-load-lexical-of-binding (car prg
))))
5763 (defun instruction-is-load-lexical-of-binding (instruction)
5764 (and (listp instruction
)
5765 (eq :load-lexical
(car instruction
))
5766 (destructuring-bind (binding destination
&key
&allow-other-keys
)
5767 (operands instruction
)
5768 (values binding destination
))))
5770 (defun make-compiled-two-forms-into-registers (form0 reg0 form1 reg1 funobj env
)
5771 "Returns first: code that does form0 into reg0, form1 into reg1.
5772 second: whether code is functional-p,
5773 third: combined set of modified bindings
5774 fourth: all compiler-values for form0, as a list.
5775 fifth: all compiler-values for form1, as a list."
5776 (assert (not (eq reg0 reg1
)))
5777 (compiler-values-bind (&all all0
&code code0
&functional-p functional0
5778 &final-form final0
&type type0
)
5779 (compiler-call #'compile-form
5784 (compiler-values-bind (&all all1
&code code1
&functional-p functional1
5785 &final-form final1
&type type1
)
5786 (compiler-call #'compile-form
5792 ((and (typep final0
'binding
)
5793 (not (code-uses-binding-p code1 final0
:load nil
:store t
)))
5794 (append (compiler-call #'compile-form-unprotected
5796 :result-mode
:ignore
5800 `((:load-lexical
,final0
,reg0
:protect-registers
(,reg1
)))))
5801 ((program-is-load-lexical-of-binding code1
)
5802 (destructuring-bind (src dst
&key protect-registers shared-reference-p
)
5804 (assert (eq reg1 dst
))
5806 `((:load-lexical
,src
,reg1
5807 :protect-registers
,(union protect-registers
5809 :shared-reference-p
,shared-reference-p
)))))
5810 ;; XXX if we knew that code1 didn't mess up reg0, we could do more..
5811 (t #+ignore
(when (and (not (tree-search code1 reg0
))
5812 (not (tree-search code1
:call
)))
5813 (warn "got b: ~S ~S for ~S: ~{~&~A~}" form0 form1 reg0 code1
))
5814 (let ((binding (make-instance 'temporary-name
:name
(gensym "tmp-")))
5815 (xenv (make-local-movitz-environment env funobj
)))
5816 (movitz-env-add-binding xenv binding
)
5817 (append (compiler-call #'compile-form
5822 `((:init-lexvar
,binding
:init-with-register
,reg0
5823 :init-with-type
,(type-specifier-primary type0
)))
5824 (compiler-call #'compile-form
5829 `((:load-lexical
,binding
,reg0
))))))
5830 (and functional0 functional1
)
5832 (compiler-values-list (all0))
5833 (compiler-values-list (all1))))))
5835 (define-compiler compile-symbol
(&all all
&form form
&env env
&result-mode result-mode
)
5836 "3.1.2.1.1 Symbols as Forms"
5837 (if (movitz-constantp form env
)
5838 (compiler-call #'compile-self-evaluating
5840 :form
(eval-form form env
))
5841 (let ((binding (movitz-binding form env
)))
5843 ((typep binding
'lexical-binding
)
5844 #+ignore
(make-compiled-lexical-variable form binding result-mode env
)
5845 (compiler-call #'compile-lexical-variable
:forward all
))
5846 ((typep binding
'symbol-macro-binding
)
5847 (compiler-call #'compile-form-unprotected
5849 :form
(funcall *movitz-macroexpand-hook
*
5850 (macro-binding-expander (movitz-binding form env
)) form env
)))
5851 (t (compiler-call #'compile-dynamic-variable
:forward all
))))))
5853 (define-compiler compile-lexical-variable
(&form variable
&result-mode result-mode
&env env
)
5854 (let ((binding (movitz-binding variable env
)))
5855 (check-type binding lexical-binding
)
5856 (case (operator result-mode
)
5859 :final-form binding
))
5860 (t (compiler-values ()
5864 :functional-p t
)))))
5866 (defun make-compiled-lexical-load (binding result-mode
&rest key-args
)
5867 "Do what is necessary to load lexical binding <binding>."
5868 `((:load-lexical
,binding
,result-mode
,@key-args
)))
5870 (define-compiler compile-dynamic-variable
(&form form
&env env
&result-mode result-mode
)
5871 "3.1.2.1.1.2 Dynamic Variables"
5872 (if (eq :ignore result-mode
)
5873 (compiler-values ())
5874 (let ((binding (movitz-binding form env
)))
5877 (unless (movitz-env-get form
'special nil env
)
5878 (cerror "Compile like a special." "Undeclared variable: ~S." form
))
5884 :code
(if *compiler-use-into-unbound-protocol
*
5885 `((:load-constant
,form
:ebx
)
5886 (,*compiler-local-segment-prefix
*
5887 :call
(:edi
,(global-constant-offset 'dynamic-variable-lookup
)))
5890 (let ((not-unbound (gensym "not-unbound-")))
5891 `((:load-constant
,form
:ebx
)
5892 (,*compiler-local-segment-prefix
*
5893 :call
(:edi
,(global-constant-offset 'dynamic-variable-lookup
)))
5894 (,*compiler-local-segment-prefix
*
5895 :cmpl
:eax
(:edi
,(global-constant-offset 'unbound-value
)))
5896 (:jne
',not-unbound
)
5899 (t (check-type binding dynamic-binding
)
5905 :code
(if *compiler-use-into-unbound-protocol
*
5906 `((:load-constant
,form
:ebx
)
5907 (,*compiler-local-segment-prefix
*
5908 :call
(:edi
,(global-constant-offset 'dynamic-variable-lookup
)))
5911 (let ((not-unbound (gensym "not-unbound-")))
5912 `((:load-constant
,form
:ebx
)
5913 (,*compiler-local-segment-prefix
*
5914 :call
(:edi
,(global-constant-offset 'dynamic-variable-lookup
)))
5915 (,*compiler-local-segment-prefix
*
5916 :cmpl
:eax
(:edi
,(global-constant-offset 'unbound-value
)))
5917 (:jne
',not-unbound
)
5919 ,not-unbound
)))))))))
5921 (define-compiler compile-lambda-form
(&form form
&all all
)
5922 "3.1.2.2.4 Lambda Forms"
5923 (let ((lambda-expression (car form
))
5924 (lambda-args (cdr form
)))
5925 (compiler-call #'compile-form-unprotected
5927 :form
`(muerte.cl
:funcall
,lambda-expression
,@lambda-args
))))
5929 (define-compiler compile-constant-compound
(&all all
&form form
&env env
&top-level-p top-level-p
)
5930 (compiler-call #'compile-self-evaluating
5932 :form
(eval-form form env top-level-p
)))
5934 (defun register32-to-low8 (register)
5941 (defun make-immediate-move (value destination-register
)
5944 `((:xorl
,destination-register
,destination-register
)))
5945 ((= value
(image-nil-word *image
*))
5946 `((:movl
:edi
,destination-register
)))
5947 ((<= #x-80
(- value
(image-nil-word *image
*)) #x7f
)
5948 `((:leal
(:edi
,(- value
(image-nil-word *image
*))) ,destination-register
)))
5949 ((<= #x-80
(- value
(* 2 (image-nil-word *image
*))) #x7f
)
5950 `((:leal
(:edi
(:edi
1) ,(- value
(* 2 (image-nil-word *image
*)))) ,destination-register
)))
5951 ((<= #x-80
(- value
(* 3 (image-nil-word *image
*))) #x7f
)
5952 `((:leal
(:edi
(:edi
2) ,(- value
(* 3 (image-nil-word *image
*)))) ,destination-register
)))
5953 ((<= #x-80
(- value
(* 5 (image-nil-word *image
*))) #x7f
)
5954 `((:leal
(:edi
(:edi
4) ,(- value
(* 5 (image-nil-word *image
*)))) ,destination-register
)))
5955 ((<= #x-80
(- value
(* 9 (image-nil-word *image
*))) #x7f
)
5956 `((:leal
(:edi
(:edi
8) ,(- value
(* 9 (image-nil-word *image
*)))) ,destination-register
)))
5958 `((:xorl
,destination-register
,destination-register
)
5959 (:movb
,value
,(register32-to-low8 destination-register
))))
5960 (t `((:movl
,value
,destination-register
)))))
5962 (defparameter *prev-self-eval
* nil
)
5964 (define-compiler compile-self-evaluating
(&form form
&result-mode result-mode
&funobj funobj
)
5965 "3.1.2.1.3 Self-Evaluating Objects"
5966 (let* ((object form
)
5967 (movitz-obj (image-read-intern-constant *image
* object
))
5968 (funobj-env (funobj-env funobj
))
5969 (binding (or (cdr (assoc movitz-obj
(movitz-environment-bindings funobj-env
)))
5970 (let ((binding (make-instance 'constant-object-binding
5971 :name
(gensym "self-eval-")
5972 :object movitz-obj
)))
5973 (setf (binding-env binding
) funobj-env
)
5974 (push (cons movitz-obj binding
)
5975 (movitz-environment-bindings funobj-env
))
5977 (compiler-values-bind (&all self-eval
)
5978 (compiler-values (nil :abstract t
)
5979 :producer
(default-compiler-values-producer)
5980 :type
`(eql ,movitz-obj
)
5983 (case (operator result-mode
)
5985 (compiler-values (self-eval)
5988 (t (compiler-values (self-eval)
5989 :returns binding
))))))
5991 (define-compiler compile-implicit-progn
(&all all
&form forms
&top-level-p top-level-p
5992 &result-mode result-mode
)
5993 "Compile all the elements of the list <forms> as a progn."
5994 (check-type forms list
)
5995 (case (length forms
)
5996 (0 (compiler-values ()))
5997 (1 (compiler-call #'compile-form-unprotected
5999 :form
(first forms
)))
6000 (t (loop with no-side-effects-p
= t
6001 with progn-codes
= nil
6002 for
(sub-form . more-forms-p
) on forms
6003 as current-result-mode
= (if more-forms-p
:ignore result-mode
)
6004 do
(compiler-values-bind (&code code
&returns sub-returns-mode
6005 &functional-p no-sub-side-effects-p
6006 &type type
&final-form final-form
&producer sub-producer
)
6007 (compiler-call (if (not more-forms-p
)
6008 #'compile-form-unprotected
6012 :top-level-p top-level-p
6013 :result-mode current-result-mode
)
6014 (assert sub-returns-mode
()
6015 "~S produced no returns-mode for form ~S." sub-producer sub-form
)
6016 (unless no-sub-side-effects-p
6017 (setf no-side-effects-p nil
))
6018 (push (if (and no-sub-side-effects-p
(eq current-result-mode
:ignore
))
6022 (when (not more-forms-p
)
6023 (return (compiler-values ()
6024 :returns sub-returns-mode
6025 :functional-p no-side-effects-p
6026 :final-form final-form
6028 :code
(reduce #'append
(nreverse progn-codes
))))))))))
6031 (defun new-make-compiled-constant-reference (obj funobj
)
6032 (let ((movitz-obj (movitz-read obj
)))
6033 (if (eq movitz-obj
(image-t-symbol *image
*))
6034 (make-indirect-reference :edi
(global-constant-offset 't-symbol
))
6035 (etypecase movitz-obj
6037 (movitz-immediate-object (movitz-immediate-value movitz-obj
))
6039 (make-indirect-reference :esi
(movitz-funobj-intern-constant funobj movitz-obj
)))))))
6041 (defun make-compiled-lexical-control-transfer (return-code return-mode from-env to-env
6042 &optional
(to-label (exit-label to-env
)))
6043 "<return-code> running in <from-env> produces <return-mode>, and we need to
6044 generate code that transfers control (and unwinds dynamic bindings, runs unwind-protect
6045 cleanup-forms etc.) to <to-env> with <return-code>'s result intact."
6046 (check-type to-env lexical-exit-point-env
)
6047 (multiple-value-bind (stack-distance num-dynamic-slots unwind-protects
)
6048 (stack-delta from-env to-env
)
6049 (assert stack-distance
)
6050 (assert (null unwind-protects
) ()
6051 "Lexical unwind-protect not implemented, to-env: ~S. (this is not supposed to happen)"
6053 ;; (warn "dist: ~S, slots: ~S" stack-distance num-dynamic-slots)
6054 (assert (not (eq t num-dynamic-slots
)) ()
6055 "Don't know how to make lexical-control-transfer across unknown number of dynamic slots.")
6057 ((and (eq t stack-distance
)
6058 (eql 0 num-dynamic-slots
))
6060 :returns
:non-local-exit
6061 :code
(append return-code
6062 (unless (eq :function
(exit-result-mode to-env
))
6063 `((:load-lexical
,(movitz-binding (save-esp-variable to-env
) to-env nil
) :esp
)))
6064 `((:jmp
',to-label
)))))
6065 ((eq t stack-distance
)
6067 :returns
:non-local-exit
6068 :code
(append return-code
6069 (compiler-call #'special-operator-with-cloak
6071 :result-mode
(exit-result-mode to-env
)
6072 :form
`(muerte::with-cloak
(,return-mode
)
6073 (muerte::with-inline-assembly
(:returns
:nothing
)
6074 ;; Compute target dynamic-env
6075 (:locally
(:movl
(:edi
(:edi-offset dynamic-env
)) :eax
))
6076 ,@(loop repeat num-dynamic-slots
6077 collect
`(:movl
(:eax
12) :eax
))
6078 (:locally
(:call
(:edi
(:edi-offset dynamic-unwind-next
))))
6079 (:locally
(:movl
:eax
(:edi
(:edi-offset dynamic-env
))))
6080 (:jc
'(:sub-program
() (:int
63))))))
6081 `((:load-lexical
,(movitz-binding (save-esp-variable to-env
) to-env nil
) :esp
)
6082 (:jmp
',to-label
)))))
6083 ((zerop num-dynamic-slots
)
6085 :returns
:non-local-exit
6086 :code
(append return-code
6087 (make-compiled-stack-restore stack-distance
6088 (exit-result-mode to-env
)
6090 `((:jmp
',to-label
)))))
6091 ((plusp num-dynamic-slots
)
6092 ;; (warn "num-dynamic-slots: ~S, distance: ~D" num-dynamic-slots stack-distance)
6094 :returns
:non-local-exit
6095 :code
(append return-code
6096 (compiler-call #'special-operator-with-cloak
6098 :result-mode
(exit-result-mode to-env
)
6099 :form
`(muerte::with-cloak
(,return-mode
)
6100 (muerte::with-inline-assembly
(:returns
:nothing
)
6101 ;; Compute target dynamic-env
6102 (:locally
(:movl
(:edi
(:edi-offset dynamic-env
)) :eax
))
6103 ,@(loop repeat num-dynamic-slots
6104 collect
`(:movl
(:eax
12) :eax
))
6105 (:locally
(:call
(:edi
(:edi-offset dynamic-unwind-next
))))
6106 (:locally
(:movl
:eax
(:edi
(:edi-offset dynamic-env
))))
6107 (:jc
'(:sub-program
() (:int
63))))))
6108 `((:leal
(:esp
,(* 4 stack-distance
)) :esp
)
6109 (:jmp
',to-label
)))))
6110 (t (error "unknown!")))))
6112 (defun make-compiled-push-current-values ()
6113 "Return code that pushes the current values onto the stack, and returns
6114 in ECX the number of values (as fixnum)."
6115 (let ((not-single-value (gensym "not-single-value-"))
6116 (push-values-done (gensym "push-values-done-"))
6117 (push-values-loop (gensym "push-values-loop-")))
6118 `((:jc
',not-single-value
)
6121 (:jmp
',push-values-done
)
6123 (:shll
,+movitz-fixnum-shift
+ :ecx
)
6124 (:jz
',push-values-done
)
6129 (:je
',push-values-done
)
6133 (:je
',push-values-done
)
6135 (:locally
(:pushl
(:edi
(:edi-offset values
) :edx -
8)))
6138 (:jne
',push-values-loop
)
6139 ,push-values-done
)))
6141 (defun stack-add (x y
)
6142 (if (and (integerp x
) (integerp y
))
6146 (define-modify-macro stack-incf
(&optional
(delta 1)) stack-add
)
6148 (defun stack-delta (inner-env outer-env
)
6149 "Calculate the amount of stack-space used (in 32-bit stack slots) at the time
6150 of <inner-env> since <outer-env>,
6151 the number of intervening dynamic-slots (special bindings, unwind-protects, and catch-tags),
6152 and a list of any intervening unwind-protect environment-slots."
6154 ((find-stack-delta (env stack-distance num-dynamic-slots unwind-protects
)
6155 #+ignore
(warn "find-stack-delta: ~S dist ~S, slots ~S" env
6156 (stack-used env
) (num-dynamic-slots env
))
6159 ;; Each dynamic-slot is 4 stack-distances, so let's check that..
6160 (assert (or (eq t stack-distance
)
6161 (>= stack-distance
(* 4 num-dynamic-slots
))) ()
6162 "The stack-distance ~D is smaller than number of dynamic-slots ~D, which is inconsistent."
6163 stack-distance num-dynamic-slots
)
6164 (values stack-distance num-dynamic-slots unwind-protects
))
6167 (t (find-stack-delta (movitz-environment-uplink env
)
6168 (stack-add stack-distance
(stack-used env
))
6169 (stack-add num-dynamic-slots
(num-dynamic-slots env
))
6170 (if (typep env
'unwind-protect-env
)
6171 (cons env unwind-protects
)
6172 unwind-protects
))))))
6173 (find-stack-delta inner-env
0 0 nil
)))
6175 (defun print-stack-delta (inner-env outer-env
)
6176 (labels ((print-stack-delta (env)
6178 ((or (eq outer-env env
)
6180 (t (format t
"~&Env: ~S used: ~S, slots: ~S"
6181 env
(stack-used env
) (num-dynamic-slots env
))
6182 (print-stack-delta (movitz-environment-uplink env
))))))
6183 (print-stack-delta inner-env
)))
6186 ;;;;;;; Extended-code declarations
6189 (defvar *extended-code-find-read-binding
*
6190 (make-hash-table :test
#'eq
))
6192 (defvar *extended-code-find-used-bindings
*
6193 (make-hash-table :test
#'eq
))
6195 (defmacro define-find-read-bindings
(name lambda-list
&body body
)
6196 (let ((defun-name (intern
6197 (with-standard-io-syntax
6198 (format nil
"~A-~A" 'find-read-bindings name
)))))
6200 (setf (gethash ',name
*extended-code-find-read-binding
*) ',defun-name
)
6201 (defun ,defun-name
(instruction)
6202 (destructuring-bind ,lambda-list
6206 (defmacro define-find-used-bindings
(name lambda-list
&body body
)
6207 (let ((defun-name (intern
6208 (with-standard-io-syntax
6209 (format nil
"~A-~A" 'find-used-bindings name
)))))
6211 (setf (gethash ',name
*extended-code-find-used-bindings
*) ',defun-name
)
6212 (defun ,defun-name
(instruction)
6213 (destructuring-bind ,lambda-list
6217 (defun find-used-bindings (extended-instruction)
6218 "Return zero, one or two bindings that this instruction reads."
6219 (when (listp extended-instruction
)
6220 (let* ((operator (car extended-instruction
))
6221 (finder (or (gethash operator
*extended-code-find-used-bindings
*)
6222 (gethash operator
*extended-code-find-read-binding
*))))
6224 (let ((result (funcall finder extended-instruction
)))
6225 (check-type result list
"a list of read bindings")
6228 (defun find-read-bindings (extended-instruction)
6229 "Return zero, one or two bindings that this instruction reads."
6230 (when (listp extended-instruction
)
6231 (let* ((operator (car extended-instruction
))
6232 (finder (gethash operator
*extended-code-find-read-binding
*)))
6234 (funcall finder extended-instruction
)))))
6236 (defmacro define-find-write-binding-and-type
(name lambda-list
&body body
)
6237 (let ((defun-name (intern
6238 (with-standard-io-syntax
6239 (format nil
"~A-~A" 'find-write-binding-and-type name
)))))
6241 (setf (gethash ',name
*extended-code-find-write-binding-and-type
*) ',defun-name
)
6242 (defun ,defun-name
,lambda-list
,@body
))))
6244 (defun find-written-binding-and-type (extended-instruction)
6245 (when (listp extended-instruction
)
6246 (let* ((operator (car extended-instruction
))
6247 (finder (gethash operator
*extended-code-find-write-binding-and-type
*)))
6249 (funcall finder extended-instruction
)))))
6251 (defmacro define-extended-code-expander
(name lambda-list
&body body
)
6252 (let ((defun-name (intern
6253 (with-standard-io-syntax
6254 (format nil
"~A-~A" 'extended-code-expander- name
)))))
6256 (setf (gethash ',name
*extended-code-expanders
*) ',defun-name
)
6257 (defun ,defun-name
,lambda-list
,@body
))))
6259 (defun can-expand-extended-p (extended-instruction frame-map
)
6260 "Given frame-map, can we expand i at this point?"
6261 (and (every (lambda (b)
6262 (or (typep (binding-target b
) 'constant-object-binding
)
6263 (new-binding-located-p (binding-target b
) frame-map
)))
6264 (find-read-bindings extended-instruction
))
6265 (let ((written-binding (find-written-binding-and-type extended-instruction
)))
6266 (or (not written-binding
)
6267 (new-binding-located-p (binding-target written-binding
) frame-map
)))))
6269 (defun expand-extended-code (extended-instruction funobj frame-map
)
6270 (if (not (listp extended-instruction
))
6271 (list extended-instruction
)
6272 (let* ((operator (car extended-instruction
))
6273 (expander (gethash operator
*extended-code-expanders
*)))
6275 (list extended-instruction
)
6276 (let ((expansion (funcall expander extended-instruction funobj frame-map
)))
6278 (expand-extended-code e funobj frame-map
))
6281 (defun ensure-local-binding (binding funobj
)
6282 "When referencing binding in funobj, ensure we have the binding local to funobj."
6283 (if (typep binding
'(or (not binding
) constant-object-binding
))
6284 binding
; Never mind if "binding" isn't a binding, or is a constant-binding.
6285 (let ((target-binding (binding-target binding
)))
6287 ((eq funobj
(binding-funobj target-binding
))
6289 (t (or (find target-binding
(borrowed-bindings funobj
)
6290 :key
(lambda (binding)
6291 (borrowed-binding-target binding
)))
6292 (error "Can't install non-local binding ~W." binding
)))))))
6294 (defun binding-store-subtypep (binding type-specifier
)
6295 "Is type-specifier a supertype of all values ever stored to binding?
6296 (Assuming analyze-bindings has put this information into binding-store-type.)"
6297 (if (not (binding-store-type binding
))
6299 (multiple-value-call #'encoded-subtypep
6300 (values-list (binding-store-type binding
))
6301 (type-specifier-encode type-specifier
))))
6303 (defun binding-singleton (binding)
6304 (let ((btype (binding-store-type binding
)))
6306 (type-specifier-singleton (apply #'encoded-type-decode btype
)))))
6309 ;;;;;;; Extended-code handlers
6313 ;;;;;;;;;;;;;;;;;; Load-lexical
6315 (define-find-write-binding-and-type :load-lexical
(instruction)
6316 (destructuring-bind (source destination
&key
&allow-other-keys
)
6318 (when (typep destination
'binding
)
6319 (values destination t
#+ignore
(binding-type-specifier source
)
6320 (lambda (source-type)
6324 (define-find-read-bindings :load-lexical
(source destination
&key
&allow-other-keys
)
6325 (check-type source binding
)
6326 (values (list source
)
6327 (list destination
)))
6329 (define-extended-code-expander :load-lexical
(instruction funobj frame-map
)
6330 (destructuring-bind (source destination
&key shared-reference-p tmp-register protect-registers
)
6332 (make-load-lexical (ensure-local-binding source funobj
)
6333 (ensure-local-binding destination funobj
)
6334 funobj shared-reference-p frame-map
6335 :tmp-register tmp-register
6336 :protect-registers protect-registers
)))
6339 ;;;;;;;;;;;;;;;;;; Lisp-move
6341 (define-find-write-binding-and-type :lmove
(instruction)
6342 (destructuring-bind (source destination
)
6344 (values destination source
)))
6346 (define-find-read-bindings :lmove
(source destination
)
6347 (declare (ignore destination
))
6350 ;;;;;;;;;;;;;;;;;; Store-lexical
6352 (define-find-write-binding-and-type :store-lexical
(instruction)
6353 (destructuring-bind (destination source
&key
(type (error "No type")) &allow-other-keys
)
6355 (declare (ignore source
))
6356 (check-type destination binding
)
6357 (values destination type
)))
6359 (define-find-read-bindings :store-lexical
(destination source
&key
&allow-other-keys
)
6360 (declare (ignore destination
))
6361 (when (typep source
'binding
)
6364 (define-extended-code-expander :store-lexical
(instruction funobj frame-map
)
6365 (destructuring-bind (destination source
&key shared-reference-p type protect-registers
)
6367 (declare (ignore type
))
6368 (make-store-lexical (ensure-local-binding destination funobj
)
6369 (ensure-local-binding source funobj
)
6370 shared-reference-p funobj frame-map
6371 :protect-registers protect-registers
)))
6373 ;;;;;;;;;;;;;;;;;; Init-lexvar
6375 (define-find-write-binding-and-type :init-lexvar
(instruction)
6376 (destructuring-bind (binding &key init-with-register init-with-type
6377 protect-registers protect-carry
6380 (declare (ignore protect-registers protect-carry shared-reference-p
))
6384 ((not (typep init-with-register
'binding
))
6385 (assert init-with-type
)
6386 (values binding init-with-type
) )
6387 ((and init-with-type
(not (bindingp init-with-type
)))
6388 (values binding init-with-type
))
6389 ((and init-with-type
6390 (bindingp init-with-type
)
6391 (binding-store-type init-with-type
))
6392 (apply #'encoded-type-decode
(binding-store-type init-with-type
)))
6393 (t (values binding t
6395 (list init-with-register
)))))
6396 ((not (typep binding
'temporary-name
))
6397 (values binding t
)))))
6399 (define-find-read-bindings :init-lexvar
(binding &key init-with-register
&allow-other-keys
)
6400 (declare (ignore binding
))
6401 (when (typep init-with-register
'binding
)
6402 (list init-with-register
)))
6404 (define-extended-code-expander :init-lexvar
(instruction funobj frame-map
)
6405 (destructuring-bind (binding &key protect-registers protect-carry
6406 init-with-register init-with-type
6409 (declare (ignore protect-carry
)) ; nothing modifies carry anyway.
6410 ;; (assert (eq binding (ensure-local-binding binding funobj)))
6411 (assert (eq funobj
(binding-funobj binding
)))
6413 ((not (new-binding-located-p binding frame-map
))
6414 (unless (or (movitz-env-get (binding-name binding
) 'ignore nil
(binding-env binding
))
6415 (movitz-env-get (binding-name binding
) 'ignorable nil
(binding-env binding
)))))
6416 ((typep binding
'forwarding-binding
)
6417 ;; No need to do any initialization because the target will be initialized.
6418 (assert (not (binding-lended-p binding
)))
6420 (t (when (movitz-env-get (binding-name binding
) 'ignore nil
(binding-env binding
))
6421 (warn "Variable ~S used while declared ignored." (binding-name binding
)))
6424 ((typep binding
'rest-function-argument
)
6425 (assert (eq :edx init-with-register
))
6426 (assert (movitz-env-get (binding-name binding
)
6427 'dynamic-extent nil
(binding-env binding
))
6429 "&REST variable ~S must be dynamic-extent." (binding-name binding
))
6430 (setf (need-normalized-ecx-p (find-function-env (binding-env binding
)
6433 (let ((restify-alloca-loop (gensym "alloca-loop-"))
6434 (restify-done (gensym "restify-done-"))
6435 (restify-at-one (gensym "restify-at-one-"))
6436 (restify-loop (gensym "restify-loop-"))
6437 (save-ecx-p (key-vars-p (find-function-env (binding-env binding
)
6440 ;; (make-immediate-move (function-argument-argnum binding) :edx)
6441 ;; `((:call (:edi ,(global-constant-offset 'restify-dynamic-extent))))
6442 ;; Make space for (1+ (* 2 (- ECX rest-pos))) words on the stack.
6443 ;; Factor two is for one cons-cell per word, 1 is for 8-byte alignment.
6445 `((,*compiler-local-segment-prefix
*
6446 :movl
:ecx
(:edi
,(global-constant-offset 'raw-scratch0
)))))
6448 (:subl
,(function-argument-argnum binding
) :ecx
)
6449 (:jbe
',restify-done
)
6450 (:leal
((:ecx
8) 4) :edx
) ; EDX is fixnum counter
6451 ,restify-alloca-loop
6454 (:jnz
',restify-alloca-loop
)
6455 ,@(when *compiler-auto-stack-checks-p
*
6456 `((,*compiler-local-segment-prefix
*
6457 :bound
(:edi
,(global-constant-offset 'stack-bottom
)) :esp
)))
6458 (:leal
(:esp
5) :edx
)
6459 (:andl -
7 :edx
)) ; Make EDX a proper consp into the alloca area.
6461 ((= 0 (function-argument-argnum binding
))
6462 `((:movl
:eax
(:edx -
1))
6465 (:jz
',restify-done
)
6467 (:movl
:eax
(:eax -
5))))
6468 (t `((:movl
:edx
:eax
))))
6469 (when (>= 1 (function-argument-argnum binding
))
6470 `((:jmp
',restify-at-one
)))
6472 (:movl
(:ebp
(:ecx
4) 4) :ebx
)
6474 (:movl
:ebx
(:eax -
1))
6476 (:jz
',restify-done
)
6478 (:movl
:eax
(:eax -
5))
6479 (:jmp
',restify-loop
)
6482 `((,*compiler-local-segment-prefix
*
6483 :movl
(:edi
,(global-constant-offset 'raw-scratch0
)) :ecx
)))
6486 ((binding-lended-p binding
)
6487 (let* ((cons-position (getf (binding-lending binding
)
6488 :stack-cons-location
))
6489 (init-register (etypecase init-with-register
6490 ((or lexical-binding constant-object-binding
)
6491 (or (find-if (lambda (r)
6492 (not (member r protect-registers
)))
6494 (error "Unable to get a register.")))
6495 (keyword init-with-register
)
6497 (tmp-register (find-if (lambda (r)
6498 (and (not (member r protect-registers
))
6499 (not (eq r init-register
))))
6500 '(:edx
:ebx
:eax
))))
6501 (when init-with-register
6502 (assert (not (null init-with-type
))))
6503 (assert tmp-register
() ; solve this with push eax .. pop eax if ever needed.
6504 "Unable to find a tmp-register for ~S." instruction
)
6505 (append (when (typep init-with-register
'binding
)
6506 (make-load-lexical init-with-register init-register funobj
6507 shared-reference-p frame-map
6508 :protect-registers protect-registers
))
6509 `((:leal
(:ebp
,(1+ (stack-frame-offset (1+ cons-position
))))
6511 (:movl
:edi
(,tmp-register
3)) ; cdr
6512 (:movl
,init-register
(,tmp-register -
1)) ; car
6513 (:movl
,tmp-register
6514 (:ebp
,(stack-frame-offset
6515 (new-binding-location binding frame-map
))))))))
6516 ((typep init-with-register
'lexical-binding
)
6517 (make-load-lexical init-with-register binding funobj nil frame-map
))
6519 (make-store-lexical binding init-with-register nil funobj frame-map
))))))))
6521 ;;;;;;;;;;;;;;;;;; car
6523 (define-find-read-bindings :cons-get
(op cell dst
)
6524 (declare (ignore op dst protect-registers
))
6525 (when (typep cell
'binding
)
6528 (define-extended-code-expander :cons-get
(instruction funobj frame-map
)
6529 (destructuring-bind (op cell dst
)
6531 (check-type dst
(member :eax
:ebx
:ecx
:edx
))
6532 (multiple-value-bind (op-offset fast-op fast-op-ebx cl-op
)
6534 (:car
(values (bt:slot-offset
'movitz-cons
'car
)
6538 (:cdr
(values (bt:slot-offset
'movitz-cons
'cdr
)
6542 (let ((binding (binding-target (ensure-local-binding (binding-target cell
) funobj
))))
6544 (constant-object-binding
6545 (let ((x (constant-object binding
)))
6548 (make-load-constant *movitz-nil
* dst funobj frame-map
))
6550 (append (make-load-constant x dst funobj frame-map
)
6551 `((:movl
(,dst
,op-offset
) ,dst
))))
6552 (t `(,@(make-load-lexical binding
:eax funobj nil frame-map
)
6553 (,*compiler-global-segment-prefix
*
6554 :call
(:edi
,(global-constant-offset fast-op
)))
6555 ,@(when (not (eq dst
:eax
))
6556 `((:movl
:eax
,dst
))))))))
6558 (let ((location (new-binding-location (binding-target binding
) frame-map
))
6559 (binding-is-list-p (binding-store-subtypep binding
'list
)))
6560 #+ignore
(warn "~A of loc ~A bind ~A" op location binding
)
6562 ((and binding-is-list-p
6563 (member location
'(:eax
:ebx
:ecx
:edx
)))
6564 `((,*compiler-nonlocal-lispval-read-segment-prefix
*
6565 :movl
(,location
,op-offset
) ,dst
)))
6567 `(,@(make-load-lexical binding dst funobj nil frame-map
)
6568 (,*compiler-nonlocal-lispval-read-segment-prefix
*
6569 :movl
(,dst
,op-offset
) ,dst
)))
6570 ((not *compiler-use-cons-reader-segment-protocol-p
*)
6573 `((,*compiler-global-segment-prefix
*
6574 :call
(:edi
,(global-constant-offset fast-op-ebx
)))
6575 ,@(when (not (eq dst
:eax
))
6576 `((:movl
:eax
,dst
)))))
6577 (t `(,@(make-load-lexical binding
:eax funobj nil frame-map
)
6578 (,*compiler-global-segment-prefix
*
6579 :call
(:edi
,(global-constant-offset fast-op
)))
6580 ,@(when (not (eq dst
:eax
))
6581 `((:movl
:eax
,dst
)))))))
6583 ((member location
'(:ebx
:ecx
:edx
))
6584 `((,(or *compiler-cons-read-segment-prefix
*
6585 *compiler-nonlocal-lispval-read-segment-prefix
*)
6586 :movl
(:eax
,op-offset
) ,dst
)))
6587 (t (append (make-load-lexical binding
:eax funobj nil frame-map
)
6588 `((,(or *compiler-cons-read-segment-prefix
*
6589 *compiler-nonlocal-lispval-read-segment-prefix
*)
6590 :movl
(:eax
,op-offset
) ,dst
))))))))))))))
6593 ;;;;;;;;;;;;;;;;;; endp
6595 (define-find-read-bindings :endp
(cell result-mode
)
6596 (declare (ignore result-mode
))
6597 (when (typep cell
'binding
)
6600 (define-extended-code-expander :endp
(instruction funobj frame-map
)
6601 (destructuring-bind (cell result-mode
)
6603 (let ((binding (binding-target (ensure-local-binding (binding-target cell
) funobj
))))
6605 (constant-object-binding
6606 (let ((x (constant-object binding
)))
6609 (make-load-constant *movitz-nil
* result-mode funobj frame-map
))
6611 (make-load-constant (image-t-symbol *image
*) result-mode funobj frame-map
))
6614 (let* ((location (new-binding-location (binding-target binding
) frame-map
))
6615 (binding-is-list-p (binding-store-subtypep binding
'list
))
6616 (tmp-register (case location
6617 ((:eax
:ebx
:ecx
:edx
)
6619 ;; (warn "endp of loc ~A bind ~A" location binding)
6621 ((and binding-is-list-p
6622 (member location
'(:eax
:ebx
:ecx
:edx
)))
6623 (make-result-and-returns-glue result-mode
:boolean-zf
=1
6624 `((:cmpl
:edi
,location
))))
6625 ((eq :boolean-branch-on-true
(result-mode-type result-mode
))
6626 (let ((tmp-register (or tmp-register
:ecx
)))
6627 (append (make-load-lexical binding
6628 (cons :boolean-branch-on-false
6630 funobj nil frame-map
)
6631 (unless binding-is-list-p
6632 (append (make-load-lexical binding tmp-register funobj nil frame-map
)
6633 `((:leal
(,tmp-register -
1) :ecx
)
6635 (:jnz
'(:sub-program
(,(gensym "endp-not-list-"))
6637 (t (let ((tmp-register (or tmp-register
:eax
)))
6638 (append (make-load-lexical binding tmp-register funobj nil frame-map
)
6639 (unless binding-is-list-p
6640 `((:leal
(,tmp-register -
1) :ecx
)
6642 (:jnz
'(:sub-program
(,(gensym "endp-not-list-"))
6644 `((:cmpl
:edi
,tmp-register
))
6645 (make-result-and-returns-glue result-mode
:boolean-zf
=1)))))))))))
6648 ;;;;;;;;;;;;;;;;;; incf-lexvar
6650 (define-find-write-binding-and-type :incf-lexvar
(instruction)
6651 (destructuring-bind (binding delta
&key protect-registers
)
6653 (declare (ignore delta protect-registers
))
6654 (values binding
'integer
)))
6656 (define-find-read-bindings :incf-lexvar
(binding delta
&key protect-registers
)
6657 (declare (ignore delta protect-registers binding
))
6660 (define-extended-code-expander :incf-lexvar
(instruction funobj frame-map
)
6661 (break "incf-lexvar??")
6662 (destructuring-bind (binding delta
&key protect-registers
)
6664 (check-type binding binding
)
6665 (check-type delta integer
)
6666 (let* ((binding (binding-target binding
))
6667 (location (new-binding-location binding frame-map
:default nil
))
6668 (binding-type (binding-store-type binding
)))
6669 ;;; (warn "incf b ~A, loc: ~A, typ: ~A" binding location binding-type)
6673 (not (binding-lended-p binding
))
6674 (binding-store-subtypep binding
'integer
))
6675 ;; This is an optimized incf that doesn't have to do type-checking.
6676 (check-type location
(integer 1 *))
6677 `((:addl
,(* delta
+movitz-fixnum-factor
+)
6678 (:ebp
,(stack-frame-offset location
)))
6680 ((binding-store-subtypep binding
'integer
)
6681 (let ((register (chose-free-register protect-registers
)))
6682 `(,@(make-load-lexical (ensure-local-binding binding funobj
)
6683 register funobj nil frame-map
6684 :protect-registers protect-registers
)
6685 (:addl
,(* delta
+movitz-fixnum-factor
+) :eax
)
6687 ,@(make-store-lexical (ensure-local-binding binding funobj
)
6688 register nil funobj frame-map
6689 :protect-registers protect-registers
))))
6690 (t (let ((register (chose-free-register protect-registers
)))
6691 `(,@(make-load-lexical (ensure-local-binding binding funobj
)
6692 register funobj nil frame-map
6693 :protect-registers protect-registers
)
6694 (:testb
,+movitz-fixnum-zmask
+ ,(register32-to-low8 register
))
6695 (:jnz
'(:sub-program
(,(gensym "not-integer-"))
6698 (:addl
,(* delta
+movitz-fixnum-factor
+) ,register
)
6700 ,@(make-store-lexical (ensure-local-binding binding funobj
)
6701 register nil funobj frame-map
6702 :protect-registers protect-registers
))))))))
6706 (define-find-write-binding-and-type :load-constant
(instruction)
6707 (destructuring-bind (object result-mode
&key
(op :movl
))
6709 (when (and (eq op
:movl
) (typep result-mode
'binding
))
6710 (check-type result-mode lexical-binding
)
6711 (values result-mode
`(eql ,object
)))))
6713 (define-extended-code-expander :load-constant
(instruction funobj frame-map
)
6714 (destructuring-bind (object result-mode
&key
(op :movl
))
6716 (make-load-constant object result-mode funobj frame-map
:op op
)))
6720 (define-find-write-binding-and-type :add
(instruction)
6721 (destructuring-bind (term0 term1 destination
)
6723 (when (typep destination
'binding
)
6724 (assert (and (bindingp term0
) (bindingp term1
)))
6727 (lambda (type0 type1
)
6728 (let ((x (multiple-value-call #'encoded-integer-types-add
6729 (type-specifier-encode type0
)
6730 (type-specifier-encode type1
))))
6731 #+ignore
(warn "thunked: ~S ~S -> ~S" term0 term1 x
)
6736 (define-find-used-bindings :add
(term0 term1 destination
)
6737 (if (bindingp destination
)
6738 (list term0 term1 destination
)
6739 (list term0 term1
)))
6741 (define-find-read-bindings :add
(term0 term1 destination
)
6742 (declare (ignore destination
))
6743 (let* ((type0 (and (binding-store-type term0
)
6744 (apply #'encoded-type-decode
(binding-store-type term0
))))
6745 (type1 (and (binding-store-type term1
)
6746 (apply #'encoded-type-decode
(binding-store-type term1
))))
6747 (singleton0 (and type0
(type-specifier-singleton type0
)))
6748 (singleton1 (and type1
(type-specifier-singleton type1
)))
6749 (singleton-sum (and singleton0 singleton1
6750 (type-specifier-singleton
6751 (apply #'encoded-integer-types-add
6752 (append (binding-store-type term0
)
6753 (binding-store-type term1
)))))))
6756 (let ((b (make-instance 'constant-object-binding
6757 :name
(gensym "constant-sum")
6758 :object
(car singleton-sum
))))
6759 (movitz-env-add-binding (binding-env term0
) b
)
6761 (t (append (unless (and singleton0
(typep (car singleton0
) 'movitz-fixnum
))
6763 (unless (and singleton1
(typep (car singleton1
) 'movitz-fixnum
))
6766 (define-extended-code-expander :add
(instruction funobj frame-map
)
6767 (destructuring-bind (term0 term1 destination
)
6769 (assert (and (bindingp term0
)
6771 (member (result-mode-type destination
)
6772 '(:lexical-binding
:function
:multple-values
:eax
:ebx
:ecx
:edx
))))
6773 (let* ((destination (ensure-local-binding destination funobj
))
6774 (term0 (ensure-local-binding term0 funobj
))
6775 (term1 (ensure-local-binding term1 funobj
))
6776 (destination-location (if (or (not (bindingp destination
))
6777 (typep destination
'borrowed-binding
))
6779 (new-binding-location (binding-target destination
)
6782 (type0 (apply #'encoded-type-decode
(binding-store-type term0
)))
6783 (type1 (apply #'encoded-type-decode
(binding-store-type term1
)))
6784 (result-type (multiple-value-call #'encoded-integer-types-add
6785 (values-list (binding-store-type term0
))
6786 (values-list (binding-store-type term1
)))))
6787 ;; A null location means the binding is unused, in which
6788 ;; case there's no need to perform the addition.
6789 (when destination-location
6790 (let ((loc0 (new-binding-location (binding-target term0
) frame-map
:default nil
))
6791 (loc1 (new-binding-location (binding-target term1
) frame-map
:default nil
)))
6793 (warn "add: ~A for ~A" instruction result-type
)
6795 (warn "add for: ~S is ~A, from ~A/~A and ~A/~A."
6796 destination result-type
6800 (when (eql destination-location
9)
6801 (warn "add for: ~S/~S~%= ~A/~A in ~S~&~A/~A in ~S."
6802 destination destination-location
6803 term0 loc0
(binding-extent-env (binding-target term0
))
6804 term1 loc1
(binding-extent-env (binding-target term1
)))
6805 (print-code 'load-term1
(make-load-lexical term1
:eax funobj nil frame-map
))
6806 (print-code 'load-dest
(make-load-lexical destination
:eax funobj nil frame-map
)))
6807 (flet ((make-store (source destination
)
6809 ((eq source destination
)
6811 ((member destination
'(:eax
:ebx
:ecx
:edx
))
6812 `((:movl
,source
,destination
)))
6813 (t (make-store-lexical destination source nil funobj frame-map
))))
6814 (make-default-add ()
6815 (when (movitz-subtypep result-type
'(unsigned-byte 32))
6816 (warn "Defaulting u32 ADD: ~A/~S = ~A/~S + ~A/~S"
6817 destination-location
6822 ((type-specifier-singleton type0
)
6823 (append (make-load-lexical term1
:eax funobj nil frame-map
)
6824 (make-load-constant (car (type-specifier-singleton type0
))
6825 :ebx funobj frame-map
)))
6826 ((type-specifier-singleton type1
)
6827 (append (make-load-lexical term0
:eax funobj nil frame-map
)
6828 (make-load-constant (car (type-specifier-singleton type1
))
6829 :ebx funobj frame-map
)))
6830 ((and (eq :eax loc0
) (eq :ebx loc1
))
6832 ((and (eq :ebx loc0
) (eq :eax loc1
))
6833 nil
) ; terms order isn't important
6836 (make-load-lexical term0
:ebx funobj nil frame-map
)))
6838 (make-load-lexical term0
:eax funobj nil frame-map
)
6839 (make-load-lexical term1
:ebx funobj nil frame-map
))))
6840 `((:movl
(:edi
,(global-constant-offset '+)) :esi
))
6841 (make-compiled-funcall-by-esi 2)
6842 (etypecase destination
6844 (unless (eq destination
:eax
)
6845 `((:movl
:eax
,destination
))))
6847 (make-store-lexical destination
:eax nil funobj frame-map
))))))
6848 (let ((constant0 (let ((x (type-specifier-singleton type0
)))
6849 (when (and x
(typep (car x
) 'movitz-fixnum
))
6850 (movitz-immediate-value (car x
)))))
6851 (constant1 (let ((x (type-specifier-singleton type1
)))
6852 (when (and x
(typep (car x
) 'movitz-fixnum
))
6853 (movitz-immediate-value (car x
))))))
6855 ((type-specifier-singleton result-type
)
6856 ;; (break "constant add: ~S" instruction)
6857 (make-load-constant (car (type-specifier-singleton result-type
))
6858 destination funobj frame-map
))
6859 ((movitz-subtypep type0
'(integer 0 0))
6861 ((eql destination loc1
)
6862 #+ignore
(break "NOP add: ~S" instruction
)
6864 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
6865 (member loc1
'(:eax
:ebx
:ecx
:edx
)))
6866 `((:movl
,loc1
,destination-location
)))
6868 (make-load-lexical term1 destination funobj nil frame-map
))
6870 ((integerp destination-location
)
6871 (make-store-lexical destination-location loc1 nil funobj frame-map
))
6872 (t (break "Unknown X zero-add: ~S" instruction
))))
6873 ((movitz-subtypep type1
'(integer 0 0))
6874 ;; (warn "zero-add ~S => ~S [~S]" loc0 destination-location result-type)
6876 ((eql destination-location loc0
)
6877 #+ignore
(break "NOP add: ~S" instruction
)
6879 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
6880 (member loc0
'(:eax
:ebx
:ecx
:edx
)))
6881 `((:movl
,loc0
,destination-location
)))
6882 ((member loc0
'(:eax
:ebx
:ecx
:edx
))
6883 (make-store-lexical destination loc0 nil funobj frame-map
))
6885 (make-load-lexical term0 destination funobj nil frame-map
))
6886 (t (break "Unknown Y zero-add: ~S" instruction
))))
6887 ((and (movitz-subtypep type0
'fixnum
)
6888 (movitz-subtypep type1
'fixnum
)
6889 (movitz-subtypep result-type
'fixnum
))
6890 (assert (not (and constant0
(zerop constant0
))))
6891 (assert (not (and constant1
(zerop constant1
))))
6893 ((and (not (binding-lended-p (binding-target term0
)))
6894 (not (binding-lended-p (binding-target term1
)))
6895 (not (and (bindingp destination
)
6896 (binding-lended-p (binding-target destination
)))))
6899 (equal loc1 destination-location
))
6901 ((member destination-location
'(:eax
:ebx
:ecx
:edx
))
6902 `((:addl
,constant0
,destination-location
)))
6904 `((:addl
,constant0
(:ebp
,(stack-frame-offset loc1
)))))
6905 ((eq :argument-stack
(operator loc1
))
6907 (:ebp
,(argument-stack-offset (binding-target term1
))))))
6908 ((eq :untagged-fixnum-ecx
(operator loc1
))
6909 `((:addl
,(truncate constant0
+movitz-fixnum-factor
+) :ecx
)))
6910 (t (error "Don't know how to add this for loc1 ~S" loc1
))))
6912 (integerp destination-location
)
6913 (eql term1 destination-location
))
6915 `((:addl
,constant0
(:ebp
,(stack-frame-offset destination-location
)))))
6917 (integerp destination-location
)
6918 (member loc1
'(:eax
:ebx
:ecx
:edx
)))
6919 `((:addl
,constant0
,loc1
)
6920 (:movl
,loc1
(:ebp
,(stack-frame-offset destination-location
)))))
6921 ((and (integerp loc0
)
6923 (member destination-location
'(:eax
:ebx
:ecx
:edx
)))
6924 (append `((:movl
(:ebp
,(stack-frame-offset loc0
)) ,destination-location
)
6925 (:addl
(:ebp
,(stack-frame-offset loc1
)) ,destination-location
))))
6926 ((and (integerp destination-location
)
6927 (eql loc0 destination-location
)
6929 `((:addl
,constant1
(:ebp
,(stack-frame-offset destination-location
)))))
6930 ((and (integerp destination-location
)
6931 (eql loc1 destination-location
)
6933 `((:addl
,constant0
(:ebp
,(stack-frame-offset destination-location
)))))
6934 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
6935 (eq loc0
:untagged-fixnum-ecx
)
6937 `((:leal
((:ecx
,+movitz-fixnum-factor
+) ,constant1
)
6938 ,destination-location
)))
6939 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
6942 `((:movl
(:ebp
,(stack-frame-offset loc1
)) ,destination-location
)
6943 (:addl
,constant0
,destination-location
)))
6944 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
6947 `((:movl
(:ebp
,(stack-frame-offset loc0
)) ,destination-location
)
6948 (:addl
,constant1
,destination-location
)))
6949 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
6951 (member loc1
'(:eax
:ebx
:ecx
:edx
))
6952 (not (eq destination-location loc1
)))
6953 `((:movl
(:ebp
,(stack-frame-offset loc0
)) ,destination-location
)
6954 (:addl
,loc1
,destination-location
)))
6955 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
6957 (member loc1
'(:eax
:ebx
:ecx
:edx
)))
6958 `((:leal
(,loc1
,constant0
) ,destination-location
)))
6959 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
6961 (member loc0
'(:eax
:ebx
:ecx
:edx
)))
6962 `((:leal
(,loc0
,constant1
) ,destination-location
)))
6963 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
6965 (eq :argument-stack
(operator loc1
)))
6966 `((:movl
(:ebp
,(argument-stack-offset (binding-target term1
)))
6967 ,destination-location
)
6968 (:addl
,constant0
,destination-location
)))
6969 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
6971 (eq :argument-stack
(operator loc0
)))
6972 `((:movl
(:ebp
,(argument-stack-offset (binding-target term0
)))
6973 ,destination-location
)
6974 (:addl
,constant1
,destination-location
)))
6976 (append (make-load-lexical term1
:eax funobj nil frame-map
)
6977 `((:addl
,constant0
:eax
))
6978 (make-store :eax destination
)))
6980 (append (make-load-lexical term0
:eax funobj nil frame-map
)
6981 `((:addl
,constant1
:eax
))
6982 (make-store :eax destination
)))
6984 (append (make-load-lexical term0
:eax funobj nil frame-map
)
6985 `((:addl
:eax
:eax
))
6986 (make-store :eax destination
)))
6987 ((and (integerp loc0
)
6989 (integerp destination-location
)
6990 (/= loc0 loc1 destination-location
))
6991 `((:movl
(:ebp
,(stack-frame-offset loc0
))
6993 (:addl
(:ebp
,(stack-frame-offset loc1
))
6995 (:movl
:ecx
(:ebp
,(stack-frame-offset destination-location
)))))
6996 (t (warn "Unknown fixnum ADD: ~A/~S = ~A/~S + ~A/~S"
6997 destination-location
7001 #+ignore
(warn "map: ~A" frame-map
)
7002 ;;; (warn "ADDI: ~S" instruction)
7004 ((type-specifier-singleton type0
)
7005 (append (make-load-lexical term1
:eax funobj nil frame-map
)
7006 (make-load-constant (car (type-specifier-singleton type0
))
7007 :ebx funobj frame-map
)))
7008 ((type-specifier-singleton type1
)
7009 (append (make-load-lexical term0
:eax funobj nil frame-map
)
7010 (make-load-constant (car (type-specifier-singleton type1
))
7011 :ebx funobj frame-map
)))
7012 ((and (eq :eax loc0
) (eq :ebx loc1
))
7014 ((and (eq :ebx loc0
) (eq :eax loc1
))
7015 nil
) ; terms order isn't important
7018 (make-load-lexical term0
:ebx funobj nil frame-map
)))
7020 (make-load-lexical term0
:eax funobj nil frame-map
)
7021 (make-load-lexical term1
:ebx funobj nil frame-map
))))
7022 `((:movl
(:edi
,(global-constant-offset '+)) :esi
))
7023 (make-compiled-funcall-by-esi 2)
7024 (etypecase destination
7026 (unless (eq destination
:eax
)
7027 `((:movl
:eax
,destination
))))
7029 (make-store-lexical destination
:eax nil funobj frame-map
)))))))
7031 (integerp destination-location
)
7032 (eql loc1 destination-location
)
7033 (binding-lended-p (binding-target destination
)))
7034 (assert (binding-lended-p (binding-target term1
)))
7035 (append (make-load-lexical destination
:eax funobj t frame-map
)
7036 `((:addl
,constant0
(-1 :eax
)))))
7037 ((warn "~S" (list (and (bindingp destination
)
7038 (binding-lended-p (binding-target destination
)))
7039 (binding-lended-p (binding-target term0
))
7040 (binding-lended-p (binding-target term1
)))))
7041 (t (warn "Unknown fixnum add: ~S" instruction
)
7042 (make-default-add))))
7043 ((and (movitz-subtypep type0
'fixnum
)
7044 (movitz-subtypep type1
'fixnum
))
7045 (flet ((mkadd-into (src destreg
)
7046 (assert (eq destreg
:eax
) (destreg)
7047 "Movitz' INTO protocol says the overflowed value must be in EAX, ~
7048 but it's requested to be in ~S."
7050 (let ((srcloc (new-binding-location (binding-target src
) frame-map
)))
7051 (unless (eql srcloc loc1
) (break))
7052 (if (integerp srcloc
)
7053 `((:addl
(:ebp
,(stack-frame-offset srcloc
))
7056 (ecase (operator srcloc
)
7057 ((:eax
:ebx
:ecx
:edx
)
7058 `((:addl
,srcloc
,destreg
)
7061 `((:addl
(:ebx
,(argument-stack-offset src
))
7066 ((and (not constant0
)
7068 (not (binding-lended-p (binding-target term0
)))
7069 (not (binding-lended-p (binding-target term1
)))
7070 (not (and (bindingp destination
)
7071 (binding-lended-p (binding-target destination
)))))
7073 ((and (not (eq loc0
:untagged-fixnum-ecx
))
7074 (not (eq loc1
:untagged-fixnum-ecx
))
7075 (not (eq destination-location
:untagged-fixnum-ecx
)))
7077 ((and (eq loc0
:eax
) (eq loc1
:eax
))
7081 (mkadd-into term1
:eax
))
7083 (mkadd-into term0
:eax
))
7084 (t (append (make-load-lexical term0
:eax funobj nil frame-map
7085 :protect-registers
(list loc1
))
7086 (mkadd-into term1
:eax
))))
7087 (make-store :eax destination
)))
7088 (t (make-default-add)
7090 (append (make-load-lexical term0
:untagged-fixnum-ecx funobj nil frame-map
)
7091 `((,*compiler-local-segment-prefix
*
7092 :movl
:ecx
(:edi
,(global-constant-offset 'raw-scratch0
))))
7093 (make-load-lexical term1
:untagged-fixnum-ecx funobj nil frame-map
)
7094 `((,*compiler-local-segment-prefix
*
7095 :addl
(:edi
,(global-constant-offset 'raw-scratch0
)) :ecx
))
7096 (if (integerp destination-location
)
7097 `((,*compiler-local-segment-prefix
*
7098 :call
(:edi
,(global-constant-offset 'box-u32-ecx
)))
7099 (:movl
:eax
(:ebp
,(stack-frame-offset destination-location
))))
7100 (ecase (operator destination-location
)
7101 ((:untagged-fixnum-ecx
)
7104 `((,*compiler-local-segment-prefix
*
7105 :call
(:edi
,(global-constant-offset 'box-u32-ecx
)))))
7107 `((,*compiler-local-segment-prefix
*
7108 :call
(:edi
,(global-constant-offset 'box-u32-ecx
)))
7109 (:movl
:eax
,destination-location
)))
7111 `((,*compiler-local-segment-prefix
*
7112 :call
(:edi
,(global-constant-offset 'box-u32-ecx
)))
7113 (:movl
:eax
(:ebp
,(argument-stack-offset
7114 (binding-target destination
))))))))))))
7115 (t (make-default-add)))))
7116 (t (make-default-add))))))))))
7120 (define-find-read-bindings :eql
(x y mode
)
7121 (declare (ignore mode
))
7124 (define-extended-code-expander :eql
(instruction funobj frame-map
)
7125 (destructuring-bind (x y return-mode
)
7127 (let* ((x-type (apply #'encoded-type-decode
(binding-store-type x
)))
7128 (y-type (apply #'encoded-type-decode
(binding-store-type y
)))
7129 (x-singleton (type-specifier-singleton x-type
))
7130 (y-singleton (type-specifier-singleton y-type
)))
7131 (when (and y-singleton
(not x-singleton
))
7133 (rotatef x-type y-type
)
7134 (rotatef x-singleton y-singleton
))
7135 (let (#+ignore
(x-loc (new-binding-location (binding-target x
) frame-map
:default nil
))
7136 (y-loc (new-binding-location (binding-target y
) frame-map
:default nil
)))
7138 (warn "eql ~S/~S xx~Xxx ~S/~S: ~S"
7139 x x-loc
(binding-target y
)
7142 (flet ((make-branch ()
7143 (ecase (operator return-mode
)
7144 (:boolean-branch-on-false
7145 `((:jne
',(operands return-mode
))))
7146 (:boolean-branch-on-true
7147 `((:je
',(operands return-mode
))))
7149 (make-load-eax-ebx ()
7151 (make-load-lexical x
:ebx funobj nil frame-map
)
7152 (append (make-load-lexical x
:eax funobj nil frame-map
)
7153 (make-load-lexical y
:ebx funobj nil frame-map
)))))
7155 ((and x-singleton y-singleton
)
7156 (let ((eql (etypecase (car x-singleton
)
7157 (movitz-immediate-object
7158 (and (typep (car y-singleton
) 'movitz-immediate-object
)
7159 (eql (movitz-immediate-value (car x-singleton
))
7160 (movitz-immediate-value (car y-singleton
))))))))
7161 (case (operator return-mode
)
7162 (:boolean-branch-on-false
7164 `((:jmp
',(operands return-mode
)))))
7165 (t (break "Constant EQL: ~S ~S" (car x-singleton
) (car y-singleton
))))))
7167 (eq :untagged-fixnum-ecx y-loc
))
7168 (let ((value (etypecase (car x-singleton
)
7170 (movitz-fixnum-value (car x-singleton
)))
7172 (movitz-bignum-value (car x-singleton
))))))
7173 (check-type value
(unsigned-byte 32))
7174 `((:cmpl
,value
:ecx
)
7177 (typep (car x-singleton
) '(or movitz-immediate-object movitz-null
)))
7178 (let ((value (if (typep (car x-singleton
) 'movitz-null
)
7180 (movitz-immediate-value (car x-singleton
)))))
7183 (member y-loc
'(:eax
:ebx
:ecx
:edx
)))
7184 `((:testl
,y-loc
,y-loc
)))
7185 ((and (member y-loc
'(:eax
:ebx
:ecx
:edx
))
7186 (not (binding-lended-p y
)))
7187 `((:cmpl
,value
,y-loc
)))
7188 ((and (integerp y-loc
)
7189 (not (binding-lended-p y
)))
7190 `((:cmpl
,value
(:ebp
,(stack-frame-offset y-loc
)))))
7191 ((and (eq :argument-stack
(operator y-loc
))
7192 (not (binding-lended-p y
)))
7193 `((:cmpl
,value
(:ebp
,(argument-stack-offset (binding-target y
))))))
7194 (t (break "x-singleton: ~S with loc ~S"
7195 (movitz-immediate-value (car x-singleton
))
7199 (typep (car x-singleton
) 'movitz-symbol
)
7200 (member y-loc
'(:eax
:ebx
:edx
)))
7201 (append (make-load-constant (car x-singleton
) y-loc funobj frame-map
:op
:cmpl
)
7204 (break "y-singleton"))
7205 ((and (not (eq t x-type
)) ; this is for bootstrapping purposes.
7206 (not (eq t y-type
)) ; ..
7207 (or (movitz-subtypep x-type
'(or fixnum character symbol vector
))
7208 (movitz-subtypep y-type
'(or fixnum character symbol vector
))))
7209 (append (make-load-eax-ebx)
7210 `((:cmpl
:eax
:ebx
))
7213 ((warn "eql ~S/~S ~S/~S"
7216 ((eq :boolean-branch-on-false
(operator return-mode
))
7217 (let ((eql-done (gensym "eql-done-"))
7218 (on-false-label (operands return-mode
)))
7219 (append (make-load-eax-ebx)
7222 (,*compiler-global-segment-prefix
*
7223 :movl
(:edi
,(global-constant-offset 'complicated-eql
)) :esi
)
7224 (:call
(:esi
,(bt:slot-offset
'movitz-funobj
'code-vector%
2op
)))
7225 (:jne
',on-false-label
)
7227 ((eq :boolean-branch-on-true
(operator return-mode
))
7228 (let ((on-true-label (operands return-mode
)))
7229 (append (make-load-eax-ebx)
7231 (:je
',on-true-label
)
7232 (,*compiler-global-segment-prefix
*
7233 :movl
(:edi
,(global-constant-offset 'complicated-eql
)) :esi
)
7234 (:call
(:esi
,(bt:slot-offset
'movitz-funobj
'code-vector%
2op
)))
7235 (:je
',on-true-label
)))))
7236 ((eq return-mode
:boolean-zf
=1)
7237 (append (make-load-eax-ebx)
7238 (let ((eql-done (gensym "eql-done-")))
7241 (,*compiler-global-segment-prefix
*
7242 :movl
(:edi
,(global-constant-offset 'complicated-eql
)) :esi
)
7243 (:call
(:esi
,(bt:slot-offset
'movitz-funobj
'code-vector%
2op
)))
7245 (t (error "unknown eql: ~S" instruction
))))))))
7247 (define-find-read-bindings :load-lambda
(lambda-binding result-mode capture-env
)
7248 (declare (ignore result-mode capture-env
))
7249 (let ((allocation (movitz-allocation (function-binding-funobj lambda-binding
))))
7250 (when (typep allocation
'with-dynamic-extent-scope-env
)
7251 (values (list (base-binding allocation
))
7254 (define-find-write-binding-and-type :enter-dynamic-scope
(instruction)
7255 (destructuring-bind (scope-env)
7257 (if (null (dynamic-extent-scope-members scope-env
))
7259 (values (base-binding scope-env
) 'fixnum
))))
7261 (define-extended-code-expander :enter-dynamic-scope
(instruction funobj frame-map
)
7262 (declare (ignore funobj frame-map
))
7263 (destructuring-bind (scope-env)
7265 (if (null (dynamic-extent-scope-members scope-env
))
7267 (append `((:pushl
:edi
)
7271 (loop for object in
(reverse (dynamic-extent-scope-members scope-env
))
7278 (append (unless (zerop (mod (sizeof object
) 8))
7280 `((:load-constant
,object
:eax
))
7281 (loop for i from
(1- (movitz-funobj-num-constants object
))
7282 downto
(movitz-funobj-num-jumpers object
)
7283 collect
`(:pushl
(:eax
,(slot-offset 'movitz-funobj
'constant0
)
7285 (loop repeat
(movitz-funobj-num-jumpers object
)
7286 collect
`(:pushl
0))
7287 `((:pushl
(:eax
,(slot-offset 'movitz-funobj
'num-jumpers
)))
7288 (:pushl
(:eax
,(slot-offset 'movitz-funobj
'name
)))
7289 (:pushl
(:eax
,(slot-offset 'movitz-funobj
'lambda-list
)))
7294 (:pushl
2) ; (default) 2 is recognized by map-header-vals as non-initialized funobj.
7296 (:pushl
(:eax
,(slot-offset 'movitz-funobj
'type
)))
7297 (:leal
(:esp
,(tag :other
)) :ebx
)
7298 (,*compiler-local-segment-prefix
*
7299 :call
(:edi
,(global-constant-offset 'copy-funobj-code-vector-slots
)))
7302 ;;;(define-extended-code-expander :exit-dynamic-scope (instruction funobj frame-map)
7305 (define-find-read-bindings :lexical-control-transfer
(return-code return-mode from-env to-env
7307 (declare (ignore return-code return-mode to-label
))
7308 (let ((distance (stack-delta from-env to-env
)))
7309 (when (eq t distance
)
7310 (values (list (movitz-binding (save-esp-variable to-env
) to-env nil
))
7313 (define-find-read-bindings :stack-cons
(proto-cons scope-env
)
7314 (declare (ignore proto-cons
))
7315 (values (list (base-binding scope-env
))
7318 (define-extended-code-expander :stack-cons
(instruction funobj frame-map
)
7319 (destructuring-bind (proto-cons dynamic-scope
)
7321 (append (make-load-lexical (base-binding dynamic-scope
) :edx
7322 funobj nil frame-map
)
7323 `((:movl
:eax
(:edx
,(dynamic-extent-object-offset dynamic-scope proto-cons
)))
7324 (:movl
:ebx
(:edx
,(+ 4 (dynamic-extent-object-offset dynamic-scope proto-cons
))))
7325 (:leal
(:edx
,(+ (tag :cons
) (dynamic-extent-object-offset dynamic-scope proto-cons
)))