movitz-cvs February 2008

movitz-cvs@common-lisp.net

1 participants
66 discussions

[movitz-cvs] CVS movitz
by ffjeld 23 Feb '08

23 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv7188 Modified Files: asm-x86.lisp Log Message: Finishing touches on the disassembler. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/18 22:30:47 1.29 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/23 22:35:10 1.30 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.29 2008/02/18 22:30:47 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.30 2008/02/23 22:35:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -278,7 +278,7 @@ (make-array 256 :initial-element nil)) (deftype disassembly-decoder () - '(list-of* keyword (or keyword null) symbol)) + '(list-of* boolean keyword (or keyword null) symbol)) (defun (setf opcode-disassembler) (decoder opcode operator-mode) (check-type decoder disassembly-decoder) @@ -312,22 +312,22 @@ -(defmacro define-disassembler ((operator opcode &optional cpu-mode (digit nil digit-p)) lambda-list &body body) +(defmacro define-disassembler ((operator opcode &optional cpu-mode digit backup-p) lambda-list &body body) (cond - (digit-p + (digit `(loop for mod from #b00 to #b11 do (loop for r/m from #b000 to #b111 as ext-opcode = (logior (ash ,opcode 8) (ash ,digit 3) (ash mod 6) r/m) - do (define-disassembler (,operator ext-opcode ,cpu-mode) ,lambda-list ,@body)))) + do (define-disassembler (,operator ext-opcode ,cpu-mode nil t) ,lambda-list ,@body)))) ((symbolp lambda-list) - `(setf (opcode-disassembler ,opcode ,cpu-mode) (list ,operator ,cpu-mode ',lambda-list ,@body))) + `(setf (opcode-disassembler ,opcode ,cpu-mode) (list ,backup-p ,operator ,cpu-mode ',lambda-list ,@body))) (t (let ((defun-name (intern (format nil "~A-~A-~X~@[-~A~]" 'disassembler operator opcode cpu-mode)))) `(progn (defun ,defun-name ,lambda-list ,@body) - (setf (opcode-disassembler ,opcode ',cpu-mode) (list ,operator ',cpu-mode ',defun-name)) + (setf (opcode-disassembler ,opcode ',cpu-mode) (list ,backup-p ,operator ',cpu-mode ',defun-name)) ',defun-name))))) (defun disassemble-simple-prefix (code operator opcode operand-size address-size rex) @@ -799,15 +799,18 @@ (defun disassemble-instruction (code &optional override-operand-size override-address-size rex) (labels ((lookup-decoder (table opcode) - (let* ((datum (pop-code code)) + (let* ((backup-code code) + (datum (pop-code code)) (opcode (logior (ash opcode 8) datum)) (decoder (svref table datum))) (typecase decoder - ((simple-vector 256) + (vector (lookup-decoder decoder opcode)) (disassembly-decoder - (values decoder + (when (car decoder) + (setf code backup-code)) + (values (cdr decoder) opcode)) (t (error "No disassembler registered for opcode #x~X." opcode)))))) (multiple-value-bind (decoder opcode) @@ -1384,14 +1387,13 @@ ;;;;;;;;;;; CALL -(define-operator* (:16 :callw :32 :calll :64 :callr :dispatch :call) (dest) - (case *cpu-mode* - (:16-bit - (pc-rel #xe8 dest (sint 16))) - (:32-bit - (pc-rel #xe8 dest (sint 32)))) - (when (eq operator-mode *cpu-mode*) - (modrm dest #xff 2))) +(define-operator/16 :callw (dest) + (pc-rel #xe8 dest (sint 16)) + (modrm dest #xff 2)) + +(define-operator/32 :call (dest) + (pc-rel #xe8 dest (sint 32)) + (modrm dest #xff 2)) (define-operator/none :call-segment (dest) (modrm dest #xff 3)) @@ -1879,11 +1881,6 @@ (define-operator* (:16 :negw :32 :negl :64 :negr) (dst) (modrm dst #xf7 3)) -;;;;;;;;;;;;;;;; NOP - -(define-operator/none :nop () - (opcode #x90)) - ;;;;;;;;;;; NOT (define-operator/8 :notb (dst) @@ -2162,3 +2159,9 @@ (imm-modrm src dst #x81 6 :int-16-32-64) (reg-modrm dst src #x33) (reg-modrm src dst #x31)) + +;;;;;;;;;;;;;;;; NOP + +(define-operator/none :nop () + (opcode #x90)) +

1 0

[movitz-cvs] CVS movitz
by ffjeld 23 Feb '08

23 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv7169 Modified Files: asm.lisp Log Message: Finishing touches on the disassembler. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/02/18 22:30:45 1.14 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/02/23 22:35:08 1.15 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.14 2008/02/18 22:30:45 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.15 2008/02/23 22:35:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -234,13 +234,22 @@ :corrections (nconc new-corrections corrections))) (t (values code *symtab*)))))))) +(defun instruction-operator (instruction) + (if (listp (car instruction)) ; skip any instruction prefixes etc. + (cadr instruction) + (car instruction))) + (defun instruction-operands (instruction) (if (listp (car instruction)) ; skip any instruction prefixes etc. (cddr instruction) (cdr instruction))) +(defun instruction-modifiers (instruction) + (if (listp (car instruction)) + (car instruction) + nil)) -(defun disassemble-proglist (code &key (cpu-package '#:asm-x86) (pc (or *pc* 0)) (symtab *symtab*)) +(defun disassemble-proglist (code &key (cpu-package '#:asm-x86) (pc (or *pc* 0)) (symtab *symtab*) collect-data collect-labels) (let* ((instruction-disassembler (find-symbol (string '#:disassemble-instruction) cpu-package)) (proglist0 (loop while code @@ -250,24 +259,33 @@ code) (when (eq code new-code) (loop-finish)) - (loop until (eq code new-code) - do (incf pc) - (setf code (cdr code))) - (let ((operands (instruction-operands instruction))) - (if (notany #'pc-relative-operand-p operands) - instruction - (nconc (loop until (eq instruction operands) - collect (pop instruction)) - (loop for operand in operands - collect (if (not (pc-relative-operand-p operand)) - operand - (let* ((location (+ pc (pc-relative-operand-offset operand))) - (entry (or (rassoc location symtab) - (car (push (cons (gensym) location) - symtab))))) - `(quote ,(car entry)))))))))))) - (values (loop for (pc instruction) on proglist0 by #'cddr - when (car (rassoc pc symtab)) - collect it - collect instruction) + (let* ((data (loop until (eq code new-code) + do (incf pc) + collect (pop code))) + (operands (instruction-operands instruction))) + ;; (format *debug-io* "~D: ~X ~S~%" pc data instruction) + (cons data + (if (notany #'pc-relative-operand-p operands) + instruction + (nconc (loop until (eq instruction operands) + collect (pop instruction)) + (loop for operand in operands + collect (if (not (pc-relative-operand-p operand)) + operand + (let* ((location (+ pc (pc-relative-operand-offset operand))) + (entry (or (rassoc location symtab) + (car (push (cons (gensym) location) + symtab))))) + `(quote ,(car entry))))))))))))) + (values (loop for (pc data-instruction) on proglist0 by #'cddr + for (data . instruction) = data-instruction + for label = (when collect-labels + (rassoc pc symtab)) + when label + collect (if (not collect-data) + (car label) + (cons nil (car label))) + collect (if (not collect-data) + instruction + data-instruction)) symtab)))

1 0

[movitz-cvs] CVS movitz
by ffjeld 23 Feb '08

23 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv6952 Modified Files: image.lisp Log Message: Use the new disassembler. --- /project/movitz/cvsroot/movitz/image.lisp 2008/02/09 18:42:00 1.114 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/02/23 22:34:14 1.115 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.114 2008/02/09 18:42:00 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.115 2008/02/23 22:34:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1244,6 +1244,7 @@ (when (= offset (bt:slot-offset 'movitz-run-time-context slot-name)) (return slot-name)))) +#+ia-x86 (defun comment-instruction (instruction funobj pc) "Return a list of strings that comments on INSTRUCTION." (loop for operand in (ia-x86::instruction-operands instruction) @@ -1361,8 +1362,57 @@ (defparameter *recursive-disassemble-remember-funobjs* nil) +(defun movitz-foo (funobj &key (name (movitz-funobj-name funobj)) ((:image *image*) *image*) + (recursive t)) + (coerce (movitz-vector-symbolic-data (movitz-funobj-code-vector funobj)) + 'list)) + +#-ia-x86 +(defun movitz-disassemble-funobj (funobj &key (name (movitz-funobj-name funobj)) ((:image *image*) *image*) + (recursive t)) + (let ((code (coerce (movitz-vector-symbolic-data (movitz-funobj-code-vector funobj)) + 'list)) + (entry-points (loop for slot in '(code-vector%1op code-vector%2op code-vector%3op) + for entry-arg-count upfrom 1 + for entry = (slot-value funobj slot) + when (and (consp entry) + (eq funobj (cdr entry))) + collect (cons (car entry) + entry-arg-count)))) + (let ((*print-case* :downcase)) + (format t "~&;; Movitz Disassembly of ~A: +;; ~D Constant~:P~@[: ~A~]. +~:{~4D: ~16<~{ ~2,'0X~}~;~> ~A~@[ ;~{ ~A~}~]~%~}" + (movitz-print (or (movitz-funobj-name funobj) name)) + (length (movitz-funobj-const-list funobj)) + (movitz-funobj-const-list funobj) + (loop with pc = 0 + for (data . instruction) in (asm:disassemble-proglist code :symtab (movitz-funobj-symtab funobj) + :collect-data t) + when (assoc pc entry-points) + collect (list pc nil + (format nil " => Entry-point for ~D arguments <=" (cdr (assoc pc entry-points))) + nil) + when (let ((x (find pc (movitz-funobj-symtab funobj) :key #'cdr))) + (when x (list pc (list (format nil " ~A" (car x))) "" nil))) + collect it + collect (list pc data instruction nil) + do (incf pc (length data)))))) + (when recursive + (let ((*recursive-disassemble-remember-funobjs* + (cons funobj *recursive-disassemble-remember-funobjs*))) + (loop for x in (movitz-funobj-const-list funobj) + do (when (and (typep x '(and movitz-funobj (not movitz-funobj-standard-gf))) + (not (member x *recursive-disassemble-remember-funobjs*))) + (push x *recursive-disassemble-remember-funobjs*) + (terpri) + (movitz-disassemble-funobj x)))))) + + + +#+ia-x86 (defun movitz-disassemble-funobj (funobj &key (name (movitz-funobj-name funobj)) ((:image *image*) *image*) - (recursive t)) + (recursive t)) (let* ((code-vector (movitz-funobj-code-vector funobj)) (code (map 'vector #'identity (movitz-vector-symbolic-data code-vector))) @@ -1375,44 +1425,65 @@ (length (movitz-funobj-const-list funobj)) (movitz-funobj-const-list funobj) (loop - for pc = 0 then code-position - for instruction = (ia-x86:decode-read-octet - #'(lambda () - (when (< code-position - (movitz-vector-fill-pointer code-vector)) - (prog1 - (aref code code-position) - (incf code-position))))) - for cbyte = (and instruction - (ia-x86::instruction-original-datum instruction)) - until (null instruction) - when (let ((x (find pc (movitz-funobj-symtab funobj) :key #'cdr))) - (when x (list pc (list (format nil " ~S" (car x))) "" nil))) - collect it - when (some (lambda (x) - (and (plusp pc) (= pc x))) - entry-points) - collect (list pc nil - (format nil " => Entry-point for ~D arguments <=" - (1+ (position-if (lambda (x) - (= pc x)) - entry-points))) - nil) - collect (list pc - (ia-x86::cbyte-to-octet-list cbyte) - instruction - (comment-instruction instruction funobj pc))))) + for pc = 0 then code-position + for instruction = (ia-x86:decode-read-octet + #'(lambda () + (when (< code-position + (movitz-vector-fill-pointer code-vector)) + (prog1 + (aref code code-position) + (incf code-position))))) + for cbyte = (and instruction + (ia-x86::instruction-original-datum instruction)) + until (null instruction) + when (let ((x (find pc (movitz-funobj-symtab funobj) :key #'cdr))) + (when x (list pc (list (format nil " ~S" (car x))) "" nil))) + collect it + when (some (lambda (x) + (and (plusp pc) (= pc x))) + entry-points) + collect (list pc nil + (format nil " => Entry-point for ~D arguments <=" + (1+ (position-if (lambda (x) + (= pc x)) + entry-points))) + nil) + collect (list pc + (ia-x86::cbyte-to-octet-list cbyte) + instruction + (comment-instruction instruction funobj pc))))) (when recursive (let ((*recursive-disassemble-remember-funobjs* (cons funobj *recursive-disassemble-remember-funobjs*))) (loop for x in (movitz-funobj-const-list funobj) - do (when (and (typep x '(and movitz-funobj (not movitz-funobj-standard-gf))) - (not (member x *recursive-disassemble-remember-funobjs*))) - (push x *recursive-disassemble-remember-funobjs*) - (terpri) - (movitz-disassemble-funobj x))))) + do (when (and (typep x '(and movitz-funobj (not movitz-funobj-standard-gf))) + (not (member x *recursive-disassemble-remember-funobjs*))) + (push x *recursive-disassemble-remember-funobjs*) + (terpri) + (movitz-disassemble-funobj x))))) (values)) +#-ia-x86 +(defun movitz-disassemble-primitive (name &optional (*image* *image*)) + (let* ((code-vector (cond + ((slot-exists-p (image-run-time-context *image*) name) + (slot-value (image-run-time-context *image*) name)) + (t (movitz-symbol-value (movitz-read name))))) + (code (coerce (movitz-vector-symbolic-data code-vector) + 'list))) + (format t "~&;; Movitz disassembly of ~S: +~:{~4D: ~16<~{ ~2,'0X~}~;~> ~A~@[ ;~{ ~A~}~]~%~}" + name + (loop with pc = 0 + for (data . instruction) in (asm:disassemble-proglist code :collect-data t) + collect (list pc + data + instruction + nil #+ignore (comment-instruction instruction nil pc)) + do (incf pc (length data)))) + (values))) + +#+ia-x86 (defun movitz-disassemble-primitive (name &optional (*image* *image*)) (let* ((code-vector (cond ((slot-exists-p (image-run-time-context *image*) name)

1 0

[movitz-cvs] CVS movitz/losp
by ffjeld 23 Feb '08

23 Feb '08

Update of /project/movitz/cvsroot/movitz/losp In directory clnet:/tmp/cvs-serv5997 Modified Files: scratch.lisp Log Message: Remove DOS EOL. --- /project/movitz/cvsroot/movitz/losp/scratch.lisp 2008/02/04 21:04:51 1.2 +++ /project/movitz/cvsroot/movitz/losp/scratch.lisp 2008/02/23 22:28:55 1.3 @@ -1,1164 +1,1164 @@ -;;;;------------------ -*- movitz-mode: t -*-------------------------- -;;;; -;;;; Copyright (C) 2007, Frode Vatvedt Fjeld -;;;; -;;;; Filename: scratch.lisp -;;;; Description: Misc. testing code etc. -;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> -;;;; Distribution: See the accompanying file COPYING. -;;;; -;;;; $Id: scratch.lisp,v 1.2 2008/02/04 21:04:51 ffjeld Exp $ -;;;; -;;;;------------------------------------------------------------------ - -(provide :scratch) - -(in-package los0) - -#+ignore -(defun set.2 () - (let ((*var-used-in-set-tests* 'a) - (var '*var-used-in-set-tests*)) - (declare (special *var-used-in-set-tests*)) - (values - (let ((*var-used-in-set-tests* 'c)) - (list (set var 'b) *var-used-in-set-tests* (symbol-value var))) - *var-used-in-set-tests*))) -;; (b c b) -;; b) - -#+ignore -(defun test-lend-constant () - (let ((symbols '(a b c d e f g h i j k l m n o p q r s t u v w x y z)) - (table (make-hash-table :test #'eq))) - (loop for sym in symbols - for i from 1 - do (setf (gethash sym table) i)) - (let ((sum 0)) - (values (maphash #'(lambda (k v) - (assert (eq (elt symbols (1- v)) k)) - (incf sum v)) - table) - sum)))) - -#+ignore -(defun test-aux (x y &aux (sum (+ x y))) - sum) - -#+ignore -(defun mapc.error.3 () - (mapc #'append)) - -#+ignore -(defun with-hash-table-iterator.12 () - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (with-hash-table-iterator (m (return-from done x)) - (declare (special x)))))) - :good) - -#+ignore -(defun string.15 () - (when (> char-code-limit 65536) - (loop for i = (random char-code-limit) - for c = (code-char i) - for s = (and c (string c)) - repeat 2000 - when (and c - (or (not (stringp s)) - (not (= (length s) 1)) - (not (eql c (char s 0))))) - collect (list i c s))) - nil) - -(defun x (bios32) - (warn "X: ~S" (memref-int bios32)) - (warn "X: ~S" (= (memref-int bios32) #x5f32335f))) - -(defun setfint (x o) - (setf (memref x o :type :unsigned-byte32) 0)) - -(defun fint (x) - (memref-int x :type :unsigned-byte32 :physicalp t)) - -(defun good () - (with-inline-assembly (:returns :untagged-fixnum-ecx) - ((:gs-override) :movl (#x1000000) :ecx))) - -(defun (setf good) (x) - (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-form (:result-mode :untagged-fixnum-ecx) x) - ((:gs-override) :movl :ecx (#x1000000)))) - -(defun test2 () - (funcall - (compile - nil - '(lambda (a) (declare (notinline > *)) - (declare (optimize (compilation-speed 0) (safety 2) (speed 2) (debug 0) (space 3))) - (catch 'ct1 (* a (throw 'ct1 (if (> 0) a 0)))))) - 5445205692802)) - -(defun test3 () - (loop for x below 2 count (not (not (typep x t))))) - -(defun test4 () - (let ((aa 1)) (if (not (/= aa 0)) aa 0))) - - -(defun test-floppy () - (muerte.x86-pc::fd-start-disk) ; to initialize the controller and spin the drive up. - (muerte.x86-pc::fd-cmd-seek 70) ; to seek to track 70. - (setf (muerte.x86-pc::fd-motor) nil)) ; to turn the drive and controller off. - - -(defun alist-get-expand (alist key) - (let (cons) - (tagbody - loop - (setq cons (car alist)) - (cond ((eq alist nil) (go end)) - ((eq cons nil)) - ((eq key (car cons)) (go end))) - (setq alist (cdr alist)) - (go loop) - end) - (cdr cons))) - -;;;(defun test-irq () -;;; (with-inline-assembly (:returns :multiple-values) -;;; (:compile-form (:result-mode :multiple-values) (values 0 1 2 3 4 5)) -;;; (:int 42))) -;;; -;;;(defun koo () -;;; (prog1 (make-values) -;;; (format t "hello: ~S" (values 'a 'b 'c 'd)))) -;;; -;;;(defun test-complement (&rest args) -;;; (declare (dynamic-extent args)) -;;; (apply (complement #'symbolp) args)) -;;; -;;;(defun test-constantly (&rest args) -;;; (declare (dynamic-extent args)) -;;; (apply (constantly 'test-value) args)) - -(defun test-closure (x z) - (flet ((closure (y) (= x (1+ y)))) - (declare (dynamic-extent (function closure))) - (closure z) - #+ignore (funcall (lambda (y) (= x (1+ y))) - z))) - -(defun test-stack-cons (x y) - (muerte::with-dynamic-extent-scope (zap) - (let ((foo (muerte::with-dynamic-extent-allocation (zap) - (cons x (lambda () y))))) - (format t "~Z: ~S, ~S" foo foo (funcall (cdr foo)))))) - -(defun test-handler (x) - (let ((foo x)) - (handler-bind - ((error (lambda (c) - (format t "error: ~S ~S" c x)))) - (error "This is an error. ~S" foo)))) - - -(defun fooo (v w) - (tagbody - (print (block blurgh - (progv (list v) (list w) - (format t "Uh: ~S" (symbol-value v)) - (if (symbol-value v) - (return-from blurgh 1) - (go zap))))) - zap) - t) - - -(defun test-break () - (with-inline-assembly (:returns :multiple-values) - (:movl 10 :ecx) - (:movl :esi :eax) ; This function should return itself! - (:clc) - (:break))) - -(defun test-upload (x) - ;; (warn "Test-upload blab la bla!!") - (setf x (cdr x)) - x) - -;;;(defun zzz (x) -;;; (multiple-value-bind (symbol status) -;;; (values-list x) -;;; (warn "sym: ~S, stat: ~S" symbol status))) -;;; - -#+ignore -(defun test-loop (x) - (format t "test-loop: ~S~%" - (loop for i from 0 to 10 collect x))) - -#+ignore -(defun delay (time) - (dotimes (i time) - (with-inline-assembly (:returns :nothing) - (:nop) - (:nop)))) -;;; -;;;(defun test-consp (x) -;;; (with-inline-assembly (:returns :boolean-cf=1) -;;; (:compile-form (:result-mode :ecx) x) -;;; (:leal (:edi -4) :eax) -;;; (:rorb :cl :al))) - - -#+ignore -(defun test-block (x) - (block nil - (let ((*print-base* (if x (return 3) 8))) - (jumbo 2 2 (and x 2) (+ 3 3 (or x 4)) (if x 2 (return nil))))) - #+ignore (+ x 2)) - -#+ignore -(defun jumbo (a b c &rest x) - (declare (dynamic-extent x)) - (print a) (print b) (print c) - (print x) - 'jumbo) - -(defun jumbo2 (a b &rest x) - (declare (dynamic-extent x)) - (print a) (print b) - (print x) - 'jumbo) - -(defun jumbo3 (a &rest x) - (declare (dynamic-extent x)) - (print a) - (print x) - 'jumbo) - -(defun jumbo4 (&rest x) - (declare (dynamic-extent x)) - (print x) - 'jumbo) - -#+ignore -(defun tagbodyxx (x) - (tagbody - (print 'hello) - haha - (unwind-protect - (when x (go hoho)) - (warn "unwind..")) - (print 'world) - hoho - (print 'blrugh))) - -#+ignore -(defun tagbodyxx (x) - (tagbody - (print 'hello) - haha - (unwind-protect - (funcall (lambda () - (when x (go hoho)))) - (warn "unwind..")) - (print 'world) - hoho - (print 'blrugh))) - -#+ignore -(defun kumbo (&key a b (c (jumbo 1 2 3)) d) - (print a) - (print b) - (print c) - (print d)) - -#+ignore -(defun lumbo (a &optional (b 'zap)) - (print a) - (print b)) - -(defmacro do-check-esp (&body body) - `(let ((before (with-inline-assembly (:returns :eax) (:movl :esp :eax)))) - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :multiple-values) (progn ,@body))) - (unless (eq before - (with-inline-assembly (:returns :eax) (:movl :esp :eax))) - (error "ESP before body: ~S, after: ~S" - (with-inline-assembly (:returns :eax) (:movl :esp :eax)))))) - -#+ignore -(defun test-m-v-call () - (do-check-esp - (multiple-value-call #'format t "~@{ ~D~}~%" - 'a (values) 'b (test-loop 1) (make-values) - 'c 'd 'e (make-no-values) 'f))) - -(defun test-m-v-call2 () - (multiple-value-call #'format t "~@{ ~D~}~%" - 'a 'b (values 1 2 3) 'c 'd 'e 'f)) - -(defun make-values () - (values 0 1 2 3 4 5)) - -(defun xfuncall (&rest args) - (declare (dynamic-extent args)) - (break "xfuncall:~{ ~S~^,~}" args) - (values)) - -(defun xfoo (f) - (do-check-esp - (multiple-value-bind (a b c d) - (multiple-value-prog1 (make-values) - (format t "hello world")) - (format t "~&a: ~S, b: ~S, c: ~S, d: ~S ~S" a b c d f)))) - - -#+ignore -(defun make-no-values () - (values)) - -#+ignore -(defun test-nth-values () - (nth-value 2 (make-values))) - -#+ignore -(defun test-values2 () - (multiple-value-bind (a b c d e f g h) - (make-values) - (format t "test-values2: A: ~S, B: ~S, C: ~S, D: ~S, E: ~S, F: ~S G: ~S, H: ~S~%" - a b c d e f g h))) - -#+ignore -(defun test-flet (zap) - (flet ((pingo (z y x) - (declare (ignore y z)) - (format t "This is pingo: ~S with zap: ~W~%" x zap))) - ;; (declare (dynamic-extent pingo)) - (pingo 100 200 300))) - -#+ignore -(defun test-flet2 (zap) - (flet ((pingo (z y x) - (declare (ignore y z)) - (format t "This is pingo: ~S with zap: ~W~%" x zap))) - ;; (declare (dynamic-extent pingo)) - (lambda (x) - (pingo 100 200 300)))) - -(defun test-boo () - (let ((real-cmuc #'test-flet2)) - (let ((plongo (lambda (x) - (warn "~S real-cmuc: ~S" x real-cmuc) - (funcall real-cmuc x)))) - (funcall plongo 'zooom)))) - -(defun test-labels () - (labels ((pingo (x) - (format t "~&This is pingo: ~S~%" x) - (when (plusp x) - (pingo (1- x))))) - (pingo 5))) - -#+ignore -(defun foo-type (length start1 sequence-1) - (do* ((i 0 #+ignore (+ start1 length -1) (1- i))) - ((< i start1) sequence-1) - (declare (type muerte::index i length)) - (setf (sequence-1-ref i) - 'foo))) - - -#+ignore -(defun test-values () - (multiple-value-bind (a b c d e f g h i j) - (multiple-value-prog1 - (make-values) -;;; (format t "this is the resulting form.~%") - (format t "this is the first ignorable form.~%" 1 2 3) - (format t "this is the second ignorable form.~%")) -;;; (format t "test-values num: ~D~%" (capture-reg8 :cl)) - (format t "test-values: A: ~Z, B: ~Z, C: ~Z, D: ~Z ~Z ~Z ~Z ~Z ~Z ~Z~%" a b c d e f g h i j))) - - -#+ignore -(defun test-keywords (&key a b (c 100) ((:d x) 5 x-p)) - (format t "test-keywords: a: ~S, b: ~S, c: ~S, x: ~S, x-p: ~S~%" - a b c x x-p)) - -#+ignore -(defun test-k1 (a b &key x) - (declare (ignore a b)) - (warn "x: ~S" x)) - [1931 lines skipped]

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 18 Feb '08

18 Feb '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv31532 Modified Files: interrupt.lisp Log Message: Prefer the new assembler. --- /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2007/04/07 20:49:17 1.56 +++ /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2008/02/18 22:31:13 1.57 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.56 2007/04/07 20:49:17 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.57 2008/02/18 22:31:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -133,7 +133,7 @@ ;; Do RET promotion of EIP. (:movl (:ebp ,(dit-frame-offset :eip)) :ecx) - ((:cs-override) :cmpb ,(realpart (ia-x86:asm :ret)) (:ecx)) + ((:cs-override) :cmpb ,@(asm-x86:assemble-instruction '(:ret)) (:ecx)) (:jne 'not-at-ret-instruction) (:globally (:movl (:edi (:edi-offset ret-trampoline)) :ecx)) (:movl :ecx (:ebp ,(dit-frame-offset :eip)))

1 0

[movitz-cvs] CVS movitz
by ffjeld 18 Feb '08

18 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv31346 Modified Files: asm-x86.lisp Log Message: Improve disassemble-proglist etc. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/18 20:57:14 1.28 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/18 22:30:47 1.29 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.28 2008/02/18 20:57:14 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.29 2008/02/18 22:30:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -445,7 +445,7 @@ (defun resolve-pc-relative (operand) (etypecase operand - ((cons (eql :pc+)) + (pc-relative-operand (reduce #'+ (cdr operand) :key #'resolve-operand)) (symbol-reference @@ -772,9 +772,12 @@ (error "No operand ~S in ~S." key operands)))) (defmacro pop-code (code-place &optional context) - `(let ((x (pop ,code-place))) + `(progn + (unless ,code-place + (error "End of byte-stream in the middle of an instruction.")) + (let ((x (pop ,code-place))) (check-type x (unsigned-byte 8) ,(format nil "an octet (context: ~A)" context)) - x)) + x))) (defmacro code-call (form &optional (code-place (case (car form) ((funcall apply) (third form)) (t (second form))))) "Execute form, then 'magically' update the code binding with the secondary return value from form."

1 0

[movitz-cvs] CVS movitz
by ffjeld 18 Feb '08

18 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv31315 Modified Files: asm.lisp Log Message: Improve disassemble-proglist etc. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/02/16 19:14:06 1.13 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/02/18 22:30:45 1.14 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.13 2008/02/16 19:14:06 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.14 2008/02/18 22:30:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,6 +25,7 @@ #:retry-symbol-resolve #:pc-relative-operand #:assemble-proglist + #:disassemble-proglist #:*pc* #:*symtab* #:*instruction-compute-extra-prefix-map* @@ -117,6 +118,10 @@ (defun pc-relative-operand-p (operand) (typep operand 'pc-relative-operand)) +(defun pc-relative-operand-offset (operand) + (check-type operand pc-relative-operand) + (second operand)) + (define-condition unresolved-symbol () ((symbol :initarg :symbol @@ -229,14 +234,40 @@ :corrections (nconc new-corrections corrections))) (t (values code *symtab*)))))))) -(defun disassemble-proglist (code &key (cpu-package '#:asm-x86)) - (let ((instruction-disassembler (find-symbol (string '#:disassemble-instruction) - cpu-package))) - (loop while code - collect (multiple-value-bind (instruction new-code) - (funcall instruction-disassembler - code) - (when (eq code new-code) - (loop-finish)) - (setf code new-code) - instruction)))) +(defun instruction-operands (instruction) + (if (listp (car instruction)) ; skip any instruction prefixes etc. + (cddr instruction) + (cdr instruction))) + + +(defun disassemble-proglist (code &key (cpu-package '#:asm-x86) (pc (or *pc* 0)) (symtab *symtab*)) + (let* ((instruction-disassembler (find-symbol (string '#:disassemble-instruction) + cpu-package)) + (proglist0 (loop while code + collect pc + collect (multiple-value-bind (instruction new-code) + (funcall instruction-disassembler + code) + (when (eq code new-code) + (loop-finish)) + (loop until (eq code new-code) + do (incf pc) + (setf code (cdr code))) + (let ((operands (instruction-operands instruction))) + (if (notany #'pc-relative-operand-p operands) + instruction + (nconc (loop until (eq instruction operands) + collect (pop instruction)) + (loop for operand in operands + collect (if (not (pc-relative-operand-p operand)) + operand + (let* ((location (+ pc (pc-relative-operand-offset operand))) + (entry (or (rassoc location symtab) + (car (push (cons (gensym) location) + symtab))))) + `(quote ,(car entry)))))))))))) + (values (loop for (pc instruction) on proglist0 by #'cddr + when (car (rassoc pc symtab)) + collect it + collect instruction) + symtab)))

1 0

[movitz-cvs] CVS movitz
by ffjeld 18 Feb '08

18 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv31162 Modified Files: bootblock.lisp Log Message: New function-names in asm. --- /project/movitz/cvsroot/movitz/bootblock.lisp 2008/02/09 18:42:26 1.14 +++ /project/movitz/cvsroot/movitz/bootblock.lisp 2008/02/18 22:30:21 1.15 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:47:19 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: bootblock.lisp,v 1.14 2008/02/09 18:42:26 ffjeld Exp $ +;;;; $Id: bootblock.lisp,v 1.15 2008/02/18 22:30:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -402,13 +402,13 @@ (multiple-value-bind (bios-loader bb-symtab) (let ((asm-x86:*position-independent-p* nil) (asm-x86:*cpu-mode* :16-bit)) - (asm:proglist-encode (mkasm16-bios-bootloader image-size load-address skip-sectors) - :start-pc #x7c00)) + (asm:assemble-proglist (mkasm16-bios-bootloader image-size load-address skip-sectors) + :start-pc #x7c00)) (multiple-value-bind (protected-loader protected-symtab) (let ((asm-x86:*position-independent-p* nil)) - (asm:proglist-encode (mkasm-loader image-size load-address call-address) - :start-pc (cdr (or (assoc 'new-world bb-symtab) - (error "No new-world defined in bios-loader."))))) + (asm:assemble-proglist (mkasm-loader image-size load-address call-address) + :start-pc (cdr (or (assoc 'new-world bb-symtab) + (error "No new-world defined in bios-loader."))))) (let* ((loader-length (+ (length bios-loader) (length protected-loader))) (bootblock (progn

1 0

[movitz-cvs] CVS movitz
by ffjeld 18 Feb '08

18 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv13327 Modified Files: asm-x86.lisp Log Message: Disassemble moffset operands. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 23:15:04 1.27 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/18 20:57:14 1.28 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.27 2008/02/16 23:15:04 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.28 2008/02/18 20:57:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -217,7 +217,7 @@ (cond ((atom body) nil) - ((member (car body) '(reg-modrm modrm opcode imm-modrm imm opcode-reg pc-rel)) + ((member (car body) '(reg-modrm modrm opcode imm-modrm imm opcode-reg pc-rel moffset)) (list body)) (t (mapcan #'find-forms body))))) (let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator)))) @@ -310,36 +310,7 @@ (set-it *opcode-disassemblers-32* opcode) (set-it *opcode-disassemblers-64* opcode))))) -(defun disassemble-instruction (code &optional override-operand-size override-address-size rex) - (labels ((lookup-decoder (table opcode) - (let* ((datum (pop-code code)) - (opcode (logior (ash opcode 8) - datum)) - (decoder (svref table datum))) - (typecase decoder - ((simple-vector 256) - (lookup-decoder decoder opcode)) - (disassembly-decoder - (values decoder - opcode)) - (t (error "No disassembler registered for opcode #x~X." opcode)))))) - (multiple-value-bind (decoder opcode) - (lookup-decoder (ecase (or override-operand-size *cpu-mode*) - (:16-bit *opcode-disassemblers-16*) - (:32-bit *opcode-disassemblers-32*) - (:64-bit *opcode-disassemblers-64*)) - 0) - (destructuring-bind (operator operand-size decoder-function &rest extra-args) - decoder - (values (code-call (apply decoder-function - code - operator - opcode - (or operand-size override-operand-size) - (or override-address-size *cpu-mode*) - rex - extra-args)) - code))))) + (defmacro define-disassembler ((operator opcode &optional cpu-mode (digit nil digit-p)) lambda-list &body body) (cond @@ -823,6 +794,37 @@ (1+ (lognot unsigned-integer))))) code))) +(defun disassemble-instruction (code &optional override-operand-size override-address-size rex) + (labels ((lookup-decoder (table opcode) + (let* ((datum (pop-code code)) + (opcode (logior (ash opcode 8) + datum)) + (decoder (svref table datum))) + (typecase decoder + ((simple-vector 256) + (lookup-decoder decoder opcode)) + (disassembly-decoder + (values decoder + opcode)) + (t (error "No disassembler registered for opcode #x~X." opcode)))))) + (multiple-value-bind (decoder opcode) + (lookup-decoder (ecase (or override-operand-size *cpu-mode*) + (:16-bit *opcode-disassemblers-16*) + (:32-bit *opcode-disassemblers-32*) + (:64-bit *opcode-disassemblers-64*)) + 0) + (destructuring-bind (operator operand-size decoder-function &rest extra-args) + decoder + (values (code-call (apply decoder-function + code + operator + opcode + (or operand-size override-operand-size) + (or override-address-size *cpu-mode*) + rex + extra-args)) + code))))) + (defun decode-no-operands (code operator opcode operand-size address-size rex &rest fixed-operands) (declare (ignore opcode operand-size address-size rex)) (values (list* operator @@ -873,6 +875,14 @@ `(:pc+ ,(code-call (decode-integer code type)))) code)) +(defun decode-moffset (code operator opcode operand-size address-size rex type operand-ordering fixed-operand) + (declare (ignore opcode operand-size address-size rex)) + (values (list* operator + (order-operands operand-ordering + :moffset (list (code-call (decode-integer code type))) + :fixed fixed-operand)) + code)) + (defun decode-opcode-reg (code operator opcode operand-size address-size rex operand-ordering extra-operand) (declare (ignore address-size rex)) (values (list* operator @@ -1125,17 +1135,31 @@ :rex default-rex) (encode-reg/mem ,op-modrm operator-mode)))))) -(defmacro moffset (opcode op-offset type) - `(when (indirect-operand-p ,op-offset) - (multiple-value-bind (reg offsets reg2) - (parse-indirect-operand ,op-offset) - (when (and (not reg) - (not reg2)) - (return-values-when - (encoded-values :opcode ,opcode - :displacement (encode-integer (reduce #'+ offsets - :key #'resolve-operand) - ',type))))))) +(defmacro moffset (opcode op-offset type fixed-operand) + `(progn + (assembler + (when (and ,@(when fixed-operand + `((eql ,@fixed-operand))) + (indirect-operand-p ,op-offset)) + (multiple-value-bind (reg offsets reg2) + (parse-indirect-operand ,op-offset) + (when (and (not reg) + (not reg2)) + (return-values-when + (encoded-values :opcode ,opcode + :displacement (encode-integer (reduce #'+ offsets + :key #'resolve-operand) + ',type))))))) + (disassembler + (define-disassembler (operator ,opcode operator-mode) + decode-moffset + ',type + (operand-ordering operand-formals + :moffset ',op-offset + :fixed ',(first fixed-operand)) + ',(second fixed-operand))))) + + (defmacro opcode (opcode &optional fixed-operand &rest extras) `(progn @@ -1771,20 +1795,16 @@ ;;;;;;;;;;; MOV (define-operator/8 :movb (src dst) - (when (eq src :al) - (moffset #xa2 dst (uint 8))) - (when (eq dst :al) - (moffset #xa0 src (uint 8))) + (moffset #xa2 dst (uint 8) (src :al)) + (moffset #xa0 src (uint 8) (dst :al)) (opcode-reg-imm #xb0 dst src (xint 8)) (imm-modrm src dst #xc6 0 (xint 8)) (reg-modrm dst src #x8a) (reg-modrm src dst #x88)) (define-operator/16 :movw (src dst) - (when (eq src :ax) - (moffset #xa3 dst (uint 16))) - (when (eq dst :ax) - (moffset #xa0 src (uint 16))) + (moffset #xa3 dst (uint 16) (src :ax)) + (moffset #xa0 src (uint 16) (dst :ax)) (opcode-reg-imm #xb8 dst src (xint 16)) (imm-modrm src dst #xc7 0 (xint 16)) (sreg-modrm src dst #x8c) @@ -1793,10 +1813,8 @@ (reg-modrm src dst #x89)) (define-operator/32 :movl (src dst) - (when (eq src :eax) - (moffset #xa3 dst (uint 32))) - (when (eq dst :eax) - (moffset #xa0 src (uint 32))) + (moffset #xa3 dst (uint 32) (src :eax)) + (moffset #xa0 src (uint 32) (dst :eax)) (opcode-reg-imm #xb8 dst src (xint 32)) (imm-modrm src dst #xc7 0 (xint 32)) (reg-modrm dst src #x8b)

1 0

[movitz-cvs] CVS movitz
by ffjeld 17 Feb '08

17 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv7215 Modified Files: compiler.lisp Log Message: Improved tree-search, for speed. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/16 23:35:22 1.191 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/17 00:10:11 1.192 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.191 2008/02/16 23:35:22 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.192 2008/02/17 00:10:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3256,12 +3256,24 @@ (binding-eql x (forwarding-binding-target y))))) (defun tree-search (tree items) - (etypecase tree - (atom (if (atom items) - (eql tree items) - (member tree items))) - (cons (or (tree-search (car tree) items) - (tree-search (cdr tree) items))))) + (if (and (atom items) ; make common case fast(er), hopefully. + (not (numberp items))) + (labels ((tree-search* (tree item) + (etypecase tree + (null nil) + (cons + (or (tree-search* (car tree) item) + (tree-search* (cdr tree) item))) + (t (eq tree item))))) + (tree-search* tree items)) + (etypecase tree + (atom + (if (atom items) + (eql tree items) + (member tree items))) + (cons + (or (tree-search (car tree) items) + (tree-search (cdr tree) items)))))) (defun operator (x) (if (atom x) x (car x)))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs February 2008