Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv3703
Modified Files:
compiler.lisp
Log Message:
Fix the %find-code-vector problem by adding NOP-prefixes in assemble-funobj.
--- /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/21 22:29:57 1.199
+++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/12 16:46:05 1.200
@@ -8,7 +8,7 @@
;;;; Created at: Wed Oct 25 12:30:49 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: compiler.lisp,v 1.199 2008/03/21 22:29:57 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.200 2008/04/12 16:46:05 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -1004,11 +1004,12 @@
(assemble-funobj funobj combined-code))))
funobj)
-(defun assemble-funobj (funobj combined-code)
- (multiple-value-bind (code-vector code-symtab)
+(defun assemble-funobj (funobj combined-code &key extra-prefix-computers)
+ (multiple-value-bind (code code-symtab)
(let ((asm-x86:*cpu-mode* :32-bit)
(asm:*instruction-compute-extra-prefix-map*
- '((:call . compute-call-extra-prefix))))
+ (append extra-prefix-computers
+ '((:call . compute-call-extra-prefix)))))
(asm:assemble-proglist combined-code
:symtab (list* (cons :nil-value (image-nil-word *image*))
(loop for (label . set) in (movitz-funobj-jumpers-map funobj)
@@ -1016,50 +1017,66 @@
(* 4 (or (search set (movitz-funobj-const-list funobj)
:end2 (movitz-funobj-num-jumpers funobj))
(error "Jumper for ~S missing." label))))))))
- (setf (movitz-funobj-symtab funobj) code-symtab)
- (let* ((code-length (- (length code-vector) 3 -3))
- (code-vector (make-array code-length
- :initial-contents code-vector
- :fill-pointer t)))
- (setf (fill-pointer code-vector) code-length)
- ;; debug info
- (setf (ldb (byte 1 5) (slot-value funobj 'debug-info))
- 1 #+ignore (if use-stack-frame-p 1 0))
- (let ((x (cdr (assoc 'start-stack-frame-setup code-symtab))))
- (cond
- ((not x)
- #+ignore (warn "No start-stack-frame-setup label for ~S." name))
- ((<= 0 x 30)
- (setf (ldb (byte 5 0) (slot-value funobj 'debug-info)) x))
- (t (warn "Can't encode start-stack-frame-setup label ~D into debug-info for ~S."
- x (movitz-funobj-name funobj)))))
- (let* ((a (or (cdr (assoc 'entry%1op code-symtab)) 0))
- (b (or (cdr (assoc 'entry%2op code-symtab)) a))
- (c (or (cdr (assoc 'entry%3op code-symtab)) b)))
- (unless (<= a b c)
- (warn "Weird code-entries: ~D, ~D, ~D." a b c))
- (unless (<= 0 a 255)
- (break "entry%1: ~D" a))
- (unless (<= 0 b 2047)
- (break "entry%2: ~D" b))
- (unless (<= 0 c 4095)
- (break "entry%3: ~D" c)))
- (loop for (entry-label slot-name) in '((entry%1op code-vector%1op)
- (entry%2op code-vector%2op)
- (entry%3op code-vector%3op))
- do (when (assoc entry-label code-symtab)
- (let ((offset (cdr (assoc entry-label code-symtab))))
- (setf (slot-value funobj slot-name)
- (cons offset funobj)))))
- (check-locate-concistency code-vector)
- (setf (movitz-funobj-code-vector funobj)
- (make-movitz-vector (length code-vector)
- :fill-pointer code-length
- :element-type 'code
- :initial-contents code-vector))))
+ (let ((code-length (- (length code) 3 -3)))
+ (let ((locate-inconsistencies (check-locate-concistency code code-length)))
+ (when locate-inconsistencies
+ (when (rassoc 'compute-extra-prefix-locate-inconsistencies
+ extra-prefix-computers)
+ (error "~S failed to fix locate-inconsistencies. This should not happen."
+ 'compute-extra-prefix-locate-inconsistencies))
+ (return-from assemble-funobj
+ (assemble-funobj funobj combined-code
+ :extra-prefix-computers (list (cons t (lambda (pc size)
+ (loop for bad-pc in locate-inconsistencies
+ when (<= pc bad-pc (+ pc size))
+ return '(#x90)))))))
+
+ (break "locate-inconsistencies: ~S" locate-inconsistencies)))
+ (setf (movitz-funobj-symtab funobj) code-symtab)
+ (let ((code-vector (make-array code-length
+ :initial-contents code
+ :fill-pointer t)))
+ (setf (fill-pointer code-vector) code-length)
+ ;; debug info
+ (setf (ldb (byte 1 5) (slot-value funobj 'debug-info))
+ 1 #+ignore (if use-stack-frame-p 1 0))
+ (let ((x (cdr (assoc 'start-stack-frame-setup code-symtab))))
+ (cond
+ ((not x)
+ #+ignore (warn "No start-stack-frame-setup label for ~S." name))
+ ((<= 0 x 30)
+ (setf (ldb (byte 5 0) (slot-value funobj 'debug-info)) x))
+ (t (warn "Can't encode start-stack-frame-setup label ~D into debug-info for ~S."
+ x (movitz-funobj-name funobj)))))
+ (let* ((a (or (cdr (assoc 'entry%1op code-symtab)) 0))
+ (b (or (cdr (assoc 'entry%2op code-symtab)) a))
+ (c (or (cdr (assoc 'entry%3op code-symtab)) b)))
+ (unless (<= a b c)
+ (warn "Weird code-entries: ~D, ~D, ~D." a b c))
+ (unless (<= 0 a 255)
+ (break "entry%1: ~D" a))
+ (unless (<= 0 b 2047)
+ (break "entry%2: ~D" b))
+ (unless (<= 0 c 4095)
+ (break "entry%3: ~D" c)))
+ (loop for (entry-label slot-name) in '((entry%1op code-vector%1op)
+ (entry%2op code-vector%2op)
+ (entry%3op code-vector%3op))
+ do (when (assoc entry-label code-symtab)
+ (let ((offset (cdr (assoc entry-label code-symtab))))
+ (setf (slot-value funobj slot-name)
+ (cons offset funobj)))))
+ (setf (movitz-funobj-code-vector funobj)
+ (make-movitz-vector (length code-vector)
+ :fill-pointer code-length
+ :element-type 'code
+ :initial-contents code-vector)))))
funobj)
(defun check-locate-concistency (code-vector)
+ "The run-time function muerte::%find-code-vector sometimes needs to find a code-vector by
+searching through the machine-code for an object header signature. This function is to
+make sure that no machine code accidentally forms such a header signature."
(loop for x from 0 below (length code-vector) by 8
do (when (and (= (tag :basic-vector) (aref code-vector x))
(= (enum-value 'movitz-vector-element-type :code) (aref code-vector (1+ x)))
@@ -1068,7 +1085,7 @@
(aref code-vector (+ x 2)))
(= (ldb (byte 8 8) (length code-vector))
(aref code-vector (+ x 3))))))
- (break "Code-vector (length #x~X) can break %find-code-vector at ~D: #x~2,'0X~2,'0X ~2,'0X~2,'0X."
+ (break "Code-vector (length ~D) can break %find-code-vector at ~D: #x~2,'0X~2,'0X ~2,'0X~2,'0X."
(length code-vector) x
(aref code-vector (+ x 0))
(aref code-vector (+ x 1))
@@ -1076,6 +1093,22 @@
(aref code-vector (+ x 3)))))
(values))
+(defun check-locate-concistency (code code-vector-length)
+ "The run-time function muerte::%find-code-vector sometimes needs to find a code-vector by
+searching through the machine-code for an object header signature. This function is to
+make sure that no machine code accidentally forms such a header signature."
+ (loop for (x0 x1 x2 x3) on code by (lambda (l) (nthcdr 8 l))
+ for pc upfrom 0 by 8
+ when (and (= x0 (tag :basic-vector))
+ (= x1 (enum-value 'movitz-vector-element-type :code))
+ (or (<= #x4000 code-vector-length)
+ (and (= x2 (ldb (byte 8 0) code-vector-length))
+ (= x3 (ldb (byte 8 8) code-vector-length)))))
+ collect pc
+ and do (warn "Code-vector (length ~D) can break %find-code-vector at ~D: #x~2,'0X~2,'0X ~2,'0X~2,'0X."
+ code-vector-length
+ pc x0 x1 x2 x3)))
+
(defun make-2req (binding0 binding1 frame-map)
(let ((location-0 (new-binding-location binding0 frame-map))
@@ -2730,9 +2763,9 @@
init-pc)
(assert (instruction-is (first init-pc) :init-lexvar))
(destructuring-bind (init-binding &key init-with-register init-with-type
- protect-registers protect-carry)
+ protect-registers protect-carry shared-reference-p)
(cdr (first init-pc))
- (declare (ignore protect-registers protect-carry init-with-type))
+ (declare (ignore protect-registers protect-carry init-with-type shared-reference-p))
(assert (eq binding init-binding))
(multiple-value-bind (load-instruction binding-destination distance)
(loop for i in (cdr init-pc) as distance upfrom 0
@@ -3372,7 +3405,7 @@
'integer))
(warn "ecx from ~S" binding)))
(when (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding))
- (break "The variable ~S is used even if it was declared ignored."
+ (warn "The variable ~S is used even if it was declared ignored."
(binding-name binding)))
(let ((binding (ensure-local-binding binding funobj))
(protect-registers (cons :edx protect-registers)))
@@ -5938,7 +5971,8 @@
(cond
((not binding)
(unless (movitz-env-get form 'special nil env)
- (cerror "Compile like a special." "Undeclared variable: ~S." form))
+ #+ignore (cerror "Compile like a special." "Undeclared variable: ~S." form)
+ (warn "Undeclared variable: ~S." form))
(compiler-values ()
:returns :eax
:functional-p t
