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.186 2007/04/05 21:10:39 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 (instr env size
)
116 (let* ((return-pointer-tag (ldb (byte 3 0)
117 (+ (ia-x86::assemble-env-current-pc env
)
120 ((not (typep instr
'ia-x86-instr
::call
))
122 ((or (= (tag :even-fixnum
) return-pointer-tag
)
123 (= (tag :odd-fixnum
) return-pointer-tag
))
126 ;;; ((= 3 return-pointer-tag)
127 ;;; ;; Insert two NOPs, 3 -> 5
129 ((= (tag :character
) return-pointer-tag
)
130 ;; Insert three NOPs, 2 -> 5
134 (defun make-compiled-primitive (form environment top-level-p docstring
)
135 "Primitive functions have no funobj, no stack-frame, and no implied
136 parameter/return value passing conventions."
137 (declare (ignore top-level-p docstring
))
138 (let* ((env (make-local-movitz-environment environment nil
))
139 (body-code (compiler-call #'compile-form
144 :result-mode
:ignore
))
145 ;; (ignmore (format t "~{~S~%~}" body-code))
146 (resolved-code (finalize-code body-code nil nil
))
147 (function-code (ia-x86:read-proglist resolved-code
)))
148 (multiple-value-bind (code-vector symtab
)
149 (let ((ia-x86:*instruction-compute-extra-prefix-map
*
150 '((:call . compute-call-extra-prefix
))))
151 (ia-x86:proglist-encode
:octet-vector
158 (:nil-value
(image-nil-word *image
*))))))
159 (values (make-movitz-vector (length code-vector
)
161 :initial-contents code-vector
)
164 (defun register-function-code-size (funobj)
165 (let* ((name (movitz-print (movitz-funobj-name funobj
)))
167 (new-size (length (movitz-vector-symbolic-data (movitz-funobj-code-vector funobj
)))))
169 (let ((old-size (gethash hash-name
(function-code-sizes *image
*))))
172 ((not *warn-function-change-p
*))
173 ((> new-size old-size
)
174 (warn "~S grew from ~D to ~D bytes." name old-size new-size
))
175 ((< new-size old-size
)
176 (warn "~S shrunk from ~D to ~D bytes" name old-size new-size
))))
177 (setf (gethash hash-name
(function-code-sizes *image
*)) new-size
))
180 (defclass movitz-funobj-pass1
()
183 :accessor movitz-funobj-name
)
185 :initarg
:lambda-list
186 :accessor movitz-funobj-lambda-list
)
188 :accessor function-envs
)
191 :accessor funobj-env
)
195 :accessor movitz-funobj-extent
)
198 :accessor movitz-allocation
)
201 :initarg
:entry-protocol
202 :reader funobj-entry-protocol
))
203 (:documentation
"This class is used for funobjs during the first compiler pass.
204 Before the second pass, such objects will be change-class-ed to proper movitz-funobjs.
205 This way, we ensure that no undue side-effects on the funobj occur during pass 1."))
207 (defmethod print-object ((object movitz-funobj-pass1
) stream
)
208 (print-unreadable-object (object stream
:type t
:identity t
)
209 (when (slot-boundp object
'name
)
210 (write (movitz-funobj-name object
) :stream stream
)))
213 (defun movitz-macro-expander-make-function (lambda-form &key name
(type :unknown
))
214 "Make a lambda-form that is a macro-expander into a proper function.
215 Gensym a name whose symbol-function is set to the macro-expander, and return that symbol."
216 (let ((function-name (gensym (format nil
"~A-expander-~@[~A-~]" type name
))))
217 (if *compiler-compile-macro-expanders
*
218 (with-host-environment ()
219 (compile function-name lambda-form
))
220 (setf (symbol-function function-name
)
221 (coerce lambda-form
'function
)))
224 (defun make-compiled-funobj (name lambda-list declarations form env top-level-p
&key funobj
)
225 "Compiler entry-point for making a (lexically) top-level function."
226 (handler-bind (((or warning error
)
229 (if (not (boundp 'muerte.cl
:*compile-file-pathname
*))
230 (format *error-output
*
231 "~&;; While Movitz compiling ~S:" name
)
232 (format *error-output
*
233 "~&;; While Movitz compiling ~S in ~A:"
234 name muerte.cl
:*compile-file-pathname
*)))))
235 (with-retries-until-true (retry-funobj "Retry compilation of ~S." name
)
236 (make-compiled-funobj-pass2
237 (make-compiled-funobj-pass1 name lambda-list declarations
238 form env top-level-p
:funobj funobj
)))))
240 (defun make-compiled-funobj-pass1 (name lambda-list declarations form env top-level-p
242 "Per funobj (i.e. not necessarily top-level) entry-point for first-pass compilation.
243 If funobj is provided, its identity will be kept, but its type (and values) might change."
244 ;; The ability to provide funobj's identity is important when a
245 ;; function must be referenced before it can be compiled, e.g. for
246 ;; mutually recursive (lexically bound) functions.
247 (with-retries-until-true (retry-pass1 "Retry first-pass compilation of ~S." name
)
248 ;; First-pass is mostly functional, so it can safely be restarted.
249 (multiple-value-bind (required-vars optional-vars rest-var key-vars aux-vars allow-p min max edx-var
)
250 (decode-normal-lambda-list lambda-list
)
251 (declare (ignore aux-vars allow-p min max
))
252 ;; There are several main branches through the function
253 ;; compiler, and this is where we decide which one to take.
255 ((let ((sub-form (cddr form
)))
256 (and (consp (car sub-form
))
257 (eq 'muerte
::numargs-case
(caar sub-form
))))
258 'make-compiled-function-pass1-numarg-case
)
259 ((and (= 1 (length required-vars
)) ; (x &optional y)
260 (= 1 (length optional-vars
))
261 (movitz-constantp (nth-value 1 (decode-optional-formal (first optional-vars
)))
266 'make-compiled-function-pass1-1req1opt
)
267 (t 'make-compiled-function-pass1
))
268 name lambda-list declarations form env top-level-p funobj
))))
270 (defun ensure-pass1-funobj (funobj class
&rest init-args
)
271 "If funobj is nil, return a fresh funobj of class.
272 Otherwise coerce funobj to class."
273 (apply #'reinitialize-instance
275 (change-class funobj class
)
276 (make-instance class
))
279 (defun make-compiled-function-pass1-numarg-case (name lambda-list declarations form env top-level-p funobj
)
280 (let* ((funobj (ensure-pass1-funobj funobj
'movitz-funobj-pass1
281 :entry-protocol
:numargs-case
283 :lambda-list
(movitz-read (lambda-list-simplify lambda-list
))))
284 (funobj-env (make-local-movitz-environment env funobj
:type
'funobj-env
)))
285 (setf (funobj-env funobj
) funobj-env
286 (function-envs funobj
) nil
)
287 (loop for
(numargs lambda-list . clause-body
) in
(cdr (caddr form
))
288 do
(when (duplicatesp lambda-list
)
289 (error "There are duplicates in lambda-list ~S." lambda-list
))
290 (multiple-value-bind (clause-body clause-declarations
)
291 (parse-declarations-and-body clause-body
)
293 (add-bindings-from-lambda-list lambda-list
294 (make-local-movitz-environment
297 :declaration-context
:funobj
299 (append clause-declarations
301 (function-form (list* 'muerte.cl
::block
302 (compute-function-block-name name
)
304 (multiple-value-bind (arg-init-code need-normalized-ecx-p
)
305 (make-function-arguments-init funobj function-env
)
306 (setf (extended-code function-env
)
307 (append arg-init-code
308 (compiler-call #'compile-form
309 :form
(make-special-funarg-shadowing function-env function-form
)
312 :top-level-p top-level-p
313 :result-mode
:function
)))
314 (setf (need-normalized-ecx-p function-env
) need-normalized-ecx-p
))
315 (push (cons numargs function-env
)
316 (function-envs funobj
)))))
319 (defun make-compiled-function-pass1-1req1opt (name lambda-list declarations form env top-level-p funobj
)
321 (when (duplicatesp lambda-list
)
322 (error "There are duplicates in lambda-list ~S." lambda-list
))
323 (let* ((funobj (ensure-pass1-funobj funobj
'movitz-funobj-pass1
324 :entry-protocol
:1req1opt
326 :lambda-list
(movitz-read (lambda-list-simplify lambda-list
))))
327 (funobj-env (make-local-movitz-environment env funobj
:type
'funobj-env
))
328 (function-env (add-bindings-from-lambda-list
330 (make-local-movitz-environment funobj-env funobj
332 :need-normalized-ecx-p nil
333 :declaration-context
:funobj
334 :declarations declarations
)))
335 (optional-env (make-local-movitz-environment function-env funobj
336 :type
'function-env
)))
337 (setf (funobj-env funobj
) funobj-env
)
338 ;; (print-code 'arg-init-code arg-init-code)
339 (setf (extended-code optional-env
)
340 (compiler-call #'compile-form
341 :form
(optional-function-argument-init-form
342 (movitz-binding (first (optional-vars function-env
)) function-env nil
))
346 (setf (extended-code function-env
)
347 (append #+ignore arg-init-code
348 (compiler-call #'compile-form
349 :form
(make-special-funarg-shadowing function-env form
)
352 :top-level-p top-level-p
353 :result-mode
:function
)))
354 (setf (function-envs funobj
)
355 (list (cons 'muerte.cl
::t function-env
)
356 (cons :optional optional-env
)))
359 (defun make-compiled-function-pass1 (name lambda-list declarations form env top-level-p funobj
)
361 (when (duplicatesp lambda-list
)
362 (error "There are duplicates in lambda-list ~S." lambda-list
))
363 (let* ((funobj (ensure-pass1-funobj funobj
'movitz-funobj-pass1
365 :lambda-list
(movitz-read (lambda-list-simplify lambda-list
))))
366 (funobj-env (make-local-movitz-environment env funobj
:type
'funobj-env
))
367 (function-env (add-bindings-from-lambda-list
369 (make-local-movitz-environment funobj-env funobj
371 :declaration-context
:funobj
372 :declarations declarations
))))
373 (setf (funobj-env funobj
) funobj-env
374 (function-envs funobj
) (list (cons 'muerte.cl
::t function-env
)))
375 (multiple-value-bind (arg-init-code need-normalized-ecx-p
)
376 (make-function-arguments-init funobj function-env
)
377 (setf (need-normalized-ecx-p function-env
) need-normalized-ecx-p
)
378 (setf (extended-code function-env
)
379 (append arg-init-code
380 (compiler-call #'compile-form
381 :form
(make-special-funarg-shadowing function-env form
)
384 :top-level-p top-level-p
385 :result-mode
:function
))))
389 (defun make-compiled-funobj-pass2 (toplevel-funobj-pass1)
390 "This is the entry-poing for second pass compilation for each top-level funobj."
391 (check-type toplevel-funobj-pass1 movitz-funobj-pass1
)
392 (let ((toplevel-funobj (change-class toplevel-funobj-pass1
'movitz-funobj
)))
393 (multiple-value-bind (toplevel-funobj function-binding-usage
)
394 (resolve-borrowed-bindings toplevel-funobj
)
398 (resolve-sub-functions toplevel-funobj function-binding-usage
)))))))
400 (defstruct (type-analysis (:type list
))
404 (multiple-value-list (type-specifier-encode nil
)))
405 (declared-encoded-type
406 (multiple-value-list (type-specifier-encode t
))))
408 (defun make-type-analysis-with-declaration (binding)
410 (if (not (and *compiler-trust-user-type-declarations-p
*
411 (movitz-env-get (binding-name binding
) :variable-type
412 nil
(binding-env binding
) nil
)))
413 (multiple-value-list (type-specifier-encode t
))
415 (type-specifier-encode (movitz-env-get (binding-name binding
) :variable-type
416 t
(binding-env binding
) nil
))))))
417 ;; (warn "~S decl: ~A" binding (apply #'encoded-type-decode declared-type))
418 (make-type-analysis :declared-encoded-type declared-type
)))
420 (defun analyze-bindings (toplevel-funobj)
421 "Figure out usage of bindings in a toplevel funobj.
422 Side-effects each binding's binding-store-type."
423 (if (not *compiler-do-type-inference
*)
425 ((analyze-code (code)
426 (dolist (instruction code
)
427 (when (listp instruction
)
429 (find-written-binding-and-type instruction
)))
431 (setf (binding-store-type binding
)
432 (multiple-value-list (type-specifier-encode t
)))))
433 (analyze-code (instruction-sub-program instruction
)))))
434 (analyze-funobj (funobj)
435 (loop for
(nil . function-env
) in
(function-envs funobj
)
436 do
(analyze-code (extended-code function-env
)))
437 (loop for function-binding in
(sub-function-binding-usage funobj
) by
#'cddr
438 do
(analyze-funobj (function-binding-funobj function-binding
)))
440 (analyze-funobj toplevel-funobj
))
441 (let ((binding-usage (make-hash-table :test
'eq
)))
442 (labels ((binding-resolved-p (binding)
443 (or (typep binding
'constant-object-binding
)
444 (typep binding
'function-argument
)
445 (let ((analysis (gethash binding binding-usage
)))
447 (null (type-analysis-thunks analysis
))))))
448 (binding-resolve (binding)
450 ((not (bindingp binding
))
452 ((typep binding
'constant-object-binding
)
453 (apply #'encoded-type-decode
454 (binding-store-type binding
)))
455 ((typep binding
'function-argument
)
457 ((let ((analysis (gethash binding binding-usage
)))
458 (assert (and (and analysis
459 (null (type-analysis-thunks analysis
))))
461 "Can't resolve unresolved binding ~S." binding
)))
462 (*compiler-trust-user-type-declarations-p
*
463 (let ((analysis (gethash binding binding-usage
)))
464 (multiple-value-call #'encoded-type-decode
465 (apply #'encoded-types-and
466 (append (type-analysis-declared-encoded-type analysis
)
467 (type-analysis-encoded-type analysis
))))))
468 (t (let ((analysis (gethash binding binding-usage
)))
469 (apply #'encoded-type-decode
470 (type-analysis-encoded-type analysis
))))))
471 (type-is-t (type-specifier)
472 (or (eq type-specifier t
)
473 (and (listp type-specifier
)
474 (eq 'or
(car type-specifier
))
475 (some #'type-is-t
(cdr type-specifier
)))))
476 (analyze-store (binding type thunk thunk-args
)
477 (assert (not (null type
)) ()
478 "store-lexical with empty type.")
479 (assert (or (typep type
'binding
)
480 (eql 1 (type-specifier-num-values type
))) ()
481 "store-lexical with multiple-valued type: ~S for ~S" type binding
)
482 #+ignore
(warn "store ~S type ~S, thunk ~S" binding type thunk
)
483 (let ((analysis (or (gethash binding binding-usage
)
484 (setf (gethash binding binding-usage
)
485 (make-type-analysis-with-declaration binding
)))))
488 (assert (some #'bindingp thunk-args
))
489 (push (cons thunk thunk-args
) (type-analysis-thunks analysis
)))
490 ((and (bindingp type
)
491 (binding-eql type binding
))
492 (break "got binding type")
494 (t (setf (type-analysis-encoded-type analysis
)
498 (values-list (type-analysis-encoded-type analysis
))
499 (type-specifier-encode type
))))))))
501 #+ignore
(print-code 'analyze code
)
502 (dolist (instruction code
)
503 (when (listp instruction
)
504 (multiple-value-bind (store-binding store-type thunk thunk-args
)
505 (find-written-binding-and-type instruction
)
507 #+ignore
(warn "store: ~S binding ~S type ~S thunk ~S"
508 instruction store-binding store-type thunk
)
509 (analyze-store store-binding store-type thunk thunk-args
)))
510 (analyze-code (instruction-sub-program instruction
)))))
511 (analyze-funobj (funobj)
512 (loop for
(nil . function-env
) in
(function-envs funobj
)
513 do
(analyze-code (extended-code function-env
)))
514 (loop for function-binding in
(sub-function-binding-usage funobj
) by
#'cddr
515 do
(analyze-funobj (function-binding-funobj function-binding
)))
517 ;; 1. Examine each store to lexical bindings.
518 (analyze-funobj toplevel-funobj
)
520 (flet ((resolve-thunks ()
521 (loop with more-thunks-p
= t
524 do
(setf more-thunks-p nil
)
525 (maphash (lambda (binding analysis
)
526 (declare (ignore binding
))
527 (setf (type-analysis-thunks analysis
)
528 (loop for
(thunk . thunk-args
) in
(type-analysis-thunks analysis
)
529 if
(not (every #'binding-resolved-p thunk-args
))
530 collect
(cons thunk thunk-args
)
533 (warn "because ~S=>~S->~S completing ~S: ~S and ~S"
535 (mapcar #'binding-resolve thunk-args
)
537 (type-analysis-declared-encoded-type analysis
)
542 (type-analysis-encoded-type analysis
))
543 (type-specifier-encode
544 (apply thunk
(mapcar #'binding-resolve
546 (setf (type-analysis-encoded-type analysis
)
551 (type-analysis-declared-encoded-type analysis
))
555 (type-analysis-encoded-type analysis
))
556 (type-specifier-encode
557 (apply thunk
(mapcar #'binding-resolve
559 (setf more-thunks-p t
))))
562 (when *compiler-trust-user-type-declarations-p
*
563 ;; For each unresolved binding, just use the declared type.
564 (maphash (lambda (binding analysis
)
565 (declare (ignore binding
))
566 (when (and (not (null (type-analysis-thunks analysis
)))
567 (not (apply #'encoded-allp
568 (type-analysis-declared-encoded-type analysis
))))
570 (warn "Trusting ~S, was ~S, because ~S [~S]"
572 (type-analysis-encoded-type analysis
)
573 (type-analysis-thunks analysis
)
574 (loop for
(thunk . thunk-args
) in
(type-analysis-thunks analysis
)
575 collect
(mapcar #'binding-resolved-p thunk-args
)))
576 (setf (type-analysis-encoded-type analysis
)
577 (type-analysis-declared-encoded-type analysis
))
578 (setf (type-analysis-thunks analysis
) nil
))) ; Ignore remaining thunks.
580 ;; Try one more time to resolve thunks.
583 (maphash (lambda (binding analysis
)
584 (when (type-analysis-thunks analysis
)
585 (warn "Unable to infer type for ~S: ~S" binding
586 (type-analysis-thunks analysis
))))
589 (maphash (lambda (binding analysis
)
590 (setf (binding-store-type binding
)
592 ((and (not (null (type-analysis-thunks analysis
)))
593 *compiler-trust-user-type-declarations-p
*
594 (movitz-env-get (binding-name binding
) :variable-type nil
595 (binding-env binding
) nil
))
597 (type-specifier-encode (movitz-env-get (binding-name binding
) :variable-type
598 t
(binding-env binding
) nil
))))
599 ((and *compiler-trust-user-type-declarations-p
*
600 (movitz-env-get (binding-name binding
) :variable-type nil
601 (binding-env binding
) nil
))
603 (multiple-value-call #'encoded-types-and
604 (type-specifier-encode (movitz-env-get (binding-name binding
) :variable-type
605 t
(binding-env binding
) nil
))
606 (values-list (type-analysis-encoded-type analysis
)))))
607 ((not (null (type-analysis-thunks analysis
)))
608 (multiple-value-list (type-specifier-encode t
)))
609 (t (type-analysis-encoded-type analysis
))))
610 #+ignore
(warn "Finally: ~S" binding
))
614 (defun resolve-borrowed-bindings (toplevel-funobj)
615 "For <funobj>'s code, for every non-local binding used we create
616 a borrowing-binding in the funobj-env. This process must be done
617 recursively, depth-first wrt. sub-functions. Also, return a plist
618 of all function-bindings seen."
619 (check-type toplevel-funobj movitz-funobj
)
620 (let ((function-binding-usage ()))
621 (labels ((process-binding (funobj binding usages
)
623 ((typep binding
'constant-object-binding
))
624 ((not (eq funobj
(binding-funobj binding
)))
625 (let ((borrowing-binding
626 (or (find binding
(borrowed-bindings funobj
)
627 :key
#'borrowed-binding-target
)
628 (car (push (movitz-env-add-binding (funobj-env funobj
)
629 (make-instance 'borrowed-binding
630 :name
(binding-name binding
)
631 :target-binding binding
))
632 (borrowed-bindings funobj
))))))
633 ;; We don't want to borrow a forwarding-binding..
634 (when (typep (borrowed-binding-target borrowing-binding
)
636 (change-class (borrowed-binding-target borrowing-binding
)
638 ;;; (warn "binding ~S of ~S is not local to ~S, replacing with ~S of ~S."
639 ;;; binding (binding-env binding) funobj
640 ;;; borrowing-binding (binding-env borrowing-binding))
641 ;;; (pushnew borrowing-binding
642 ;;; (getf (binding-lended-p binding) :lended-to))
643 (dolist (usage usages
)
644 (pushnew usage
(borrowed-binding-usage borrowing-binding
)))
646 (t ; Binding is local to this funobj
649 (process-binding funobj
(forwarding-binding-target binding
) usages
)
651 (setf (forwarding-binding-target binding
)
652 (process-binding funobj
(forwarding-binding-target binding
) usages
)))
654 (dolist (usage usages
)
656 (getf (sub-function-binding-usage (function-binding-parent binding
))
658 (pushnew usage
(getf function-binding-usage binding
)))
661 (resolve-sub-funobj (funobj sub-funobj
)
662 (dolist (binding-we-lend (borrowed-bindings (resolve-funobj-borrowing sub-funobj
)))
664 (warn "Lending from ~S to ~S: ~S <= ~S"
666 (borrowed-binding-target binding-we-lend
)
668 (process-binding funobj
669 (borrowed-binding-target binding-we-lend
)
670 (borrowed-binding-usage binding-we-lend
))))
671 (resolve-code (funobj code
)
672 (dolist (instruction code
)
673 (when (listp instruction
)
674 (let ((store-binding (find-written-binding-and-type instruction
)))
676 (process-binding funobj store-binding
'(:write
))))
677 (dolist (load-binding (find-read-bindings instruction
))
678 (process-binding funobj load-binding
'(:read
)))
679 (case (car instruction
)
681 (process-binding funobj
(second instruction
) '(:call
)))
683 (destructuring-bind (proto-cons dynamic-scope
)
685 (push proto-cons
(dynamic-extent-scope-members dynamic-scope
))))
687 (destructuring-bind (lambda-binding lambda-result-mode capture-env
)
689 (declare (ignore lambda-result-mode
))
690 (assert (eq funobj
(binding-funobj lambda-binding
)) ()
691 "A non-local lambda doesn't make sense. There must be a bug.")
692 (let ((lambda-funobj (function-binding-funobj lambda-binding
)))
693 (let ((dynamic-scope (find-dynamic-extent-scope capture-env
)))
695 ;; (warn "Adding ~S to ~S/~S" lambda-funobj dynamic-extent dynamic-scope)
696 (setf (movitz-funobj-extent lambda-funobj
) :dynamic-extent
697 (movitz-allocation lambda-funobj
) dynamic-scope
)
698 (push lambda-funobj
(dynamic-extent-scope-members dynamic-scope
))
699 (process-binding funobj
(base-binding dynamic-scope
) '(:read
))))
700 (resolve-sub-funobj funobj lambda-funobj
)
701 (process-binding funobj lambda-binding
'(:read
))
702 ;; This funobj is effectively using every binding that the lambda
704 (map nil
(lambda (borrowed-binding)
705 (process-binding funobj
706 (borrowed-binding-target borrowed-binding
)
708 (borrowed-bindings (function-binding-funobj lambda-binding
))))))
709 (:local-function-init
710 (let ((function-binding (second instruction
)))
711 (assert (eq funobj
(binding-funobj function-binding
)) ()
712 "Initialization of a non-local function doesn't make sense.")
713 (resolve-sub-funobj funobj
(function-binding-funobj (second instruction
)))
714 (map nil
(lambda (borrowed-binding)
715 (process-binding funobj
716 (borrowed-binding-target borrowed-binding
)
718 (borrowed-bindings (function-binding-funobj (second instruction
)))))))
719 (resolve-code funobj
(instruction-sub-program instruction
)))))
720 (resolve-funobj-borrowing (funobj)
721 (let ((funobj (change-class funobj
'movitz-funobj
:borrowed-bindings nil
)))
722 (loop for
(nil . function-env
) in
(function-envs funobj
)
723 do
(resolve-code funobj
(extended-code function-env
)))
724 ;; (warn "~S borrows ~S." funobj (borrowed-bindings funobj))
726 (values (resolve-funobj-borrowing toplevel-funobj
)
727 function-binding-usage
))))
729 (defun resolve-sub-functions (toplevel-funobj function-binding-usage
)
730 (assert (null (borrowed-bindings toplevel-funobj
)) ()
731 "Can't deal with toplevel closures yet. Borrowed: ~S"
732 (borrowed-bindings toplevel-funobj
))
733 (setf (movitz-funobj-extent toplevel-funobj
) :indefinite-extent
)
734 (let ((sub-funobj-index 0))
735 (loop for
(function-binding usage
) on function-binding-usage by
#'cddr
736 do
(let ((sub-funobj (function-binding-funobj function-binding
)))
737 ;; (warn "USage: ~S => ~S" sub-funobj usage)
738 (case (car (movitz-funobj-name sub-funobj
))
740 (setf (movitz-funobj-name sub-funobj
)
741 (list 'muerte.cl
:lambda
742 (movitz-funobj-name toplevel-funobj
)
743 (post-incf sub-funobj-index
)))))
744 (loop for borrowed-binding in
(borrowed-bindings sub-funobj
)
745 do
(pushnew borrowed-binding
746 (getf (binding-lending (borrowed-binding-target borrowed-binding
))
748 ;; (warn "old extent: ~S" (movitz-funobj-extent sub-funobj))
751 (null (borrowed-bindings sub-funobj
)))
753 (warn "null usage for ~S" sub-funobj
))
754 (change-class function-binding
'funobj-binding
)
755 (setf (movitz-funobj-extent sub-funobj
)
757 ((equal usage
'(:call
))
758 (change-class function-binding
'closure-binding
)
759 (setf (movitz-funobj-extent sub-funobj
)
761 ((eq :dynamic-extent
(movitz-funobj-extent sub-funobj
))
762 (change-class function-binding
'closure-binding
))
763 (t (change-class function-binding
'closure-binding
)
764 (setf (movitz-funobj-extent sub-funobj
)
765 :indefinite-extent
))))))
766 (loop for function-binding in function-binding-usage by
#'cddr
767 do
(finalize-funobj (function-binding-funobj function-binding
)))
768 (finalize-funobj toplevel-funobj
))
770 (defun finalize-funobj (funobj)
771 "Calculate funobj's constants, jumpers."
772 (loop with all-key-args-constants
= nil
773 with all-constants-plist
= () and all-jumper-sets
= ()
774 for
(nil . function-env
) in
(function-envs funobj
)
775 ;; (borrowed-bindings body-code) in code-specs
776 as body-code
= (extended-code function-env
)
777 as
(const-plist jumper-sets key-args-constants
) =
778 (multiple-value-list (find-code-constants-and-jumpers body-code
))
779 do
(when key-args-constants
780 (assert (not all-key-args-constants
) ()
781 "only one &key parsing allowed per funobj.")
782 (setf all-key-args-constants key-args-constants
))
783 (loop for
(constant usage
) on const-plist by
#'cddr
784 do
(incf (getf all-constants-plist constant
0) usage
))
785 (loop for
(name set
) on jumper-sets by
#'cddr
786 do
(assert (not (getf all-jumper-sets name
)) ()
787 "Jumper-set ~S multiply defined." name
)
788 (setf (getf all-jumper-sets name
) set
))
790 (multiple-value-bind (const-list num-jumpers jumpers-map borrower-map
)
791 (layout-funobj-vector all-constants-plist
792 all-key-args-constants
793 #+ignore
(mapcar (lambda (x)
794 (cons (movitz-read x
) 1))
797 (borrowed-bindings funobj
))
798 (setf (movitz-funobj-num-jumpers funobj
) num-jumpers
799 (movitz-funobj-const-list funobj
) const-list
800 (movitz-funobj-num-constants funobj
) (length const-list
)
801 (movitz-funobj-jumpers-map funobj
) jumpers-map
)
802 (loop for
(binding . pos
) in borrower-map
803 do
(setf (borrowed-binding-reference-slot binding
) pos
))
806 (defun layout-stack-frames (funobj)
807 "Lay out the stack-frame (i.e. create a frame-map) for funobj
808 and all its local functions. This must be done breadth-first, because
809 a (lexical-extent) sub-function might care about its parent frame-map."
810 (loop for
(nil . function-env
) in
(function-envs funobj
)
811 do
(assert (not (slot-boundp function-env
'frame-map
)))
812 (setf (frame-map function-env
)
813 (funobj-assign-bindings (extended-code function-env
)
815 (loop for
(sub-function-binding) on
(sub-function-binding-usage funobj
) by
#'cddr
816 do
(layout-stack-frames (function-binding-funobj sub-function-binding
)))
819 (defun complete-funobj (funobj)
820 (case (funobj-entry-protocol funobj
)
822 (complete-funobj-1req1opt funobj
))
823 (t (complete-funobj-default funobj
)))
824 (loop for
(sub-function-binding) on
(sub-function-binding-usage funobj
) by
#'cddr
825 do
(complete-funobj (function-binding-funobj sub-function-binding
)))
826 (register-function-code-size funobj
))
828 (defun complete-funobj-1req1opt (funobj)
829 (assert (= 2 (length (function-envs funobj
))))
830 (let* ((function-env (cdr (assoc 'muerte.cl
::t
(function-envs funobj
))))
831 (optional-env (cdr (assoc :optional
(function-envs funobj
))))
832 (frame-map (frame-map function-env
))
833 (resolved-code (finalize-code (extended-code function-env
) funobj frame-map
))
834 (resolved-optional-code (finalize-code (extended-code optional-env
) funobj frame-map
))
835 (stack-frame-size (frame-map-size (frame-map function-env
)))
836 (use-stack-frame-p (or (plusp stack-frame-size
)
837 (tree-search resolved-code
838 '(:pushl
:popl
:ebp
:esp
:call
:leave
))
840 (and (not (equal '(:movl
(:ebp -
4) :esi
) x
))
841 (tree-search x
':esi
)))
843 (let* ((function-code
844 (let* ((req-binding (movitz-binding (first (required-vars function-env
))
846 (req-location (cdr (assoc req-binding frame-map
)))
847 (opt-binding (movitz-binding (first (optional-vars function-env
))
849 (opt-location (cdr (assoc opt-binding frame-map
)))
850 (optp-binding (movitz-binding (optional-function-argument-supplied-p-var opt-binding
)
852 (optp-location (cdr (assoc optp-binding frame-map
)))
854 (append `((:jmp
(:edi
,(global-constant-offset 'trampoline-cl-dispatch-1or2
))))
856 (unless (eql nil opt-location
)
857 resolved-optional-code
)
860 (:jmp
'optp-into-edx-ok
)))
863 `((,*compiler-global-segment-prefix
*
864 :movl
(:edi
,(global-constant-offset 't-symbol
)) :edx
)
866 (when use-stack-frame-p
867 +enter-stack-frame-code
+)
868 '(start-stack-frame-setup)
870 ((and (eql 1 req-location
)
871 (eql 2 opt-location
))
872 (incf stack-setup-pre
2)
875 ((and (eql 1 req-location
)
876 (eql nil opt-location
))
877 (incf stack-setup-pre
1)
879 ((and (member req-location
'(nil :eax
))
880 (eql 1 opt-location
))
881 (incf stack-setup-pre
1)
883 ((and (member req-location
'(nil :eax
))
884 (member opt-location
'(nil :ebx
)))
886 (t (error "Can't deal with req ~S opt ~S."
887 req-location opt-location
)))
890 (make-stack-setup-code (- stack-frame-size stack-setup-pre
)))
891 ((and (integerp optp-location
)
892 (= optp-location
(1+ stack-setup-pre
)))
893 (append `((:pushl
:edx
))
894 (make-stack-setup-code (- stack-frame-size stack-setup-pre
1))))
895 ((integerp optp-location
)
896 (append (make-stack-setup-code (- stack-frame-size stack-setup-pre
))
897 `((:movl
:edx
(:ebp
,(stack-frame-offset optp-location
))))))
898 (t (error "Can't deal with optional-p at ~S, after (~S ~S)."
899 optp-location req-location opt-location
)))
900 (flet ((make-lending (location lended-cons-position
)
901 (etypecase req-location
903 `((:movl
(:ebp
,(stack-frame-offset location
)) :edx
)
904 (:movl
:edi
(:ebp
,(stack-frame-offset lended-cons-position
))) ; cdr
905 (:movl
:edx
(:ebp
,(stack-frame-offset (1+ lended-cons-position
)))) ; car
906 (:leal
(:ebp
1 ,(stack-frame-offset (1+ lended-cons-position
)))
908 (:movl
:edx
(:ebp
,(stack-frame-offset location
))))))))
910 (when (binding-lended-p req-binding
)
911 (make-lending req-location
(getf (binding-lending req-binding
)
912 :stack-cons-location
)))
913 (when (binding-lended-p opt-binding
)
914 (make-lending opt-location
(getf (binding-lending opt-binding
)
915 :stack-cons-location
)))
916 (when (and optp-binding
(binding-lended-p optp-binding
))
917 (make-lending optp-location
(getf (binding-lending optp-binding
)
918 :stack-cons-location
)))))
920 (make-compiled-function-postlude funobj function-env
921 use-stack-frame-p
)))))
922 (let ((optimized-function-code
923 (optimize-code function-code
924 :keep-labels
(append (subseq (movitz-funobj-const-list funobj
)
925 0 (movitz-funobj-num-jumpers funobj
))
926 '(entry%
1op entry%
2op
)))))
927 (assemble-funobj funobj optimized-function-code
)))))
929 (defun complete-funobj-default (funobj)
931 (loop for
(numargs . function-env
) in
(function-envs funobj
)
933 (let* ((frame-map (frame-map function-env
))
934 (resolved-code (finalize-code (extended-code function-env
) funobj frame-map
))
935 (stack-frame-size (frame-map-size (frame-map function-env
)))
936 (use-stack-frame-p (or (plusp stack-frame-size
)
937 (tree-search resolved-code
938 '(:push
:pop
:ebp
:esp
:call
:leave
))
940 (and (not (equal '(:movl
(:ebp -
4) :esi
) x
))
941 (tree-search x
':esi
)))
943 (multiple-value-bind (prelude-code have-normalized-ecx-p
)
944 (make-compiled-function-prelude stack-frame-size function-env use-stack-frame-p
945 (need-normalized-ecx-p function-env
) frame-map
946 :do-check-stack-p
(or (<= 32 stack-frame-size
)
947 (tree-search resolved-code
950 (install-arg-cmp (append prelude-code
952 (make-compiled-function-postlude funobj function-env
954 have-normalized-ecx-p
)))
955 (let ((optimized-function-code
956 (optimize-code function-code
958 (subseq (movitz-funobj-const-list funobj
)
959 0 (movitz-funobj-num-jumpers funobj
))
963 (cons numargs optimized-function-code
))))))))
964 (let ((code1 (cdr (assoc 1 code-specs
)))
965 (code2 (cdr (assoc 2 code-specs
)))
966 (code3 (cdr (assoc 3 code-specs
)))
967 (codet (cdr (assoc 'muerte.cl
::t code-specs
))))
968 (assert codet
() "A default numargs-case is required.")
969 ;; (format t "codet:~{~&~A~}" codet)
971 (delete 'start-stack-frame-setup
976 ,@(unless (find 'entry%
1op code1
)
977 '(entry%
1op
(:movb
1 :cl
)))
983 ,@(unless (find 'entry%
2op code2
)
984 '(entry%
2op
(:movb
2 :cl
)))
989 (:jne
'not-three-args
)
990 ,@(unless (find 'entry%
3op code3
)
991 '(entry%
3op
(:movb
3 :cl
)))
994 (delete-if (lambda (x)
995 (or (and code1
(eq x
'entry%
1op
))
996 (and code2
(eq x
'entry%
2op
))
997 (and code3
(eq x
'entry%
3op
))))
999 ;; (print-code funobj combined-code)
1000 (assemble-funobj funobj combined-code
))))
1004 (defun assemble-funobj (funobj combined-code
)
1005 (multiple-value-bind (code-vector code-symtab
)
1006 (let ((ia-x86:*instruction-compute-extra-prefix-map
*
1007 '((:call . compute-call-extra-prefix
))))
1008 (ia-x86:proglist-encode
:octet-vector
:32-bit
#x00000000
1009 (ia-x86:read-proglist combined-code
)
1013 (:nil-value
(image-nil-word *image
*))
1014 (t (let ((set (cdr (assoc label
1015 (movitz-funobj-jumpers-map funobj
)))))
1017 (let ((pos (search set
(movitz-funobj-const-list funobj
)
1018 :end2
(movitz-funobj-num-jumpers funobj
))))
1020 "Couldn't find for ~s set ~S in ~S."
1021 label set
(subseq (movitz-funobj-const-list funobj
)
1022 0 (movitz-funobj-num-jumpers funobj
)))
1024 (setf (movitz-funobj-symtab funobj
) code-symtab
)
1025 (let ((code-length (- (length code-vector
) 3 -
3)))
1026 (setf (fill-pointer code-vector
) code-length
)
1028 (setf (ldb (byte 1 5) (slot-value funobj
'debug-info
))
1029 1 #+ignore
(if use-stack-frame-p
1 0))
1030 (let ((x (cdr (assoc 'start-stack-frame-setup code-symtab
))))
1033 #+ignore
(warn "No start-stack-frame-setup label for ~S." name
))
1035 (setf (ldb (byte 5 0) (slot-value funobj
'debug-info
)) x
))
1036 (t (warn "Can't encode start-stack-frame-setup label ~D into debug-info for ~S."
1037 x
(movitz-funobj-name funobj
)))))
1038 (let* ((a (or (cdr (assoc 'entry%
1op code-symtab
)) 0))
1039 (b (or (cdr (assoc 'entry%
2op code-symtab
)) a
))
1040 (c (or (cdr (assoc 'entry%
3op code-symtab
)) b
)))
1042 (warn "Weird code-entries: ~D, ~D, ~D." a b c
))
1043 (unless (<= 0 a
255)
1044 (break "entry%1: ~D" a
))
1045 (unless (<= 0 b
2047)
1046 (break "entry%2: ~D" b
))
1047 (unless (<= 0 c
4095)
1048 (break "entry%3: ~D" c
)))
1049 (loop for
((entry-label slot-name
)) on
'((entry%
1op code-vector%
1op
)
1050 (entry%
2op code-vector%
2op
)
1051 (entry%
3op code-vector%
3op
))
1053 ((assoc entry-label code-symtab
)
1054 (let ((offset (cdr (assoc entry-label code-symtab
))))
1055 (setf (slot-value funobj slot-name
)
1056 (cons offset funobj
))
1057 #+ignore
(when (< offset
#x100
)
1058 (vector-push offset code-vector
))))
1060 ((some (lambda (label) (assoc label code-symtab
))
1061 (mapcar #'car rest
))
1062 (vector-push 0 code-vector
))))
1063 (check-locate-concistency code-vector
)
1064 (setf (movitz-funobj-code-vector funobj
)
1065 (make-movitz-vector (length code-vector
)
1066 :fill-pointer code-length
1068 :initial-contents code-vector
))))
1071 (defun check-locate-concistency (code-vector)
1072 (loop for x from
0 below
(length code-vector
) by
8
1073 do
(when (and (= (tag :basic-vector
) (aref code-vector x
))
1074 (= (enum-value 'movitz-vector-element-type
:code
) (aref code-vector
(1+ x
)))
1075 (or (<= #x4000
(length code-vector
))
1076 (and (= (ldb (byte 8 0) (length code-vector
))
1077 (aref code-vector
(+ x
2)))
1078 (= (ldb (byte 8 8) (length code-vector
))
1079 (aref code-vector
(+ x
3))))))
1080 (break "Code-vector (length #x~X) can break %find-code-vector at ~D: #x~2,'0X~2,'0X ~2,'0X~2,'0X."
1081 (length code-vector
) x
1082 (aref code-vector
(+ x
0))
1083 (aref code-vector
(+ x
1))
1084 (aref code-vector
(+ x
2))
1085 (aref code-vector
(+ x
3)))))
1089 (defun make-compiled-function-body-default (form funobj env top-level-p
)
1090 (make-compiled-body-pass2 (make-compiled-function-pass1 form funobj env top-level-p
)
1094 (defun old-make-compiled-function-body-default (form funobj env top-level-p
&key include-programs
)
1095 (multiple-value-bind (arg-init-code body-form need-normalized-ecx-p
)
1096 (make-function-arguments-init funobj env form
)
1097 (multiple-value-bind (resolved-code stack-frame-size use-stack-frame-p frame-map
)
1098 (make-compiled-body body-form funobj env top-level-p arg-init-code include-programs
)
1099 (multiple-value-bind (prelude-code have-normalized-ecx-p
)
1100 (make-compiled-function-prelude stack-frame-size env use-stack-frame-p
1101 need-normalized-ecx-p frame-map
)
1102 (values (install-arg-cmp (append prelude-code
1104 (make-compiled-function-postlude funobj env use-stack-frame-p
))
1105 have-normalized-ecx-p
)
1106 use-stack-frame-p
)))))
1109 (defun make-compiled-function-body-without-prelude (form funobj env top-level-p
)
1110 (multiple-value-bind (code stack-frame-size use-stack-frame-p
)
1111 (make-compiled-body form funobj env top-level-p
)
1112 (if (not use-stack-frame-p
)
1113 (append code
(make-compiled-function-postlude funobj env nil
))
1114 (values (append `((:pushl
:ebp
)
1117 start-stack-frame-setup
)
1118 (case stack-frame-size
1120 (1 '((:pushl
:edi
)))
1121 (2 '((:pushl
:edi
) (:pushl
:edi
)))
1122 (t `((:subl
,(* 4 stack-frame-size
) :esp
))))
1123 (when (tree-search code
'(:ecx
))
1125 (:js
'(:sub-program
(normalize-ecx)
1127 (:jmp
'normalize-ecx-ok
)))
1131 (make-compiled-function-postlude funobj env t
))
1132 use-stack-frame-p
))))
1135 (defun make-compiled-function-body-2req-1opt (form funobj env top-level-p
)
1136 (when (and (= 2 (length (required-vars env
)))
1137 (= 1 (length (optional-vars env
)))
1138 (= 0 (length (key-vars env
)))
1139 (null (rest-var env
)))
1140 (let* ((opt-var (first (optional-vars env
)))
1141 (opt-binding (movitz-binding opt-var env nil
))
1142 (req1-binding (movitz-binding (first (required-vars env
)) env nil
))
1143 (req2-binding (movitz-binding (second (required-vars env
)) env nil
))
1144 (default-form (optional-function-argument-init-form opt-binding
)))
1145 (compiler-values-bind (&code push-default-code-uninstalled
&producer default-code-producer
)
1146 (compiler-call #'compile-form
1152 ((eq 'compile-self-evaluating default-code-producer
)
1153 (multiple-value-bind (code stack-frame-size use-stack-frame-p frame-map
)
1154 (make-compiled-body form funobj env top-level-p nil
(list push-default-code-uninstalled
))
1155 (when (and (new-binding-located-p req1-binding frame-map
)
1156 (new-binding-located-p req2-binding frame-map
)
1157 (new-binding-located-p opt-binding frame-map
))
1158 (multiple-value-bind (eax-ebx-code eax-ebx-stack-offset
)
1159 (make-2req req1-binding req2-binding frame-map
)
1160 (let ((stack-init-size (- stack-frame-size eax-ebx-stack-offset
))
1162 (finalize-code push-default-code-uninstalled funobj env frame-map
)))
1163 (values (append `((:jmp
'(:sub-program
()
1173 start-stack-frame-setup
1174 ,@(when (and (edx-var env
) (new-binding-located-p (edx-var env
) frame-map
))
1175 `((:movl
:edx
(:ebp
,(stack-frame-offset
1176 (new-binding-location (edx-var env
) frame-map
))))))
1178 ,@(if (eql (1+ eax-ebx-stack-offset
)
1179 (new-binding-location opt-binding frame-map
))
1180 (append `((:pushl
(:ebp
,(argument-stack-offset-shortcut 3 2))))
1181 (make-compiled-stack-frame-init (1- stack-init-size
)))
1182 (append (make-compiled-stack-frame-init stack-init-size
)
1183 `((:movl
(:ebp
,(argument-stack-offset-shortcut 3 2)) :edx
)
1184 (:movl
:edx
(:ebp
,(stack-frame-offset
1185 (new-binding-location opt-binding
1187 (:jmp
'arg-init-done
)
1193 ,@(if (eql (1+ eax-ebx-stack-offset
)
1194 (new-binding-location opt-binding frame-map
))
1195 (append push-default-code
1196 (make-compiled-stack-frame-init (1- stack-init-size
)))
1197 (append (make-compiled-stack-frame-init stack-init-size
)
1199 `((:popl
(:ebp
,(stack-frame-offset (new-binding-location opt-binding frame-map
)))))))
1202 (make-compiled-function-postlude funobj env t
))
1203 use-stack-frame-p
))))))
1206 (defun make-2req (binding0 binding1 frame-map
)
1207 (let ((location-0 (new-binding-location binding0 frame-map
))
1208 (location-1 (new-binding-location binding1 frame-map
)))
1210 ((and (eq :eax location-0
)
1211 (eq :ebx location-1
))
1213 ((and (eq :ebx location-0
)
1214 (eq :eax location-1
))
1215 (values '((:xchgl
:eax
:ebx
)) 0))
1216 ((and (eql 1 location-0
)
1218 (values '((:pushl
:eax
)
1221 ((and (eq :eax location-0
)
1223 (values '((:pushl
:ebx
))
1225 (t (error "make-2req confused by loc0: ~W, loc1: ~W" location-0 location-1
)))))
1228 (defun movitz-compile-file (path &key
((:image
*image
*) *image
*)
1230 (delete-file-p nil
))
1232 (#+sbcl
(sb-ext:defconstant-uneql
#'continue
))
1234 (let ((*movitz-host-features
* *features
*)
1235 (*features
* (image-movitz-features *image
*)))
1236 (multiple-value-prog1
1237 (movitz-compile-file-internal path load-priority
)
1238 (unless (equalp *features
* (image-movitz-features *image
*))
1239 (warn "*features* changed from ~S to ~S." (image-movitz-features *image
*) *features
*)
1240 (setf (image-movitz-features *image
*) *features
*))))
1242 (assert (equal (pathname-directory "/tmp/")
1243 (pathname-directory path
))
1245 "Refusing to delete file not in /tmp.")
1246 (delete-file path
)))))
1248 (defun movitz-compile-file-internal (path &optional
(*default-load-priority
*
1249 (and (boundp '*default-load-priority
*)
1250 (symbol-value '*default-load-priority
*)
1251 (1+ (symbol-value '*default-load-priority
*)))))
1252 (declare (special *default-load-priority
*))
1253 (with-simple-restart (continue "Skip Movitz compilation of ~S." path
)
1254 (with-retries-until-true (retry "Restart Movitz compilation of ~S." path
)
1255 (with-open-file (stream path
:direction
:input
)
1256 (let ((*package
* (find-package :muerte
)))
1257 (movitz-compile-stream-internal stream
:path path
))))))
1259 (defun movitz-compile-stream (stream &key
(path "unknown-toplevel.lisp") (package :muerte
))
1261 (#+sbcl
(sb-ext:defconstant-uneql
#'continue
))
1263 (let ((*package
* (find-package package
))
1264 (*movitz-host-features
* *features
*)
1265 (*features
* (image-movitz-features *image
*)))
1266 (multiple-value-prog1
1267 (movitz-compile-stream-internal stream
:path path
)
1268 (unless (equalp *features
* (image-movitz-features *image
*))
1269 (warn "*features* changed from ~S to ~S." (image-movitz-features *image
*) *features
*)
1270 (setf (image-movitz-features *image
*) *features
*)))))))
1272 (defun movitz-compile-stream-internal (stream &key
(path "unknown-toplevel.lisp"))
1273 (let* ((muerte.cl
::*compile-file-pathname
* path
)
1274 (funobj (make-instance 'movitz-funobj-pass1
1275 :name
(intern (format nil
"~A" path
) :muerte
)
1276 :lambda-list
(movitz-read nil
)))
1277 (funobj-env (make-local-movitz-environment nil funobj
1279 :declaration-context
:funobj
))
1280 (function-env (make-local-movitz-environment funobj-env funobj
1282 :declaration-context
:funobj
))
1284 (with-compilation-unit ()
1285 (add-bindings-from-lambda-list () function-env
)
1286 (setf (funobj-env funobj
) funobj-env
)
1287 (loop for form
= (with-movitz-syntax ()
1288 (read stream nil
'#0=#:eof
))
1289 until
(eq form
'#0#)
1291 (with-simple-restart (skip-toplevel-form
1292 "Skip the compilation of top-level form~{ ~A~}."
1296 ((symbolp (car form
))
1299 (when *compiler-verbose-p
*
1300 (format *query-io
* "~&Movitz Compiling ~S..~%"
1302 ((symbolp form
) form
)
1303 ((symbolp (car form
))
1304 (xsubseq form
0 2)))))
1305 (compiler-call #'compile-form
1310 :result-mode
:ignore
))))))
1313 (setf (image-load-time-funobjs *image
*)
1314 (delete funobj
(image-load-time-funobjs *image
*) :key
#'first
))
1315 'muerte
::constantly-true
)
1316 (t (setf (extended-code function-env
) file-code
1317 (need-normalized-ecx-p function-env
) nil
1318 (function-envs funobj
) (list (cons 'muerte.cl
::t function-env
))
1319 (funobj-env funobj
) funobj-env
)
1320 (make-compiled-funobj-pass2 funobj
)
1321 (let ((name (funobj-name funobj
)))
1322 (setf (movitz-env-named-function name
) funobj
)
1327 (defun print-code (x code
)
1328 (let ((*print-level
* 4))
1329 (format t
"~&~A code:~{~& ~A~}" x code
))
1332 (defun layout-program (pc)
1333 "For the program in pc, layout sub-programs at the top-level program."
1334 (do ((previous-subs nil
)
1338 (assert (not pending-subs
) ()
1339 "pending sub-programs: ~S" pending-subs
)
1340 (nreverse new-program
))
1342 (multiple-value-bind (sub-prg sub-opts
)
1343 (instruction-sub-program i
)
1345 (push i new-program
)
1346 (destructuring-bind (&optional
(label (gensym "sub-prg-label-")))
1348 (let ((x (cons label sub-prg
)))
1349 (unless (find x previous-subs
:test
#'equal
)
1350 (push x pending-subs
)
1351 (push x previous-subs
)))
1352 (unless (instruction-is i
:jnever
)
1353 (push `(,(car i
) ',label
)
1355 (when (or (instruction-uncontinues-p i
)
1357 (let* ((match-label (and (eq (car i
) :jmp
)
1359 (eq (car (second i
)) 'quote
)
1360 (symbolp (second (second i
)))
1361 (second (second i
))))
1362 (matching-sub (assoc match-label pending-subs
)))
1363 (unless (and match-label
1364 (or (eq match-label
(first pc
))
1365 (and (symbolp (first pc
))
1366 (eq match-label
(second pc
)))))
1368 (setf pc
(append (cdr matching-sub
) pc
)
1369 pending-subs
(delete matching-sub pending-subs
))
1370 (setf pc
(append (reduce #'append
(nreverse pending-subs
)) pc
)
1371 pending-subs nil
)))))))))
1374 (defun optimize-code (unoptimized-code &rest args
)
1375 #+ignore
(print-code 'to-optimize unoptimized-code
)
1376 (if (not *compiler-do-optimize
*)
1377 (layout-program (optimize-code-unfold-branches unoptimized-code
))
1378 (apply #'optimize-code-internal
1379 (optimize-code-dirties
1380 (layout-program (optimize-code-unfold-branches unoptimized-code
)))
1383 (defun optimize-code-unfold-branches (unoptimized-code)
1384 "This particular optimization should be done before code layout:
1385 (:jcc 'label) (:jmp 'foo) label => (:jncc 'foo) label"
1386 (flet ((explain (always format
&rest args
)
1387 (when (or always
*explain-peephole-optimizations
*)
1388 (warn "Peephole: ~?~&----------------------------" format args
)))
1389 (branch-instruction-label (i &optional jmp
(branch-types '(:je
:jne
:jb
:jnb
:jbe
:jz
1390 :jl
:jnz
:jle
:ja
:jae
:jg
1391 :jge
:jnc
:jc
:js
:jns
)))
1392 "If i is a branch, return the label."
1393 (when jmp
(push :jmp branch-types
))
1394 (let ((i (ignore-instruction-prefixes i
)))
1395 (or (and (listp i
) (member (car i
) branch-types
)
1396 (listp (second i
)) (member (car (second i
)) '(quote muerte.cl
::quote
))
1397 (second (second i
))))))
1398 (negate-branch (branch-type)
1400 (:jb
:jnb
) (:jnb
:jb
)
1401 (:jbe
:ja
) (:ja
:jbe
)
1402 (:jz
:jnz
) (:jnz
:jz
)
1403 (:je
:jne
) (:jne
:je
)
1404 (:jc
:jnc
) (:jnc
:jc
)
1405 (:jl
:jge
) (:jge
:jl
)
1406 (:jle
:jg
) (:jg
:jle
))))
1407 (loop with next-pc
= 'auto-next
1408 ;; initially (warn "opt: ~{ ~A~%~}" unoptimized-code)
1409 for pc
= unoptimized-code then
(prog1 (if (eq 'auto-next next-pc
) auto-next-pc next-pc
)
1410 (setq next-pc
'auto-next
))
1411 as auto-next-pc
= (cdr unoptimized-code
) then
(cdr pc
)
1412 as p
= (list (car pc
)) ; will be appended.
1413 as i1
= (first pc
) ; current instruction, collected by default.
1414 and i2
= (second pc
) and i3
= (third pc
)
1416 do
(when (and (branch-instruction-label i1
)
1417 (branch-instruction-label i2 t nil
)
1419 (eq i3
(branch-instruction-label i1
)))
1420 (setf p
(list `(,(negate-branch (car i1
)) ',(branch-instruction-label i2 t nil
))
1422 next-pc
(nthcdr 3 pc
))
1423 (explain nil
"Got a sit: ~{~&~A~} => ~{~&~A~}" (subseq pc
0 3) p
))
1426 (defun optimize-code-dirties (unoptimized-code)
1427 "These optimizations may rearrange register usage in a way that is incompatible
1428 with other optimizations that track register usage. So this is performed just once,
1432 (labels ; This stuff doesn't work..
1433 ((explain (always format
&rest args
)
1434 (when (or always
*explain-peephole-optimizations
*)
1435 (warn "Peephole: ~?~&----------------------------" format args
)))
1436 (twop-p (c &optional op
)
1437 (let ((c (ignore-instruction-prefixes c
)))
1438 (and (listp c
) (= 3 (length c
))
1439 (or (not op
) (eq op
(first c
)))
1441 (twop-dst (c &optional op src
)
1442 (let ((c (ignore-instruction-prefixes c
)))
1444 (equal src
(first (twop-p c op
))))
1445 (second (twop-p c op
)))))
1446 (twop-src (c &optional op dest
)
1447 (let ((c (ignore-instruction-prefixes c
)))
1449 (equal dest
(second (twop-p c op
))))
1450 (first (twop-p c op
)))))
1451 (register-operand (op)
1452 (and (member op
'(:eax
:ebx
:ecx
:edx
:edi
))
1454 (loop with next-pc
= 'auto-next
1455 ;; initially (warn "opt: ~{ ~A~%~}" unoptimized-code)
1456 for pc
= unoptimized-code then
(prog1 (if (eq 'auto-next next-pc
) auto-next-pc next-pc
)
1457 (setq next-pc
'auto-next
))
1458 as auto-next-pc
= (cdr unoptimized-code
) then
(cdr pc
)
1459 as p
= (list (car pc
)) ; will be appended.
1460 as i1
= (first pc
) ; current instruction, collected by default.
1461 and i2
= (second pc
) and i3
= (third pc
)
1463 do
(let ((regx (register-operand (twop-src i1
:movl
)))
1464 (regy (register-operand (twop-dst i1
:movl
))))
1465 (when (and regx regy
1466 (eq regx
(twop-dst i2
:movl
))
1467 (eq regx
(twop-src i3
:cmpl
))
1468 (eq regy
(twop-dst i3
:cmpl
)))
1469 (setq p
(list `(:cmpl
,(twop-src i2
) ,regx
) i1
)
1470 next-pc
(nthcdr 3 pc
))
1471 (explain t
"4: ~S for ~S [regx ~S, regy ~S]" p
(subseq pc
0 5) regx regy
)))
1474 (defun xsubseq (sequence start end
)
1475 (subseq sequence start
(min (length sequence
) end
)))
1477 (defun optimize-code-internal (unoptimized-code recursive-count
&rest key-args
1478 &key keep-labels stack-frame-size
)
1479 "Peephole optimizer. Based on a lot of rather random heuristics."
1480 (declare (ignore stack-frame-size
))
1481 (when (<= 20 recursive-count
)
1482 (error "Peephole-optimizer recursive count reached ~D.
1483 There is (propably) a bug in the peephole optimizer." recursive-count
))
1484 ;; (warn "==================OPTIMIZE: ~{~&~A~}" unoptimized-code)
1485 (macrolet ((explain (always format
&rest args
)
1486 `(when (or *explain-peephole-optimizations
* ,always
)
1487 (warn "Peephole: ~@?~&----------------------------" ,format
,@args
))))
1490 (explain (always format
&rest args
)
1491 (when (or always
*explain-peephole-optimizations
*)
1492 (warn "Peephole: ~?~&----------------------------" format args
)))
1493 (twop-p (c &optional op
)
1494 (let ((c (ignore-instruction-prefixes c
)))
1495 (and (listp c
) (= 3 (length c
))
1496 (or (not op
) (eq op
(first c
)))
1498 (twop-dst (c &optional op src
)
1499 (let ((c (ignore-instruction-prefixes c
)))
1501 (equal src
(first (twop-p c op
))))
1502 (second (twop-p c op
)))))
1503 (twop-src (c &optional op dest
)
1504 (let ((c (ignore-instruction-prefixes c
)))
1506 (equal dest
(second (twop-p c op
))))
1507 (first (twop-p c op
)))))
1509 (let ((c (ignore-instruction-prefixes c
)))
1510 (ecase (length (cdr c
))
1515 (let ((c (ignore-instruction-prefixes c
)))
1516 (ecase (length (cdr c
))
1520 (non-destructive-p (c)
1521 (let ((c (ignore-instruction-prefixes c
)))
1523 (member (car c
) '(:testl
:testb
:cmpl
:cmpb
:frame-map
:std
)))))
1524 (simple-instruction-p (c)
1525 (let ((c (ignore-instruction-prefixes c
)))
1528 '(:movl
:xorl
:popl
:pushl
:cmpl
:leal
:andl
:addl
:subl
)))))
1529 (register-indirect-operand (op base
)
1530 (multiple-value-bind (reg off
)
1533 if
(integerp x
) sum x into off
1534 else collect x into reg
1535 finally
(return (values reg off
))))
1536 (and (eq base
(car reg
))
1539 (stack-frame-operand (op)
1540 (register-indirect-operand op
:ebp
))
1541 (funobj-constant-operand (op)
1542 (register-indirect-operand op
:esi
))
1543 (global-constant-operand (op)
1544 (register-indirect-operand op
:edi
))
1545 (global-funcall-p (op &optional funs
)
1546 (let ((op (ignore-instruction-prefixes op
)))
1547 (when (instruction-is op
:call
)
1548 (let ((x (global-constant-operand (second op
))))
1550 (and (eql x
(slot-offset 'movitz-run-time-context name
))
1555 ((atom funs
) (try funs
))
1556 (t (some #'try funs
))))))))
1557 (preserves-stack-location-p (i stack-location
)
1558 (let ((i (ignore-instruction-prefixes i
)))
1560 (or (global-funcall-p i
)
1561 (instruction-is i
:frame-map
)
1562 (branch-instruction-label i
)
1563 (non-destructive-p i
)
1564 (and (simple-instruction-p i
)
1565 (not (eql stack-location
(stack-frame-operand (idst i
)))))))))
1566 (preserves-register-p (i register
)
1567 (let ((i (ignore-instruction-prefixes i
)))
1569 (not (and (eq register
:esp
)
1570 (member (instruction-is i
)
1572 (or (and (simple-instruction-p i
)
1573 (not (eq register
(idst i
))))
1574 (instruction-is i
:frame-map
)
1575 (branch-instruction-label i
)
1576 (non-destructive-p i
)
1577 (and (member register
'(:edx
))
1578 (member (global-funcall-p i
)
1579 '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx
)))
1580 (and (not (eq register
:esp
))
1581 (instruction-is i
:pushl
))))))
1582 (operand-register-indirect-p (operand register
)
1583 (and (consp operand
)
1584 (tree-search operand register
)))
1585 (doesnt-read-register-p (i register
)
1586 (let ((i (ignore-instruction-prefixes i
)))
1588 (and (simple-instruction-p i
)
1589 (if (member (instruction-is i
) '(:movl
))
1590 (and (not (eq register
(twop-src i
)))
1591 (not (operand-register-indirect-p (twop-src i
) register
))
1592 (not (operand-register-indirect-p (twop-dst i
) register
)))
1593 (not (or (eq register
(isrc i
))
1594 (operand-register-indirect-p (isrc i
) register
)
1595 (eq register
(idst i
))
1596 (operand-register-indirect-p (idst i
) register
)))))
1597 (instruction-is i
:frame-map
)
1598 (and (member register
'(:edx
))
1599 (member (global-funcall-p i
)
1600 '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx
))))))
1601 (register-operand (op)
1602 (and (member op
'(:eax
:ebx
:ecx
:edx
:edi
))
1604 (true-and-equal (x &rest more
)
1605 (declare (dynamic-extent more
))
1606 (and x
(dolist (y more t
)
1609 (uses-stack-frame-p (c)
1611 (some #'stack-frame-operand
(cdr (ignore-instruction-prefixes c
)))))
1612 (load-stack-frame-p (c &optional
(op :movl
))
1613 (stack-frame-operand (twop-src c op
)))
1614 (store-stack-frame-p (c &optional
(op :movl
))
1615 (stack-frame-operand (twop-dst c op
)))
1616 (read-stack-frame-p (c)
1617 (or (load-stack-frame-p c
:movl
)
1618 (load-stack-frame-p c
:addl
)
1619 (load-stack-frame-p c
:subl
)
1620 (load-stack-frame-p c
:cmpl
)
1621 (store-stack-frame-p c
:cmpl
)
1624 (stack-frame-operand (second c
)))))
1625 (in-stack-frame-p (c reg
)
1626 "Does c ensure that reg is in some particular stack-frame location?"
1627 (or (and (load-stack-frame-p c
)
1628 (eq reg
(twop-dst c
))
1629 (stack-frame-operand (twop-src c
)))
1630 (and (store-stack-frame-p c
)
1631 (eq reg
(twop-src c
))
1632 (stack-frame-operand (twop-dst c
)))))
1633 (load-funobj-constant-p (c)
1634 (funobj-constant-operand (twop-src c
:movl
)))
1636 (sub-program-label-p (l)
1638 (eq :sub-program
(car l
))))
1640 (if (or (load-stack-frame-p c
)
1641 (load-funobj-constant-p c
))
1644 (label-here-p (label code
)
1645 "Is <label> at this point in <code>?"
1647 while
(or (symbolp i
)
1648 (instruction-is i
:frame-map
))
1649 thereis
(eq label i
)))
1650 (negate-branch (branch-type)
1652 (:jbe
:ja
) (:ja
:jbe
)
1653 (:jz
:jnz
) (:jnz
:jz
)
1654 (:je
:jne
) (:jne
:je
)
1655 (:jc
:jnc
) (:jnc
:jc
)
1656 (:jl
:jge
) (:jge
:jl
)
1657 (:jle
:jg
) (:jg
:jle
)))
1658 (branch-instruction-label (i &optional jmp
(branch-types '(:je
:jne
:jb
:jnb
:jbe
:jz
:jl
:jnz
1659 :jle
:ja
:jae
:jg
:jge
:jnc
:jc
:js
:jns
)))
1660 "If i is a branch, return the label."
1661 (when jmp
(push :jmp branch-types
))
1662 (let ((i (ignore-instruction-prefixes i
)))
1663 (or (and (listp i
) (member (car i
) branch-types
)
1664 (listp (second i
)) (member (car (second i
)) '(quote muerte.cl
::quote
))
1665 (second (second i
)))
1670 (not (member (car i
) '(:jmp
:jecxz
)))
1671 (char= #\J
(char (symbol-name (car i
)) 0))
1672 (warn "Not a branch: ~A / ~A [~A]" i
(symbol-package (caadr i
)) branch-types
)))))
1673 (find-branches-to-label (start-pc label
&optional
(context-size 0))
1674 "Context-size is the number of instructions _before_ the branch you want returned."
1675 (dotimes (i context-size
)
1676 (push nil start-pc
))
1677 (loop for pc on start-pc
1678 as i
= (nth context-size pc
)
1679 as i-label
= (branch-instruction-label i t
)
1680 if
(or (eq label i-label
)
1681 (and (consp i-label
)
1682 (eq :label-plus-one
(car i-label
))))
1684 else if
(let ((sub-program i-label
))
1685 (and (consp sub-program
)
1686 (eq :sub-program
(car sub-program
))))
1687 nconc
(find-branches-to-label (cddr (branch-instruction-label i t
))
1689 else if
(and (not (atom i
))
1690 (tree-search i label
))
1691 nconc
(list 'unknown-label-usage
)))
1692 (optimize-trim-stack-frame (unoptimized-code)
1693 "Any unused local variables on the stack-frame?"
1695 ;; BUILD A MAP OF USED STACK-VARS AND REMAP THEM!
1696 #+ignore
(if (not (and stack-frame-size
1697 (find 'start-stack-frame-setup unoptimized-code
)))
1699 (let ((old-code unoptimized-code
)
1701 ;; copy everything upto start-stack-frame-setup
1702 (loop for i
= (pop old-code
)
1703 do
(push i new-code
)
1705 until
(eq i
'start-stack-frame-setup
))
1706 (assert (eq (car new-code
) 'start-stack-frame-setup
) ()
1707 "no start-stack-frame-setup label, but we already checked!")
1708 (loop for pos downfrom -
8 by
4
1709 as i
= (pop old-code
)
1710 if
(and (consp i
) (eq :pushl
(car i
)) (symbolp (cadr i
)))
1711 collect
(cons pos
(cadr i
))
1712 and do
(unless (find pos old-code
:key
#'read-stack-frame-p
)
1714 ((find pos old-code
:key
#'store-stack-frame-p
)
1715 (warn "Unused local but stored var: ~S" pos
))
1716 ((find pos old-code
:key
#'uses-stack-frame-p
)
1717 (warn "Unused BUT USED local var: ~S" pos
))
1718 (t (warn "Unused local var: ~S" pos
))))
1723 (frame-map-code (unoptimized-code)
1724 "After each label in unoptimized-code, insert a (:frame-map <full-map> <branch-map> <sticky>)
1725 that says which registers are known to hold which stack-frame-locations.
1726 A branch-map is the map that is guaranteed after every branch to the label, i.e. not including
1727 falling below the label."
1728 #+ignore
(warn "unmapped:~{~&~A~}" unoptimized-code
)
1729 (flet ((rcode-map (code)
1730 #+ignore
(when (instruction-is (car code
) :testb
)
1731 (warn "rcoding ~A" code
))
1732 (loop with modifieds
= nil
1733 with registers
= (list :eax
:ebx
:ecx
:edx
)
1734 with local-map
= nil
1737 do
(flet ((add-map (stack reg
)
1738 (when (and (not (member stack modifieds
))
1739 (member reg registers
))
1740 (push (cons stack reg
)
1742 (cond ((instruction-is ii
:frame-map
)
1743 (dolist (m (second ii
))
1744 (add-map (car m
) (cdr m
))))
1745 ((load-stack-frame-p ii
)
1746 (add-map (load-stack-frame-p ii
)
1748 ((store-stack-frame-p ii
)
1749 (add-map (store-stack-frame-p ii
)
1751 (pushnew (store-stack-frame-p ii
)
1753 ((non-destructive-p ii
))
1754 ((branch-instruction-label ii
))
1755 ((simple-instruction-p ii
)
1756 (let ((op (idst ii
)))
1758 ((stack-frame-operand op
)
1759 (pushnew (stack-frame-operand op
) modifieds
))
1761 (setf registers
(delete op registers
))))))
1762 (t #+ignore
(when (instruction-is (car code
) :testb
)
1763 (warn "stopped at ~A" ii
))
1766 (delete-if (lambda (r)
1767 (not (preserves-register-p ii r
)))
1770 #+ignore
(when (instruction-is (car code
) :testb
)
1771 (warn "..map ~A" local-map
))
1772 (return local-map
))))
1773 (loop with next-pc
= 'auto-next
1774 ;; initially (warn "opt: ~{ ~A~%~}" unoptimized-code)
1775 for pc
= unoptimized-code then
(prog1 (if (eq 'auto-next next-pc
) auto-next-pc next-pc
)
1776 (setq next-pc
'auto-next
))
1777 as auto-next-pc
= (cdr unoptimized-code
) then
(cdr pc
)
1778 as p
= (list (car pc
)) ; will be appended.
1779 as i1
= (first pc
) ; current instruction, collected by default.
1780 and i2
= (second pc
)
1782 do
(when (and (symbolp i1
)
1783 (not (and (instruction-is i2
:frame-map
)
1786 (branch-map (reduce (lambda (&optional x y
)
1787 (intersection x y
:test
#'equal
))
1788 (mapcar (lambda (lpc)
1789 (if (eq 'unknown-label-usage lpc
)
1791 (rcode-map (nreverse (xsubseq lpc
0 9)))))
1792 (find-branches-to-label unoptimized-code label
9))))
1793 (full-map (let ((rcode (nreverse (let* ((pos (loop for x on unoptimized-code
1796 finally
(return pos
)))
1797 (back9 (max 0 (- pos
9))))
1798 (subseq unoptimized-code
1800 (if (instruction-uncontinues-p (car rcode
))
1802 (intersection branch-map
(rcode-map rcode
) :test
#'equal
)))))
1803 (when (or full-map branch-map nil
)
1805 (explain nil
"Inserting at ~A frame-map ~S branch-map ~S."
1806 label full-map branch-map
))
1807 (setq p
(list label
`(:frame-map
,full-map
,branch-map
))
1808 next-pc
(if (instruction-is i2
:frame-map
)
1812 (optimize-stack-frame-init (unoptimized-code)
1813 "Look at the function's stack-frame initialization code, and see
1814 if we can optimize that, and/or immediately subsequent loads/stores."
1815 (if (not (find 'start-stack-frame-setup unoptimized-code
))
1817 (let ((old-code unoptimized-code
)
1819 ;; copy everything upto start-stack-frame-setup
1820 (loop for i
= (pop old-code
)
1821 do
(push i new-code
)
1823 until
(eq i
'start-stack-frame-setup
))
1824 (assert (eq (car new-code
) 'start-stack-frame-setup
) ()
1825 "no start-stack-frame-setup label, but we already checked!")
1826 (let* ((frame-map (loop with pos
= -
8
1827 as i
= (pop old-code
)
1828 if
(instruction-is i
:frame-map
)
1831 (and (consp i
) (eq :pushl
(car i
)) (symbolp (cadr i
)))
1840 (mod-p (loop with mod-p
= nil
1841 for i
= `(:frame-map
,(copy-list frame-map
) nil t
)
1844 do
(let ((new-i (cond
1845 ((let ((store-pos (store-stack-frame-p i
)))
1847 (eq (cdr (assoc store-pos frame-map
))
1849 (explain nil
"removed stack-init store: ~S" i
)
1851 ((let ((load-pos (load-stack-frame-p i
)))
1853 (eq (cdr (assoc load-pos frame-map
))
1855 (explain nil
"removed stack-init load: ~S" i
)
1857 ((and (load-stack-frame-p i
)
1858 (assoc (load-stack-frame-p i
) frame-map
))
1859 (let ((old-reg (cdr (assoc (load-stack-frame-p i
)
1861 (explain nil
"load ~S already in ~S."
1863 `(:movl
,old-reg
,(twop-dst i
))))
1864 ((and (instruction-is i
:pushl
)
1865 (stack-frame-operand (idst i
))
1866 (assoc (stack-frame-operand (idst i
))
1869 (cdr (assoc (stack-frame-operand (idst i
))
1871 (explain nil
"push ~S already in ~S."
1873 `(:pushl
,old-reg
)))
1875 (unless (eq new-i i
)
1877 (when (branch-instruction-label new-i t
)
1879 (push `(:frame-map
,(copy-list frame-map
) nil t
)
1882 (push new-i new-code
)
1883 ;; (warn "new-i: ~S, fm: ~S" new-i frame-map)
1885 (delete-if (lambda (map)
1886 ;; (warn "considering: ~S" map)
1887 (not (and (preserves-register-p new-i
(cdr map
))
1888 (preserves-stack-location-p new-i
1891 ;; (warn "Frame-map now: ~S" frame-map)
1892 (when (store-stack-frame-p new-i
)
1893 (loop for map in frame-map
1894 do
(when (= (store-stack-frame-p new-i
)
1896 (setf (cdr map
) (twop-src new-i
)))))))
1898 finally
(return mod-p
))))
1901 (append (nreverse new-code
)
1903 (remove-frame-maps (code)
1904 (remove-if (lambda (x)
1905 (typep x
'(cons (eql :frame-map
) *)))
1907 (let* ((unoptimized-code (frame-map-code (optimize-stack-frame-init unoptimized-code
)))
1908 (code-modified-p nil
)
1909 (stack-frame-used-map (loop with map
= nil
1910 for i in unoptimized-code
1911 do
(let ((x (read-stack-frame-p i
)))
1912 (when x
(pushnew x map
)))
1913 (when (and (instruction-is i
:leal
)
1914 (stack-frame-operand (twop-src i
)))
1915 (let ((x (stack-frame-operand (twop-src i
))))
1916 (when (= (tag :cons
) (ldb (byte 2 0) x
))
1917 (pushnew (+ x -
1) map
)
1918 (pushnew (+ x
3) map
))))
1919 finally
(return map
)))
1921 ;; This loop applies a set of (hard-coded) heuristics on unoptimized-code.
1922 (loop with next-pc
= 'auto-next
1923 ;; initially (warn "opt: ~{ ~A~%~}" unoptimized-code)
1924 for pc
= unoptimized-code then
(prog1 (if (eq 'auto-next next-pc
) auto-next-pc next-pc
)
1925 (setq next-pc
'auto-next
))
1926 as auto-next-pc
= (cdr unoptimized-code
) then
(cdr pc
)
1927 as p
= (list (car pc
)) ; will be appended.
1929 as i
= (first pc
) ; current instruction, collected by default.
1930 and i2
= (second pc
) and i3
= (third pc
) and i4
= (fourth pc
) and i5
= (fifth pc
)
1933 ((and (instruction-is i
:frame-map
)
1934 (instruction-is i2
:frame-map
)
1937 (let ((map (union (second i
) (second i2
) :test
#'equal
)))
1938 (explain nil
"Merged maps:~%~A + ~A~% => ~A"
1939 (second i
) (second i2
) map
)
1940 (setq p
`((:frame-map
,map
))
1941 next-pc
(cddr pc
))))
1942 ((let ((x (store-stack-frame-p i
)))
1943 (and x
(not (member x stack-frame-used-map
))))
1945 (explain nil
"Removed store of unused local var: ~S" i
))
1946 ((and (global-funcall-p i2
'(fast-car))
1947 (global-funcall-p i5
'(fast-cdr))
1948 (true-and-equal (in-stack-frame-p i
:eax
)
1949 (in-stack-frame-p i4
:eax
)))
1950 (let ((call-prefix (if (consp (car i2
)) (car i2
) nil
)))
1952 ((equal i3
'(:pushl
:eax
))
1953 (explain nil
"merge car,push,cdr to cdr-car,push")
1955 `(,call-prefix
:call
1956 (:edi
,(global-constant-offset 'fast-cdr-car
)))
1958 next-pc
(nthcdr 5 pc
)))
1959 ((and (store-stack-frame-p i3
)
1960 (eq :eax
(twop-src i3
)))
1961 (explain nil
"merge car,store,cdr to cdr-car,store")
1963 `(,call-prefix
:call
1964 (:edi
,(global-constant-offset 'fast-cdr-car
)))
1965 `(:movl
:ebx
,(twop-dst i3
)))
1966 next-pc
(nthcdr 5 pc
)))
1967 (t (error "can't deal with cdr-car here: ~{~&~A~}" (subseq pc
0 8))))))
1968 ((flet ((try (place register
&optional map reason
)
1969 "See if we can remove a stack-frame load below current pc,
1970 given the knowledge that <register> is equal to <place>."
1973 (dolist (si (cdr pc
))
1974 (when (and (twop-p si
:cmpl
)
1975 (equal place
(twop-src si
)))
1976 (warn "Reverse cmp not yet dealed with.."))
1978 ((and (twop-p si
:cmpl
)
1979 (equal place
(twop-dst si
)))
1981 ((equal place
(local-load-p si
))
1983 ((or (not (consp si
))
1984 (not (preserves-register-p si register
))
1985 (equal place
(twop-dst si
)))
1988 (remove-if (lambda (m)
1989 (not (preserves-register-p si
(cdr m
))))
1991 (case (instruction-is next-load
)
1993 (let ((pos (position next-load pc
)))
1994 (setq p
(nconc (subseq pc
0 pos
)
1995 (if (or (eq register
(twop-dst next-load
))
1996 (find-if (lambda (m)
1997 (and (eq (twop-dst next-load
) (cdr m
))
1998 (= (car m
) (stack-frame-operand place
))))
2001 (list `(:movl
,register
,(twop-dst next-load
)))))
2002 next-pc
(nthcdr (1+ pos
) pc
))
2003 (explain nil
"preserved load/store .. load ~S of place ~S because ~S."
2004 next-load place reason
)))
2006 (let ((pos (position next-load pc
)))
2007 (setq p
(nconc (subseq pc
0 pos
)
2008 (list `(:cmpl
,(twop-src next-load
) ,register
)))
2009 next-pc
(nthcdr (1+ pos
) pc
))
2010 (explain nil
"preserved load/store..cmp: ~S" p next-load
))))
2011 (if next-load t nil
))))
2012 (or (when (instruction-is i
:frame-map
)
2013 (loop for
(place . register
) in
(second i
)
2014 ;;; do (warn "map try ~S ~S: ~S" place register
2015 ;;; (try place register))
2016 thereis
(try `(:ebp
,place
) register
(second i
) :frame-map
)))
2017 (try (or (local-load-p i
)
2018 (and (store-stack-frame-p i
)
2020 (if (store-stack-frame-p i
)
2025 (instruction-is i2
:frame-map
)
2026 (load-stack-frame-p i3
)
2028 (cdr (assoc (load-stack-frame-p i3
) (third i2
))))
2029 (not (assoc (load-stack-frame-p i3
) (second i2
))))
2030 (let ((reg (cdr (assoc (load-stack-frame-p i3
) (third i2
)))))
2031 (explain nil
"factor out load from loop: ~S" i3
)
2032 (assert (eq reg
(twop-dst i3
)))
2033 (setq p
(if (eq reg
(twop-dst i3
))
2035 (append (list i3 i i2
)
2036 `((:movl
,reg
,(twop-dst i3
)))))
2037 next-pc
(cdddr pc
))))
2038 ;; ((:movl <foo> <bar>) label (:movl <zot> <bar>))
2039 ;; => (label (:movl <zot> <bar>))
2040 ((and (instruction-is i
:movl
)
2042 (and (not (branch-instruction-label i2
))
2043 (symbolp (twop-dst i
))
2044 (doesnt-read-register-p i2
(twop-dst i
))))
2045 (instruction-is i3
:frame-map
)
2046 (instruction-is i4
:movl
)
2047 (equal (twop-dst i
) (twop-dst i4
))
2048 (not (and (symbolp (twop-dst i
))
2049 (operand-register-indirect-p (twop-src i4
)
2051 (setq p
(list i2 i3 i4
)
2052 next-pc
(nthcdr 4 pc
))
2053 (explain nil
"Removed redundant store before ~A: ~A"
2054 i2
(subseq pc
0 4)))
2055 ((and (instruction-is i
:movl
)
2056 (not (branch-instruction-label i2
))
2057 (symbolp (twop-dst i
))
2058 (doesnt-read-register-p i2
(twop-dst i
))
2059 (instruction-is i3
:movl
)
2060 (equal (twop-dst i
) (twop-dst i3
))
2061 (not (and (symbolp (twop-dst i
))
2062 (operand-register-indirect-p (twop-src i3
)
2064 (setq p
(list i2 i3
)
2065 next-pc
(nthcdr 3 pc
))
2066 (explain nil
"Removed redundant store before ~A: ~A"
2067 i2
(subseq pc
0 3)))
2069 ((let ((stack-pos (store-stack-frame-p i
)))
2071 (loop with search-pc
= (cdr pc
)
2074 for ii
= (pop search-pc
)
2075 thereis
(eql stack-pos
2076 (store-stack-frame-p ii
))
2077 while
(or (global-funcall-p ii
)
2078 (and (simple-instruction-p ii
)
2080 (uses-stack-frame-p ii
))))))
2083 (store-stack-frame-p i4
))
2086 (or (global-funcall-p ii
)
2087 (and (simple-instruction-p ii
)
2089 (uses-stack-frame-p ii
))))))
2093 (explain t
"removing redundant store at ~A"
2094 (subseq pc
0 (min 10 (length pc
)))))
2095 ((and (member (instruction-is i
)
2096 '(:cmpl
:cmpb
:cmpw
:testl
:testb
:testw
))
2097 (member (instruction-is i2
)
2098 '(:cmpl
:cmpb
:cmpw
:testl
:testb
:testw
)))
2100 next-pc
(nthcdr 2 pc
))
2101 (explain nil
"Trimmed double test: ~A" (subseq pc
0 4)))
2102 ;; ((:jmp x) ...(no labels).... x ..)
2104 ((let ((x (branch-instruction-label i t nil
)))
2105 (and (position x
(cdr pc
))
2106 (not (find-if #'symbolp
(cdr pc
) :end
(position x
(cdr pc
))))))
2107 (explain nil
"jmp x .. x: ~W"
2108 (subseq pc
0 (1+ (position (branch-instruction-label i t nil
)
2111 next-pc
(member (branch-instruction-label i t nil
) pc
)))
2112 ;; (:jcc 'x) .... x (:jmp 'y) ..
2113 ;; => (:jcc 'y) .... x (:jmp 'y) ..
2114 ((let* ((from (branch-instruction-label i t
))
2115 (dest (member (branch-instruction-label i t
)
2117 (to (branch-instruction-label (if (instruction-is (second dest
) :frame-map
)
2121 (when (and from to
(not (eq from to
)))
2122 (setq p
(list `(,(car i
) ',to
)))
2123 (explain nil
"branch redirect from ~S to ~S" from to
)
2125 ;; remove back-to-back std/cld
2126 ((and (instruction-is i
:cld
)
2127 (instruction-is i2
:std
))
2128 (explain nil
"removing back-to-back cld, std.")
2129 (setq p nil next-pc
(cddr pc
)))
2130 ;; remove branch no-ops.
2131 ((and (branch-instruction-label i t
)
2132 (label-here-p (branch-instruction-label i t
)
2134 (explain nil
"branch no-op: ~A" i
)
2137 (null (symbol-package i
))
2138 (null (find-branches-to-label unoptimized-code i
))
2139 (not (member i keep-labels
)))
2141 next-pc
(if (instruction-is i2
:frame-map
)
2144 (explain nil
"unused label: ~S" i
))
2145 ;; ((:jcc 'label) (:jmp 'y) label) => ((:jncc 'y) label)
2146 ((and (branch-instruction-label i
)
2147 (branch-instruction-label i2 t nil
)
2149 (eq (branch-instruction-label i
) i3
))
2150 (setq p
(list `(,(negate-branch (first i
))
2151 ',(branch-instruction-label i2 t nil
)))
2152 next-pc
(nthcdr 2 pc
))
2153 (explain nil
"collapsed double negative branch to ~S: ~A." i3 p
))
2154 ((and (branch-instruction-label i
)
2155 (instruction-is i2
:frame-map
)
2156 (branch-instruction-label i3 t nil
)
2158 (eq (branch-instruction-label i
) i4
))
2159 (setq p
(list `(,(negate-branch (first i
))
2160 ',(branch-instruction-label i3 t nil
)))
2161 next-pc
(nthcdr 3 pc
))
2162 (explain nil
"collapsed double negative branch to ~S: ~A." i4 p
))
2163 ((and (twop-p i
:movl
)
2164 (register-operand (twop-src i
))
2165 (register-operand (twop-dst i
))
2167 (eq (twop-dst i
) (twop-dst i2
))
2168 (register-indirect-operand (twop-src i2
) (twop-dst i
)))
2169 (setq p
(list `(:movl
(,(twop-src i
)
2170 ,(register-indirect-operand (twop-src i2
)
2173 next-pc
(nthcdr 2 pc
))
2174 (explain nil
"(movl edx eax) (movl (eax <z>) eax) => (movl (edx <z>) eax: ~S"
2176 ((and (twop-p i
:movl
)
2177 (instruction-is i2
:pushl
)
2178 (eq (twop-dst i
) (second i2
))
2180 (eq (twop-dst i
) (twop-dst i3
)))
2181 (setq p
(list `(:pushl
,(twop-src i
)))
2182 next-pc
(nthcdr 2 pc
))
2183 (explain nil
"(movl <z> :eax) (pushl :eax) => (pushl <z>): ~S" p
))
2184 ((and (instruction-uncontinues-p i
)
2185 (not (or (symbolp i2
)
2186 #+ignore
(member (instruction-is i2
) '(:foobar
)))))
2187 (do ((x (cdr pc
) (cdr x
)))
2190 ((not (or (symbolp (car x
))
2191 #+ignore
(member (instruction-is (car x
)) '(:foobar
))))
2192 (explain nil
"Removing unreachable code ~A after ~A." (car x
) i
))
2196 ((and (store-stack-frame-p i
)
2197 (load-stack-frame-p i2
)
2198 (load-stack-frame-p i3
)
2199 (= (store-stack-frame-p i
)
2200 (load-stack-frame-p i3
))
2201 (not (eq (twop-dst i2
) (twop-dst i3
))))
2202 (setq p
(list i
`(:movl
,(twop-src i
) ,(twop-dst i3
)) i2
)
2203 next-pc
(nthcdr 3 pc
))
2204 (explain nil
"store, z, load => store, move, z: ~A" p
))
2205 ((and (instruction-is i
:movl
)
2206 (member (twop-dst i
) '(:eax
:ebx
:ecx
:edx
))
2207 (instruction-is i2
:pushl
)
2208 (not (member (second i2
) '(:eax
:ebx
:ecx
:edx
)))
2209 (equal (twop-src i
) (second i2
)))
2210 (setq p
(list i
`(:pushl
,(twop-dst i
)))
2211 next-pc
(nthcdr 2 pc
))
2212 (explain t
"load, push => load, push reg."))
2213 ((and (instruction-is i
:movl
)
2214 (member (twop-src i
) '(:eax
:ebx
:ecx
:edx
))
2215 (instruction-is i2
:pushl
)
2216 (not (member (second i2
) '(:eax
:ebx
:ecx
:edx
)))
2217 (equal (twop-dst i
) (second i2
)))
2218 (setq p
(list i
`(:pushl
,(twop-src i
)))
2219 next-pc
(nthcdr 2 pc
))
2220 (explain nil
"store, push => store, push reg: ~S ~S" i i2
))
2221 ;;; ((and (instruction-is i :cmpl)
2222 ;;; (true-and-equal (stack-frame-operand (twop-dst i))
2223 ;;; (load-stack-frame-p i3))
2224 ;;; (branch-instruction-label i2))
2225 ;;; (setf p (list i3
2226 ;;; `(:cmpl ,(twop-src i) ,(twop-dst i3))
2228 ;;; next-pc (nthcdr 3 pc))
2229 ;;; (explain t "~S ~S ~S => ~S" i i2 i3 p))
2230 ((and (instruction-is i
:pushl
)
2231 (instruction-is i3
:popl
)
2232 (store-stack-frame-p i2
)
2233 (store-stack-frame-p i4
)
2234 (eq (idst i3
) (twop-src i4
)))
2236 `(:movl
,(idst i
) ,(twop-dst i4
))
2237 `(:movl
,(idst i
) ,(idst i3
)))
2238 next-pc
(nthcdr 4 pc
))
2239 (explain nil
"~S => ~S" (subseq pc
0 4) p
))
2241 ((let ((i6 (nth 6 pc
)))
2242 (and (global-funcall-p i2
'(fast-car))
2243 (global-funcall-p i6
'(fast-cdr))
2244 (load-stack-frame-p i
)
2245 (eq :eax
(twop-dst i
))
2247 ((and (equal i
'(:movl
:ebx
:eax
))
2248 (global-funcall-p i2
'(fast-car fast-cdr
)))
2249 (let ((newf (ecase (global-funcall-p i2
'(fast-car fast-cdr
))
2250 (fast-car 'fast-car-ebx
)
2251 (fast-cdr 'fast-cdr-ebx
))))
2252 (setq p
`((:call
(:edi
,(global-constant-offset newf
))))
2253 next-pc
(nthcdr 2 pc
))
2254 (explain nil
"Changed [~S ~S] to ~S" i i2 newf
)))
2255 ((and (equal i
'(:movl
:eax
:ebx
))
2256 (global-funcall-p i2
'(fast-car-ebx fast-cdr-ebx
)))
2257 (let ((newf (ecase (global-funcall-p i2
'(fast-car-ebx fast-cdr-ebx
))
2258 (fast-car-ebx 'fast-car
)
2259 (fast-cdr-ebx 'fast-cdr
))))
2260 (setq p
`((:call
(:edi
,(global-constant-offset newf
))))
2261 next-pc
(nthcdr 2 pc
))
2262 (explain nil
"Changed [~S ~S] to ~S" i i2 newf
)))
2264 ((and (global-funcall-p i
'(fast-cdr))
2265 (global-funcall-p i2
'(fast-cdr))
2266 (global-funcall-p i3
'(fast-cdr)))
2267 (setq p
`((:call
(:edi
,(global-constant-offset 'fast-cdddr
))))
2268 next-pc
(nthcdr 3 pc
))
2269 (explain nil
"Changed (cdr (cdr (cdr :eax))) to (cdddr :eax)."))
2270 ((and (global-funcall-p i
'(fast-cdr))
2271 (global-funcall-p i2
'(fast-cdr)))
2272 (setq p
`((:call
(:edi
,(global-constant-offset 'fast-cddr
))))
2273 next-pc
(nthcdr 2 pc
))
2274 (explain nil
"Changed (cdr (cdr :eax)) to (cddr :eax)."))
2275 ((and (load-stack-frame-p i
) (eq :eax
(twop-dst i
))
2276 (global-funcall-p i2
'(fast-car fast-cdr
))
2277 (preserves-stack-location-p i3
(load-stack-frame-p i
))
2278 (preserves-register-p i3
:ebx
)
2279 (eql (load-stack-frame-p i
)
2280 (load-stack-frame-p i4
)))
2281 (let ((newf (ecase (global-funcall-p i2
'(fast-car fast-cdr
))
2282 (fast-car 'fast-car-ebx
)
2283 (fast-cdr 'fast-cdr-ebx
))))
2284 (setq p
`((:movl
,(twop-src i
) :ebx
)
2285 (:call
(:edi
,(global-constant-offset newf
)))
2287 ,@(unless (eq :ebx
(twop-dst i4
))
2288 `((:movl
:ebx
,(twop-dst i4
)))))
2289 next-pc
(nthcdr 4 pc
))
2290 (explain nil
"load around ~A: ~{~&~A~}~%=>~% ~{~&~A~}"
2291 newf
(subseq pc
0 5) p
))))
2292 do
(unless (eq p original-p
) ; auto-detect whether any heuristic fired..
2293 #+ignore
(warn "at ~A, ~A inserted ~A" i i2 p
)
2294 #+ignore
(warn "modified at ~S ~S ~S" i i2 i3
)
2295 (setf code-modified-p t
))
2298 (apply #'optimize-code-internal optimized-code
(1+ recursive-count
) key-args
)
2299 (optimize-trim-stack-frame (remove-frame-maps unoptimized-code
)))))))
2300 ;;;; Compiler internals
2302 (defclass binding
()
2305 :accessor binding-name
)
2307 :accessor binding-env
)
2309 :initarg
:declarations
2310 :accessor binding-declarations
)
2312 :accessor binding-extent-env
2315 (defmethod (setf binding-env
) :after
(env (binding binding
))
2316 (unless (binding-extent-env binding
)
2317 (setf (binding-extent-env binding
) env
)))
2319 (defmethod print-object ((object binding
) stream
)
2320 (print-unreadable-object (object stream
:type t
:identity t
)
2321 (when (slot-boundp object
'name
)
2322 (format stream
"name: ~S~@[->~S~]~@[ %~A~]"
2323 (and (slot-boundp object
'name
)
2324 (binding-name object
))
2325 (when (and (binding-target object
)
2326 (not (eq object
(binding-target object
))))
2327 (binding-name (forwarding-binding-target object
)))
2328 (when (and (slot-exists-p object
'store-type
)
2329 (slot-boundp object
'store-type
)
2330 (binding-store-type object
))
2331 (or (apply #'encoded-type-decode
2332 (binding-store-type object
))
2335 (defclass constant-object-binding
(binding)
2338 :reader constant-object
)))
2340 (defmethod binding-lended-p ((binding constant-object-binding
)) nil
)
2341 (defmethod binding-store-type ((binding constant-object-binding
))
2342 (multiple-value-list (type-specifier-encode `(eql ,(constant-object binding
)))))
2345 (defclass operator-binding
(binding) ())
2347 (defclass macro-binding
(operator-binding)
2350 :accessor macro-binding-expander
)))
2352 (defclass symbol-macro-binding
(binding)
2355 :accessor macro-binding-expander
)))
2357 (defclass variable-binding
(binding)
2358 ((lending ; a property-list
2360 :accessor binding-lending
)
2361 (store-type ; union of all types ever stored here
2363 ;; :initarg :store-type
2364 :accessor binding-store-type
)))
2366 (defmethod binding-lended-p ((binding variable-binding
))
2367 (and (getf (binding-lending binding
) :lended-to
)
2368 (not (eq :unused
(getf (binding-lending binding
) :lended-to
)))))
2370 (defclass lexical-binding
(variable-binding) ())
2371 (defclass located-binding
(lexical-binding) ())
2373 (defclass function-binding
(operator-binding located-binding
)
2376 :accessor function-binding-funobj
)
2378 :initarg
:parent-funobj
2379 :reader function-binding-parent
)))
2381 (defclass funobj-binding
(function-binding) ())
2382 (defclass closure-binding
(function-binding located-binding
) ())
2383 (defclass lambda-binding
(function-binding) ())
2385 (defclass temporary-name
(located-binding)
2388 (defclass borrowed-binding
(located-binding)
2390 :initarg
:reference-slot
2391 :accessor borrowed-binding-reference-slot
)
2393 :initarg
:target-binding
2394 :reader borrowed-binding-target
)
2398 :accessor borrowed-binding-usage
)))
2400 (defclass lexical-borrowed-binding
(borrowed-binding)
2401 ((stack-frame-distance
2402 :initarg
:stack-frame-distance
2403 :reader stack-frame-distance
))
2404 (:documentation
"A closure with lexical extent borrows bindings using this class."))
2406 (defclass indefinite-borrowed-binding
(borrowed-binding)
2408 :initarg
:reference-slot
2409 :reader borrowed-binding-reference-slot
)))
2412 (defclass constant-reference-binding
(lexical-binding)
2415 :reader constant-reference-object
)))
2418 (defmethod print-object ((object constant-reference-binding
) stream
)
2419 (print-unreadable-object (object stream
:type t
:identity t
)
2420 (format stream
"object: ~S" (constant-reference-object object
)))
2423 (defclass forwarding-binding
(lexical-binding)
2425 :initarg
:target-binding
2426 :accessor forwarding-binding-target
)))
2428 (defmethod binding-funobj ((binding binding
))
2429 (movitz-environment-funobj (binding-env binding
)))
2431 (defmethod binding-funobj ((binding forwarding-binding
))
2432 (movitz-environment-funobj (binding-env (forwarding-binding-target binding
))))
2434 (defclass function-argument
(located-binding) ())
2435 (defclass edx-function-argument
(function-argument) ())
2437 (defclass positional-function-argument
(function-argument)
2440 :reader function-argument-argnum
)))
2442 (defclass required-function-argument
(positional-function-argument) ())
2444 (defclass register-required-function-argument
(required-function-argument) ())
2445 (defclass fixed-required-function-argument
(required-function-argument)
2448 :reader binding-numargs
)))
2449 (defclass floating-required-function-argument
(required-function-argument) ())
2451 (defclass non-required-function-argument
(function-argument)
2454 :reader optional-function-argument-init-form
)
2456 :initarg supplied-p-var
2457 :reader optional-function-argument-supplied-p-var
)))
2459 (defclass optional-function-argument
(non-required-function-argument positional-function-argument
) ())
2461 (defclass supplied-p-function-argument
(function-argument) ())
2463 (defclass rest-function-argument
(positional-function-argument) ())
2465 (defclass keyword-function-argument
(non-required-function-argument)
2467 :initarg
:keyword-name
2468 :reader keyword-function-argument-keyword-name
)))
2470 (defclass dynamic-binding
(variable-binding) ())
2472 (defclass shadowing-binding
(binding) ())
2474 (defclass shadowing-dynamic-binding
(dynamic-binding shadowing-binding
)
2476 :initarg
:shadowed-variable
2477 :reader shadowed-variable
)
2479 :initarg
:shadowing-variable
2480 :reader shadowing-variable
)))
2482 (defmethod binding-store-type ((binding dynamic-binding
))
2483 (multiple-value-list (type-specifier-encode t
)))
2485 (defun stack-frame-offset (stack-frame-position)
2486 (* -
4 (1+ stack-frame-position
)))
2488 (defun argument-stack-offset (binding)
2489 (check-type binding fixed-required-function-argument
)
2490 (argument-stack-offset-shortcut (binding-numargs binding
)
2491 (function-argument-argnum binding
)))
2493 (defun argument-stack-offset-shortcut (numargs argnum
)
2494 "For a function of <numargs> arguments, locate the ebp-relative position
2495 of argument <argnum>."
2496 (* 4 (- numargs -
1 argnum
)))
2500 ;;; New style of locating bindings. The point is to not side-effect the binding objects.
2502 (defun new-binding-location (binding map
&key
(default nil default-p
))
2503 (check-type binding
(or binding
(cons keyword binding
)))
2504 (let ((x (assoc binding map
)))
2508 (t (error "No location for ~S." binding
)))))
2510 (defun make-binding-map () nil
)
2512 (defun new-binding-located-p (binding map
)
2513 (check-type binding
(or null binding
(cons keyword binding
)))
2514 (and (assoc binding map
) t
))
2516 (defun frame-map-size (map)
2520 (if (integerp (cdr x
))
2524 (defun frame-map-next-free-location (frame-map env
&optional
(size 1))
2525 (labels ((stack-location (binding)
2526 (if (typep binding
'forwarding-binding
)
2527 (stack-location (forwarding-binding-target binding
))
2528 (new-binding-location binding frame-map
:default nil
)))
2529 (env-extant (env1 env2
)
2530 "Is env1 active whenever env2 is active?"
2535 ;; (warn "~S shadowed by ~S" env env2)
2537 (t (env-extant env1
(movitz-environment-extent-uplink env2
))))))
2538 (let ((frame-size (frame-map-size frame-map
)))
2539 (or (loop for location from
1 to frame-size
2541 (loop for sub-location from location below
(+ location size
)
2543 (find-if (lambda (b-loc)
2544 (destructuring-bind (binding . binding-location
)
2546 (or (and (eq binding nil
) ; nil means "back off!"
2547 (eql sub-location binding-location
))
2548 (and (not (bindingp binding
))
2549 (eql sub-location binding-location
))
2550 (and (bindingp binding
)
2551 (eql sub-location
(stack-location binding
))
2555 (or (env-extant (binding-env b
) env
)
2556 (env-extant env
(binding-env b
))
2557 (when (typep b
'forwarding-binding
)
2558 (z (forwarding-binding-target b
)))))))
2562 (1+ frame-size
))))) ; no free location found, so grow frame-size.
2564 (define-setf-expander new-binding-location
(binding map-place
&environment env
)
2565 (multiple-value-bind (temps values stores setter getter
)
2566 (get-setf-expansion map-place env
)
2567 (let ((new-value (gensym))
2568 (binding-var (gensym)))
2569 (values (append temps
(list binding-var
))
2570 (append values
(list binding
))
2572 `(let ((,(car stores
) (progn
2573 (assert (or (null binding
)
2574 (not (new-binding-located-p ,binding-var
,getter
))))
2575 (check-type ,new-value
(or keyword
2578 (cons (eql :argument-stack
) *)))
2579 (acons ,binding-var
,new-value
,getter
))))
2582 `(new-binding-location ,binding-var
,getter
)))))
2584 ;;; Objects with dynamic extent may be located on the stack-frame, which at
2585 ;;; compile-time is represented with this structure.
2587 ;;;(defclass stack-allocated-object ()
2589 ;;; ;; Size in words (4 octets) this object occupies in the stack-frame.
2593 ;;; ;; Stack-frame offset (in words) this object is allocated to.
2594 ;;; :accessor location)))
2600 (defun ignore-instruction-prefixes (instruction)
2601 (if (and (consp instruction
)
2602 (listp (car instruction
)))
2606 (defun instruction-sub-program (instruction)
2607 "When an instruction contains a sub-program, return that program, and
2608 the sub-program options (&optional label) as secondary value."
2609 (let ((instruction (ignore-instruction-prefixes instruction
)))
2610 (and (consp instruction
)
2611 (consp (second instruction
))
2612 (symbolp (car (second instruction
)))
2613 (string= 'quote
(car (second instruction
)))
2614 (let ((x (second (second instruction
))))
2616 (eq :sub-program
(car x
))
2620 (defun instruction-is (instruction &optional operator
)
2621 (and (listp instruction
)
2622 (if (member (car instruction
) '(:globally
:locally
))
2623 (instruction-is (second instruction
) operator
)
2624 (let ((instruction (ignore-instruction-prefixes instruction
)))
2626 (eq operator
(car instruction
))
2627 (car instruction
))))))
2629 (defun instruction-uncontinues-p (instruction)
2630 "Is it impossible for control to return after instruction?"
2631 (or (member (instruction-is instruction
)
2637 #+ignore
(defun sub-environment-p (env1 env2
)
2641 (t (sub-environment-p (movitz-environment-uplink env1
) env2
))))
2643 (defun find-code-constants-and-jumpers (code &key include-programs
)
2644 "Return code's constants (a plist of constants and their usage-counts) and jumper-sets."
2645 (let (jumper-sets constants key-args-set
)
2646 (labels ((process-binding (binding)
2647 "Some bindings are really references to constants."
2649 (constant-object-binding
2650 (let ((object (movitz-read (constant-object binding
))))
2651 (when (typep object
'movitz-heap-object
)
2652 (incf (getf constants object
0)))))
2654 (process-binding (forwarding-binding-target binding
)))
2656 (let ((funobj (function-binding-funobj binding
)))
2657 (incf (getf constants funobj
0))))
2660 (error "No function-binding now..: ~S" binding
))))
2662 "This local function side-effects the variables jumper-sets and constants."
2663 (loop for instruction in sub-code
2664 do
(case (instruction-is instruction
)
2665 ((:local-function-init
:load-lambda
)
2666 (let* ((binding (second instruction
))
2667 (funobj (function-binding-funobj binding
)))
2668 (unless (eq :unused
(movitz-funobj-extent funobj
))
2669 (incf (getf constants funobj
0))
2670 (dolist (binding (borrowed-bindings funobj
))
2671 (process-binding binding
)))))
2672 ((:load-lexical
:lend-lexical
:call-lexical
)
2673 (process-binding (second instruction
)))
2675 (let ((object (movitz-read (second instruction
))))
2676 (when (typep object
'movitz-heap-object
)
2677 (incf (getf constants object
0)))))
2679 (destructuring-bind (name set
)
2681 (assert (not (getf jumper-sets name
)) ()
2682 "Duplicate jumper declaration for ~S." name
)
2683 (setf (getf jumper-sets name
) set
)))
2684 (:declare-key-arg-set
2685 (setf key-args-set
(cdr instruction
)))
2686 (t (when (listp instruction
)
2687 (dolist (binding (find-read-bindings instruction
))
2688 (process-binding binding
)))))
2689 do
(let ((sub (instruction-sub-program instruction
)))
2690 (when sub
(process sub
))))))
2692 (map nil
#'process include-programs
))
2693 (loop for key-arg in key-args-set
2694 do
(remf constants key-arg
))
2695 (values constants jumper-sets key-args-set
)))
2697 (defun layout-funobj-vector (constants key-args-constants jumper-sets borrowing-bindings
)
2698 (let* ((jumpers (loop with x
2699 for set in
(cdr jumper-sets
) by
#'cddr
2700 unless
(search set x
)
2701 do
(setf x
(nconc x
(copy-list set
)))
2702 finally
(return x
)))
2703 (num-jumpers (length jumpers
))
2704 (stuff (append (mapcar (lambda (c)
2707 (when key-args-constants
2708 (list (cons (movitz-read 0)
2710 (sort (loop for
(constant count
) on constants by
#'cddr
2711 unless
(or (eq constant
*movitz-nil
*)
2712 (eq constant
(image-t-symbol *image
*)))
2713 collect
(cons constant count
))
2715 (values (append jumpers
2717 (movitz-read (car x
)))
2719 (make-list (length borrowing-bindings
)
2720 :initial-element
*movitz-nil
*))
2722 (loop for
(name set
) on jumper-sets by
#'cddr
2723 collect
(cons name set
))
2724 (loop for borrowing-binding in borrowing-bindings
2725 as pos upfrom
(+ num-jumpers
(length stuff
))
2726 collect
(cons borrowing-binding pos
)))))
2728 (defun movitz-funobj-intern-constant (funobj obj
)
2730 (let ((cobj (movitz-read obj
)))
2731 (+ (slot-offset 'movitz-funobj
'constant0
)
2733 (let* ((pos (position cobj
(movitz-funobj-const-list funobj
)
2734 :start
(movitz-funobj-num-jumpers funobj
))))
2736 "Couldn't find constant ~S in ~S's set of constants ~S."
2737 obj funobj
(movitz-funobj-const-list funobj
))
2740 (defun compute-free-registers (pc distance funobj frame-map
2741 &key
(free-registers '(:ecx
:eax
:ebx
:edx
)))
2742 "Return set of free register, and whether there may be more registers
2743 free later, with a more specified frame-map."
2744 (loop with free-so-far
= free-registers
2745 repeat distance for i in pc
2746 while
(not (null free-so-far
))
2749 ((and (instruction-is i
:init-lexvar
)
2750 (typep (second i
) 'required-function-argument
)) ; XXX
2751 (destructuring-bind (binding &key init-with-register init-with-type
2752 protect-registers protect-carry
)
2754 (declare (ignore protect-carry init-with-type
))
2755 (when init-with-register
2756 (setf free-so-far
(remove-if (lambda (x)
2757 (if (new-binding-located-p binding frame-map
)
2758 (eq x
(new-binding-location binding frame-map
))
2759 (or (eq x init-with-register
)
2760 (member x protect-registers
))))
2762 (t (case (instruction-is i
)
2764 (return nil
)) ; a label, most likely
2765 ((:declare-key-arg-set
:declare-label-set
)
2767 ((:lexical-control-transfer
:load-lambda
)
2768 (return nil
)) ; not sure about these.
2771 (remove-if (lambda (r)
2776 (remove :ecx free-so-far
)))
2779 (set-difference free-so-far
'(:eax
:edx
))))
2780 ((:into
:clc
:stc
:int
))
2781 ((:jmp
:jnz
:je
:jne
:jz
:jge
:jae
:jnc
:jbe
)
2783 (remove :push free-so-far
)))
2786 (remove-if (lambda (r)
2792 (set-difference free-so-far
'(:eax
:edx
))))
2793 ((:movb
:testb
:andb
:cmpb
)
2795 (remove-if (lambda (r)
2796 (and (not (eq r
:push
))
2797 (or (tree-search i r
)
2798 (tree-search i
(register32-to-low8 r
)))))
2800 ((:sarl
:shrl
:shll
:xorl
:cmpl
:leal
:btl
:sbbl
:cdq
2801 :movl
:movzxw
:movzxb
:testl
:andl
:addl
:subl
:imull
:idivl
)
2803 (remove-if (lambda (r)
2806 ((:load-constant
:load-lexical
:store-lexical
:cons-get
:endp
:incf-lexvar
:init-lexvar
)
2807 (assert (gethash (instruction-is i
) *extended-code-expanders
*))
2809 ((and (instruction-is i
:init-lexvar
) ; special case..
2810 (typep (second i
) 'forwarding-binding
)))
2811 (t (unless (can-expand-extended-p i frame-map
)
2812 ;; (warn "can't expand ~A from ~A" i frame-map)
2813 (return (values nil t
)))
2814 (let ((exp (expand-extended-code i funobj frame-map
)))
2815 (when (tree-search exp
'(:call
:local-function-init
))
2817 (remove-if (lambda (r)
2821 (remove-if (lambda (r)
2822 (and (not (eq r
:push
))
2823 (or (tree-search exp r
)
2824 (tree-search exp
(register32-to-low8 r
)))))
2826 ((:local-function-init
)
2827 (destructuring-bind (binding)
2829 (unless (typep binding
'funobj-binding
)
2831 (t #+ignore
(warn "Dist ~D stopped by ~A"
2834 ;; do (warn "after ~A: ~A" i free-so-far)
2835 finally
(return free-so-far
)))
2837 (defun try-locate-in-register (binding var-counts funobj frame-map
)
2838 "Try to locate binding in a register. Return a register, or
2839 nil and :not-now, or :never.
2840 This function is factored out from assign-bindings."
2841 (assert (not (typep binding
'forwarding-binding
)))
2842 (let* ((count-init-pc (gethash binding var-counts
))
2843 (count (car count-init-pc
))
2844 (init-pc (second count-init-pc
)))
2845 #+ignore
(warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc
)
2847 ((and (not *compiler-allow-transients
*)
2848 (typep binding
'function-argument
))
2849 (values nil
:never
))
2850 ((binding-lended-p binding
)
2851 ;; We can't lend a register.
2852 (values nil
:never
))
2855 (assert (instruction-is (first init-pc
) :init-lexvar
))
2856 (destructuring-bind (init-binding &key init-with-register init-with-type
2857 protect-registers protect-carry
)
2858 (cdr (first init-pc
))
2859 (declare (ignore protect-registers protect-carry init-with-type
))
2860 (assert (eq binding init-binding
))
2861 (multiple-value-bind (load-instruction binding-destination distance
)
2862 (loop for i in
(cdr init-pc
) as distance upfrom
0
2863 do
(when (not (instruction-is i
:init-lexvar
))
2864 (multiple-value-bind (read-bindings read-destinations
)
2865 (find-read-bindings i
)
2866 (let ((pos (position binding read-bindings
:test
#'binding-eql
)))
2868 (return (values i
(nth pos read-destinations
) distance
)))))))
2869 (declare (ignore load-instruction
))
2870 (multiple-value-bind (free-registers more-later-p
)
2871 (and distance
(compute-free-registers (cdr init-pc
) distance funobj frame-map
))
2873 (when (string= 'num-jumpers
(binding-name binding
))
2874 (warn "load: ~S, dist: ~S, dest: ~S" load-instruction distance binding-destination
)
2875 (warn "free: ~S, more: ~S" free-registers more-later-p
))
2876 (let ((free-registers-no-ecx (remove :ecx free-registers
)))
2878 ((member binding-destination free-registers-no-ecx
)
2879 binding-destination
)
2880 ((and (not (typep binding
'(or fixed-required-function-argument
2881 register-required-function-argument
)))
2882 (member binding-destination free-registers
))
2883 binding-destination
)
2884 ((member init-with-register free-registers
)
2886 ((and (member :ecx free-registers
)
2887 (not (typep binding
'function-argument
))
2888 (or (eq :untagged-fixnum-ecx binding-destination
)
2889 (eq :untagged-fixnum-ecx init-with-register
)))
2890 :untagged-fixnum-ecx
)
2891 ((and (binding-store-type binding
)
2892 (member :ecx free-registers
)
2893 (not (typep binding
'(or fixed-required-function-argument
2894 register-required-function-argument
)))
2895 (multiple-value-call #'encoded-subtypep
2896 (values-list (binding-store-type binding
))
2897 (type-specifier-encode '(or integer character
))))
2899 ((not (null free-registers-no-ecx
))
2900 (first free-registers-no-ecx
))
2902 (values nil
:not-now
))
2903 ((and distance
(typep binding
'temporary-name
))
2904 ;; We might push/pop this variable
2905 (multiple-value-bind (push-available-p maybe-later
)
2906 (compute-free-registers (cdr init-pc
) distance funobj frame-map
2907 :free-registers
'(:push
))
2908 ;; (warn "pushing.. ~S ~A ~A" binding push-available-p maybe-later)
2913 (values nil
:not-now
))
2914 (t (values nil
:never
)))))
2915 (t (values nil
:never
))))))))
2916 (t (values nil
:never
)))))
2918 (defun discover-variables (code function-env
)
2919 "Iterate over CODE, and take note in the hash-table VAR-COUNTER which ~
2920 variables CODE references that are lexically bound in ENV."
2921 (check-type function-env function-env
)
2922 ;; (print-code 'discover code)
2923 (let ((var-counter (make-hash-table :test
#'eq
:size
40)))
2924 (labels ((record-binding-used (binding)
2925 (let ((count-init-pc (or (gethash binding var-counter
)
2926 (setf (gethash binding var-counter
)
2928 (setf (third count-init-pc
) t
)
2929 (when (typep binding
'forwarding-binding
)
2930 (record-binding-used (forwarding-binding-target binding
)))))
2931 (take-note-of-binding (binding &optional storep init-pc
)
2932 (let ((count-init-pc (or (gethash binding var-counter
)
2933 (setf (gethash binding var-counter
)
2934 (list 0 nil
(not storep
))))))
2936 (assert (not (second count-init-pc
)))
2937 (setf (second count-init-pc
) init-pc
))
2939 (unless (eq binding
(binding-target binding
))
2940 ;; (break "ewfew: ~S" (gethash (binding-target binding) var-counter))
2941 (take-note-of-binding (binding-target binding
)))
2942 (setf (third count-init-pc
) t
)
2943 (incf (car count-init-pc
))))
2945 (when (typep binding
'forwarding-binding
)
2946 (take-note-of-binding (forwarding-binding-target binding
) storep
)))
2947 (take-note-of-init (binding init-pc
)
2948 (let ((count-init-pc (or (gethash binding var-counter
)
2949 (setf (gethash binding var-counter
)
2950 (list 0 nil nil
)))))
2951 (assert (not (second count-init-pc
)))
2952 (setf (second count-init-pc
) init-pc
)))
2953 (do-discover-variables (code env
)
2954 (loop for pc on code as instruction in code
2955 when
(listp instruction
)
2956 do
(flet ((lend-lexical (borrowing-binding dynamic-extent-p
)
2957 (let ((lended-binding
2958 (borrowed-binding-target borrowing-binding
)))
2959 (assert (not (typep lended-binding
'forwarding-binding
)) ()
2960 "Can't lend a forwarding-binding.")
2961 (pushnew lended-binding
2962 (potentially-lended-bindings function-env
))
2963 (take-note-of-binding lended-binding
)
2964 (symbol-macrolet ((p (binding-lending lended-binding
)))
2965 (incf (getf p
:lended-count
0))
2966 (setf (getf p
:dynamic-extent-p
) (and (getf p
:dynamic-extent-p t
)
2967 dynamic-extent-p
))))))
2968 (case (instruction-is instruction
)
2969 ((:local-function-init
:load-lambda
)
2970 (let ((function-binding (second instruction
)))
2971 (take-note-of-binding function-binding
)
2972 (let ((sub-funobj (function-binding-funobj function-binding
)))
2974 (warn "fun-ext: ~S ~S ~S"
2976 (movitz-funobj-extent sub-funobj
)
2977 (movitz-allocation sub-funobj
))
2978 (when (typep (movitz-allocation sub-funobj
)
2979 'with-dynamic-extent-scope-env
)
2980 (take-note-of-binding (base-binding (movitz-allocation sub-funobj
)))))
2981 (let ((closure-funobj (function-binding-funobj function-binding
)))
2982 (dolist (borrowing-binding (borrowed-bindings closure-funobj
))
2983 (lend-lexical borrowing-binding nil
)))))
2985 (destructuring-bind (binding num-args
)
2987 (declare (ignore num-args
))
2990 (take-note-of-binding binding
))
2993 (destructuring-bind (binding &key init-with-register init-with-type
2994 protect-registers protect-carry
2997 (declare (ignore protect-registers protect-carry init-with-type
2998 shared-reference-p
))
3000 ((not init-with-register
)
3001 (take-note-of-init binding pc
))
3003 (take-note-of-binding binding t pc
)
3004 (when (and (typep init-with-register
'binding
)
3005 (not (typep binding
'forwarding-binding
))
3006 (not (typep binding
'keyword-function-argument
))) ; XXX
3007 (take-note-of-binding init-with-register
))))))
3008 (t (mapcar #'take-note-of-binding
3009 (find-read-bindings instruction
))
3010 (mapcar #'record-binding-used
; This is just concerning "unused variable"
3011 (find-used-bindings instruction
)) ; warnings!
3012 (let ((store-binding (find-written-binding-and-type instruction
)))
3014 (take-note-of-binding store-binding t
)))
3015 (do-discover-variables (instruction-sub-program instruction
) env
)))))))
3016 (do-discover-variables code function-env
))
3017 (values var-counter
)))
3019 (defun assign-bindings (code function-env
&optional
(initial-stack-frame-position 1)
3020 (frame-map (make-binding-map)))
3021 "Assign locations to all lexical variables in CODE. Recurses into any
3022 sub-environments found in CODE. A frame-map which is an assoc from
3023 bindings to stack-frame locations."
3024 ;; Then assign them to locations in the stack-frame.
3025 #+ignore
(warn "assigning code:~%~{~& ~A~}" code
)
3026 (check-type function-env function-env
)
3027 (assert (= initial-stack-frame-position
3028 (1+ (frame-map-size frame-map
))))
3029 (let* ((env-assigned-p nil
) ; memoize result of assign-env-bindings
3031 (var-counts (discover-variables flat-program function-env
)))
3033 ((assign-env-bindings (env)
3034 (unless (member env env-assigned-p
)
3035 (unless (eq env function-env
)
3036 (assign-env-bindings (movitz-environment-extent-uplink env
)))
3037 (let* ((bindings-to-locate
3038 (loop for binding being the hash-keys of var-counts
3040 (and (eq env
(binding-extent-env binding
))
3041 (not (let ((variable (binding-name binding
)))
3043 ((not (typep binding
'lexical-binding
)))
3044 ((typep binding
'lambda-binding
))
3045 ((typep binding
'constant-object-binding
))
3046 ((typep binding
'forwarding-binding
)
3047 (when (plusp (or (car (gethash binding var-counts
)) 0))
3048 (assert (new-binding-located-p binding frame-map
)))
3050 ((typep binding
'borrowed-binding
))
3051 ((typep binding
'funobj-binding
))
3052 ((and (typep binding
'fixed-required-function-argument
)
3053 (plusp (or (car (gethash binding var-counts
)) 0)))
3054 (prog1 nil
; may need lending-cons
3055 (setf (new-binding-location binding frame-map
)
3056 `(:argument-stack
,(function-argument-argnum binding
)))))
3057 ((unless (or (movitz-env-get variable
'ignore nil
3058 (binding-env binding
) nil
)
3059 (movitz-env-get variable
'ignorable nil
3060 (binding-env binding
) nil
)
3061 (third (gethash binding var-counts
)))
3062 (warn "Unused variable: ~S"
3063 (binding-name binding
))))
3064 ((not (plusp (or (car (gethash binding var-counts
)) 0))))))))
3066 (bindings-fun-arg-sorted
3067 (when (eq env function-env
)
3068 (sort (copy-list bindings-to-locate
) #'<
3069 :key
(lambda (binding)
3071 (edx-function-argument 3)
3072 (positional-function-argument
3073 (* 2 (function-argument-argnum binding
)))
3074 (binding 100000))))))
3075 (bindings-register-goodness-sort
3076 (sort (copy-list bindings-to-locate
) #'<
3077 ;; Sort so as to make the most likely
3078 ;; candidates for locating to registers
3079 ;; be assigned first (i.e. maps to
3080 ;; a smaller value).
3083 ((or constant-object-binding
3087 (fixed-required-function-argument
3088 (+ 100 (function-argument-argnum b
)))
3090 (let* ((count-init (gethash b var-counts
))
3091 (count (car count-init
))
3092 (init-pc (second count-init
)))
3093 (if (not (and count init-pc
))
3096 (or (position-if (lambda (i)
3097 (member b
(find-read-bindings i
)))
3101 ;; First, make several passes while trying to locate bindings
3103 (loop repeat
100 with try-again
= t and did-assign
= t
3104 do
(unless (and try-again did-assign
)
3106 do
(setf try-again nil did-assign nil
)
3107 (loop for binding in bindings-fun-arg-sorted
3108 while
(or (typep binding
'register-required-function-argument
)
3109 (typep binding
'floating-required-function-argument
)
3110 (and (typep binding
'positional-function-argument
)
3111 (< (function-argument-argnum binding
)
3113 do
(unless (new-binding-located-p binding frame-map
)
3114 (multiple-value-bind (register status
)
3115 (try-locate-in-register binding var-counts
3116 (movitz-environment-funobj function-env
)
3120 (setf (new-binding-location binding frame-map
)
3122 (setf did-assign t
))
3123 ((eq status
:not-now
)
3124 ;; (warn "Wait for ~S map ~A" binding frame-map)
3126 (t (assert (eq status
:never
)))))))
3127 (dolist (binding bindings-register-goodness-sort
)
3128 (unless (and (binding-lended-p binding
)
3129 (not (typep binding
'borrowed-binding
))
3130 (not (getf (binding-lending binding
) :stack-cons-location
)))
3131 (unless (new-binding-located-p binding frame-map
)
3132 (check-type binding located-binding
)
3133 (multiple-value-bind (register status
)
3134 (try-locate-in-register binding var-counts
3135 (movitz-environment-funobj function-env
)
3139 (setf (new-binding-location binding frame-map
)
3141 (setf did-assign t
))
3142 ((eq status
:not-now
)
3144 (t (assert (eq status
:never
))))))))
3145 do
(when (and try-again
(not did-assign
))
3146 (let ((binding (or (find-if (lambda (b)
3147 (and (typep b
'positional-function-argument
)
3148 (= 0 (function-argument-argnum b
))
3149 (not (new-binding-located-p b frame-map
))))
3150 bindings-fun-arg-sorted
)
3151 (find-if (lambda (b)
3152 (and (typep b
'positional-function-argument
)
3153 (= 1 (function-argument-argnum b
))
3154 (not (new-binding-located-p b frame-map
))))
3155 bindings-fun-arg-sorted
)
3156 (find-if (lambda (b)
3157 (and (not (new-binding-located-p b frame-map
))
3158 (not (typep b
'function-argument
))))
3159 bindings-register-goodness-sort
3162 (setf (new-binding-location binding frame-map
)
3163 (frame-map-next-free-location frame-map
(binding-env binding
)))
3164 (setf did-assign t
))))
3165 finally
(break "100 iterations didn't work"))
3166 ;; Then, make one pass assigning bindings to stack-frame.
3167 (loop for binding in bindings-fun-arg-sorted
3168 while
(or (typep binding
'register-required-function-argument
)
3169 (typep binding
'floating-required-function-argument
)
3170 (and (typep binding
'positional-function-argument
)
3171 (< (function-argument-argnum binding
)
3173 do
(unless (new-binding-located-p binding frame-map
)
3174 (setf (new-binding-location binding frame-map
)
3175 (frame-map-next-free-location frame-map
(binding-env binding
)))))
3176 (dolist (binding bindings-register-goodness-sort
)
3177 (when (and (binding-lended-p binding
)
3178 (not (typep binding
'borrowed-binding
))
3179 (not (getf (binding-lending binding
) :stack-cons-location
)))
3181 (assert (not (typep binding
'keyword-function-argument
)) ()
3182 "Can't lend keyword binding ~S." binding
)
3183 ;; (warn "assigning lending-cons for ~W at ~D" binding stack-frame-position)
3184 (let ((cons-pos (frame-map-next-free-location frame-map function-env
2)))
3185 (setf (new-binding-location (cons :lended-cons binding
) frame-map
)
3187 (setf (new-binding-location (cons :lended-cons binding
) frame-map
)
3189 (setf (getf (binding-lending binding
) :stack-cons-location
)
3191 (unless (new-binding-located-p binding frame-map
)
3193 (constant-object-binding) ; no location needed.
3194 (forwarding-binding) ; will use the location of target binding.
3195 (borrowed-binding) ; location is predetermined
3196 (fixed-required-function-argument
3197 (setf (new-binding-location binding frame-map
)
3198 `(:argument-stack
,(function-argument-argnum binding
))))
3200 (setf (new-binding-location binding frame-map
)
3201 (frame-map-next-free-location frame-map
(binding-env binding
)))))))
3202 (push env env-assigned-p
)))))
3203 ;; First, "assign" each forwarding binding to their target.
3204 (loop for binding being the hash-keys of var-counts
3205 do
(when (and (typep binding
'forwarding-binding
)
3206 (plusp (car (gethash binding var-counts
'(0)))))
3207 (setf (new-binding-location binding frame-map
)
3208 (forwarding-binding-target binding
))))
3210 (flet ((set-exclusive-location (binding location
)
3211 (assert (not (rassoc location frame-map
))
3212 () "Fixed location ~S for ~S is taken by ~S."
3213 location binding
(rassoc location frame-map
))
3214 (setf (new-binding-location binding frame-map
) location
)))
3215 (when (key-vars-p function-env
)
3216 (when (= 0 (rest-args-position function-env
))
3217 (set-exclusive-location (loop for var in
(required-vars function-env
)
3218 as binding
= (movitz-binding var function-env nil
)
3219 thereis
(when (= 0 (function-argument-argnum binding
))
3222 (when (>= 1 (rest-args-position function-env
))
3223 (set-exclusive-location (loop for var in
(required-vars function-env
)
3224 as binding
= (movitz-binding var function-env nil
)
3225 thereis
(when (= 1 (function-argument-argnum binding
))
3228 (loop for key-var in
(key-vars function-env
)
3229 as key-binding
= (or (movitz-binding key-var function-env nil
)
3230 (error "No binding for key-var ~S." key-var
))
3231 as used-key-binding
=
3232 (when (plusp (car (gethash key-binding var-counts
'(0))))
3234 as used-supplied-p-binding
=
3235 (when (optional-function-argument-supplied-p-var key-binding
)
3236 (let ((b (or (movitz-binding (optional-function-argument-supplied-p-var key-binding
)
3238 (error "No binding for supplied-p-var ~S."
3239 (optional-function-argument-supplied-p-var key-binding
)))))
3240 (when (plusp (car (gethash key-binding var-counts
'(0))))
3242 as location upfrom
3 by
2
3243 do
(set-exclusive-location used-key-binding location
)
3244 (set-exclusive-location used-supplied-p-binding
(1+ location
))))
3245 ;; Now, use assing-env-bindings on the remaining bindings.
3248 for b being the hash-keys of var-counts using
(hash-value c
)
3249 as env
= (binding-env b
)
3250 when
(sub-env-p env function-env
)
3251 do
(incf (getf z env
0) (car c
))
3253 (return (sort (loop for x in z by
#'cddr
3258 do
(assign-env-bindings env
))
3259 #+ignore
(warn "Frame-map ~D:~{~&~A~}"
3260 (frame-map-size frame-map
)
3261 (stable-sort (sort (loop for
(b . l
) in frame-map
3262 collect
(list b l
(car (gethash b var-counts nil
))))
3265 (and (bindingp (car x
))
3266 (binding-name (car x
)))))
3269 (if (integerp (cadr x
))
3275 (defun operators-present-in-code-p (code operators operands
&key
(operand-test #'eql
)
3277 "A simple tree search for `(<one of operators> ,operand) in CODE."
3278 ;; (break "Deprecated operators-present-in-code-p")
3282 ((and (member (first code
) operators
)
3285 (funcall operand-test
(second code
) operands
)
3286 (member (second code
) operands
:test operand-test
)))
3289 (t (or (operators-present-in-code-p (car code
) operators operands
3290 :operand-test operand-test
3292 (operators-present-in-code-p (cdr code
) operators operands
3293 :operand-test operand-test
3297 (defun code-uses-binding-p (code binding
&key
(load t
) store call
)
3298 "Does extended <code> potentially read/write/call <binding>?"
3299 (labels ((search-funobj (funobj binding load store call
)
3300 ;; If this is a recursive lexical call (i.e. labels),
3301 ;; the function-envs might not be bound, but then this
3302 ;; code is searched already.
3303 (when (slot-boundp funobj
'function-envs
)
3304 (some (lambda (function-env-spec)
3305 (code-search (extended-code (cdr function-env-spec
)) binding
3307 (function-envs funobj
))))
3308 (code-search (code binding load store call
)
3309 (dolist (instruction code
)
3310 (when (consp instruction
)
3311 (let ((x (or (when load
3312 (some (lambda (read-binding)
3313 (binding-eql read-binding binding
))
3314 (find-read-bindings instruction
)))
3316 (let ((store-binding (find-written-binding-and-type instruction
)))
3318 (binding-eql binding store-binding
))))
3319 (case (car instruction
)
3320 (:local-function-init
3321 (search-funobj (function-binding-funobj (second instruction
))
3322 binding load store call
))
3325 (binding-eql binding
(second instruction
)))
3326 (let ((allocation (movitz-allocation
3327 (function-binding-funobj (second instruction
)))))
3329 (typep allocation
'with-dynamic-extent-scope-env
))
3330 (binding-eql binding
(base-binding allocation
))))
3331 (search-funobj (function-binding-funobj (second instruction
))
3332 binding load store call
)))
3335 (binding-eql binding
(second instruction
)))
3336 (search-funobj (function-binding-funobj (second instruction
))
3337 binding load store call
))))
3338 (code-search (instruction-sub-program instruction
)
3339 binding load store call
))))
3340 (when x
(return t
)))))))
3341 (code-search code binding load store call
)))
3346 (defun binding-target (binding)
3347 "Resolve a binding in terms of forwarding."
3350 (binding-target (forwarding-binding-target binding
)))
3354 (defun binding-eql (x y
)
3355 (check-type x binding
)
3356 (check-type y binding
)
3358 (and (typep x
'forwarding-binding
)
3359 (binding-eql (forwarding-binding-target x
) y
))
3360 (and (typep y
'forwarding-binding
)
3361 (binding-eql x
(forwarding-binding-target y
)))))
3363 (defun tree-search (tree items
)
3365 (atom (if (atom items
)
3367 (member tree items
)))
3368 (cons (or (tree-search (car tree
) items
)
3369 (tree-search (cdr tree
) items
)))))
3372 (if (atom x
) x
(car x
)))
3374 (defun result-mode-type (x)
3378 (constant-object-binding :constant-binding
)
3379 (lexical-binding :lexical-binding
)
3380 (dynamic-binding :dynamic-binding
)))
3383 (if (symbolp x
) nil
(cdr x
)))
3385 (defun funobj-assign-bindings (code env
&optional
(stack-frame-position 1)
3386 (frame-map (make-binding-map)))
3387 "This wrapper around assign-bindings checks if the first instructions of CODE
3388 are load-lexicals of the first two function arguments, and if possible these
3389 bindings are located in the appropriate register, so no stack location is needed."
3390 (check-type env function-env
)
3391 (assign-bindings (append (when (first (required-vars env
))
3392 (let ((binding (movitz-binding (first (required-vars env
))
3394 (check-type binding required-function-argument
)
3395 `((:init-lexvar
,binding
:init-with-register
:eax
:init-with-type t
))))
3396 (when (second (required-vars env
))
3397 (let ((binding (movitz-binding (second (required-vars env
))
3399 (check-type binding required-function-argument
)
3400 `((:init-lexvar
,binding
:init-with-register
:ebx
:init-with-type t
))))
3402 env stack-frame-position frame-map
))
3404 (defun single-value-register (mode)
3406 ((:eax
:single-value
:multiple-values
:function
) :eax
)
3407 ((:ebx
:ecx
:edx
:esi
:esp
:ebp
) mode
)))
3409 (defun result-mode-register (mode)
3411 ((:eax
:single-value
) :eax
)
3412 ((:ebx
:ecx
:edx
:esi
:esp
) mode
)
3415 (defun accept-register-mode (mode &optional
(default-mode :eax
))
3417 ((:eax
:ebx
:ecx
:edx
)
3421 (defun chose-free-register (unfree-registers &optional
(preferred-register :eax
))
3423 ((not (member preferred-register unfree-registers
))
3425 ((find-if (lambda (r) (not (member r unfree-registers
)))
3426 '(:eax
:ebx
:ecx
:edx
)))
3427 (t (error "Unable to find a free register."))))
3429 (defun make-indirect-reference (base-register offset
)
3430 "Make the shortest possible assembly indirect reference, explointing the constant edi register."
3431 (if (<= #x-80 offset
#x7f
)
3432 (list base-register offset
)
3433 (let ((edi (image-nil-word *image
*)))
3435 ((<= #x-80
(- offset edi
) #x7f
)
3436 `(,base-register
:edi
,(- offset edi
)))
3437 ((<= #x-80
(- offset
(* 2 edi
)) #x7f
)
3438 `(,base-register
(:edi
2) ,(- offset
(* 2 edi
))))
3439 ((<= #x-80
(- offset
(* 4 edi
)) #x7f
)
3440 `(,base-register
(:edi
4) ,(- offset
(* 4 edi
))))
3441 ((<= #x-80
(- offset
(* 8 edi
)) #x7f
)
3442 `(,base-register
(:edi
8) ,(- offset
(* 8 edi
))))
3443 (t (list base-register offset
))))))
3445 (defun make-load-lexical (binding result-mode funobj shared-reference-p frame-map
3446 &key tmp-register protect-registers override-binding-type
)
3447 "When tmp-register is provided, use that for intermediate storage required when
3448 loading borrowed bindings."
3450 (when (eq :ecx result-mode
)
3451 ;; (warn "loading to ecx: ~S" binding)
3452 (unless (or (null (binding-store-type binding
))
3453 (movitz-subtypep (apply #'encoded-type-decode
3454 (binding-store-type binding
))
3456 (warn "ecx from ~S" binding
)))
3457 (when (movitz-env-get (binding-name binding
) 'ignore nil
(binding-env binding
))
3458 (break "The variable ~S is used even if it was declared ignored."
3459 (binding-name binding
)))
3460 (let ((binding (ensure-local-binding binding funobj
))
3461 (protect-registers (cons :edx protect-registers
)))
3462 (labels ((chose-tmp-register (&optional preferred
)
3464 (unless (member preferred protect-registers
)
3466 (first (set-difference '(:eax
:ebx
:edx
)
3468 (error "Unable to chose a temporary register.")))
3469 (install-for-single-value (lexb lexb-location result-mode indirect-p
3470 &optional binding-type
)
3471 (let ((decoded-type (when binding-type
3472 (apply #'encoded-type-decode binding-type
))))
3474 ((and (eq result-mode
:untagged-fixnum-ecx
)
3475 (integerp lexb-location
))
3478 (type-specifier-singleton decoded-type
))
3479 #+ignore
(warn "Immloadlex: ~S"
3480 (type-specifier-singleton decoded-type
))
3481 (make-immediate-move (movitz-fixnum-value
3482 (car (type-specifier-singleton decoded-type
)))
3485 (movitz-subtypep decoded-type
'(and fixnum
(unsigned-byte 32))))
3486 (assert (not indirect-p
))
3487 (append (install-for-single-value lexb lexb-location
:ecx nil
)
3488 `((:shrl
,+movitz-fixnum-shift
+ :ecx
))))
3489 #+ignore
((warn "utecx ~S bt: ~S" lexb decoded-type
))
3491 (assert (not indirect-p
))
3492 (assert (not (member :eax protect-registers
)))
3493 (append (install-for-single-value lexb lexb-location
:eax nil
)
3494 `((,*compiler-global-segment-prefix
*
3495 :call
(:edi
,(global-constant-offset 'unbox-u32
))))))))
3496 ((integerp lexb-location
)
3497 (append `((:movl
,(make-indirect-reference :ebp
(stack-frame-offset lexb-location
))
3498 ,(single-value-register result-mode
)))
3500 `((:movl
(-1 ,(single-value-register result-mode
))
3501 ,(single-value-register result-mode
))))))
3502 ((eq lexb-location result-mode
)
3504 (t (when (and (eq result-mode
:untagged-fixnum-ecx
)
3506 (type-specifier-singleton decoded-type
))
3507 (break "xxx Immloadlex: ~S ~S"
3508 (operator lexb-location
)
3509 (type-specifier-singleton decoded-type
)))
3510 (ecase (operator lexb-location
)
3512 (assert (member result-mode
'(:eax
:ebx
:ecx
:edx
)))
3513 (assert (not indirect-p
))
3514 `((:popl
,result-mode
)))
3516 (assert (not indirect-p
))
3518 ((:ebx
:ecx
:edx
:esi
) `((:movl
:eax
,result-mode
)))
3519 ((:eax
:single-value
) nil
)
3520 (:untagged-fixnum-ecx
3521 `((,*compiler-global-segment-prefix
*
3522 :call
(:edi
,(global-constant-offset 'unbox-u32
)))))))
3524 (assert (not indirect-p
))
3525 (unless (eq result-mode lexb-location
)
3527 ((:eax
:single-value
) `((:movl
,lexb-location
:eax
)))
3528 ((:ebx
:ecx
:edx
:esi
) `((:movl
,lexb-location
,result-mode
)))
3529 (:untagged-fixnum-ecx
3530 `((:movl
,lexb-location
:ecx
)
3531 (:sarl
,movitz
:+movitz-fixnum-shift
+ :ecx
))))))
3533 (assert (<= 2 (function-argument-argnum lexb
)) ()
3534 "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb
))
3536 ((eq result-mode
:untagged-fixnum-ecx
)
3537 (assert (not indirect-p
))
3538 `((:movl
(:ebp
,(argument-stack-offset lexb
)) :ecx
)
3539 (:sarl
,+movitz-fixnum-shift
+ :ecx
)))
3540 (t (append `((:movl
(:ebp
,(argument-stack-offset lexb
))
3541 ,(single-value-register result-mode
)))
3543 `((:movl
(-1 ,(single-value-register result-mode
))
3544 ,(single-value-register result-mode
))))))))
3545 (:untagged-fixnum-ecx
3547 ((:eax
:ebx
:ecx
:edx
)
3548 `((:leal
((:ecx
,+movitz-fixnum-factor
+)) ,result-mode
)))
3549 (:untagged-fixnum-ecx
3553 (assert (not (binding-lended-p binding
)) (binding)
3554 "Can't lend a forwarding-binding ~S." binding
)
3555 (make-load-lexical (forwarding-binding-target binding
)
3556 result-mode funobj shared-reference-p frame-map
3557 :override-binding-type
(binding-store-type binding
)))
3558 (constant-object-binding
3559 (assert (not (binding-lended-p binding
)) (binding)
3560 "Can't lend a constant-reference-binding ~S." binding
)
3561 (make-load-constant (constant-object binding
)
3565 (make-load-constant (function-binding-funobj binding
)
3566 result-mode funobj frame-map
))
3568 (let ((slot (borrowed-binding-reference-slot binding
)))
3571 (ecase (result-mode-type result-mode
)
3572 ((:eax
:ebx
:ecx
:edx
)
3573 `((:movl
(:esi
,(+ (slot-offset 'movitz-funobj
'constant0
) (* 4 slot
)))
3574 ,(result-mode-type result-mode
))))))
3575 ((not shared-reference-p
)
3577 ((:single-value
:eax
:ebx
:ecx
:edx
:esi
)
3578 (let ((tmp-register (chose-tmp-register (single-value-register result-mode
))))
3579 `((:movl
(:esi
,(+ (slot-offset 'movitz-funobj
'constant0
) (* 4 slot
)))
3581 (:movl
(,tmp-register -
1)
3582 ,(single-value-register result-mode
)))))
3584 (let ((tmp-register (chose-tmp-register :eax
)))
3585 `((:movl
(:esi
,(+ (slot-offset 'movitz-funobj
'constant0
) (* 4 slot
)))
3587 (:pushl
(,tmp-register -
1)))))
3588 (t (let ((tmp-register (chose-tmp-register :eax
)))
3589 (make-result-and-returns-glue
3590 result-mode tmp-register
3591 `((:movl
(:esi
,(+ (slot-offset 'movitz-funobj
'constant0
) (* 4 slot
)))
3593 (:movl
(,tmp-register -
1) ,tmp-register
))))))))))
3595 (let ((binding-type (or override-binding-type
3596 (binding-store-type binding
)))
3597 (binding-location (new-binding-location binding frame-map
)))
3598 #+ignore
(warn "~S type: ~S ~:[~;lended~]"
3601 (binding-lended-p binding
))
3603 ((and (binding-lended-p binding
)
3604 (not shared-reference-p
))
3605 (case (result-mode-type result-mode
)
3606 ((:single-value
:eax
:ebx
:ecx
:edx
:esi
:esp
)
3607 (install-for-single-value binding binding-location
3608 (single-value-register result-mode
) t
))
3610 (if (integerp binding-location
)
3611 `((:movl
(:ebp
,(stack-frame-offset binding-location
)) :eax
)
3613 (ecase (operator binding-location
)
3615 (assert (<= 2 (function-argument-argnum binding
)) ()
3616 ":load-lexical argnum can't be ~A." (function-argument-argnum binding
))
3617 `((:movl
(:ebp
,(argument-stack-offset binding
)) :eax
)
3618 (:pushl
(:eax -
1)))))))
3619 (t (make-result-and-returns-glue
3621 (install-for-single-value binding binding-location
:eax t
)))))
3622 (t (when (integerp result-mode
)
3623 (break "result-mode: ~S" result-mode
))
3624 (case (result-mode-type result-mode
)
3625 ((:single-value
:eax
:ebx
:ecx
:edx
:esi
:esp
:ebp
)
3626 (install-for-single-value binding binding-location
3627 (single-value-register result-mode
) nil
))
3629 (if (integerp binding-location
)
3630 `((:pushl
(:ebp
,(stack-frame-offset binding-location
))))
3631 (ecase (operator binding-location
)
3632 ((:eax
:ebx
:ecx
:edx
)
3633 `((:pushl
,binding-location
)))
3634 (:untagged-fixnum-ecx
3635 `((,*compiler-local-segment-prefix
*
3636 :call
(:edi
,(global-constant-offset 'box-u32-ecx
)))
3639 (assert (<= 2 (function-argument-argnum binding
)) ()
3640 ":load-lexical argnum can't be ~A." (function-argument-argnum binding
))
3641 `((:pushl
(:ebp
,(argument-stack-offset binding
))))))))
3642 (:boolean-branch-on-true
3643 (if (integerp binding-location
)
3644 `((:cmpl
:edi
(:ebp
,(stack-frame-offset binding-location
)))
3645 (:jne
',(operands result-mode
)))
3646 (ecase (operator binding-location
)
3648 `((:cmpl
:edi
,binding-location
)
3649 (:jne
',(operands result-mode
))))
3651 `((:cmpl
:edi
(:ebp
,(argument-stack-offset binding
)))
3652 (:jne
',(operands result-mode
)))))))
3653 (:boolean-branch-on-false
3654 (if (integerp binding-location
)
3655 `((:cmpl
:edi
(:ebp
,(stack-frame-offset binding-location
)))
3656 (:je
',(operands result-mode
)))
3657 (ecase (operator binding-location
)
3659 `((:cmpl
:edi
,binding-location
)
3660 (:je
',(operands result-mode
))))
3662 `((:cmpl
:edi
(:ebp
,(argument-stack-offset binding
)))
3663 (:je
',(operands result-mode
)))))))
3664 (:untagged-fixnum-ecx
3665 (install-for-single-value binding binding-location
:untagged-fixnum-ecx nil
3668 (let* ((destination result-mode
)
3669 (dest-location (new-binding-location destination frame-map
:default nil
)))
3671 ((not dest-location
) ; unknown, e.g. a borrowed-binding.
3672 (append (install-for-single-value binding binding-location
:edx nil
)
3673 (make-store-lexical result-mode
:edx nil funobj frame-map
)))
3674 ((equal binding-location dest-location
)
3676 ((member binding-location
'(:eax
:ebx
:ecx
:edx
))
3677 (make-store-lexical destination binding-location nil funobj frame-map
))
3678 ((member dest-location
'(:eax
:ebx
:ecx
:edx
))
3679 (install-for-single-value binding binding-location dest-location nil
))
3680 (t #+ignore
(warn "binding => binding: ~A => ~A~% => ~A ~A"
3685 (append (install-for-single-value binding binding-location
:eax nil
)
3686 (make-store-lexical result-mode
:eax nil funobj frame-map
))))))
3687 (t (make-result-and-returns-glue
3689 (install-for-single-value binding binding-location
:eax nil
)))
3692 (defun make-store-lexical (binding source shared-reference-p funobj frame-map
3693 &key protect-registers
)
3694 (let ((binding (ensure-local-binding binding funobj
)))
3695 (assert (not (and shared-reference-p
3696 (not (binding-lended-p binding
))))
3698 "funny binding: ~W" binding
)
3699 (if (and nil
(typep source
'constant-object-binding
))
3700 (make-load-constant (constant-object source
) binding funobj frame-map
)
3701 (let ((protect-registers (cons source protect-registers
)))
3703 ((eq :untagged-fixnum-ecx source
)
3704 (if (eq :untagged-fixnum-ecx
3705 (new-binding-location binding frame-map
))
3707 (append (make-result-and-returns-glue :ecx
:untagged-fixnum-ecx
)
3708 (make-store-lexical binding
:ecx shared-reference-p funobj frame-map
3709 :protect-registers protect-registers
))))
3710 ((typep binding
'borrowed-binding
)
3711 (let ((slot (borrowed-binding-reference-slot binding
)))
3712 (if (not shared-reference-p
)
3713 (let ((tmp-reg (chose-free-register protect-registers
)
3714 #+ignore
(if (eq source
:eax
) :ebx
:eax
)))
3715 (when (eq :ecx source
)
3716 (break "loading a word from ECX?"))
3717 `((:movl
(:esi
,(+ (slot-offset 'movitz-funobj
'constant0
) (* 4 slot
)))
3719 (:movl
,source
(-1 ,tmp-reg
))))
3720 `((:movl
,source
(:esi
,(+ (slot-offset 'movitz-funobj
'constant0
) (* 4 slot
))))))))
3721 ((typep binding
'forwarding-binding
)
3722 (assert (not (binding-lended-p binding
)) (binding))
3723 (make-store-lexical (forwarding-binding-target binding
)
3724 source shared-reference-p funobj frame-map
))
3725 ((not (new-binding-located-p binding frame-map
))
3726 ;; (warn "Can't store to unlocated binding ~S." binding)
3728 ((and (binding-lended-p binding
)
3729 (not shared-reference-p
))
3730 (let ((tmp-reg (chose-free-register protect-registers
)
3731 #+ignore
(if (eq source
:eax
) :ebx
:eax
))
3732 (location (new-binding-location binding frame-map
)))
3733 (if (integerp location
)
3734 `((:movl
(:ebp
,(stack-frame-offset location
)) ,tmp-reg
)
3735 (:movl
,source
(,tmp-reg -
1)))
3736 (ecase (operator location
)
3738 (assert (<= 2 (function-argument-argnum binding
)) ()
3739 "store-lexical argnum can't be ~A." (function-argument-argnum binding
))
3740 `((:movl
(:ebp
,(argument-stack-offset binding
)) ,tmp-reg
)
3741 (:movl
,source
(,tmp-reg -
1))))))))
3742 (t (let ((location (new-binding-location binding frame-map
)))
3744 ((member source
'(:eax
:ebx
:ecx
:edx
:edi
:esp
))
3745 (if (integerp location
)
3746 `((:movl
,source
(:ebp
,(stack-frame-offset location
))))
3747 (ecase (operator location
)
3749 `((:pushl
,source
)))
3750 ((:eax
:ebx
:ecx
:edx
)
3751 (unless (eq source location
)
3752 `((:movl
,source
,location
))))
3754 (assert (<= 2 (function-argument-argnum binding
)) ()
3755 "store-lexical argnum can't be ~A." (function-argument-argnum binding
))
3756 `((:movl
,source
(:ebp
,(argument-stack-offset binding
)))))
3757 (:untagged-fixnum-ecx
3758 (assert (not (eq source
:edi
)))
3760 ((eq source
:untagged-fixnum-ecx
)
3763 `((,*compiler-global-segment-prefix
*
3764 :call
(:edi
,(global-constant-offset 'unbox-u32
)))))
3765 (t `((:movl
,source
:eax
)
3766 (,*compiler-global-segment-prefix
*
3767 :call
(:edi
,(global-constant-offset 'unbox-u32
))))))))))
3768 ((eq source
:boolean-cf
=1)
3769 (let ((tmp (chose-free-register protect-registers
)))
3771 (,*compiler-local-segment-prefix
*
3772 :movl
(:edi
(:ecx
4) ,(global-constant-offset 'not-not-nil
)) ,tmp
)
3773 ,@(make-store-lexical binding tmp shared-reference-p funobj frame-map
3774 :protect-registers protect-registers
))))
3775 ((eq source
:boolean-cf
=0)
3776 (let ((tmp (chose-free-register protect-registers
)))
3778 (,*compiler-local-segment-prefix
*
3779 :movl
(:edi
(:ecx
4) ,(global-constant-offset 'boolean-zero
)) ,tmp
)
3780 ,@(make-store-lexical binding tmp shared-reference-p funobj frame-map
3781 :protect-registers protect-registers
))))
3782 ((and *compiler-use-cmov-p
*
3783 (member source
+boolean-modes
+))
3784 (let ((tmp (chose-free-register protect-registers
)))
3785 (append `((:movl
:edi
,tmp
))
3786 (list (cons *compiler-local-segment-prefix
*
3787 (make-cmov-on-boolean source
3788 `(:edi
,(global-constant-offset 't-symbol
))
3790 (make-store-lexical binding tmp shared-reference-p funobj frame-map
3791 :protect-registers protect-registers
))))
3792 ((member source
+boolean-modes
+)
3793 (let ((tmp (chose-free-register protect-registers
))
3794 (label (gensym "store-lexical-bool-")))
3795 (append `((:movl
:edi
,tmp
))
3796 (list (make-branch-on-boolean source label
:invert t
))
3797 `((,*compiler-local-segment-prefix
*
3798 :movl
(:edi
,(global-constant-offset 't-symbol
)) ,tmp
))
3800 (make-store-lexical binding tmp shared-reference-p funobj frame-map
3801 :protect-registers protect-registers
))))
3802 ((not (bindingp source
))
3803 (error "Unknown source for store-lexical: ~S" source
))
3804 ((binding-singleton source
)
3805 (assert (not shared-reference-p
))
3806 (let ((value (car (binding-singleton source
))))
3809 (let ((immediate (movitz-immediate-value value
)))
3810 (if (integerp location
)
3811 (let ((tmp (chose-free-register protect-registers
)))
3812 (append (make-immediate-move immediate tmp
)
3813 `((:movl
,tmp
(:ebp
,(stack-frame-offset location
))))))
3814 #+ignore
(if (= 0 immediate
)
3815 (let ((tmp (chose-free-register protect-registers
)))
3817 (:movl
,tmp
(:ebp
,(stack-frame-offset location
)))))
3818 `((:movl
,immediate
(:ebp
,(stack-frame-offset location
)))))
3819 (ecase (operator location
)
3821 `((:movl
,immediate
(:ebp
,(argument-stack-offset binding
)))))
3822 ((:eax
:ebx
:ecx
:edx
)
3823 (make-immediate-move immediate location
))
3824 ((:untagged-fixnum-ecx
)
3825 (make-immediate-move (movitz-fixnum-value value
) :ecx
))))))
3827 (let ((immediate (movitz-immediate-value value
)))
3828 (if (integerp location
)
3829 (let ((tmp (chose-free-register protect-registers
)))
3830 (append (make-immediate-move immediate tmp
)
3831 `((:movl
,tmp
(:ebp
,(stack-frame-offset location
))))))
3832 (ecase (operator location
)
3834 `((:movl
,immediate
(:ebp
,(argument-stack-offset binding
)))))
3835 ((:eax
:ebx
:ecx
:edx
)
3836 (make-immediate-move immediate location
))))))
3839 ((member :eax
:ebx
:edx
)
3840 (make-load-constant value location funobj frame-map
))
3842 (let ((tmp (chose-free-register protect-registers
)))
3843 (append (make-load-constant value tmp funobj frame-map
)
3844 (make-store-lexical binding tmp shared-reference-p
3846 :protect-registers protect-registers
))))
3847 ((eql :untagged-fixnum-ecx
)
3848 (check-type value movitz-bignum
)
3849 (let ((immediate (movitz-bignum-value value
)))
3850 (check-type immediate
(unsigned-byte 32))
3851 (make-immediate-move immediate
:ecx
)))
3853 (t (error "Generalized lexb source for store-lexical not implemented: ~S" source
))))))))))
3855 (defun finalize-code (code funobj frame-map
)
3856 ;; (print-code 'to-be-finalized code)
3857 ;; (warn "frame-map: ~A" frame-map)
3858 (labels ((actual-binding (b)
3859 (if (typep b
'borrowed-binding
)
3860 (borrowed-binding-target b
)
3862 (make-lend-lexical (borrowing-binding funobj-register dynamic-extent-p
)
3863 (let ((lended-binding (ensure-local-binding
3864 (borrowed-binding-target borrowing-binding
))))
3865 #+ignore
(warn "LB: in ~S ~S from ~S"
3867 lended-binding borrowing-binding
)
3868 (assert (eq funobj
(binding-funobj lended-binding
)))
3869 (assert (plusp (getf (binding-lending (actual-binding lended-binding
))
3870 :lended-count
0)) ()
3871 "Asked to lend ~S of ~S to ~S of ~S with no lended-count."
3872 lended-binding
(binding-env lended-binding
)
3873 borrowing-binding
(binding-env borrowing-binding
))
3874 (assert (eq funobj-register
:edx
))
3875 (when (getf (binding-lending lended-binding
) :dynamic-extent-p
)
3876 (assert dynamic-extent-p
))
3878 (warn "lending: ~W: ~S"
3880 (mapcar #'movitz-funobj-extent
3881 (mapcar #'binding-funobj
3882 (getf (binding-lending lended-binding
) :lended-to
))))
3883 (append (make-load-lexical lended-binding
:eax funobj t frame-map
)
3884 (unless (or (typep lended-binding
'borrowed-binding
)
3885 (getf (binding-lending lended-binding
) :dynamic-extent-p
)
3886 (every (lambda (borrower)
3887 (member (movitz-funobj-extent (binding-funobj borrower
))
3888 '(:lexical-extent
:dynamic-extent
)))
3889 (getf (binding-lending lended-binding
) :lended-to
)))
3890 (append `((:pushl
:edx
)
3891 (:globally
(:call
(:edi
(:edi-offset ensure-heap-cons-variable
))))
3893 (make-store-lexical lended-binding
:eax t funobj frame-map
)))
3896 ,(+ (slot-offset 'movitz-funobj
'constant0
)
3897 (* 4 (borrowed-binding-reference-slot borrowing-binding
)))))))))
3898 (ensure-local-binding (binding)
3899 (if (eq funobj
(binding-funobj binding
))
3901 (or (find binding
(borrowed-bindings funobj
)
3902 :key
#'borrowed-binding-target
)
3903 (error "Can't install non-local binding ~W." binding
)))))
3904 (labels ((fix-edi-offset (tree)
3908 ((eq :edi-offset
(car tree
))
3909 (check-type (cadr tree
) symbol
"a Movitz run-time-context label")
3910 (+ (global-constant-offset (cadr tree
))
3911 (reduce #'+ (cddr tree
))))
3912 (t (cons (fix-edi-offset (car tree
))
3913 (fix-edi-offset (cdr tree
)))))))
3914 (loop for instruction in code
3919 ((and (= 2 (length instruction
))
3920 (let ((operand (second instruction
)))
3921 (and (listp operand
)
3922 (symbolp (first operand
))
3923 (string= 'quote
(first operand
))
3924 (listp (second operand
)))))
3925 ;;(break "op: ~S" (second (second instruction)))
3926 ;; recurse into program-to-append..
3927 (list (list (first instruction
)
3928 (list 'quote
(finalize-code (second (second instruction
))
3929 funobj frame-map
)))))
3931 (t ;; (warn "finalizing ~S" instruction)
3932 (case (first instruction
)
3933 ((:locally
:globally
)
3934 (destructuring-bind (sub-instr)
3936 (let ((pf (ecase (first instruction
)
3937 (:locally
*compiler-local-segment-prefix
*)
3938 (:globally
*compiler-global-segment-prefix
*))))
3939 (list (fix-edi-offset
3943 ((consp (car sub-instr
))
3944 (list* (append pf
(car sub-instr
))
3946 (t (list* pf sub-instr
))))))))
3947 ((:declare-label-set
3948 :declare-key-arg-set
)
3950 (:local-function-init
3951 (destructuring-bind (function-binding)
3952 (operands instruction
)
3954 (warn "local-function-init: init ~S at ~S"
3956 (new-binding-location function-binding frame-map
))
3958 (let* ((sub-funobj (function-binding-funobj function-binding
)))
3960 ((eq (movitz-funobj-extent sub-funobj
) :unused
)
3961 (unless (or (movitz-env-get (binding-name function-binding
)
3963 (binding-env function-binding
) nil
)
3964 (movitz-env-get (binding-name function-binding
)
3966 (binding-env function-binding
) nil
))
3967 (warn "Unused local function: ~S"
3968 (binding-name function-binding
)))
3970 ((typep function-binding
'funobj-binding
)
3973 ((member (movitz-funobj-extent sub-funobj
)
3974 '(:dynamic-extent
:lexical-extent
))
3975 (check-type function-binding closure-binding
)
3976 (when (plusp (movitz-funobj-num-jumpers sub-funobj
))
3977 (break "Don't know yet how to stack a funobj with jumpers."))
3978 (let ((words (+ (movitz-funobj-num-constants sub-funobj
)
3979 (/ (sizeof 'movitz-funobj
) 4))))
3980 (break "words for ~S: ~S" words sub-funobj
)
3981 (append `((:movl
:esp
:eax
)
3983 (:jz
'no-alignment-needed
)
3985 no-alignment-needed
)
3986 (make-load-constant sub-funobj
:eax funobj frame-map
)
3988 (t (assert (not (null (borrowed-bindings sub-funobj
))))
3989 (append (make-load-constant sub-funobj
:eax funobj frame-map
)
3990 `((:movl
(:edi
,(global-constant-offset 'copy-funobj
)) :esi
)
3991 (:call
(:esi
,(bt:slot-offset
'movitz-funobj
'code-vector%
1op
)))
3993 (make-store-lexical function-binding
:eax nil funobj frame-map
)
3994 (loop for bb in
(borrowed-bindings sub-funobj
)
3995 append
(make-lend-lexical bb
:edx nil
))))))
3998 (destructuring-bind (function-binding register capture-env
)
3999 (operands instruction
)
4000 (declare (ignore capture-env
))
4002 (let* ((sub-funobj (function-binding-funobj function-binding
))
4003 (lend-code (loop for bb in
(borrowed-bindings sub-funobj
)
4005 (make-lend-lexical bb
:edx nil
))))
4008 ;; (warn "null lambda lending")
4009 (append (make-load-constant sub-funobj register funobj frame-map
)))
4010 ((typep (movitz-allocation sub-funobj
)
4011 'with-dynamic-extent-scope-env
)
4012 (setf (headers-on-stack-frame-p funobj
) t
)
4013 (let ((dynamic-scope (movitz-allocation sub-funobj
)))
4014 (append (make-load-lexical (base-binding dynamic-scope
) :edx
4015 funobj nil frame-map
)
4016 `((:leal
(:edx
,(tag :other
)
4017 ,(dynamic-extent-object-offset dynamic-scope
4021 `((:movl
:edx
,register
)))))
4022 (t (append (make-load-constant sub-funobj
:eax funobj frame-map
)
4023 `((:movl
(:edi
,(global-constant-offset 'copy-funobj
)) :esi
)
4024 (:call
(:esi
,(bt:slot-offset
'movitz-funobj
'code-vector%
1op
)))
4027 `((:movl
:edx
,register
))))))
4030 (destructuring-bind (object result-mode
&key
(op :movl
))
4032 (make-load-constant object result-mode funobj frame-map
:op op
)))
4033 (:lexical-control-transfer
4034 (destructuring-bind (return-code return-mode from-env to-env
&optional to-label
)
4036 (declare (ignore return-code
))
4037 (let ((x (apply #'make-compiled-lexical-control-transfer
4039 return-mode from-env to-env
4040 (when to-label
(list to-label
)))))
4041 (finalize-code x funobj frame-map
))))
4043 (destructuring-bind (binding num-args
)
4044 (operands instruction
)
4045 (append (etypecase binding
4047 (make-load-lexical (ensure-local-binding binding
)
4048 :esi funobj nil frame-map
4049 :tmp-register
:edx
))
4051 (make-load-constant (function-binding-funobj binding
)
4052 :esi funobj frame-map
)))
4053 (make-compiled-funcall-by-esi num-args
))))
4054 (t (expand-extended-code instruction funobj frame-map
)))))))))
4057 (defun image-t-symbol-p (x)
4058 (eq x
(image-t-symbol *image
*)))
4060 (deftype movitz-t
()
4061 `(satisfies image-t-symbol-p
))
4063 (defun make-load-constant (object result-mode funobj frame-map
&key
(op :movl
))
4064 (let ((movitz-obj (movitz-read object
)))
4067 (etypecase movitz-obj
4069 (ecase (result-mode-type result-mode
)
4071 (make-store-lexical result-mode
:edi nil funobj frame-map
))
4074 ((:eax
:ebx
:ecx
:edx
)
4075 `((:movl
:edi
,result-mode
)))
4076 (:boolean-branch-on-true
4077 ;; (warn "branch-on-true for nil!")
4079 (:boolean-branch-on-false
4080 ;; (warn "branch-on-false for nil!")
4081 `((:jmp
',(operands result-mode
))))
4082 ((:multiple-values
:function
)
4086 (t (when (eq :boolean result-mode
)
4087 (warn "Compiling ~S for mode ~S." object result-mode
))
4088 (make-result-and-returns-glue result-mode
:edi nil
)
4089 #+ignore
'((:movl
:edi
:eax
)))))
4091 (ecase (result-mode-type result-mode
)
4093 `((:pushl
(:edi
,(global-constant-offset 't-symbol
)))))
4094 ((:eax
:ebx
:ecx
:edx
)
4095 `((:movl
(:edi
,(global-constant-offset 't-symbol
)) ,result-mode
)))
4096 (:boolean-branch-on-false
4097 ;; (warn "boolean-branch-on-false T")
4099 (:boolean-branch-on-true
4100 ;; (warn "boolean-branch-on-true T")
4101 `((:jmp
',(operands result-mode
))))
4102 ((:multiple-values
:function
)
4103 `((:movl
(:edi
,(global-constant-offset 't-symbol
))
4107 (append `((:movl
(:edi
,(global-constant-offset 't-symbol
))
4109 (make-store-lexical result-mode
:eax nil funobj frame-map
)))
4111 (t (when (eq :boolean result-mode
)
4112 (warn "Compiling ~S for mode ~S." object result-mode
))
4113 (make-result-and-returns-glue result-mode
:eax
4114 `((:movl
(:edi
,(global-constant-offset 't-symbol
))
4116 (movitz-immediate-object
4117 (let ((x (movitz-immediate-value movitz-obj
)))
4118 (ecase (result-mode-type result-mode
)
4120 (append (make-immediate-move x
:eax
)
4121 (make-store-lexical result-mode
:eax nil funobj frame-map
)))
4122 (:untagged-fixnum-ecx
4123 (let ((value (movitz-fixnum-value object
)))
4124 (check-type value
(unsigned-byte 32))
4125 (make-immediate-move value
:ecx
)))
4128 ((:eax
:ebx
:ecx
:edx
)
4129 (make-immediate-move x result-mode
))
4130 ((:multiple-values
:function
)
4131 (append (make-immediate-move x
:eax
)
4134 (ecase (result-mode-type result-mode
)
4135 (:untagged-fixnum-ecx
4136 (let ((value (movitz-bignum-value object
)))
4137 (make-immediate-move (ldb (byte 32 0) value
) :ecx
)))
4140 ((and (typep movitz-obj
'movitz-bignum
)
4141 (eq :untagged-fixnum-ecx
4142 (new-binding-location result-mode frame-map
:default nil
)))
4143 (unless (typep (movitz-bignum-value movitz-obj
) '(unsigned-byte 32))
4144 (warn "Loading non-u32 ~S into ~S."
4145 (movitz-bignum-value movitz-obj
)
4147 (make-immediate-move (ldb (byte 32 0) (movitz-bignum-value movitz-obj
))
4149 (t (when (member (new-binding-location result-mode frame-map
:default nil
)
4150 '(:ebx
:ecx
:edx
:esi
))
4151 (warn "load to ~S at ~S from ~S"
4152 result-mode
(new-binding-location result-mode frame-map
) movitz-obj
))
4153 (append `((:movl
,(new-make-compiled-constant-reference movitz-obj funobj
)
4155 (make-store-lexical result-mode
:eax nil funobj frame-map
)))))
4157 `((:pushl
,(new-make-compiled-constant-reference movitz-obj funobj
))))
4158 ((:eax
:ebx
:ecx
:edx
:esi
)
4159 `((,op
,(new-make-compiled-constant-reference movitz-obj funobj
)
4162 (assert (eq op
:cmpl
))
4163 `((,op
,(new-make-compiled-constant-reference movitz-obj funobj
)
4165 ((:function
:multiple-values
)
4166 (assert (eq op
:movl
))
4167 `((,op
,(new-make-compiled-constant-reference movitz-obj funobj
)
4170 (t (ecase result-mode
4171 ((:eax
:ebx
:ecx
:edx
:esi
)
4172 `((,op
,(new-make-compiled-constant-reference movitz-obj funobj
)
4175 (assert (eq op
:cmpl
))
4176 `((,op
,(new-make-compiled-constant-reference movitz-obj funobj
)
4177 ,result-mode
))))))))
4179 (defparameter +movitz-lambda-list-keywords
+
4180 '(muerte.cl
:&OPTIONAL
4186 muerte.cl
:&ALLOW-OTHER-KEYS
4187 muerte.cl
:&ENVIRONMENT
))
4189 (defun add-bindings-from-lambda-list (lambda-list env
)
4190 "From a (normal) <lambda-list>, add bindings to <env>."
4192 (multiple-value-bind (required-vars optional-vars rest-var key-vars auxes allow-p min-args max-args edx-var oddeven key-vars-p
)
4193 (decode-normal-lambda-list lambda-list
)
4194 (setf (min-args env
) min-args
4195 (max-args env
) max-args
4196 (oddeven-args env
) oddeven
4197 (aux-vars env
) auxes
4198 (allow-other-keys-p env
) allow-p
)
4199 (flet ((shadow-when-special (formal env
)
4200 "Iff <formal> is special, return a fresh variable-name that takes <formal>'s place
4201 as the lexical variable-name, and add a new shadowing dynamic binding for <formal> in <env>."
4202 (if (not (movitz-env-get formal
'special nil env
))
4204 (let* ((shadowed-formal (gensym (format nil
"shady-~A-" formal
)))
4205 (shadowing-binding (make-instance 'shadowing-dynamic-binding
4206 :name shadowed-formal
4207 :shadowing-variable formal
4208 :shadowed-variable shadowed-formal
)))
4209 (movitz-env-add-binding env shadowing-binding formal
)
4210 (push (list formal shadowed-formal
)
4211 (special-variable-shadows env
))
4214 (movitz-env-add-binding env
4216 (make-instance 'edx-function-argument
4218 (setf (required-vars env
)
4219 (loop for formal in required-vars
4220 do
(check-type formal symbol
)
4222 (shadow-when-special formal env
))
4223 do
(movitz-env-add-binding env
(cond
4225 (make-instance 'register-required-function-argument
4228 ((and max-args
(= min-args max-args
))
4229 (make-instance 'fixed-required-function-argument
4233 (t (make-instance 'floating-required-function-argument
4238 (setf (optional-vars env
)
4239 (loop for spec in optional-vars
4241 (multiple-value-bind (formal init-form supplied-p-parameter
)
4242 (decode-optional-formal spec
)
4243 (setf formal
(shadow-when-special formal env
))
4244 (movitz-env-add-binding env
(make-instance 'optional-function-argument
4246 :argnum
(post-incf arg-pos
)
4247 'init-form init-form
4248 'supplied-p-var supplied-p-parameter
))
4249 (when supplied-p-parameter
4250 (setf supplied-p-parameter
4251 (shadow-when-special supplied-p-parameter env
))
4252 (movitz-env-add-binding env
(make-instance 'supplied-p-function-argument
4253 :name supplied-p-parameter
)))
4255 (when (or rest-var key-vars-p
)
4256 (setf (rest-args-position env
) arg-pos
))
4258 (check-type rest-var symbol
)
4259 (let ((formal (shadow-when-special rest-var env
)))
4260 (setf (rest-var env
) formal
)
4261 (movitz-env-add-binding env
(make-instance 'rest-function-argument
4263 :argnum
(post-incf arg-pos
)))))
4265 (setf (key-vars-p env
) t
)
4266 (when (>= 1 (rest-args-position env
))
4267 (let ((name (gensym "save-ebx-for-keyscan")))
4268 (setf (required-vars env
)
4269 (append (required-vars env
)
4271 (movitz-env-add-binding env
(make-instance 'register-required-function-argument
4274 :declarations
'(muerte.cl
:ignore
)))
4275 (setf (movitz-env-get name
'ignore nil env
) t
)))
4276 (when (= 0 (rest-args-position env
))
4277 (let ((name (gensym "save-eax-for-keyscan")))
4278 (push name
(required-vars env
))
4279 (movitz-env-add-binding env
(make-instance 'register-required-function-argument
4282 (setf (movitz-env-get name
'ignore nil env
) t
))))
4283 (setf (key-vars env
)
4284 (loop for spec in key-vars
4286 (multiple-value-bind (formal keyword-name init-form supplied-p
)
4287 (decode-keyword-formal spec
)
4288 (let ((formal (shadow-when-special formal env
))
4289 (supplied-p-parameter supplied-p
))
4290 (movitz-env-add-binding env
(make-instance 'keyword-function-argument
4292 'init-form init-form
4293 'supplied-p-var supplied-p-parameter
4294 :keyword-name keyword-name
))
4295 (when supplied-p-parameter
4296 (movitz-env-add-binding env
(make-instance 'supplied-p-function-argument
4297 :name
(shadow-when-special supplied-p-parameter env
))))
4300 (multiple-value-bind (key-decode-map key-decode-shift
)
4301 (best-key-encode (key-vars env
))
4302 (setf (key-decode-map env
) key-decode-map
4303 (key-decode-shift env
) key-decode-shift
))
4306 (warn "~D waste, keys: ~S, shift ~D, map: ~S"
4307 (- (length (key-decode-map env
))
4310 (key-decode-shift env
)
4311 (key-decode-map env
))))))
4314 (defun make-compiled-function-prelude-numarg-check (min-args max-args
)
4315 "The prelude is compiled after the function's body."
4316 (assert (or (not max-args
) (<= 0 min-args max-args
)))
4317 (assert (<= 0 min-args
(or max-args min-args
) #xffff
) ()
4318 "Lambda lists longer than #xffff are not yet implemented.")
4319 (let ((wrong-numargs (make-symbol "wrong-numargs")))
4321 ((and (zerop min-args
) ; any number of arguments is
4322 (not max-args
)) ; acceptable, no check necessary.
4326 (if (< min-args
#x80
)
4327 `((:cmpb
,min-args
:cl
)
4328 (:jb
'(:sub-program
(,wrong-numargs
) (:int
100))))
4329 `((:cmpl
,(dpb min-args
(byte 24 8) #x80
) :ecx
)
4330 (:jb
'(:sub-program
(,wrong-numargs
) (:int
100))))))
4331 ((and max-args
(= 0 min-args max-args
))
4334 (:jnz
'(:sub-program
(,wrong-numargs
) (:int
100)))))
4335 ((and max-args
(= min-args max-args
))
4338 ((= 1 min-args max-args
)
4339 `((:call
(:edi
,(global-constant-offset 'assert-1arg
)))))
4340 ((= 2 min-args max-args
)
4341 `((:call
(:edi
,(global-constant-offset 'assert-2args
)))))
4342 ((= 3 min-args max-args
)
4343 `((:call
(:edi
,(global-constant-offset 'assert-3args
)))))
4345 `((:cmpb
,min-args
:cl
)
4346 (:jne
'(:sub-program
(,wrong-numargs
) (:int
100)))))
4347 (t `((:cmpl
,(dpb min-args
(byte 24 8) #x80
) :ecx
)
4348 (:jne
'(:sub-program
(,wrong-numargs
) (:int
100)))))))
4349 ((and max-args
(/= min-args max-args
) (= 0 min-args
))
4351 (if (< max-args
#x80
)
4352 `((:cmpb
,max-args
:cl
)
4353 (:ja
'(:sub-program
(,wrong-numargs
) (:int
100))))
4354 `((:cmpl
,(dpb max-args
(byte 24 8) #x80
) :ecx
)
4355 (:ja
'(:sub-program
(,wrong-numargs
) (:int
100))))))
4356 ((and max-args
(/= min-args max-args
))
4358 (append (if (< min-args
#x80
)
4359 `((:cmpb
,min-args
:cl
)
4360 (:jb
'(:sub-program
(,wrong-numargs
) (:int
100))))
4361 `((:cmpl
,(dpb min-args
(byte 24 8) #x80
) :ecx
)
4362 (:jb
'(:sub-program
(,wrong-numargs
) (:int
100)))))
4363 (if (< max-args
#x80
)
4364 `((:cmpb
,max-args
:cl
)
4365 (:ja
'(:sub-program
(,wrong-numargs
) (:int
100))))
4366 `((:cmpl
,(dpb max-args
(byte 24 8) #x80
) :ecx
)
4367 (:ja
'(:sub-program
(,wrong-numargs
) (:int
100)))))))
4368 (t (error "Don't know how to compile checking for ~A to ~A arguments."
4369 min-args max-args
)))))
4371 (defun make-stack-setup-code (stack-setup-size)
4372 (loop repeat stack-setup-size
4373 collect
'(:pushl
:edi
))
4375 (case stack-setup-size
4377 (1 '((:pushl
:edi
)))
4378 (2 '((:pushl
:edi
) (:pushl
:edi
)))
4379 (3 '((:pushl
:edi
) (:pushl
:edi
) (:pushl
:edi
)))
4380 (t `((:subl
,(* 4 stack-setup-size
) :esp
)))))
4382 (defun make-compiled-function-prelude (stack-frame-size env use-stack-frame-p
4383 need-normalized-ecx-p frame-map
4384 &key do-check-stack-p
)
4385 "The prelude is compiled after the function's body is."
4386 (when (without-function-prelude-p env
)
4387 (return-from make-compiled-function-prelude
4388 (when use-stack-frame-p
4392 (let ((required-vars (required-vars env
))
4393 (min-args (min-args env
))
4394 (max-args (max-args env
)))
4395 (let ((stack-setup-size stack-frame-size
)
4396 (edx-needs-saving-p (and (edx-var env
)
4397 (new-binding-location (edx-var env
) frame-map
:default nil
))))
4398 (multiple-value-bind (eax-ebx-code eax-ebx-code-post-stackframe
)
4399 (let* ((map0 (find-if (lambda (bb)
4400 (and (typep (car bb
) '(or required-function-argument
4401 optional-function-argument
))
4402 (= 0 (function-argument-argnum (car bb
)))))
4404 (location-0 (cdr map0
))
4405 (map1 (find-if (lambda (bb)
4406 (and (typep (car bb
) '(or required-function-argument
4407 optional-function-argument
))
4408 (= 1 (function-argument-argnum (car bb
)))))
4410 (location-1 (cdr map1
))
4413 (new-binding-location (edx-var env
) frame-map
:default nil
))))
4414 #+ignore
(warn "l0: ~S, l1: ~S" location-0 location-1
)
4415 (assert (not (and location-0
4416 (eql location-0 location-1
))) ()
4417 "Compiler bug: two bindings in same location.")
4419 ((and (eq :ebx location-0
) (eq :eax location-1
))
4420 `((:xchgl
:eax
:ebx
)))
4421 ((and (eql 1 location-0
) (eql 2 location-1
))
4422 (decf stack-setup-size
2)
4423 (when (eql 3 edx-location
)
4424 (decf stack-setup-size
1)
4425 (setf edx-needs-saving-p nil
))
4426 (let (before-code after-code
)
4431 (when (eql 3 edx-location
)
4433 ;; Keep pushing any sequentially following floating requireds.
4434 ;; NB: Fixed-floats are used in-place, e.g above the stack-frame,
4435 ;; so no need to worry about them.
4436 (loop with expected-location
= 2
4437 for var in
(cddr required-vars
)
4438 as binding
= (movitz-binding var env
)
4439 if
(and expected-location
4440 (typep binding
'floating-required-function-argument
)
4441 (new-binding-located-p binding frame-map
)
4442 (= expected-location
4443 (new-binding-location binding frame-map
)))
4444 do
(decf stack-setup-size
)
4445 and do
(incf expected-location
)
4446 and do
(setq need-normalized-ecx-p t
)
4448 `(:pushl
(:ebp
(:ecx
4)
4449 ,(* -
4 (1- (function-argument-argnum binding
)))))
4450 else do
(setf expected-location nil
)
4451 and do
(when (and (typep binding
'floating-required-function-argument
)
4452 (new-binding-located-p binding frame-map
))
4453 (setq need-normalized-ecx-p t
)
4457 `((:movl
(:ebp
(:ecx
4)
4458 ,(* -
4 (1- (function-argument-argnum binding
))))
4460 (:movl
:edx
(:ebp
,(stack-frame-offset
4461 (new-binding-location binding frame-map
)))))))))))
4462 (values before-code after-code
)))
4465 ((and (eq :ebx location-0
)
4467 (decf stack-setup-size
)
4469 (:xchgl
:eax
:ebx
)))
4470 ((and (eq :ebx location-0
)
4471 (eq :edx location-1
))
4477 (decf stack-setup-size
)
4479 (t (ecase location-0
4481 (:ebx
(assert (not location-1
))
4482 '((:movl
:eax
:ebx
)))
4483 (:edx
(assert (not edx-location
))
4484 '((:movl
:eax
:edx
))))))
4487 (decf stack-setup-size
)
4489 (t (ecase location-1
4491 (:edx
'((:movl
:ebx
:edx
)))
4492 (:eax
`((:movl
:ebx
:eax
)))))))))
4494 ((or (and (or (eql 1 location-0
)
4496 (eql 2 edx-location
))
4497 (and (not (integerp location-0
))
4498 (not (integerp location-1
))
4499 (eql 1 edx-location
)))
4500 (decf stack-setup-size
)
4501 (setf edx-needs-saving-p nil
)
4503 (loop for var in
(cddr required-vars
)
4504 as binding
= (movitz-binding var env
)
4505 when
(and (typep binding
'floating-required-function-argument
)
4506 (new-binding-located-p binding frame-map
))
4508 `((:movl
(:ebp
(:ecx
4)
4509 ,(* -
4 (1- (function-argument-argnum binding
))))
4511 (:movl
:edx
(:ebp
,(stack-frame-offset
4512 (new-binding-location binding frame-map
)))))
4514 (setq need-normalized-ecx-p t
))))))
4515 (assert (not (minusp stack-setup-size
)))
4516 (let ((stack-frame-init-code
4517 (append (when (and do-check-stack-p use-stack-frame-p
4518 *compiler-auto-stack-checks-p
*
4519 (not (without-check-stack-limit-p env
)))
4520 `((,*compiler-local-segment-prefix
*
4521 :bound
(:edi
,(global-constant-offset 'stack-bottom
)) :esp
)))
4522 (when use-stack-frame-p
4529 ((and (eql 1 min-args
)
4531 (append (make-compiled-function-prelude-numarg-check min-args max-args
)
4533 stack-frame-init-code
))
4534 ((and (eql 2 min-args
)
4536 (append (make-compiled-function-prelude-numarg-check min-args max-args
)
4538 stack-frame-init-code
))
4539 ((and (eql 3 min-args
)
4541 (append (make-compiled-function-prelude-numarg-check min-args max-args
)
4543 stack-frame-init-code
))
4544 (t (append stack-frame-init-code
4545 (make-compiled-function-prelude-numarg-check min-args max-args
))))
4546 '(start-stack-frame-setup)
4548 (make-stack-setup-code stack-setup-size
)
4549 (when need-normalized-ecx-p
4551 ;; normalize arg-count in ecx..
4552 ((and max-args
(= min-args max-args
))
4554 ((and max-args
(<= 0 min-args max-args
#x7f
))
4555 `((:andl
#x7f
:ecx
)))
4558 (t (let ((normalize (make-symbol "normalize-ecx"))
4559 (normalize-done (make-symbol "normalize-ecx-done")))
4561 (:js
'(:sub-program
(,normalize
)
4563 (:jmp
',normalize-done
)))
4565 ,normalize-done
))))))
4566 (when edx-needs-saving-p
4567 `((:movl
:edx
(:ebp
,(stack-frame-offset (new-binding-location (edx-var env
) frame-map
))))))
4568 eax-ebx-code-post-stackframe
4569 (loop for binding in
(potentially-lended-bindings env
)
4570 as lended-cons-position
= (getf (binding-lending binding
) :stack-cons-location
)
4571 as location
= (new-binding-location binding frame-map
:default nil
)
4572 when
(and (not (typep binding
'borrowed-binding
))
4573 lended-cons-position
4577 (required-function-argument
4578 ;; (warn "lend: ~W => ~W" binding lended-cons-position)
4579 (etypecase (operator location
)
4581 (warn "lending EAX..")
4583 (:ebp
,(stack-frame-offset lended-cons-position
))) ; cdr
4585 (:ebp
,(stack-frame-offset (1+ lended-cons-position
)))) ; car
4586 (:leal
(:ebp
1 ,(stack-frame-offset (1+ lended-cons-position
)))
4588 ((eql :argument-stack
)
4589 `((:movl
(:ebp
,(argument-stack-offset binding
)) :edx
)
4591 (:ebp
,(stack-frame-offset lended-cons-position
))) ; cdr
4593 (:ebp
,(stack-frame-offset (1+ lended-cons-position
)))) ; car
4594 (:leal
(:ebp
1 ,(stack-frame-offset (1+ lended-cons-position
)))
4597 (:ebp
,(argument-stack-offset binding
)))))
4599 `((:movl
(:ebp
,(stack-frame-offset location
))
4602 (:ebp
,(stack-frame-offset lended-cons-position
))) ; cdr
4604 (:ebp
,(stack-frame-offset (1+ lended-cons-position
)))) ; car
4605 (:leal
(:ebp
1 ,(stack-frame-offset (1+ lended-cons-position
)))
4608 (:ebp
,(stack-frame-offset location
)))))))
4610 ;; (warn "lend closure-binding: ~W => ~W" binding lended-cons-position)
4611 (etypecase (operator location
)
4612 ((eql :argument-stack
)
4613 `((:movl
(:edi
,(global-constant-offset 'unbound-function
)) :edx
)
4614 (:movl
:edi
(:ebp
,(stack-frame-offset lended-cons-position
))) ; cdr
4615 (:movl
:edx
(:ebp
,(stack-frame-offset (1+ lended-cons-position
)))) ; car
4616 (:leal
(:ebp
1 ,(stack-frame-offset (1+ lended-cons-position
))) :edx
)
4617 (:movl
:edx
(:ebp
,(argument-stack-offset binding
)))))
4619 `((:movl
(:edi
,(global-constant-offset 'unbound-function
)) :edx
)
4620 (:movl
:edi
(:ebp
,(stack-frame-offset lended-cons-position
))) ; cdr
4621 (:movl
:edx
(:ebp
,(stack-frame-offset (1+ lended-cons-position
)))) ; car
4622 (:leal
(:ebp
1 ,(stack-frame-offset (1+ lended-cons-position
))) :edx
)
4623 (:movl
:edx
(:ebp
,(stack-frame-offset location
)))))))
4625 (t (etypecase location
4626 ((eql :argument-stack
)
4627 `((:movl
:edi
(:ebp
,(stack-frame-offset lended-cons-position
))) ; cdr
4628 (:movl
:edi
(:ebp
,(stack-frame-offset (1+ lended-cons-position
)))) ; car
4629 (:leal
(:ebp
1 ,(stack-frame-offset (1+ lended-cons-position
))) :edx
)
4630 (:movl
:edx
(:ebp
,(argument-stack-offset binding
)))))
4632 `((:movl
:edi
(:ebp
,(stack-frame-offset lended-cons-position
))) ; cdr
4633 (:movl
:edi
(:ebp
,(stack-frame-offset (1+ lended-cons-position
)))) ; car
4634 (:leal
(:ebp
1 ,(stack-frame-offset (1+ lended-cons-position
))) :edx
)
4635 (:movl
:edx
(:ebp
,(stack-frame-offset location
))))))))))
4636 need-normalized-ecx-p
))))))
4638 (defparameter *restify-stats
* (make-hash-table :test
#'eql
))
4640 (defparameter *ll
* (make-array 20 :initial-element
0))
4641 (defparameter *xx
* (make-array 20))
4643 (defun install-arg-cmp (code have-normalized-ecx-p
)
4646 (if (not (and (listp i
) (eq :arg-cmp
(car i
))))
4648 (let ((arg-count (second i
)))
4650 (have-normalized-ecx-p
4651 `(:cmpl
,arg-count
:ecx
))
4653 `(:cmpb
,arg-count
:cl
))
4654 (t `(:cmpl
,(dpb arg-count
(byte 24 8) #x80
) :ecx
)))))))
4656 (defun make-function-arguments-init (funobj env
)
4657 "The arugments-init is compiled before the function's body is.
4658 Return arg-init-code, need-normalized-ecx-p."
4659 (when (without-function-prelude-p env
)
4660 (return-from make-function-arguments-init
4662 (let ((need-normalized-ecx-p nil
)
4663 (required-vars (required-vars env
))
4664 (optional-vars (optional-vars env
))
4665 (rest-var (rest-var env
))
4666 (key-vars (key-vars env
)))
4669 (loop for optional in optional-vars
4670 as optional-var
= (decode-optional-formal optional
)
4671 as binding
= (movitz-binding optional-var env
)
4672 as last-optional-p
= (and (null key-vars
)
4674 (= 1 (- (+ (length optional-vars
) (length required-vars
))
4675 (function-argument-argnum binding
))))
4676 as supplied-p-var
= (optional-function-argument-supplied-p-var binding
)
4677 as supplied-p-binding
= (movitz-binding supplied-p-var env
)
4678 as not-present-label
= (make-symbol (format nil
"optional-~D-not-present"
4679 (function-argument-argnum binding
)))
4680 and optional-ok-label
= (make-symbol (format nil
"optional-~D-ok"
4681 (function-argument-argnum binding
)))
4682 unless
(movitz-env-get optional-var
'ignore nil env nil
) ; XXX
4685 ((= 0 (function-argument-argnum binding
))
4686 `((:init-lexvar
,binding
:init-with-register
:eax
:init-with-type t
)))
4687 ((= 1 (function-argument-argnum binding
))
4688 `((:init-lexvar
,binding
:init-with-register
:ebx
:init-with-type t
)))
4689 (t `((:init-lexvar
,binding
))))
4690 when supplied-p-binding
4691 append
`((:init-lexvar
,supplied-p-binding
))
4693 (compiler-values-bind (&code init-code-edx
&producer producer
)
4694 (compiler-call #'compile-form
4695 :form
(optional-function-argument-init-form binding
)
4700 ((and (eq 'compile-self-evaluating producer
)
4701 (member (function-argument-argnum binding
) '(0 1)))
4702 ;; The binding is already preset with EAX or EBX.
4703 (check-type binding lexical-binding
)
4705 (when supplied-p-var
4706 `((:load-constant
,(movitz-read t
) :edx
)
4707 (:store-lexical
,supplied-p-binding
:edx
:type
(member t
))))
4708 `((:arg-cmp
,(function-argument-argnum binding
))
4709 (:ja
',optional-ok-label
))
4710 (compiler-call #'compile-form
4711 :form
(optional-function-argument-init-form binding
)
4714 :result-mode binding
)
4715 (when supplied-p-var
4716 `((:store-lexical
,supplied-p-binding
:edi
:type null
)))
4717 `(,optional-ok-label
)))
4718 ((eq 'compile-self-evaluating producer
)
4719 `(,@(when supplied-p-var
4720 `((:store-lexical
,supplied-p-binding
:edi
:type null
)))
4721 ,@(if (optional-function-argument-init-form binding
)
4722 (append init-code-edx
`((:store-lexical
,binding
:edx
:type t
)))
4723 `((:store-lexical
,binding
:edi
:type null
)))
4724 (:arg-cmp
,(function-argument-argnum binding
))
4725 (:jbe
',not-present-label
)
4726 ,@(case (function-argument-argnum binding
)
4727 (0 `((:store-lexical
,binding
:eax
:type t
)))
4728 (1 `((:store-lexical
,binding
:ebx
:type t
)))
4731 `((:movl
(:ebp
,(* 4 (- (1+ (function-argument-argnum binding
))
4732 -
1 (function-argument-argnum binding
))))
4734 (:store-lexical
,binding
:eax
:type t
)))
4735 (t (setq need-normalized-ecx-p t
)
4736 `((:movl
(:ebp
(:ecx
4)
4737 ,(* -
4 (1- (function-argument-argnum binding
))))
4739 (:store-lexical
,binding
:eax
:type t
))))))
4740 ,@(when supplied-p-var
4741 `((:movl
(:edi
,(global-constant-offset 't-symbol
)) :eax
)
4742 (:store-lexical
,supplied-p-binding
:eax
4743 :type
(eql ,(image-t-symbol *image
*)))))
4744 ,not-present-label
))
4745 (t `((:arg-cmp
,(function-argument-argnum binding
))
4746 (:jbe
',not-present-label
)
4747 ,@(when supplied-p-var
4748 `((:movl
(:edi
,(global-constant-offset 't-symbol
)) :eax
)
4749 (:store-lexical
,supplied-p-binding
:eax
4750 :type
(eql ,(image-t-symbol *image
*)))))
4751 ,@(case (function-argument-argnum binding
)
4752 (0 `((:store-lexical
,binding
:eax
:type t
)))
4753 (1 `((:store-lexical
,binding
:ebx
:type t
)))
4756 `((:movl
(:ebp
,(* 4 (- (1+ (function-argument-argnum binding
))
4757 -
1 (function-argument-argnum binding
))))
4759 (:store-lexical
,binding
:eax
:type t
)))
4760 (t (setq need-normalized-ecx-p t
)
4761 `((:movl
(:ebp
(:ecx
4)
4762 ,(* -
4 (1- (function-argument-argnum binding
))))
4764 (:store-lexical
,binding
:eax
:type t
))))))
4765 (:jmp
',optional-ok-label
)
4767 ,@(when supplied-p-var
4768 `((:store-lexical
,supplied-p-binding
:edi
:type null
)))
4769 ,@(when (and (= 0 (function-argument-argnum binding
))
4770 (not last-optional-p
))
4771 `((:pushl
:ebx
))) ; protect ebx
4772 ,@(if (optional-function-argument-init-form binding
)
4773 (append `((:shll
,+movitz-fixnum-shift
+ :ecx
)
4775 (when (= 0 (function-argument-argnum binding
))
4778 `((:store-lexical
,binding
:edx
:type t
))
4779 (when (= 0 (function-argument-argnum binding
))
4782 (:shrl
,+movitz-fixnum-shift
+ :ecx
)))
4783 (progn (error "Unsupported situation.")
4784 #+ignore
`((:store-lexical
,binding
:edi
:type null
))))
4785 ,@(when (and (= 0 (function-argument-argnum binding
))
4786 (not last-optional-p
))
4787 `((:popl
:ebx
))) ; protect ebx
4788 ,optional-ok-label
)))))
4790 (let* ((rest-binding (movitz-binding rest-var env
)))
4791 `((:init-lexvar
,rest-binding
4792 :init-with-register
:edx
4793 :init-with-type list
))))
4795 (play-with-keys key-vars
))
4796 (when (key-vars-p env
)
4797 ;; &key processing..
4798 (setq need-normalized-ecx-p t
)
4800 `((:declare-key-arg-set
,@(mapcar (lambda (k)
4802 (keyword-function-argument-keyword-name
4803 (movitz-binding (decode-keyword-formal k
) env
))))
4805 (make-immediate-move (* +movitz-fixnum-factor
+
4806 (rest-args-position env
))
4808 `((:call
(:edi
,(global-constant-offset 'decode-keyargs-default
))))
4809 (unless (allow-other-keys-p env
)
4810 `((:testl
:eax
:eax
)
4811 (:jnz
'(:sub-program
(unknown-keyword)
4813 (loop for key-var in key-vars
4814 as key-location upfrom
3 by
2
4816 (decode-keyword-formal key-var
)
4818 (movitz-binding key-var-name env
)
4819 as supplied-p-binding
=
4820 (when (optional-function-argument-supplied-p-var binding
)
4821 (movitz-binding (optional-function-argument-supplied-p-var binding
)
4823 as keyword-ok-label
= (make-symbol (format nil
"keyword-~A-ok" key-var-name
))
4825 ;; (not (movitz-constantp (optional-function-argument-init-form binding)))
4827 (append `((:init-lexvar
,binding
4828 :init-with-register
,binding
4830 :shared-reference-p t
))
4831 (when supplied-p-binding
4832 `((:init-lexvar
,supplied-p-binding
4833 :init-with-register
,supplied-p-binding
4835 :shared-reference-p t
)))
4836 (when (optional-function-argument-init-form binding
)
4837 `((:cmpl
:edi
(:ebp
,(stack-frame-offset (1+ key-location
))))
4838 (:jne
',keyword-ok-label
)
4839 ,@(compiler-call #'compile-form
4840 :form
(optional-function-argument-init-form binding
)
4843 :result-mode binding
)
4844 ,keyword-ok-label
)))
4848 (append (when supplied-p-var
4849 `((:init-lexvar
,supplied-p-binding
4850 :init-with-register
:edi
4851 :init-with-type null
)))
4852 (compiler-call #'compile-form
4853 :form
(list 'muerte.cl
:quote
4854 (eval-form (optional-function-argument-init-form binding
)
4860 ,(movitz-read (keyword-function-argument-keyword-name binding
)) :ecx
)
4861 (:load-lexical
,rest-binding
:ebx
)
4862 (:call
(:edi
,(global-constant-offset 'keyword-search
))))
4863 (when supplied-p-var
4864 `((:jz
',keyword-not-supplied-label
)
4865 (:movl
(:edi
,(global-constant-offset 't-symbol
)) :ebx
)
4866 (:store-lexical
,supplied-p-binding
:ebx
4867 :type
(eql ,(image-t-symbol *image
*)))
4868 ,keyword-not-supplied-label
))
4869 `((:init-lexvar
,binding
4870 :init-with-register
:eax
4871 :init-with-type t
)))))))
4872 need-normalized-ecx-p
)))
4874 (defun old-key-encode (vars &key
(size (ash 1 (integer-length (1- (length vars
)))))
4876 (assert (<= (length vars
) size
))
4879 (loop with h
= (make-array size
)
4881 for var in
(sort (copy-list vars
) #'<
4883 (mod (ldb byte
(movitz-sxhash (movitz-read v
)))
4885 do
(let ((pos (mod (ldb byte
(movitz-sxhash (movitz-read var
)))
4887 (loop while
(aref h pos
)
4889 (setf pos
(mod (1+ pos
) (length h
))))
4890 (setf (aref h pos
) var
))
4891 finally
(return (values (subseq h
0 (1+ (position-if-not #'null h
:from-end t
)))
4894 (define-condition key-encoding-failed
() ())
4896 (defun key-cuckoo (x shift table
&optional path old-position
)
4898 (error 'key-encoding-failed
)
4899 (let* ((pos1 (mod (ash (movitz-sxhash (movitz-read x
)) (- shift
))
4901 (pos2 (mod (ash (movitz-sxhash (movitz-read x
)) (- 0 shift
9))
4903 (pos (if (eql pos1 old-position
) pos2 pos1
))
4904 (kickout (aref table pos
)))
4905 (setf (aref table pos
)
4908 (key-cuckoo kickout shift table
(cons x path
) pos
)))))
4910 (defun key-encode (vars &key
(size (ash 1 (integer-length (1- (length vars
)))))
4912 (declare (ignore byte
))
4913 (assert (<= (length vars
) size
))
4916 (loop with table
= (make-array size
)
4917 for var in
(sort (copy-list vars
) #'<
4919 (mod (movitz-sxhash (movitz-read v
))
4921 do
(key-cuckoo var shift table
)
4923 (return (values table
4925 (count-if (lambda (v)
4926 (eq v
(aref table
(mod (ash (movitz-sxhash (movitz-read v
))
4931 (defun best-key-encode (vars)
4933 (loop with best-encoding
= nil
4936 for size
= (ash 1 (integer-length (1- (length vars
))))
4938 ;; from (length vars) to (+ 8 (ash 1 (integer-length (1- (length vars)))))
4939 while
(<= size
(max 16 (ash 1 (integer-length (1- (length vars
))))))
4940 do
(loop for shift from
0 to
9 by
3
4942 (multiple-value-bind (encoding crashes
)
4943 (key-encode vars
:size size
:shift shift
)
4944 (when (or (not best-encoding
)
4945 (< crashes best-crashes
)
4946 (and (= crashes best-crashes
)
4947 (or (< shift best-shift
)
4948 (and (= shift best-shift
)
4949 (< (length encoding
)
4950 (length best-encoding
))))))
4951 (setf best-encoding encoding
4953 best-crashes crashes
)))
4954 (key-encoding-failed ())))
4956 (unless best-encoding
4957 (warn "Key-encoding failed for ~S: ~S."
4960 (list (movitz-sxhash (movitz-read v
))
4961 (ldb (byte (+ 3 (integer-length (1- (length vars
)))) 0)
4962 (movitz-sxhash (movitz-read v
)))
4963 (ldb (byte (+ 3 (integer-length (1- (length vars
)))) 9)
4964 (movitz-sxhash (movitz-read v
)))))
4967 (warn "~D waste for ~S"
4968 (- (length best-encoding
)
4971 (return (values best-encoding best-shift best-crashes
)))))
4975 (defun play-with-keys (key-vars)
4977 (let* ((vars (mapcar #'decode-keyword-formal key-vars
)))
4978 (multiple-value-bind (encoding shift crashes
)
4979 (best-key-encode vars
)
4980 (when (or (plusp crashes
)
4981 #+ignore
(>= shift
3)
4982 (>= (- (length encoding
) (length vars
))
4984 (warn "KEY vars: ~S, crash ~D, shift ~D, waste: ~D hash: ~S"
4986 (- (length encoding
) (length vars
))
4988 (movitz-sxhash (movitz-read s
)))
4992 (defun make-special-funarg-shadowing (env function-body
)
4993 "Wrap function-body in a let, if we need to.
4994 We need to when the function's lambda-list binds a special variable,
4995 or when there's a non-dynamic-extent &rest binding."
4996 (if (without-function-prelude-p env
)
4999 (append (special-variable-shadows env
)
5001 (when (and (rest-var env
)
5002 (not (movitz-env-get (rest-var env
) 'dynamic-extent nil env nil
))
5003 (not (movitz-env-get (rest-var env
) 'ignore nil env nil
)))
5004 (movitz-env-load-declarations `((muerte.cl
:dynamic-extent
,(rest-var env
)))
5006 `((,(rest-var env
) (muerte.cl
:copy-list
,(rest-var env
))))))))
5007 (if (null shadowing
)
5009 `(muerte.cl
::let
,shadowing
,function-body
)))))
5011 (defun make-compiled-function-postlude (funobj env use-stack-frame-p
)
5012 (declare (ignore funobj env
))
5013 (let ((p '((:movl
(:ebp -
4) :esi
)
5015 (if use-stack-frame-p
5019 (defun complement-boolean-result-mode (mode)
5023 (:boolean-greater
:boolean-less-equal
)
5024 (:boolean-less
:boolean-greater-equal
)
5025 (:boolean-greater-equal
:boolean-less
)
5026 (:boolean-less-equal
:boolean-greater
)
5027 (:boolean-below
:boolean-above-equal
)
5028 (:boolean-above
:boolean-below-equal
)
5029 (:boolean-below-equal
:boolean-above
)
5030 (:boolean-above-equal
:boolean-below
)
5031 (:boolean-zf
=1 :boolean-zf
=0)
5032 (:boolean-zf
=0 :boolean-zf
=1)
5033 (:boolean-cf
=1 :boolean-cf
=0)
5034 (:boolean-cf
=0 :boolean-cf
=1)))
5036 (let ((args (cdr mode
)))
5039 (list :boolean-ecx
(second args
) (first args
)))
5040 (:boolean-branch-on-true
5041 (cons :boolean-branch-on-false args
))
5042 (:boolean-branch-on-false
5043 (cons :boolean-branch-on-true args
)))))))
5045 (defun make-branch-on-boolean (mode label
&key invert
)
5046 (list (ecase (if invert
(complement-boolean-result-mode mode
) mode
)
5047 (:boolean-greater
:jg
) ; ZF=0 and SF=OF
5048 (:boolean-greater-equal
:jge
) ; SF=OF
5049 (:boolean-less
:jl
) ; SF!=OF
5050 (:boolean-less-equal
:jle
) ; ZF=1 or SF!=OF
5051 (:boolean-below
:jb
)
5052 (:boolean-above
:ja
)
5053 (:boolean-below-equal
:jbe
)
5054 (:boolean-above-equal
:jae
)
5056 (:boolean-zf
=0 :jnz
)
5058 (:boolean-cf
=0 :jnc
)
5059 (:boolean-true
:jmp
))
5060 (list 'quote label
)))
5063 (defun make-cmov-on-boolean (mode src dst
&key invert
)
5064 (list (ecase (if invert
(complement-boolean-result-mode mode
) mode
)
5065 (:boolean-greater
:cmovg
) ; ZF=0 and SF=OF
5066 (:boolean-greater-equal
:cmovge
) ; SF=OF
5067 (:boolean-less
:cmovl
) ; SF!=OF
5068 (:boolean-less-equal
:cmovle
) ; ZF=1 or SF!=OF
5069 (:boolean-zf
=1 :cmovz
)
5070 (:boolean-zf
=0 :cmovnz
)
5071 (:boolean-cf
=1 :cmovc
)
5072 (:boolean-cf
=0 :cmovnc
))
5075 (defun return-satisfies-result-p (desired-result returns-provided
)
5076 (or (eq desired-result returns-provided
)
5077 (case desired-result
5079 ((:eax
:single-value
)
5080 (member returns-provided
'(:eax
:multiple-values
:single-value
)))
5082 (member returns-provided
'(:multiple-values
:function
)))
5084 (member returns-provided
+boolean-modes
+)))))
5086 (defun make-result-and-returns-glue (desired-result returns-provided
5088 &key
(type t
) provider really-desired
)
5089 "Returns new-code and new-returns-provided, and glue-side-effects-p."
5090 (declare (optimize (debug 3)))
5091 (case returns-provided
5093 ;; when CODE does a non-local exit, we certainly don't need any glue.
5094 (return-from make-result-and-returns-glue
5095 (values code
:non-local-exit
))))
5096 (multiple-value-bind (new-code new-returns-provided glue-side-effects-p
)
5097 (case (result-mode-type desired-result
)
5099 (case (result-mode-type returns-provided
)
5101 (if (eq desired-result returns-provided
)
5102 (values code returns-provided
)
5103 (values (append code
`((:load-lexical
,returns-provided
,desired-result
)))
5105 ((:eax
:multiple-values
)
5106 (values (append code
5107 `((:store-lexical
,desired-result
:eax
5108 :type
,(type-specifier-primary type
))))
5112 (values (append code
5113 `((:store-lexical
,desired-result
5114 ,(result-mode-type returns-provided
)
5115 :type
,(type-specifier-primary type
))))
5118 (:ignore
(values code
:nothing
))
5120 (let ((true (first (operands desired-result
)))
5121 (false (second (operands desired-result
))))
5122 (etypecase (operator returns-provided
)
5124 (if (equal (operands desired-result
)
5125 (operands returns-provided
))
5126 (values code desired-result
)
5128 ((eql :boolean-cf
=1)
5130 ((and (= -
1 true
) (= 0 false
))
5131 (values (append code
5132 `((:sbbl
:ecx
:ecx
)))
5133 '(:boolean-ecx -
1 0)))
5134 ((and (= 0 true
) (= -
1 false
))
5135 (values (append code
5138 '(:boolean-ecx
0 -
1)))
5139 (t (error "Don't know modes ~S => ~S." returns-provided desired-result
))))
5141 (make-result-and-returns-glue desired-result
5144 `((:leal
(:eax
,(- (image-nil-word *image
*)))
5149 :really-desired desired-result
)))))
5150 (:boolean-branch-on-true
5151 ;; (warn "rm :b-true with ~S." returns-provided)
5152 (etypecase (operator returns-provided
)
5153 ((member :boolean-branch-on-true
)
5154 (assert (eq (operands desired-result
) (operands returns-provided
)))
5155 (values code returns-provided
))
5156 ((member :eax
:multiple-values
)
5157 (values (append code
5159 (:jne
',(operands desired-result
))))
5161 ((member :ebx
:ecx
:edx
)
5162 (values (append code
5163 `((:cmpl
:edi
,returns-provided
)
5164 (:jne
',(operands desired-result
))))
5167 ;; no branch, nothing is nil is false.
5168 (values code desired-result
))
5169 ((member .
#.
+boolean-modes
+)
5170 (values (append code
5171 (list (make-branch-on-boolean returns-provided
(operands desired-result
))))
5174 (values (append code
5175 `((:load-lexical
,returns-provided
,desired-result
)))
5177 (constant-object-binding
5178 (values (if (eq *movitz-nil
* (constant-object returns-provided
))
5180 `((:jmp
',(operands desired-result
))))
5182 (:boolean-branch-on-false
5183 (etypecase (operator returns-provided
)
5184 ((member :boolean-branch-on-false
)
5185 (assert (eq (operands desired-result
)
5186 (operands returns-provided
)))
5187 (values code desired-result
))
5189 (values (append code
5190 `((:jmp
',(operands desired-result
))))
5192 ((member .
#.
+boolean-modes
+)
5193 (values (append code
5194 (list (make-branch-on-boolean returns-provided
(operands desired-result
)
5197 ((member :ebx
:ecx
:edx
)
5198 (values (append code
5199 `((:cmpl
:edi
,returns-provided
)
5200 (:je
',(operands desired-result
))))
5202 ((member :eax
:multiple-values
)
5203 (values (append code
5205 (:je
',(operands desired-result
))))
5208 (values (append code
5209 `((:load-lexical
,returns-provided
,desired-result
)))
5211 (constant-object-binding
5212 (values (if (not (eq *movitz-nil
* (constant-object returns-provided
)))
5214 `((:jmp
',(operands desired-result
))))
5216 (:untagged-fixnum-ecx
5217 (case (result-mode-type returns-provided
)
5218 (:untagged-fixnum-ecx
5219 (values code
:untagged-fixnum-ecx
))
5220 ((:eax
:single-value
:multiple-values
:function
)
5221 (values (append code
5222 `((,*compiler-global-segment-prefix
*
5223 :call
(:edi
,(global-constant-offset 'unbox-u32
)))))
5224 :untagged-fixnum-ecx
))
5226 ;; In theory (at least..) ECX can only hold non-pointers, so don't check.
5227 (values (append code
5228 `((:shrl
,+movitz-fixnum-shift
+ :ecx
)))
5229 :untagged-fixnum-ecx
))
5231 (values (append code
5232 `((:movl
,returns-provided
:eax
)
5233 (,*compiler-global-segment-prefix
*
5234 :call
(:edi
,(global-constant-offset 'unbox-u32
)))))
5235 :untagged-fixnum-ecx
))
5237 (values (append code
5238 `((:load-lexical
,returns-provided
:untagged-fixnum-ecx
)))
5239 :untagged-fixnum-ecx
))))
5240 ((:single-value
:eax
)
5242 ((eq returns-provided
:eax
)
5244 ((typep returns-provided
'lexical-binding
)
5245 (values (append code
`((:load-lexical
,returns-provided
:eax
)))
5247 (t (case (operator returns-provided
)
5248 (:untagged-fixnum-eax
5249 (values (append code
`((:shll
,+movitz-fixnum-shift
+ :eax
))) :eax
))
5251 (case (first (operands returns-provided
))
5252 (0 (values (append code
'((:movl
:edi
:eax
)))
5254 (t (values code
:eax
))))
5255 ((:single-value
:eax
:function
:multiple-values
)
5258 (values (append code
'((:movl
:edi
:eax
)))
5260 ((:ebx
:ecx
:edx
:edi
)
5261 (values (append code
`((:movl
,returns-provided
:eax
)))
5264 (let ((true-false (operands returns-provided
)))
5266 ((equal '(0 1) true-false
)
5267 (values (append code
`((:movl
(:edi
(:ecx
4) ,(global-constant-offset 'boolean-zero
))
5270 ((equal '(1 0) true-false
)
5271 (values (append code
`((:movl
(:edi
(:ecx
4) ,(global-constant-offset 'boolean-one
))
5274 (t (error "Don't know ECX mode ~S." returns-provided
)))))
5276 (values (append code
5277 `((:sbbl
:ecx
:ecx
) ; T => -1, NIL => 0
5278 (:movl
(:edi
(:ecx
4) ,(global-constant-offset 'not-not-nil
))
5282 ;; (warn "bool for ~S" returns-provided)
5283 (let ((boolean-false-label (make-symbol "boolean-false-label")))
5284 (values (append code
5285 '((:movl
:edi
:eax
))
5286 (if *compiler-use-cmov-p
*
5287 `(,(make-cmov-on-boolean returns-provided
5288 `(:edi
,(global-constant-offset 't-symbol
))
5291 `(,(make-branch-on-boolean returns-provided
5294 (:movl
(:edi
,(global-constant-offset 't-symbol
))
5296 ,boolean-false-label
)))
5298 ((:ebx
:ecx
:edx
:esp
:esi
)
5300 ((eq returns-provided desired-result
)
5301 (values code returns-provided
))
5302 ((typep returns-provided
'lexical-binding
)
5303 (values (append code
`((:load-lexical
,returns-provided
,desired-result
)))
5305 (t (case (operator returns-provided
)
5307 (values (append code
5308 `((:movl
:edi
,desired-result
)))
5310 ((:ebx
:ecx
:edx
:esp
)
5311 (values (append code
5312 `((:movl
,returns-provided
,desired-result
)))
5314 ((:eax
:single-value
:multiple-values
:function
)
5315 (values (append code
5316 `((:movl
:eax
,desired-result
)))
5319 (let ((true-false (operands returns-provided
)))
5321 ((equal '(0 1) true-false
)
5322 (values (append code
`((:movl
(:edi
(:ecx
4) ,(global-constant-offset 'boolean-zero
))
5325 ((equal '(1 0) true-false
)
5326 (values (append code
`((:movl
(:edi
(:ecx
4) ,(global-constant-offset 'boolean-one
))
5329 (t (error "Don't know ECX mode ~S." returns-provided
)))))
5331 ;;; (values (append code `((:movl (:edi (:ecx 4) ,(global-constant-offset 'boolean-zero))
5332 ;;; ,desired-result)))
5333 ;;; desired-result))
5335 ;;; (values (append code `((:movl (:edi (:ecx 4) ,(global-constant-offset 'boolean-one))
5336 ;;; ,desired-result)))
5337 ;;; desired-result))
5339 (values (append code
5341 (:movl
(:edi
(:ecx
4) ,(global-constant-offset 'not-not-nil
))
5345 ;; (warn "bool to ~S for ~S" desired-result returns-provided)
5346 (values (append code
5348 (*compiler-use-cmov-p
*
5349 `((:movl
:edi
,desired-result
)
5350 ,(make-cmov-on-boolean returns-provided
5351 `(:edi
,(global-constant-offset 't-symbol
))
5353 ((not *compiler-use-cmov-p
*)
5354 (let ((boolean-false-label (make-symbol "boolean-false-label")))
5355 `((:movl
:edi
,desired-result
)
5356 ,(make-branch-on-boolean returns-provided
5359 (:movl
(:edi
,(global-constant-offset 't-symbol
))
5361 ,boolean-false-label
)))))
5362 desired-result
))))))
5364 (typecase returns-provided
5365 ((member :push
) (values code
:push
))
5367 (values (append code
'((:pushl
:edi
)))
5369 ((member :single-value
:eax
:multiple-values
:function
)
5370 (values (append code
`((:pushl
:eax
)))
5372 ((member :ebx
:ecx
:edx
)
5373 (values (append code
`((:pushl
,returns-provided
)))
5376 (values (append code
`((:load-lexical
,returns-provided
:push
)))
5379 (case (operator returns-provided
)
5381 (values code returns-provided
))
5383 (values code
:values
))
5384 (t (values (make-result-and-returns-glue :eax returns-provided code
5387 ((:multiple-values
:function
)
5388 (case (operator returns-provided
)
5389 ((:multiple-values
:function
)
5390 (values code
:multiple-values
))
5392 (case (first (operands returns-provided
))
5393 (0 (values (append code
'((:movl
:edi
:eax
) (:xorl
:ecx
:ecx
) (:stc
)))
5395 (1 (values (append code
'((:clc
)))
5397 ((nil) (values code
:multiple-values
))
5398 (t (values (append code
5399 (make-immediate-move (first (operands returns-provided
)) :ecx
)
5401 :multiple-values
))))
5402 (t (values (append (make-result-and-returns-glue :eax
5407 :really-desired desired-result
)
5409 :multiple-values
)))))
5410 (unless new-returns-provided
5411 (multiple-value-setq (new-code new-returns-provided glue-side-effects-p
)
5412 (ecase (result-mode-type returns-provided
)
5414 (case (result-mode-type desired-result
)
5415 ((:eax
:ebx
:ecx
:edx
:push
:lexical-binding
)
5416 (values (append code
5417 `((:load-constant
,(constant-object returns-provided
)
5421 (make-result-and-returns-glue desired-result
:eax
5422 (make-result-and-returns-glue :eax returns-provided code
5425 :really-desired desired-result
)
5427 :provider provider
))
5428 (:untagged-fixnum-ecx
5429 (let ((fixnump (subtypep type
`(integer 0 ,+movitz-most-positive-fixnum
+))))
5432 (member (result-mode-type desired-result
) '(:eax
:ebx
:ecx
:edx
)))
5433 (values (append code
5434 `((:leal
((:ecx
,+movitz-fixnum-factor
+))
5435 ,(result-mode-type desired-result
))))
5438 (member (result-mode-type desired-result
) '(:eax
:single-value
)))
5439 (values (append code
5440 `((:call
(:edi
,(global-constant-offset 'box-u32-ecx
)))))
5442 (t (make-result-and-returns-glue
5444 (make-result-and-returns-glue :eax
:untagged-fixnum-ecx code
5446 :really-desired desired-result
5451 (:untagged-fixnum-eax
5452 (make-result-and-returns-glue desired-result
:eax
5453 (make-result-and-returns-glue :eax
:untagged-fixnum-eax code
5455 :really-desired desired-result
)
5456 :provider provider
)))))
5457 (assert new-returns-provided
()
5458 "Don't know how to match desired-result ~S with returns-provided ~S~@[ from ~S~]."
5459 (or really-desired desired-result
) returns-provided provider
)
5460 (values new-code new-returns-provided glue-side-effects-p
)))
5462 (define-compiler compile-form
(&all form-info
&result-mode result-mode
)
5463 "3.1.2.1 Form Evaluation. Guaranteed to honor RESULT-MODE."
5464 (compiler-values-bind (&all unprotected-values
&code form-code
&returns form-returns
5465 &producer producer
&type form-type
&functional-p functional-p
)
5466 (compiler-call #'compile-form-unprotected
:forward form-info
)
5467 (multiple-value-bind (new-code new-returns-provided glue-side-effects-p
)
5468 (make-result-and-returns-glue result-mode form-returns form-code
5471 (compiler-values (unprotected-values)
5473 :functional-p
(and functional-p
(not glue-side-effects-p
))
5476 :returns new-returns-provided
))))
5478 (define-compiler compile-form-selected
(&all form-info
&result-mode result-modes
)
5479 "3.1.2.1 Form Evaluation. Guaranteed to honor one of RESULT-MODE, which
5480 for this call (exclusively!) is a list of the acceptable result-modes, where
5481 the first one takes preference. Note that :non-local-exit might also be returned."
5482 (check-type result-modes list
"a list of result-modes")
5483 (compiler-values-bind (&all unprotected-values
&code form-code
&returns form-returns
5484 &producer producer
&type form-type
)
5485 (compiler-call #'compile-form-unprotected
5486 :result-mode
(car result-modes
)
5488 (if (member form-returns result-modes
)
5489 (compiler-values (unprotected-values))
5490 (compiler-call #'compile-form
5491 :result-mode
(car result-modes
)
5492 :forward form-info
))))
5494 (define-compiler compile-form-to-register
(&all form-info
)
5495 (compiler-values-bind (&all unprotected-values
&code form-code
&returns form-returns
5496 &final-form final-form
&producer producer
&type form-type
)
5497 (compiler-call #'compile-form-unprotected
5502 ((and (typep final-form
'required-function-argument
)
5503 (= 1 (function-argument-argnum final-form
)))
5504 (compiler-call #'compile-form
5506 :forward form-info
))
5507 ((member form-returns
'(:eax
:ebx
:ecx
:edx
:edi
:untagged-fixnum-ecx
))
5508 (compiler-values (unprotected-values)))
5509 (t (compiler-call #'compile-form
5511 :forward form-info
)))))
5513 (define-compiler compile-form-unprotected
(&all downstream
&form form
&result-mode result-mode
5515 "3.1.2.1 Form Evaluation. May not honor RESULT-MODE.
5516 That is, RESULT-MODE is taken to be a suggestion, not an imperative."
5517 (compiler-values-bind (&all upstream
)
5519 (symbol (compiler-call #'compile-symbol
:forward downstream
))
5520 (cons (compiler-call #'compile-cons
:forward downstream
))
5521 (t (compiler-call #'compile-self-evaluating
:forward downstream
)))
5522 (when (typep (upstream :final-form
) 'lexical-binding
)
5523 (labels ((fix-extent (binding)
5525 ((sub-env-p extent
(binding-extent-env binding
))
5526 #+ignore
(warn "Binding ~S OK in ~S wrt. ~S."
5528 (binding-extent-env binding
)
5530 (t #+ignore
(break "Binding ~S escapes from ~S to ~S"
5531 binding
(binding-extent-env binding
)
5533 (setf (binding-extent-env binding
) extent
)))
5534 (when (typep binding
'forwarding-binding
)
5535 (fix-extent (forwarding-binding-target binding
)))))
5537 (fix-extent (upstream :final-form
)))))
5538 (compiler-values (upstream))))
5540 (defun lambda-form-p (form)
5542 (eq 'muerte.cl
:lambda
(first form
))))
5544 (defun function-name-p (operator)
5545 (or (and (symbolp operator
) operator
)
5546 (setf-name operator
)))
5548 (define-compiler compile-cons
(&all all
&form form
&env env
)
5549 "3.1.2.1.2 Conses as Forms"
5550 (let ((operator (car form
)))
5551 (if (and (symbolp operator
) (movitz-special-operator-p operator
))
5552 (compiler-call (movitz-special-operator-compiler operator
) :forward all
)
5553 (let* ((compiler-macro-function (movitz-compiler-macro-function operator env
))
5554 (compiler-macro-expansion (and compiler-macro-function
5556 (funcall *movitz-macroexpand-hook
*
5557 compiler-macro-function
5560 (warn "Compiler-macro for ~S failed: ~A" operator c
)
5563 ((and compiler-macro-function
5564 (not (movitz-env-get operator
'notinline nil env
))
5565 (not (eq form compiler-macro-expansion
)))
5566 (compiler-call #'compile-form-unprotected
:forward all
:form compiler-macro-expansion
))
5567 ((movitz-constantp form env
)
5568 (compiler-call #'compile-constant-compound
:forward all
))
5569 ((lambda-form-p operator
) ; 3.1.2.1.2.4
5570 (compiler-call #'compile-lambda-form
:forward all
))
5573 ((movitz-special-operator-p operator
)
5574 (compiler-call (movitz-special-operator-compiler operator
) :forward all
))
5575 ((movitz-macro-function operator env
)
5576 (compiler-call #'compile-macro-form
:forward all
))
5577 ((movitz-operator-binding operator env
)
5578 (compiler-call #'compile-apply-lexical-funobj
:forward all
))
5579 (t (compiler-call #'compile-apply-symbol
:forward all
))))
5580 (t (error "Don't know how to compile compound form ~A" form
)))))))
5582 (define-compiler compile-compiler-macro-form
(&all all
&form form
&env env
)
5583 (compiler-call #'compile-form-unprotected
5585 :form
(funcall *movitz-macroexpand-hook
*
5586 (movitz-compiler-macro-function (car form
) env
)
5589 (define-compiler compile-macro-form
(&all all
&form form
&env env
)
5590 "3.1.2.1.2.2 Macro Forms"
5591 (let* ((operator (car form
))
5592 (macro-function (movitz-macro-function operator env
)))
5593 (compiler-call #'compile-form-unprotected
5595 :form
(funcall *movitz-macroexpand-hook
* macro-function form env
))))
5597 (define-compiler compile-lexical-macro-form
(&all all
&form form
&env env
)
5598 "Compiles MACROLET and SYMBOL-MACROLET forms."
5599 (compiler-call #'compile-form-unprotected
5601 :form
(funcall *movitz-macroexpand-hook
*
5602 (macro-binding-expander (movitz-operator-binding form env
))
5605 (defun like-compile-macroexpand-form (form env
)
5607 ;; (symbol (compile-macroexpand-symbol form funobj env top-level-p result-mode))
5608 (cons (like-compile-macroexpand-cons form env
))
5609 (t (values form nil
))))
5611 (defun like-compile-macroexpand-cons (form env
)
5612 "3.1.2.1.2 Conses as Forms"
5613 (let* ((operator (car form
))
5614 (notinline (movitz-env-get operator
'notinline nil env
))
5615 (compiler-macro-function (movitz-compiler-macro-function operator env
))
5616 (compiler-macro-expansion (and compiler-macro-function
5617 (funcall *movitz-macroexpand-hook
*
5618 compiler-macro-function
5621 ((and (not notinline
)
5622 compiler-macro-function
5623 (not (eq form compiler-macro-expansion
)))
5624 (values compiler-macro-expansion t
))
5627 ((movitz-macro-function operator env
)
5628 (values (funcall *movitz-macroexpand-hook
*
5629 (movitz-macro-function operator env
)
5635 (defun make-compiled-stack-restore (stack-displacement result-mode returns
)
5636 "Return the code required to reset the stack according to stack-displacement,
5637 result-mode, and returns (which specify the returns-mode of the immediately
5638 preceding code). As secondary value, returns the new :returns value."
5639 (flet ((restore-by-pop (scratch)
5640 (case stack-displacement
5641 (1 `((:popl
,scratch
)))
5642 (2 `((:popl
,scratch
) (:popl
,scratch
))))))
5643 (if (zerop stack-displacement
)
5644 (values nil returns
)
5645 (ecase (result-mode-type result-mode
)
5647 (values nil returns
))
5648 ((:multiple-values
:values
)
5651 (values `((:leal
(:esp
,(* 4 stack-displacement
)) :esp
))
5653 ((:single-value
:eax
:ebx
)
5654 (values `((:addl
,(* 4 stack-displacement
) :esp
))
5655 :multiple-values
)))) ; assume this addl will set CF=0
5656 ((:single-value
:eax
:ebx
:ecx
:edx
:push
:lexical-binding
:untagged-fixnum-ecx
5657 :boolean
:boolean-branch-on-false
:boolean-branch-on-true
)
5660 (values (or (restore-by-pop :eax
)
5661 `((:leal
(:esp
,(* 4 stack-displacement
)) :esp
))) ; preserve all flags
5664 (values (or (restore-by-pop :eax
)
5665 `((:addl
,(* 4 stack-displacement
) :esp
)))
5667 ((:multiple-values
:single-value
:eax
)
5668 (values (or (restore-by-pop :ebx
)
5669 `((:addl
,(* 4 stack-displacement
) :esp
)))
5672 (values (or (restore-by-pop :eax
)
5673 `((:addl
,(* 4 stack-displacement
) :esp
)))
5676 (define-compiler compile-apply-symbol
(&form form
&funobj funobj
&env env
5677 &result-mode result-mode
)
5678 "3.1.2.1.2.3 Function Forms"
5679 (destructuring-bind (operator &rest arg-forms
)
5681 #+ignore
(when (and (eq result-mode
:function
)
5682 (eq operator
(movitz-print (movitz-funobj-name funobj
))))
5683 (warn "Tail-recursive call detected."))
5684 (when (eq operator
'muerte.cl
::declare
)
5685 (break "Compiling funcall to ~S" 'muerte.cl
::declare
))
5686 (pushnew (cons operator muerte.cl
::*compile-file-pathname
*)
5687 (image-called-functions *image
*)
5689 (multiple-value-bind (arguments-code stack-displacement arguments-modifies
)
5690 (make-compiled-argument-forms arg-forms funobj env
)
5691 (multiple-value-bind (stack-restore-code new-returns
)
5692 (make-compiled-stack-restore stack-displacement result-mode
:multiple-values
)
5694 :returns new-returns
5696 :modifies arguments-modifies
5697 :code
(append arguments-code
5698 (if (and (not *compiler-relink-recursive-funcall
*)
5699 (eq (movitz-read operator
)
5700 (movitz-read (movitz-funobj-name funobj
)))) ; recursive?
5701 (make-compiled-funcall-by-esi (length arg-forms
))
5702 (make-compiled-funcall-by-symbol operator
(length arg-forms
) funobj
))
5703 stack-restore-code
))))))
5705 (define-compiler compile-apply-lexical-funobj
(&all all
&form form
&funobj funobj
&env env
5706 &result-mode result-mode
)
5707 "3.1.2.1.2.3 Function Forms"
5708 (destructuring-bind (operator &rest arg-forms
)
5710 (let ((binding (movitz-operator-binding operator env
)))
5711 (multiple-value-bind (arguments-code stack-displacement
)
5712 (make-compiled-argument-forms arg-forms funobj env
)
5713 (multiple-value-bind (stack-restore-code new-returns
)
5714 (make-compiled-stack-restore stack-displacement result-mode
:multiple-values
)
5716 :returns new-returns
5718 :code
(append arguments-code
5719 (if (eq funobj
(function-binding-funobj binding
))
5720 (make-compiled-funcall-by-esi (length arg-forms
)) ; call ourselves
5721 `((:call-lexical
,binding
,(length arg-forms
))))
5722 stack-restore-code
)))))))
5724 (defun make-compiled-funcall-by-esi (num-args)
5726 (1 `((:call
(:esi
,(slot-offset 'movitz-funobj
'code-vector%
1op
)))))
5727 (2 `((:call
(:esi
,(slot-offset 'movitz-funobj
'code-vector%
2op
)))))
5728 (3 `((:call
(:esi
,(slot-offset 'movitz-funobj
'code-vector%
3op
)))))
5729 (t (append (if (< num-args
#x80
)
5730 `((:movb
,num-args
:cl
))
5731 (make-immediate-move (dpb num-args
(byte 24 8) #x80
) :ecx
))
5732 ; call new ESI's code-vector
5733 `((:call
(:esi
,(slot-offset 'movitz-funobj
'code-vector
))))))))
5735 (defun make-compiled-funcall-by-symbol (apply-symbol num-args funobj
)
5736 (declare (ignore funobj
))
5737 (check-type apply-symbol symbol
)
5738 `((:load-constant
,(movitz-read apply-symbol
) :edx
) ; put function symbol in EDX
5739 (:movl
(:edx
,(slot-offset 'movitz-symbol
'function-value
))
5740 :esi
) ; load new funobj from symbol into ESI
5741 ,@(make-compiled-funcall-by-esi num-args
)))
5743 (defun make-compiled-funcall-by-funobj (apply-funobj num-args funobj
)
5744 (declare (ignore funobj
))
5745 (check-type apply-funobj movitz-funobj
)
5747 :returns
:multiple-values
5749 :code
`( ; put function funobj in ESI
5750 (:load-constant
,apply-funobj
:esi
)
5751 ,@(make-compiled-funcall-by-esi num-args
))))
5753 (defun make-compiled-argument-forms (argument-forms funobj env
)
5754 "Return code as primary value, and stack displacement as secondary value.
5755 Return the set of modified lexical bindings third. Fourth, a list of the individual
5756 compile-time types of each argument. Fifth: The combined functional-p."
5757 ;; (incf (aref *args* (min (length argument-forms) 9)))
5758 (case (length argument-forms
) ;; "optimized" versions for 0, 1, 2, and 3 aruments.
5759 (0 (values nil
0 nil
() t
))
5760 (1 (compiler-values-bind (&code code
&type type
&functional-p functional-p
)
5761 (compiler-call #'compile-form
5762 :form
(first argument-forms
)
5766 (values code
0 t
(list (type-specifier-primary type
)) functional-p
)))
5767 (2 (multiple-value-bind (code functional-p modified first-values second-values
)
5768 (make-compiled-two-forms-into-registers (first argument-forms
) :eax
5769 (second argument-forms
) :ebx
5771 (values code
0 modified
5772 (list (type-specifier-primary (compiler-values-getf first-values
:type
))
5773 (type-specifier-primary (compiler-values-getf second-values
:type
)))
5775 (t (let* ((arguments-self-evaluating-p t
)
5776 (arguments-are-load-lexicals-p t
)
5777 (arguments-lexical-variables ())
5778 (arguments-modifies nil
)
5779 (arguments-functional-p t
)
5780 (arguments-types nil
)
5784 (loop for form in
(nthcdr 2 argument-forms
)
5786 (compiler-values-bind (&code code
&producer producer
&modifies modifies
&type type
5787 &functional-p functional-p
)
5788 (compiler-call #'compile-form
5793 :with-stack-used
(post-incf stack-pos
))
5794 ;; (incf (stack-used arg-env))
5795 (unless functional-p
5796 (setf arguments-functional-p nil
))
5797 (push producer producers
)
5798 (push (type-specifier-primary type
)
5800 (setf arguments-modifies
5801 (modifies-union arguments-modifies modifies
))
5803 (compile-self-evaluating)
5804 (compile-lexical-variable
5805 (setf arguments-self-evaluating-p nil
)
5806 (assert (eq :load-lexical
(caar code
)) ()
5807 "comp-lex-var produced for ~S~% ~S" form code
)
5808 (pushnew (cadar code
) arguments-lexical-variables
))
5809 (t (setf arguments-self-evaluating-p nil
5810 arguments-are-load-lexicals-p nil
)))
5812 (multiple-value-bind (code01 functionalp01 modifies01 all0 all1
)
5813 (make-compiled-two-forms-into-registers (first argument-forms
) :eax
5814 (second argument-forms
) :ebx
5816 (unless functionalp01
5817 (setf arguments-functional-p nil
))
5818 (let ((final0 (compiler-values-getf all0
:final-form
))
5819 (final1 (compiler-values-getf all1
:final-form
))
5820 (types (list* (type-specifier-primary (compiler-values-getf all0
:type
))
5821 (type-specifier-primary (compiler-values-getf all1
:type
))
5822 (nreverse arguments-types
))))
5824 ((or arguments-self-evaluating-p
5825 (and (typep final0
'lexical-binding
)
5826 (typep final1
'lexical-binding
)))
5827 (values (append arguments-code code01
)
5829 (+ -
2 (length argument-forms
))
5832 arguments-functional-p
))
5833 ((and arguments-are-load-lexicals-p
5834 (typep final0
'(or lexical-binding movitz-object
))
5835 (typep final1
'(or lexical-binding movitz-object
)))
5836 (values (append arguments-code code01
)
5837 (+ -
2 (length argument-forms
))
5840 arguments-functional-p
))
5841 ((and arguments-are-load-lexicals-p
5842 (not (some (lambda (arg-binding)
5843 (code-uses-binding-p code01 arg-binding
:store t
:load nil
))
5844 arguments-lexical-variables
)))
5845 (values (append arguments-code code01
)
5846 (+ -
2 (length argument-forms
))
5849 arguments-functional-p
))
5850 (t ;; (warn "fail: ~S by ~S" argument-forms (nreverse producers))
5851 (let ((stack-pos 0))
5852 (values (append (compiler-call #'compile-form
5853 :form
(first argument-forms
)
5858 :with-stack-used
(post-incf stack-pos
))
5859 ;; (prog1 nil (incf (stack-used arg-env)))
5860 (compiler-call #'compile-form
5861 :form
(second argument-forms
)
5866 :with-stack-used
(post-incf stack-pos
))
5867 ;; (prog1 nil (incf (stack-used arg-env)))
5868 (loop for form in
(nthcdr 2 argument-forms
)
5870 (compiler-call #'compile-form
5875 :with-stack-used
(post-incf stack-pos
)))
5876 `((:movl
(:esp
,(* 4 (- (length argument-forms
) 1))) :eax
)
5877 (:movl
(:esp
,(* 4 (- (length argument-forms
) 2))) :ebx
)))
5878 ;; restore-stack.. don't mess up CF!
5879 (prog1 (length argument-forms
)
5880 #+ignore
(assert (= (length argument-forms
) (stack-used arg-env
))))
5881 (modifies-union modifies01 arguments-modifies
)
5883 arguments-functional-p
))))))))))
5885 (defun program-is-load-lexical-of-binding (prg)
5886 (and (not (cdr prg
))
5887 (instruction-is-load-lexical-of-binding (car prg
))))
5889 (defun instruction-is-load-lexical-of-binding (instruction)
5890 (and (listp instruction
)
5891 (eq :load-lexical
(car instruction
))
5892 (destructuring-bind (binding destination
&key
&allow-other-keys
)
5893 (operands instruction
)
5894 (values binding destination
))))
5896 (defun make-compiled-two-forms-into-registers (form0 reg0 form1 reg1 funobj env
)
5897 "Returns first: code that does form0 into reg0, form1 into reg1.
5898 second: whether code is functional-p,
5899 third: combined set of modified bindings
5900 fourth: all compiler-values for form0, as a list.
5901 fifth: all compiler-values for form1, as a list."
5902 (assert (not (eq reg0 reg1
)))
5903 (compiler-values-bind (&all all0
&code code0
&functional-p functional0
5904 &final-form final0
&type type0
)
5905 (compiler-call #'compile-form
5910 (compiler-values-bind (&all all1
&code code1
&functional-p functional1
5911 &final-form final1
&type type1
)
5912 (compiler-call #'compile-form
5918 ((and (typep final0
'binding
)
5919 (not (code-uses-binding-p code1 final0
:load nil
:store t
)))
5920 (append (compiler-call #'compile-form-unprotected
5922 :result-mode
:ignore
5926 `((:load-lexical
,final0
,reg0
:protect-registers
(,reg1
)))))
5927 ((program-is-load-lexical-of-binding code1
)
5928 (destructuring-bind (src dst
&key protect-registers shared-reference-p
)
5930 (assert (eq reg1 dst
))
5932 `((:load-lexical
,src
,reg1
5933 :protect-registers
,(union protect-registers
5935 :shared-reference-p
,shared-reference-p
)))))
5936 ;; XXX if we knew that code1 didn't mess up reg0, we could do more..
5937 (t #+ignore
(when (and (not (tree-search code1 reg0
))
5938 (not (tree-search code1
:call
)))
5939 (warn "got b: ~S ~S for ~S: ~{~&~A~}" form0 form1 reg0 code1
))
5940 (let ((binding (make-instance 'temporary-name
:name
(gensym "tmp-")))
5941 (xenv (make-local-movitz-environment env funobj
)))
5942 (movitz-env-add-binding xenv binding
)
5943 (append (compiler-call #'compile-form
5948 `((:init-lexvar
,binding
:init-with-register
,reg0
5949 :init-with-type
,(type-specifier-primary type0
)))
5950 (compiler-call #'compile-form
5955 `((:load-lexical
,binding
,reg0
))))))
5956 (and functional0 functional1
)
5958 (compiler-values-list (all0))
5959 (compiler-values-list (all1))))))
5961 (define-compiler compile-symbol
(&all all
&form form
&env env
&result-mode result-mode
)
5962 "3.1.2.1.1 Symbols as Forms"
5963 (if (movitz-constantp form env
)
5964 (compiler-call #'compile-self-evaluating
5966 :form
(eval-form form env
))
5967 (let ((binding (movitz-binding form env
)))
5969 ((typep binding
'lexical-binding
)
5970 #+ignore
(make-compiled-lexical-variable form binding result-mode env
)
5971 (compiler-call #'compile-lexical-variable
:forward all
))
5972 ((typep binding
'symbol-macro-binding
)
5973 (compiler-call #'compile-form-unprotected
5975 :form
(funcall *movitz-macroexpand-hook
*
5976 (macro-binding-expander (movitz-binding form env
)) form env
)))
5977 (t (compiler-call #'compile-dynamic-variable
:forward all
))))))
5979 (define-compiler compile-lexical-variable
(&form variable
&result-mode result-mode
&env env
)
5980 (let ((binding (movitz-binding variable env
)))
5981 (check-type binding lexical-binding
)
5982 (case (operator result-mode
)
5985 :final-form binding
))
5986 (t (compiler-values ()
5990 :functional-p t
)))))
5992 (defun make-compiled-lexical-load (binding result-mode
&rest key-args
)
5993 "Do what is necessary to load lexical binding <binding>."
5994 `((:load-lexical
,binding
,result-mode
,@key-args
)))
5996 (define-compiler compile-dynamic-variable
(&form form
&env env
&result-mode result-mode
)
5997 "3.1.2.1.1.2 Dynamic Variables"
5998 (if (eq :ignore result-mode
)
5999 (compiler-values ())
6000 (let ((binding (movitz-binding form env
)))
6003 (unless (movitz-env-get form
'special nil env
)
6004 (cerror "Compile like a special." "Undeclared variable: ~S." form
))
6010 :code
(if *compiler-use-into-unbound-protocol
*
6011 `((:load-constant
,form
:ebx
)
6012 (,*compiler-local-segment-prefix
*
6013 :call
(:edi
,(global-constant-offset 'dynamic-variable-lookup
)))
6016 (let ((not-unbound (gensym "not-unbound-")))
6017 `((:load-constant
,form
:ebx
)
6018 (,*compiler-local-segment-prefix
*
6019 :call
(:edi
,(global-constant-offset 'dynamic-variable-lookup
)))
6020 (,*compiler-local-segment-prefix
*
6021 :cmpl
:eax
(:edi
,(global-constant-offset 'unbound-value
)))
6022 (:jne
',not-unbound
)
6025 (t (check-type binding dynamic-binding
)
6031 :code
(if *compiler-use-into-unbound-protocol
*
6032 `((:load-constant
,form
:ebx
)
6033 (,*compiler-local-segment-prefix
*
6034 :call
(:edi
,(global-constant-offset 'dynamic-variable-lookup
)))
6037 (let ((not-unbound (gensym "not-unbound-")))
6038 `((:load-constant
,form
:ebx
)
6039 (,*compiler-local-segment-prefix
*
6040 :call
(:edi
,(global-constant-offset 'dynamic-variable-lookup
)))
6041 (,*compiler-local-segment-prefix
*
6042 :cmpl
:eax
(:edi
,(global-constant-offset 'unbound-value
)))
6043 (:jne
',not-unbound
)
6045 ,not-unbound
)))))))))
6047 (define-compiler compile-lambda-form
(&form form
&all all
)
6048 "3.1.2.2.4 Lambda Forms"
6049 (let ((lambda-expression (car form
))
6050 (lambda-args (cdr form
)))
6051 (compiler-call #'compile-form-unprotected
6053 :form
`(muerte.cl
:funcall
,lambda-expression
,@lambda-args
))))
6055 (define-compiler compile-constant-compound
(&all all
&form form
&env env
&top-level-p top-level-p
)
6056 (compiler-call #'compile-self-evaluating
6058 :form
(eval-form form env top-level-p
)))
6060 (defun register32-to-low8 (register)
6067 (defun make-immediate-move (value destination-register
)
6070 `((:xorl
,destination-register
,destination-register
)))
6071 ((= value
(image-nil-word *image
*))
6072 `((:movl
:edi
,destination-register
)))
6073 ((<= #x-80
(- value
(image-nil-word *image
*)) #x7f
)
6074 `((:leal
(:edi
,(- value
(image-nil-word *image
*))) ,destination-register
)))
6075 ((<= #x-80
(- value
(* 2 (image-nil-word *image
*))) #x7f
)
6076 `((:leal
(:edi
(:edi
1) ,(- value
(* 2 (image-nil-word *image
*)))) ,destination-register
)))
6077 ((<= #x-80
(- value
(* 3 (image-nil-word *image
*))) #x7f
)
6078 `((:leal
(:edi
(:edi
2) ,(- value
(* 3 (image-nil-word *image
*)))) ,destination-register
)))
6079 ((<= #x-80
(- value
(* 5 (image-nil-word *image
*))) #x7f
)
6080 `((:leal
(:edi
(:edi
4) ,(- value
(* 5 (image-nil-word *image
*)))) ,destination-register
)))
6081 ((<= #x-80
(- value
(* 9 (image-nil-word *image
*))) #x7f
)
6082 `((:leal
(:edi
(:edi
8) ,(- value
(* 9 (image-nil-word *image
*)))) ,destination-register
)))
6084 `((:xorl
,destination-register
,destination-register
)
6085 (:movb
,value
,(register32-to-low8 destination-register
))))
6086 (t `((:movl
,value
,destination-register
)))))
6088 (defparameter *prev-self-eval
* nil
)
6090 (define-compiler compile-self-evaluating
(&form form
&result-mode result-mode
&funobj funobj
)
6091 "3.1.2.1.3 Self-Evaluating Objects"
6092 (let* ((object form
)
6093 (movitz-obj (image-read-intern-constant *image
* object
))
6094 (funobj-env (funobj-env funobj
))
6095 (binding (or (cdr (assoc movitz-obj
(movitz-environment-bindings funobj-env
)))
6096 (let ((binding (make-instance 'constant-object-binding
6097 :name
(gensym "self-eval-")
6098 :object movitz-obj
)))
6099 (setf (binding-env binding
) funobj-env
)
6100 (push (cons movitz-obj binding
)
6101 (movitz-environment-bindings funobj-env
))
6103 (compiler-values-bind (&all self-eval
)
6104 (compiler-values (nil :abstract t
)
6105 :producer
(default-compiler-values-producer)
6106 :type
`(eql ,movitz-obj
)
6109 (case (operator result-mode
)
6111 (compiler-values (self-eval)
6114 (t (compiler-values (self-eval)
6115 :returns binding
))))))
6117 (define-compiler compile-implicit-progn
(&all all
&form forms
&top-level-p top-level-p
6118 &result-mode result-mode
)
6119 "Compile all the elements of the list <forms> as a progn."
6120 (check-type forms list
)
6121 (case (length forms
)
6122 (0 (compiler-values ()))
6123 (1 (compiler-call #'compile-form-unprotected
6125 :form
(first forms
)))
6126 (t (loop with no-side-effects-p
= t
6127 with progn-codes
= nil
6128 for
(sub-form . more-forms-p
) on forms
6129 as current-result-mode
= (if more-forms-p
:ignore result-mode
)
6130 do
(compiler-values-bind (&code code
&returns sub-returns-mode
6131 &functional-p no-sub-side-effects-p
6132 &type type
&final-form final-form
&producer sub-producer
)
6133 (compiler-call (if (not more-forms-p
)
6134 #'compile-form-unprotected
6138 :top-level-p top-level-p
6139 :result-mode current-result-mode
)
6140 (assert sub-returns-mode
()
6141 "~S produced no returns-mode for form ~S." sub-producer sub-form
)
6142 (unless no-sub-side-effects-p
6143 (setf no-side-effects-p nil
))
6144 (push (if (and no-sub-side-effects-p
(eq current-result-mode
:ignore
))
6148 (when (not more-forms-p
)
6149 (return (compiler-values ()
6150 :returns sub-returns-mode
6151 :functional-p no-side-effects-p
6152 :final-form final-form
6154 :code
(reduce #'append
(nreverse progn-codes
))))))))))
6157 (defun new-make-compiled-constant-reference (obj funobj
)
6158 (let ((movitz-obj (movitz-read obj
)))
6159 (if (eq movitz-obj
(image-t-symbol *image
*))
6160 (make-indirect-reference :edi
(global-constant-offset 't-symbol
))
6161 (etypecase movitz-obj
6163 (movitz-immediate-object (movitz-immediate-value movitz-obj
))
6165 (make-indirect-reference :esi
(movitz-funobj-intern-constant funobj movitz-obj
)))))))
6167 (defun make-compiled-lexical-control-transfer (return-code return-mode from-env to-env
6168 &optional
(to-label (exit-label to-env
)))
6169 "<return-code> running in <from-env> produces <return-mode>, and we need to
6170 generate code that transfers control (and unwinds dynamic bindings, runs unwind-protect
6171 cleanup-forms etc.) to <to-env> with <return-code>'s result intact."
6172 (check-type to-env lexical-exit-point-env
)
6173 (multiple-value-bind (stack-distance num-dynamic-slots unwind-protects
)
6174 (stack-delta from-env to-env
)
6175 (assert stack-distance
)
6176 (assert (null unwind-protects
) ()
6177 "Lexical unwind-protect not implemented, to-env: ~S. (this is not supposed to happen)"
6179 ;; (warn "dist: ~S, slots: ~S" stack-distance num-dynamic-slots)
6180 (assert (not (eq t num-dynamic-slots
)) ()
6181 "Don't know how to make lexical-control-transfer across unknown number of dynamic slots.")
6183 ((and (eq t stack-distance
)
6184 (eql 0 num-dynamic-slots
))
6186 :returns
:non-local-exit
6187 :code
(append return-code
6188 (unless (eq :function
(exit-result-mode to-env
))
6189 `((:load-lexical
,(movitz-binding (save-esp-variable to-env
) to-env nil
) :esp
)))
6190 `((:jmp
',to-label
)))))
6191 ((eq t stack-distance
)
6193 :returns
:non-local-exit
6194 :code
(append return-code
6195 (compiler-call #'special-operator-with-cloak
6197 :result-mode
(exit-result-mode to-env
)
6198 :form
`(muerte::with-cloak
(,return-mode
)
6199 (muerte::with-inline-assembly
(:returns
:nothing
)
6200 ;; Compute target dynamic-env
6201 (:locally
(:movl
(:edi
(:edi-offset dynamic-env
)) :eax
))
6202 ,@(loop repeat num-dynamic-slots
6203 collect
`(:movl
(:eax
12) :eax
))
6204 (:locally
(:call
(:edi
(:edi-offset dynamic-unwind-next
))))
6205 (:locally
(:movl
:eax
(:edi
(:edi-offset dynamic-env
))))
6206 (:jc
'(:sub-program
() (:int
63))))))
6207 `((:load-lexical
,(movitz-binding (save-esp-variable to-env
) to-env nil
) :esp
)
6208 (:jmp
',to-label
)))))
6209 ((zerop num-dynamic-slots
)
6211 :returns
:non-local-exit
6212 :code
(append return-code
6213 (make-compiled-stack-restore stack-distance
6214 (exit-result-mode to-env
)
6216 `((:jmp
',to-label
)))))
6217 ((plusp num-dynamic-slots
)
6218 ;; (warn "num-dynamic-slots: ~S, distance: ~D" num-dynamic-slots stack-distance)
6220 :returns
:non-local-exit
6221 :code
(append return-code
6222 (compiler-call #'special-operator-with-cloak
6224 :result-mode
(exit-result-mode to-env
)
6225 :form
`(muerte::with-cloak
(,return-mode
)
6226 (muerte::with-inline-assembly
(:returns
:nothing
)
6227 ;; Compute target dynamic-env
6228 (:locally
(:movl
(:edi
(:edi-offset dynamic-env
)) :eax
))
6229 ,@(loop repeat num-dynamic-slots
6230 collect
`(:movl
(:eax
12) :eax
))
6231 (:locally
(:call
(:edi
(:edi-offset dynamic-unwind-next
))))
6232 (:locally
(:movl
:eax
(:edi
(:edi-offset dynamic-env
))))
6233 (:jc
'(:sub-program
() (:int
63))))))
6234 `((:leal
(:esp
,(* 4 stack-distance
)) :esp
)
6235 (:jmp
',to-label
)))))
6236 (t (error "unknown!")))))
6238 (defun make-compiled-push-current-values ()
6239 "Return code that pushes the current values onto the stack, and returns
6240 in ECX the number of values (as fixnum)."
6241 (let ((not-single-value (gensym "not-single-value-"))
6242 (push-values-done (gensym "push-values-done-"))
6243 (push-values-loop (gensym "push-values-loop-")))
6244 `((:jc
',not-single-value
)
6247 (:jmp
',push-values-done
)
6249 (:shll
,+movitz-fixnum-shift
+ :ecx
)
6250 (:jz
',push-values-done
)
6255 (:je
',push-values-done
)
6259 (:je
',push-values-done
)
6261 (:locally
(:pushl
(:edi
(:edi-offset values
) :edx -
8)))
6264 (:jne
',push-values-loop
)
6265 ,push-values-done
)))
6267 (defun stack-add (x y
)
6268 (if (and (integerp x
) (integerp y
))
6272 (define-modify-macro stack-incf
(&optional
(delta 1)) stack-add
)
6274 (defun stack-delta (inner-env outer-env
)
6275 "Calculate the amount of stack-space used (in 32-bit stack slots) at the time
6276 of <inner-env> since <outer-env>,
6277 the number of intervening dynamic-slots (special bindings, unwind-protects, and catch-tags),
6278 and a list of any intervening unwind-protect environment-slots."
6280 ((find-stack-delta (env stack-distance num-dynamic-slots unwind-protects
)
6281 #+ignore
(warn "find-stack-delta: ~S dist ~S, slots ~S" env
6282 (stack-used env
) (num-dynamic-slots env
))
6285 ;; Each dynamic-slot is 4 stack-distances, so let's check that..
6286 (assert (or (eq t stack-distance
)
6287 (>= stack-distance
(* 4 num-dynamic-slots
))) ()
6288 "The stack-distance ~D is smaller than number of dynamic-slots ~D, which is inconsistent."
6289 stack-distance num-dynamic-slots
)
6290 (values stack-distance num-dynamic-slots unwind-protects
))
6293 (t (find-stack-delta (movitz-environment-uplink env
)
6294 (stack-add stack-distance
(stack-used env
))
6295 (stack-add num-dynamic-slots
(num-dynamic-slots env
))
6296 (if (typep env
'unwind-protect-env
)
6297 (cons env unwind-protects
)
6298 unwind-protects
))))))
6299 (find-stack-delta inner-env
0 0 nil
)))
6301 (defun print-stack-delta (inner-env outer-env
)
6302 (labels ((print-stack-delta (env)
6304 ((or (eq outer-env env
)
6306 (t (format t
"~&Env: ~S used: ~S, slots: ~S"
6307 env
(stack-used env
) (num-dynamic-slots env
))
6308 (print-stack-delta (movitz-environment-uplink env
))))))
6309 (print-stack-delta inner-env
)))
6312 ;;;;;;; Extended-code declarations
6315 (defvar *extended-code-find-read-binding
*
6316 (make-hash-table :test
#'eq
))
6318 (defvar *extended-code-find-used-bindings
*
6319 (make-hash-table :test
#'eq
))
6321 (defmacro define-find-read-bindings
(name lambda-list
&body body
)
6322 (let ((defun-name (intern
6323 (with-standard-io-syntax
6324 (format nil
"~A-~A" 'find-read-bindings name
)))))
6326 (setf (gethash ',name
*extended-code-find-read-binding
*) ',defun-name
)
6327 (defun ,defun-name
(instruction)
6328 (destructuring-bind ,lambda-list
6332 (defmacro define-find-used-bindings
(name lambda-list
&body body
)
6333 (let ((defun-name (intern
6334 (with-standard-io-syntax
6335 (format nil
"~A-~A" 'find-used-bindings name
)))))
6337 (setf (gethash ',name
*extended-code-find-used-bindings
*) ',defun-name
)
6338 (defun ,defun-name
(instruction)
6339 (destructuring-bind ,lambda-list
6343 (defun find-used-bindings (extended-instruction)
6344 "Return zero, one or two bindings that this instruction reads."
6345 (when (listp extended-instruction
)
6346 (let* ((operator (car extended-instruction
))
6347 (finder (or (gethash operator
*extended-code-find-used-bindings
*)
6348 (gethash operator
*extended-code-find-read-binding
*))))
6350 (let ((result (funcall finder extended-instruction
)))
6351 (check-type result list
"a list of read bindings")
6354 (defun find-read-bindings (extended-instruction)
6355 "Return zero, one or two bindings that this instruction reads."
6356 (when (listp extended-instruction
)
6357 (let* ((operator (car extended-instruction
))
6358 (finder (gethash operator
*extended-code-find-read-binding
*)))
6360 (funcall finder extended-instruction
)))))
6362 (defmacro define-find-write-binding-and-type
(name lambda-list
&body body
)
6363 (let ((defun-name (intern
6364 (with-standard-io-syntax
6365 (format nil
"~A-~A" 'find-write-binding-and-type name
)))))
6367 (setf (gethash ',name
*extended-code-find-write-binding-and-type
*) ',defun-name
)
6368 (defun ,defun-name
,lambda-list
,@body
))))
6370 (defun find-written-binding-and-type (extended-instruction)
6371 (when (listp extended-instruction
)
6372 (let* ((operator (car extended-instruction
))
6373 (finder (gethash operator
*extended-code-find-write-binding-and-type
*)))
6375 (funcall finder extended-instruction
)))))
6377 (defmacro define-extended-code-expander
(name lambda-list
&body body
)
6378 (let ((defun-name (intern
6379 (with-standard-io-syntax
6380 (format nil
"~A-~A" 'extended-code-expander- name
)))))
6382 (setf (gethash ',name
*extended-code-expanders
*) ',defun-name
)
6383 (defun ,defun-name
,lambda-list
,@body
))))
6385 (defun can-expand-extended-p (extended-instruction frame-map
)
6386 "Given frame-map, can we expand i at this point?"
6387 (and (every (lambda (b)
6388 (or (typep (binding-target b
) 'constant-object-binding
)
6389 (new-binding-located-p (binding-target b
) frame-map
)))
6390 (find-read-bindings extended-instruction
))
6391 (let ((written-binding (find-written-binding-and-type extended-instruction
)))
6392 (or (not written-binding
)
6393 (new-binding-located-p (binding-target written-binding
) frame-map
)))))
6395 (defun expand-extended-code (extended-instruction funobj frame-map
)
6396 (if (not (listp extended-instruction
))
6397 (list extended-instruction
)
6398 (let* ((operator (car extended-instruction
))
6399 (expander (gethash operator
*extended-code-expanders
*)))
6401 (list extended-instruction
)
6402 (let ((expansion (funcall expander extended-instruction funobj frame-map
)))
6404 (expand-extended-code e funobj frame-map
))
6407 (defun ensure-local-binding (binding funobj
)
6408 "When referencing binding in funobj, ensure we have the binding local to funobj."
6409 (if (typep binding
'(or (not binding
) constant-object-binding
))
6410 binding
; Never mind if "binding" isn't a binding, or is a constant-binding.
6411 (let ((target-binding (binding-target binding
)))
6413 ((eq funobj
(binding-funobj target-binding
))
6415 (t (or (find target-binding
(borrowed-bindings funobj
)
6416 :key
(lambda (binding)
6417 (borrowed-binding-target binding
)))
6418 (error "Can't install non-local binding ~W." binding
)))))))
6420 (defun binding-store-subtypep (binding type-specifier
)
6421 "Is type-specifier a supertype of all values ever stored to binding?
6422 (Assuming analyze-bindings has put this information into binding-store-type.)"
6423 (if (not (binding-store-type binding
))
6425 (multiple-value-call #'encoded-subtypep
6426 (values-list (binding-store-type binding
))
6427 (type-specifier-encode type-specifier
))))
6429 (defun binding-singleton (binding)
6430 (let ((btype (binding-store-type binding
)))
6432 (type-specifier-singleton (apply #'encoded-type-decode btype
)))))
6435 ;;;;;;; Extended-code handlers
6439 ;;;;;;;;;;;;;;;;;; Load-lexical
6441 (define-find-write-binding-and-type :load-lexical
(instruction)
6442 (destructuring-bind (source destination
&key
&allow-other-keys
)
6444 (when (typep destination
'binding
)
6445 (values destination t
#+ignore
(binding-type-specifier source
)
6446 (lambda (source-type)
6450 (define-find-read-bindings :load-lexical
(source destination
&key
&allow-other-keys
)
6451 (check-type source binding
)
6452 (values (list source
)
6453 (list destination
)))
6455 (define-extended-code-expander :load-lexical
(instruction funobj frame-map
)
6456 (destructuring-bind (source destination
&key shared-reference-p tmp-register protect-registers
)
6458 (make-load-lexical (ensure-local-binding source funobj
)
6459 (ensure-local-binding destination funobj
)
6460 funobj shared-reference-p frame-map
6461 :tmp-register tmp-register
6462 :protect-registers protect-registers
)))
6465 ;;;;;;;;;;;;;;;;;; Lisp-move
6467 (define-find-write-binding-and-type :lmove
(instruction)
6468 (destructuring-bind (source destination
)
6470 (values destination source
)))
6472 (define-find-read-bindings :lmove
(source destination
)
6473 (declare (ignore destination
))
6476 ;;;;;;;;;;;;;;;;;; Store-lexical
6478 (define-find-write-binding-and-type :store-lexical
(instruction)
6479 (destructuring-bind (destination source
&key
(type (error "No type")) &allow-other-keys
)
6481 (declare (ignore source
))
6482 (check-type destination binding
)
6483 (values destination type
)))
6485 (define-find-read-bindings :store-lexical
(destination source
&key
&allow-other-keys
)
6486 (declare (ignore destination
))
6487 (when (typep source
'binding
)
6490 (define-extended-code-expander :store-lexical
(instruction funobj frame-map
)
6491 (destructuring-bind (destination source
&key shared-reference-p type protect-registers
)
6493 (declare (ignore type
))
6494 (make-store-lexical (ensure-local-binding destination funobj
)
6495 (ensure-local-binding source funobj
)
6496 shared-reference-p funobj frame-map
6497 :protect-registers protect-registers
)))
6499 ;;;;;;;;;;;;;;;;;; Init-lexvar
6501 (define-find-write-binding-and-type :init-lexvar
(instruction)
6502 (destructuring-bind (binding &key init-with-register init-with-type
6503 protect-registers protect-carry
6506 (declare (ignore protect-registers protect-carry shared-reference-p
))
6510 ((not (typep init-with-register
'binding
))
6511 (assert init-with-type
)
6512 (values binding init-with-type
) )
6513 ((and init-with-type
(not (bindingp init-with-type
)))
6514 (values binding init-with-type
))
6515 ((and init-with-type
6516 (bindingp init-with-type
)
6517 (binding-store-type init-with-type
))
6518 (apply #'encoded-type-decode
(binding-store-type init-with-type
)))
6519 (t (values binding t
6521 (list init-with-register
)))))
6522 ((not (typep binding
'temporary-name
))
6523 (values binding t
)))))
6525 (define-find-read-bindings :init-lexvar
(binding &key init-with-register
&allow-other-keys
)
6526 (declare (ignore binding
))
6527 (when (typep init-with-register
'binding
)
6528 (list init-with-register
)))
6530 (define-extended-code-expander :init-lexvar
(instruction funobj frame-map
)
6531 (destructuring-bind (binding &key protect-registers protect-carry
6532 init-with-register init-with-type
6535 (declare (ignore protect-carry
)) ; nothing modifies carry anyway.
6536 ;; (assert (eq binding (ensure-local-binding binding funobj)))
6537 (assert (eq funobj
(binding-funobj binding
)))
6539 ((not (new-binding-located-p binding frame-map
))
6540 (unless (or (movitz-env-get (binding-name binding
) 'ignore nil
(binding-env binding
))
6541 (movitz-env-get (binding-name binding
) 'ignorable nil
(binding-env binding
)))))
6542 ((typep binding
'forwarding-binding
)
6543 ;; No need to do any initialization because the target will be initialized.
6544 (assert (not (binding-lended-p binding
)))
6546 (t (when (movitz-env-get (binding-name binding
) 'ignore nil
(binding-env binding
))
6547 (warn "Variable ~S used while declared ignored." (binding-name binding
)))
6550 ((typep binding
'rest-function-argument
)
6551 (assert (eq :edx init-with-register
))
6552 (assert (movitz-env-get (binding-name binding
)
6553 'dynamic-extent nil
(binding-env binding
))
6555 "&REST variable ~S must be dynamic-extent." (binding-name binding
))
6556 (setf (need-normalized-ecx-p (find-function-env (binding-env binding
)
6559 (let ((restify-alloca-loop (gensym "alloca-loop-"))
6560 (restify-done (gensym "restify-done-"))
6561 (restify-at-one (gensym "restify-at-one-"))
6562 (restify-loop (gensym "restify-loop-"))
6563 (save-ecx-p (key-vars-p (find-function-env (binding-env binding
)
6566 ;; (make-immediate-move (function-argument-argnum binding) :edx)
6567 ;; `((:call (:edi ,(global-constant-offset 'restify-dynamic-extent))))
6568 ;; Make space for (1+ (* 2 (- ECX rest-pos))) words on the stack.
6569 ;; Factor two is for one cons-cell per word, 1 is for 8-byte alignment.
6571 `((,*compiler-local-segment-prefix
*
6572 :movl
:ecx
(:edi
,(global-constant-offset 'raw-scratch0
)))))
6574 (:subl
,(function-argument-argnum binding
) :ecx
)
6575 (:jbe
',restify-done
)
6576 (:leal
((:ecx
8) 4) :edx
) ; EDX is fixnum counter
6577 ,restify-alloca-loop
6580 (:jnz
',restify-alloca-loop
)
6581 ,@(when *compiler-auto-stack-checks-p
*
6582 `((,*compiler-local-segment-prefix
*
6583 :bound
(:edi
,(global-constant-offset 'stack-bottom
)) :esp
)))
6584 (:leal
(:esp
5) :edx
)
6585 (:andl -
7 :edx
)) ; Make EDX a proper consp into the alloca area.
6587 ((= 0 (function-argument-argnum binding
))
6588 `((:movl
:eax
(:edx -
1))
6591 (:jz
',restify-done
)
6593 (:movl
:eax
(:eax -
5))))
6594 (t `((:movl
:edx
:eax
))))
6595 (when (>= 1 (function-argument-argnum binding
))
6596 `((:jmp
',restify-at-one
)))
6598 (:movl
(:ebp
(:ecx
4) 4) :ebx
)
6600 (:movl
:ebx
(:eax -
1))
6602 (:jz
',restify-done
)
6604 (:movl
:eax
(:eax -
5))
6605 (:jmp
',restify-loop
)
6608 `((,*compiler-local-segment-prefix
*
6609 :movl
(:edi
,(global-constant-offset 'raw-scratch0
)) :ecx
)))
6612 ((binding-lended-p binding
)
6613 (let* ((cons-position (getf (binding-lending binding
)
6614 :stack-cons-location
))
6615 (init-register (etypecase init-with-register
6616 ((or lexical-binding constant-object-binding
)
6617 (or (find-if (lambda (r)
6618 (not (member r protect-registers
)))
6620 (error "Unable to get a register.")))
6621 (keyword init-with-register
)
6623 (tmp-register (find-if (lambda (r)
6624 (and (not (member r protect-registers
))
6625 (not (eq r init-register
))))
6626 '(:edx
:ebx
:eax
))))
6627 (when init-with-register
6628 (assert (not (null init-with-type
))))
6629 (assert tmp-register
() ; solve this with push eax .. pop eax if ever needed.
6630 "Unable to find a tmp-register for ~S." instruction
)
6631 (append (when (typep init-with-register
'binding
)
6632 (make-load-lexical init-with-register init-register funobj
6633 shared-reference-p frame-map
6634 :protect-registers protect-registers
))
6635 `((:leal
(:ebp
,(1+ (stack-frame-offset (1+ cons-position
))))
6637 (:movl
:edi
(,tmp-register
3)) ; cdr
6638 (:movl
,init-register
(,tmp-register -
1)) ; car
6639 (:movl
,tmp-register
6640 (:ebp
,(stack-frame-offset
6641 (new-binding-location binding frame-map
))))))))
6642 ((typep init-with-register
'lexical-binding
)
6643 (make-load-lexical init-with-register binding funobj nil frame-map
))
6645 (make-store-lexical binding init-with-register nil funobj frame-map
))))))))
6647 ;;;;;;;;;;;;;;;;;; car
6649 (define-find-read-bindings :cons-get
(op cell dst
)
6650 (declare (ignore op dst protect-registers
))
6651 (when (typep cell
'binding
)
6654 (define-extended-code-expander :cons-get
(instruction funobj frame-map
)
6655 (destructuring-bind (op cell dst
)
6657 (check-type dst
(member :eax
:ebx
:ecx
:edx
))
6658 (multiple-value-bind (op-offset fast-op fast-op-ebx cl-op
)
6660 (:car
(values (bt:slot-offset
'movitz-cons
'car
)
6664 (:cdr
(values (bt:slot-offset
'movitz-cons
'cdr
)
6668 (let ((binding (binding-target (ensure-local-binding (binding-target cell
) funobj
))))
6670 (constant-object-binding
6671 (let ((x (constant-object binding
)))
6674 (make-load-constant *movitz-nil
* dst funobj frame-map
))
6676 (append (make-load-constant x dst funobj frame-map
)
6677 `((:movl
(,dst
,op-offset
) ,dst
))))
6678 (t `(,@(make-load-lexical binding
:eax funobj nil frame-map
)
6679 (,*compiler-global-segment-prefix
*
6680 :call
(:edi
,(global-constant-offset fast-op
)))
6681 ,@(when (not (eq dst
:eax
))
6682 `((:movl
:eax
,dst
))))))))
6684 (let ((location (new-binding-location (binding-target binding
) frame-map
))
6685 (binding-is-list-p (binding-store-subtypep binding
'list
)))
6686 #+ignore
(warn "~A of loc ~A bind ~A" op location binding
)
6688 ((and binding-is-list-p
6689 (member location
'(:eax
:ebx
:ecx
:edx
)))
6690 `((,*compiler-nonlocal-lispval-read-segment-prefix
*
6691 :movl
(,location
,op-offset
) ,dst
)))
6693 `(,@(make-load-lexical binding dst funobj nil frame-map
)
6694 (,*compiler-nonlocal-lispval-read-segment-prefix
*
6695 :movl
(,dst
,op-offset
) ,dst
)))
6696 ((not *compiler-use-cons-reader-segment-protocol-p
*)
6699 `((,*compiler-global-segment-prefix
*
6700 :call
(:edi
,(global-constant-offset fast-op-ebx
)))
6701 ,@(when (not (eq dst
:eax
))
6702 `((:movl
:eax
,dst
)))))
6703 (t `(,@(make-load-lexical binding
:eax funobj nil frame-map
)
6704 (,*compiler-global-segment-prefix
*
6705 :call
(:edi
,(global-constant-offset fast-op
)))
6706 ,@(when (not (eq dst
:eax
))
6707 `((:movl
:eax
,dst
)))))))
6709 ((member location
'(:ebx
:ecx
:edx
))
6710 `((,(or *compiler-cons-read-segment-prefix
*
6711 *compiler-nonlocal-lispval-read-segment-prefix
*)
6712 :movl
(:eax
,op-offset
) ,dst
)))
6713 (t (append (make-load-lexical binding
:eax funobj nil frame-map
)
6714 `((,(or *compiler-cons-read-segment-prefix
*
6715 *compiler-nonlocal-lispval-read-segment-prefix
*)
6716 :movl
(:eax
,op-offset
) ,dst
))))))))))))))
6719 ;;;;;;;;;;;;;;;;;; endp
6721 (define-find-read-bindings :endp
(cell result-mode
)
6722 (declare (ignore result-mode
))
6723 (when (typep cell
'binding
)
6726 (define-extended-code-expander :endp
(instruction funobj frame-map
)
6727 (destructuring-bind (cell result-mode
)
6729 (let ((binding (binding-target (ensure-local-binding (binding-target cell
) funobj
))))
6731 (constant-object-binding
6732 (let ((x (constant-object binding
)))
6735 (make-load-constant *movitz-nil
* result-mode funobj frame-map
))
6737 (make-load-constant (image-t-symbol *image
*) result-mode funobj frame-map
))
6740 (let* ((location (new-binding-location (binding-target binding
) frame-map
))
6741 (binding-is-list-p (binding-store-subtypep binding
'list
))
6742 (tmp-register (case location
6743 ((:eax
:ebx
:ecx
:edx
)
6745 ;; (warn "endp of loc ~A bind ~A" location binding)
6747 ((and binding-is-list-p
6748 (member location
'(:eax
:ebx
:ecx
:edx
)))
6749 (make-result-and-returns-glue result-mode
:boolean-zf
=1
6750 `((:cmpl
:edi
,location
))))
6751 ((eq :boolean-branch-on-true
(result-mode-type result-mode
))
6752 (let ((tmp-register (or tmp-register
:ecx
)))
6753 (append (make-load-lexical binding
6754 (cons :boolean-branch-on-false
6756 funobj nil frame-map
)
6757 (unless binding-is-list-p
6758 (append (make-load-lexical binding tmp-register funobj nil frame-map
)
6759 `((:leal
(,tmp-register -
1) :ecx
)
6761 (:jnz
'(:sub-program
(,(gensym "endp-not-list-"))
6763 (t (let ((tmp-register (or tmp-register
:eax
)))
6764 (append (make-load-lexical binding tmp-register funobj nil frame-map
)
6765 (unless binding-is-list-p
6766 `((:leal
(,tmp-register -
1) :ecx
)
6768 (:jnz
'(:sub-program
(,(gensym "endp-not-list-"))
6770 `((:cmpl
:edi
,tmp-register
))
6771 (make-result-and-returns-glue result-mode
:boolean-zf
=1)))))))))))
6774 ;;;;;;;;;;;;;;;;;; incf-lexvar
6776 (define-find-write-binding-and-type :incf-lexvar
(instruction)
6777 (destructuring-bind (binding delta
&key protect-registers
)
6779 (declare (ignore delta protect-registers
))
6780 (values binding
'integer
)))
6782 (define-find-read-bindings :incf-lexvar
(binding delta
&key protect-registers
)
6783 (declare (ignore delta protect-registers binding
))
6786 (define-extended-code-expander :incf-lexvar
(instruction funobj frame-map
)
6787 (break "incf-lexvar??")
6788 (destructuring-bind (binding delta
&key protect-registers
)
6790 (check-type binding binding
)
6791 (check-type delta integer
)
6792 (let* ((binding (binding-target binding
))
6793 (location (new-binding-location binding frame-map
:default nil
))
6794 (binding-type (binding-store-type binding
)))
6795 ;;; (warn "incf b ~A, loc: ~A, typ: ~A" binding location binding-type)
6799 (not (binding-lended-p binding
))
6800 (binding-store-subtypep binding
'integer
))
6801 ;; This is an optimized incf that doesn't have to do type-checking.
6802 (check-type location
(integer 1 *))
6803 `((:addl
,(* delta
+movitz-fixnum-factor
+)
6804 (:ebp
,(stack-frame-offset location
)))
6806 ((binding-store-subtypep binding
'integer
)
6807 (let ((register (chose-free-register protect-registers
)))
6808 `(,@(make-load-lexical (ensure-local-binding binding funobj
)
6809 register funobj nil frame-map
6810 :protect-registers protect-registers
)
6811 (:addl
,(* delta
+movitz-fixnum-factor
+) :eax
)
6813 ,@(make-store-lexical (ensure-local-binding binding funobj
)
6814 register nil funobj frame-map
6815 :protect-registers protect-registers
))))
6816 (t (let ((register (chose-free-register protect-registers
)))
6817 `(,@(make-load-lexical (ensure-local-binding binding funobj
)
6818 register funobj nil frame-map
6819 :protect-registers protect-registers
)
6820 (:testb
,+movitz-fixnum-zmask
+ ,(register32-to-low8 register
))
6821 (:jnz
'(:sub-program
(,(gensym "not-integer-"))
6824 (:addl
,(* delta
+movitz-fixnum-factor
+) ,register
)
6826 ,@(make-store-lexical (ensure-local-binding binding funobj
)
6827 register nil funobj frame-map
6828 :protect-registers protect-registers
))))))))
6832 (define-find-write-binding-and-type :load-constant
(instruction)
6833 (destructuring-bind (object result-mode
&key
(op :movl
))
6835 (when (and (eq op
:movl
) (typep result-mode
'binding
))
6836 (check-type result-mode lexical-binding
)
6837 (values result-mode
`(eql ,object
)))))
6839 (define-extended-code-expander :load-constant
(instruction funobj frame-map
)
6840 (destructuring-bind (object result-mode
&key
(op :movl
))
6842 (make-load-constant object result-mode funobj frame-map
:op op
)))
6846 (define-find-write-binding-and-type :add
(instruction)
6847 (destructuring-bind (term0 term1 destination
)
6849 (when (typep destination
'binding
)
6850 (assert (and (bindingp term0
) (bindingp term1
)))
6853 (lambda (type0 type1
)
6854 (let ((x (multiple-value-call #'encoded-integer-types-add
6855 (type-specifier-encode type0
)
6856 (type-specifier-encode type1
))))
6857 #+ignore
(warn "thunked: ~S ~S -> ~S" term0 term1 x
)
6862 (define-find-used-bindings :add
(term0 term1 destination
)
6863 (if (bindingp destination
)
6864 (list term0 term1 destination
)
6865 (list term0 term1
)))
6867 (define-find-read-bindings :add
(term0 term1 destination
)
6868 (declare (ignore destination
))
6869 (let* ((type0 (and (binding-store-type term0
)
6870 (apply #'encoded-type-decode
(binding-store-type term0
))))
6871 (type1 (and (binding-store-type term1
)
6872 (apply #'encoded-type-decode
(binding-store-type term1
))))
6873 (singleton0 (and type0
(type-specifier-singleton type0
)))
6874 (singleton1 (and type1
(type-specifier-singleton type1
)))
6875 (singleton-sum (and singleton0 singleton1
6876 (type-specifier-singleton
6877 (apply #'encoded-integer-types-add
6878 (append (binding-store-type term0
)
6879 (binding-store-type term1
)))))))
6882 (let ((b (make-instance 'constant-object-binding
6883 :name
(gensym "constant-sum")
6884 :object
(car singleton-sum
))))
6885 (movitz-env-add-binding (binding-env term0
) b
)
6887 (t (append (unless (and singleton0
(typep (car singleton0
) 'movitz-fixnum
))
6889 (unless (and singleton1
(typep (car singleton1
) 'movitz-fixnum
))
6892 (define-extended-code-expander :add
(instruction funobj frame-map
)
6893 (destructuring-bind (term0 term1 destination
)
6895 (assert (and (bindingp term0
)
6897 (member (result-mode-type destination
)
6898 '(:lexical-binding
:function
:multple-values
:eax
:ebx
:ecx
:edx
))))
6899 (let* ((destination (ensure-local-binding destination funobj
))
6900 (term0 (ensure-local-binding term0 funobj
))
6901 (term1 (ensure-local-binding term1 funobj
))
6902 (destination-location (if (or (not (bindingp destination
))
6903 (typep destination
'borrowed-binding
))
6905 (new-binding-location (binding-target destination
)
6908 (type0 (apply #'encoded-type-decode
(binding-store-type term0
)))
6909 (type1 (apply #'encoded-type-decode
(binding-store-type term1
)))
6910 (result-type (multiple-value-call #'encoded-integer-types-add
6911 (values-list (binding-store-type term0
))
6912 (values-list (binding-store-type term1
)))))
6913 ;; A null location means the binding is unused, in which
6914 ;; case there's no need to perform the addition.
6915 (when destination-location
6916 (let ((loc0 (new-binding-location (binding-target term0
) frame-map
:default nil
))
6917 (loc1 (new-binding-location (binding-target term1
) frame-map
:default nil
)))
6919 (warn "add: ~A for ~A" instruction result-type
)
6921 (warn "add for: ~S is ~A, from ~A/~A and ~A/~A."
6922 destination result-type
6926 (when (eql destination-location
9)
6927 (warn "add for: ~S/~S~%= ~A/~A in ~S~&~A/~A in ~S."
6928 destination destination-location
6929 term0 loc0
(binding-extent-env (binding-target term0
))
6930 term1 loc1
(binding-extent-env (binding-target term1
)))
6931 (print-code 'load-term1
(make-load-lexical term1
:eax funobj nil frame-map
))
6932 (print-code 'load-dest
(make-load-lexical destination
:eax funobj nil frame-map
)))
6933 (flet ((make-store (source destination
)
6935 ((eq source destination
)
6937 ((member destination
'(:eax
:ebx
:ecx
:edx
))
6938 `((:movl
,source
,destination
)))
6939 (t (make-store-lexical destination source nil funobj frame-map
))))
6940 (make-default-add ()
6941 (when (movitz-subtypep result-type
'(unsigned-byte 32))
6942 (warn "Defaulting u32 ADD: ~A/~S = ~A/~S + ~A/~S"
6943 destination-location
6948 ((type-specifier-singleton type0
)
6949 (append (make-load-lexical term1
:eax funobj nil frame-map
)
6950 (make-load-constant (car (type-specifier-singleton type0
))
6951 :ebx funobj frame-map
)))
6952 ((type-specifier-singleton type1
)
6953 (append (make-load-lexical term0
:eax funobj nil frame-map
)
6954 (make-load-constant (car (type-specifier-singleton type1
))
6955 :ebx funobj frame-map
)))
6956 ((and (eq :eax loc0
) (eq :ebx loc1
))
6958 ((and (eq :ebx loc0
) (eq :eax loc1
))
6959 nil
) ; terms order isn't important
6962 (make-load-lexical term0
:ebx funobj nil frame-map
)))
6964 (make-load-lexical term0
:eax funobj nil frame-map
)
6965 (make-load-lexical term1
:ebx funobj nil frame-map
))))
6966 `((:movl
(:edi
,(global-constant-offset '+)) :esi
))
6967 (make-compiled-funcall-by-esi 2)
6968 (etypecase destination
6970 (unless (eq destination
:eax
)
6971 `((:movl
:eax
,destination
))))
6973 (make-store-lexical destination
:eax nil funobj frame-map
))))))
6974 (let ((constant0 (let ((x (type-specifier-singleton type0
)))
6975 (when (and x
(typep (car x
) 'movitz-fixnum
))
6976 (movitz-immediate-value (car x
)))))
6977 (constant1 (let ((x (type-specifier-singleton type1
)))
6978 (when (and x
(typep (car x
) 'movitz-fixnum
))
6979 (movitz-immediate-value (car x
))))))
6981 ((type-specifier-singleton result-type
)
6982 ;; (break "constant add: ~S" instruction)
6983 (make-load-constant (car (type-specifier-singleton result-type
))
6984 destination funobj frame-map
))
6985 ((movitz-subtypep type0
'(integer 0 0))
6987 ((eql destination loc1
)
6988 #+ignore
(break "NOP add: ~S" instruction
)
6990 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
6991 (member loc1
'(:eax
:ebx
:ecx
:edx
)))
6992 `((:movl
,loc1
,destination-location
)))
6994 (make-load-lexical term1 destination funobj nil frame-map
))
6996 ((integerp destination-location
)
6997 (make-store-lexical destination-location loc1 nil funobj frame-map
))
6998 (t (break "Unknown X zero-add: ~S" instruction
))))
6999 ((movitz-subtypep type1
'(integer 0 0))
7000 ;; (warn "zero-add ~S => ~S [~S]" loc0 destination-location result-type)
7002 ((eql destination-location loc0
)
7003 #+ignore
(break "NOP add: ~S" instruction
)
7005 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
7006 (member loc0
'(:eax
:ebx
:ecx
:edx
)))
7007 `((:movl
,loc0
,destination-location
)))
7008 ((member loc0
'(:eax
:ebx
:ecx
:edx
))
7009 (make-store-lexical destination loc0 nil funobj frame-map
))
7011 (make-load-lexical term0 destination funobj nil frame-map
))
7012 (t (break "Unknown Y zero-add: ~S" instruction
))))
7013 ((and (movitz-subtypep type0
'fixnum
)
7014 (movitz-subtypep type1
'fixnum
)
7015 (movitz-subtypep result-type
'fixnum
))
7016 (assert (not (and constant0
(zerop constant0
))))
7017 (assert (not (and constant1
(zerop constant1
))))
7019 ((and (not (binding-lended-p (binding-target term0
)))
7020 (not (binding-lended-p (binding-target term1
)))
7021 (not (and (bindingp destination
)
7022 (binding-lended-p (binding-target destination
)))))
7025 (equal loc1 destination-location
))
7027 ((member destination-location
'(:eax
:ebx
:ecx
:edx
))
7028 `((:addl
,constant0
,destination-location
)))
7030 `((:addl
,constant0
(:ebp
,(stack-frame-offset loc1
)))))
7031 ((eq :argument-stack
(operator loc1
))
7033 (:ebp
,(argument-stack-offset (binding-target term1
))))))
7034 ((eq :untagged-fixnum-ecx
(operator loc1
))
7035 `((:addl
,(truncate constant0
+movitz-fixnum-factor
+) :ecx
)))
7036 (t (error "Don't know how to add this for loc1 ~S" loc1
))))
7038 (integerp destination-location
)
7039 (eql term1 destination-location
))
7041 `((:addl
,constant0
(:ebp
,(stack-frame-offset destination-location
)))))
7043 (integerp destination-location
)
7044 (member loc1
'(:eax
:ebx
:ecx
:edx
)))
7045 `((:addl
,constant0
,loc1
)
7046 (:movl
,loc1
(:ebp
,(stack-frame-offset destination-location
)))))
7047 ((and (integerp loc0
)
7049 (member destination-location
'(:eax
:ebx
:ecx
:edx
)))
7050 (append `((:movl
(:ebp
,(stack-frame-offset loc0
)) ,destination-location
)
7051 (:addl
(:ebp
,(stack-frame-offset loc1
)) ,destination-location
))))
7052 ((and (integerp destination-location
)
7053 (eql loc0 destination-location
)
7055 `((:addl
,constant1
(:ebp
,(stack-frame-offset destination-location
)))))
7056 ((and (integerp destination-location
)
7057 (eql loc1 destination-location
)
7059 `((:addl
,constant0
(:ebp
,(stack-frame-offset destination-location
)))))
7060 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
7061 (eq loc0
:untagged-fixnum-ecx
)
7063 `((:leal
((:ecx
,+movitz-fixnum-factor
+) ,constant1
)
7064 ,destination-location
)))
7065 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
7068 `((:movl
(:ebp
,(stack-frame-offset loc1
)) ,destination-location
)
7069 (:addl
,constant0
,destination-location
)))
7070 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
7073 `((:movl
(:ebp
,(stack-frame-offset loc0
)) ,destination-location
)
7074 (:addl
,constant1
,destination-location
)))
7075 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
7077 (member loc1
'(:eax
:ebx
:ecx
:edx
))
7078 (not (eq destination-location loc1
)))
7079 `((:movl
(:ebp
,(stack-frame-offset loc0
)) ,destination-location
)
7080 (:addl
,loc1
,destination-location
)))
7081 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
7083 (member loc1
'(:eax
:ebx
:ecx
:edx
)))
7084 `((:leal
(,loc1
,constant0
) ,destination-location
)))
7085 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
7087 (member loc0
'(:eax
:ebx
:ecx
:edx
)))
7088 `((:leal
(,loc0
,constant1
) ,destination-location
)))
7089 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
7091 (eq :argument-stack
(operator loc1
)))
7092 `((:movl
(:ebp
,(argument-stack-offset (binding-target term1
)))
7093 ,destination-location
)
7094 (:addl
,constant0
,destination-location
)))
7095 ((and (member destination-location
'(:eax
:ebx
:ecx
:edx
))
7097 (eq :argument-stack
(operator loc0
)))
7098 `((:movl
(:ebp
,(argument-stack-offset (binding-target term0
)))
7099 ,destination-location
)
7100 (:addl
,constant1
,destination-location
)))
7102 (append (make-load-lexical term1
:eax funobj nil frame-map
)
7103 `((:addl
,constant0
:eax
))
7104 (make-store :eax destination
)))
7106 (append (make-load-lexical term0
:eax funobj nil frame-map
)
7107 `((:addl
,constant1
:eax
))
7108 (make-store :eax destination
)))
7110 (append (make-load-lexical term0
:eax funobj nil frame-map
)
7111 `((:addl
:eax
:eax
))
7112 (make-store :eax destination
)))
7113 ((and (integerp loc0
)
7115 (integerp destination-location
)
7116 (/= loc0 loc1 destination-location
))
7117 `((:movl
(:ebp
,(stack-frame-offset loc0
))
7119 (:addl
(:ebp
,(stack-frame-offset loc1
))
7121 (:movl
:ecx
(:ebp
,(stack-frame-offset destination-location
)))))
7122 (t (warn "Unknown fixnum ADD: ~A/~S = ~A/~S + ~A/~S"
7123 destination-location
7127 #+ignore
(warn "map: ~A" frame-map
)
7128 ;;; (warn "ADDI: ~S" instruction)
7130 ((type-specifier-singleton type0
)
7131 (append (make-load-lexical term1
:eax funobj nil frame-map
)
7132 (make-load-constant (car (type-specifier-singleton type0
))
7133 :ebx funobj frame-map
)))
7134 ((type-specifier-singleton type1
)
7135 (append (make-load-lexical term0
:eax funobj nil frame-map
)
7136 (make-load-constant (car (type-specifier-singleton type1
))
7137 :ebx funobj frame-map
)))
7138 ((and (eq :eax loc0
) (eq :ebx loc1
))
7140 ((and (eq :ebx loc0
) (eq :eax loc1
))
7141 nil
) ; terms order isn't important
7144 (make-load-lexical term0
:ebx funobj nil frame-map
)))
7146 (make-load-lexical term0
:eax funobj nil frame-map
)
7147 (make-load-lexical term1
:ebx funobj nil frame-map
))))
7148 `((:movl
(:edi
,(global-constant-offset '+)) :esi
))
7149 (make-compiled-funcall-by-esi 2)
7150 (etypecase destination
7152 (unless (eq destination
:eax
)
7153 `((:movl
:eax
,destination
))))
7155 (make-store-lexical destination
:eax nil funobj frame-map
)))))))
7157 (integerp destination-location
)
7158 (eql loc1 destination-location
)
7159 (binding-lended-p (binding-target destination
)))
7160 (assert (binding-lended-p (binding-target term1
)))
7161 (append (make-load-lexical destination
:eax funobj t frame-map
)
7162 `((:addl
,constant0
(-1 :eax
)))))
7163 ((warn "~S" (list (and (bindingp destination
)
7164 (binding-lended-p (binding-target destination
)))
7165 (binding-lended-p (binding-target term0
))
7166 (binding-lended-p (binding-target term1
)))))
7167 (t (warn "Unknown fixnum add: ~S" instruction
)
7168 (make-default-add))))
7169 ((and (movitz-subtypep type0
'fixnum
)
7170 (movitz-subtypep type1
'fixnum
))
7171 (flet ((mkadd-into (src destreg
)
7172 (assert (eq destreg
:eax
) (destreg)
7173 "Movitz' INTO protocol says the overflowed value must be in EAX, ~
7174 but it's requested to be in ~S."
7176 (let ((srcloc (new-binding-location (binding-target src
) frame-map
)))
7177 (unless (eql srcloc loc1
) (break))
7178 (if (integerp srcloc
)
7179 `((:addl
(:ebp
,(stack-frame-offset srcloc
))
7182 (ecase (operator srcloc
)
7183 ((:eax
:ebx
:ecx
:edx
)
7184 `((:addl
,srcloc
,destreg
)
7187 `((:addl
(:ebx
,(argument-stack-offset src
))
7192 ((and (not constant0
)
7194 (not (binding-lended-p (binding-target term0
)))
7195 (not (binding-lended-p (binding-target term1
)))
7196 (not (and (bindingp destination
)
7197 (binding-lended-p (binding-target destination
)))))
7199 ((and (not (eq loc0
:untagged-fixnum-ecx
))
7200 (not (eq loc1
:untagged-fixnum-ecx
))
7201 (not (eq destination-location
:untagged-fixnum-ecx
)))
7203 ((and (eq loc0
:eax
) (eq loc1
:eax
))
7207 (mkadd-into term1
:eax
))
7209 (mkadd-into term0
:eax
))
7210 (t (append (make-load-lexical term0
:eax funobj nil frame-map
7211 :protect-registers
(list loc1
))
7212 (mkadd-into term1
:eax
))))
7213 (make-store :eax destination
)))
7214 (t (make-default-add)
7216 (append (make-load-lexical term0
:untagged-fixnum-ecx funobj nil frame-map
)
7217 `((,*compiler-local-segment-prefix
*
7218 :movl
:ecx
(:edi
,(global-constant-offset 'raw-scratch0
))))
7219 (make-load-lexical term1
:untagged-fixnum-ecx funobj nil frame-map
)
7220 `((,*compiler-local-segment-prefix
*
7221 :addl
(:edi
,(global-constant-offset 'raw-scratch0
)) :ecx
))
7222 (if (integerp destination-location
)
7223 `((,*compiler-local-segment-prefix
*
7224 :call
(:edi
,(global-constant-offset 'box-u32-ecx
)))
7225 (:movl
:eax
(:ebp
,(stack-frame-offset destination-location
))))
7226 (ecase (operator destination-location
)
7227 ((:untagged-fixnum-ecx
)
7230 `((,*compiler-local-segment-prefix
*
7231 :call
(:edi
,(global-constant-offset 'box-u32-ecx
)))))
7233 `((,*compiler-local-segment-prefix
*
7234 :call
(:edi
,(global-constant-offset 'box-u32-ecx
)))
7235 (:movl
:eax
,destination-location
)))
7237 `((,*compiler-local-segment-prefix
*
7238 :call
(:edi
,(global-constant-offset 'box-u32-ecx
)))
7239 (:movl
:eax
(:ebp
,(argument-stack-offset
7240 (binding-target destination
))))))))))))
7241 (t (make-default-add)))))
7242 (t (make-default-add))))))))))
7246 (define-find-read-bindings :eql
(x y mode
)
7247 (declare (ignore mode
))
7250 (define-extended-code-expander :eql
(instruction funobj frame-map
)
7251 (destructuring-bind (x y return-mode
)
7253 (let* ((x-type (apply #'encoded-type-decode
(binding-store-type x
)))
7254 (y-type (apply #'encoded-type-decode
(binding-store-type y
)))
7255 (x-singleton (type-specifier-singleton x-type
))
7256 (y-singleton (type-specifier-singleton y-type
)))
7257 (when (and y-singleton
(not x-singleton
))
7259 (rotatef x-type y-type
)
7260 (rotatef x-singleton y-singleton
))
7261 (let (#+ignore
(x-loc (new-binding-location (binding-target x
) frame-map
:default nil
))
7262 (y-loc (new-binding-location (binding-target y
) frame-map
:default nil
)))
7264 (warn "eql ~S/~S xx~Xxx ~S/~S: ~S"
7265 x x-loc
(binding-target y
)
7268 (flet ((make-branch ()
7269 (ecase (operator return-mode
)
7270 (:boolean-branch-on-false
7271 `((:jne
',(operands return-mode
))))
7272 (:boolean-branch-on-true
7273 `((:je
',(operands return-mode
))))
7275 (make-load-eax-ebx ()
7277 (make-load-lexical x
:ebx funobj nil frame-map
)
7278 (append (make-load-lexical x
:eax funobj nil frame-map
)
7279 (make-load-lexical y
:ebx funobj nil frame-map
)))))
7281 ((and x-singleton y-singleton
)
7282 (let ((eql (etypecase (car x-singleton
)
7283 (movitz-immediate-object
7284 (and (typep (car y-singleton
) 'movitz-immediate-object
)
7285 (eql (movitz-immediate-value (car x-singleton
))
7286 (movitz-immediate-value (car y-singleton
))))))))
7287 (case (operator return-mode
)
7288 (:boolean-branch-on-false
7290 `((:jmp
',(operands return-mode
)))))
7291 (t (break "Constant EQL: ~S ~S" (car x-singleton
) (car y-singleton
))))))
7293 (eq :untagged-fixnum-ecx y-loc
))
7294 (let ((value (etypecase (car x-singleton
)
7296 (movitz-fixnum-value (car x-singleton
)))
7298 (movitz-bignum-value (car x-singleton
))))))
7299 (check-type value
(unsigned-byte 32))
7300 `((:cmpl
,value
:ecx
)
7303 (typep (car x-singleton
) '(or movitz-immediate-object movitz-null
)))
7304 (let ((value (if (typep (car x-singleton
) 'movitz-null
)
7306 (movitz-immediate-value (car x-singleton
)))))
7309 (member y-loc
'(:eax
:ebx
:ecx
:edx
)))
7310 `((:testl
,y-loc
,y-loc
)))
7311 ((and (member y-loc
'(:eax
:ebx
:ecx
:edx
))
7312 (not (binding-lended-p y
)))
7313 `((:cmpl
,value
,y-loc
)))
7314 ((and (integerp y-loc
)
7315 (not (binding-lended-p y
)))
7316 `((:cmpl
,value
(:ebp
,(stack-frame-offset y-loc
)))))
7317 ((and (eq :argument-stack
(operator y-loc
))
7318 (not (binding-lended-p y
)))
7319 `((:cmpl
,value
(:ebp
,(argument-stack-offset (binding-target y
))))))
7320 (t (break "x-singleton: ~S with loc ~S"
7321 (movitz-immediate-value (car x-singleton
))
7325 (typep (car x-singleton
) 'movitz-symbol
)
7326 (member y-loc
'(:eax
:ebx
:edx
)))
7327 (append (make-load-constant (car x-singleton
) y-loc funobj frame-map
:op
:cmpl
)
7330 (break "y-singleton"))
7331 ((and (not (eq t x-type
)) ; this is for bootstrapping purposes.
7332 (not (eq t y-type
)) ; ..
7333 (or (movitz-subtypep x-type
'(or fixnum character symbol vector
))
7334 (movitz-subtypep y-type
'(or fixnum character symbol vector
))))
7335 (append (make-load-eax-ebx)
7336 `((:cmpl
:eax
:ebx
))
7339 ((warn "eql ~S/~S ~S/~S"
7342 ((eq :boolean-branch-on-false
(operator return-mode
))
7343 (let ((eql-done (gensym "eql-done-"))
7344 (on-false-label (operands return-mode
)))
7345 (append (make-load-eax-ebx)
7348 (,*compiler-global-segment-prefix
*
7349 :movl
(:edi
,(global-constant-offset 'complicated-eql
)) :esi
)
7350 (:call
(:esi
,(bt:slot-offset
'movitz-funobj
'code-vector%
2op
)))
7351 (:jne
',on-false-label
)
7353 ((eq :boolean-branch-on-true
(operator return-mode
))
7354 (let ((on-true-label (operands return-mode
)))
7355 (append (make-load-eax-ebx)
7357 (:je
',on-true-label
)
7358 (,*compiler-global-segment-prefix
*
7359 :movl
(:edi
,(global-constant-offset 'complicated-eql
)) :esi
)
7360 (:call
(:esi
,(bt:slot-offset
'movitz-funobj
'code-vector%
2op
)))
7361 (:je
',on-true-label
)))))
7362 ((eq return-mode
:boolean-zf
=1)
7363 (append (make-load-eax-ebx)
7364 (let ((eql-done (gensym "eql-done-")))
7367 (,*compiler-global-segment-prefix
*
7368 :movl
(:edi
,(global-constant-offset 'complicated-eql
)) :esi
)
7369 (:call
(:esi
,(bt:slot-offset
'movitz-funobj
'code-vector%
2op
)))
7371 (t (error "unknown eql: ~S" instruction
))))))))
7373 (define-find-read-bindings :load-lambda
(lambda-binding result-mode capture-env
)
7374 (declare (ignore result-mode capture-env
))
7375 (let ((allocation (movitz-allocation (function-binding-funobj lambda-binding
))))
7376 (when (typep allocation
'with-dynamic-extent-scope-env
)
7377 (values (list (base-binding allocation
))
7380 (define-find-write-binding-and-type :enter-dynamic-scope
(instruction)
7381 (destructuring-bind (scope-env)
7383 (if (null (dynamic-extent-scope-members scope-env
))
7385 (values (base-binding scope-env
) 'fixnum
))))
7387 (define-extended-code-expander :enter-dynamic-scope
(instruction funobj frame-map
)
7388 (declare (ignore funobj frame-map
))
7389 (destructuring-bind (scope-env)
7391 (if (null (dynamic-extent-scope-members scope-env
))
7393 (append `((:pushl
:edi
)
7397 (loop for object in
(reverse (dynamic-extent-scope-members scope-env
))
7404 (append (unless (zerop (mod (sizeof object
) 8))
7406 `((:load-constant
,object
:eax
))
7407 (loop for i from
(1- (movitz-funobj-num-constants object
))
7408 downto
(movitz-funobj-num-jumpers object
)
7409 collect
`(:pushl
(:eax
,(slot-offset 'movitz-funobj
'constant0
)
7411 (loop repeat
(movitz-funobj-num-jumpers object
)
7412 collect
`(:pushl
0))
7413 `((:pushl
(:eax
,(slot-offset 'movitz-funobj
'num-jumpers
)))
7414 (:pushl
(:eax
,(slot-offset 'movitz-funobj
'name
)))
7415 (:pushl
(:eax
,(slot-offset 'movitz-funobj
'lambda-list
)))
7420 (:pushl
2) ; (default) 2 is recognized by map-header-vals as non-initialized funobj.
7422 (:pushl
(:eax
,(slot-offset 'movitz-funobj
'type
)))
7423 (:leal
(:esp
,(tag :other
)) :ebx
)
7424 (,*compiler-local-segment-prefix
*
7425 :call
(:edi
,(global-constant-offset 'copy-funobj-code-vector-slots
)))
7428 ;;;(define-extended-code-expander :exit-dynamic-scope (instruction funobj frame-map)
7431 (define-find-read-bindings :lexical-control-transfer
(return-code return-mode from-env to-env
7433 (declare (ignore return-code return-mode to-label
))
7434 (let ((distance (stack-delta from-env to-env
)))
7435 (when (eq t distance
)
7436 (values (list (movitz-binding (save-esp-variable to-env
) to-env nil
))
7439 (define-find-read-bindings :stack-cons
(proto-cons scope-env
)
7440 (declare (ignore proto-cons
))
7441 (values (list (base-binding scope-env
))
7444 (define-extended-code-expander :stack-cons
(instruction funobj frame-map
)
7445 (destructuring-bind (proto-cons dynamic-scope
)
7447 (append (make-load-lexical (base-binding dynamic-scope
) :edx
7448 funobj nil frame-map
)
7449 `((:movl
:eax
(:edx
,(dynamic-extent-object-offset dynamic-scope proto-cons
)))
7450 (:movl
:ebx
(:edx
,(+ 4 (dynamic-extent-object-offset dynamic-scope proto-cons
))))
7451 (:leal
(:edx
,(+ (tag :cons
) (dynamic-extent-object-offset dynamic-scope proto-cons
)))