movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[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 16 Feb '08

16 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

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

16 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv32621 Modified Files: compiler.lisp Log Message: Small speedup of peeping optimizer. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/16 21:22:05 1.190 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/16 23:35:22 1.191 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.190 2008/02/16 21:22:05 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.191 2008/02/16 23:35:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1553,8 +1553,10 @@ "If i is a branch, return the label." (when jmp (push :jmp branch-types)) (let ((i (ignore-instruction-prefixes i))) - (or (and (listp i) (member (car i) branch-types) - (listp (second i)) (member (car (second i)) '(quote muerte.cl::quote)) + (or (and (listp i) + (listp (second i)) + (member (car (second i)) '(quote muerte.cl::quote)) + (member (car i) branch-types) (second (second i))) #+ignore (and (listp i)

1 0

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

16 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv28273 Modified Files: asm-x86.lisp Log Message: Fix typo in testb declaration. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 22:13:25 1.26 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 23:15:04 1.27 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.26 2008/02/16 22:13:25 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.27 2008/02/16 23:15:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2098,7 +2098,7 @@ ;;;;;;;;;;; TEST (define-operator/8 :testb (mask dst) - (imm mask #xa8 (xint 8) (mask :al)) + (imm mask #xa8 (xint 8) (dst :al)) (imm-modrm mask dst #xf6 0 (xint 8)) (reg-modrm mask dst #x84))

1 0

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

16 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv14860 Modified Files: asm-x86.lisp Log Message: Fix up used/unused variables. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 21:58:57 1.25 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 22:13:25 1.26 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.25 2008/02/16 21:58:57 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.26 2008/02/16 22:13:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -243,7 +243,7 @@ (let ((operator ',operator) (operator-mode ',operator-mode) (operand-formals ',lambda-list)) - (declare (ignorable operand-formals)) + (declare (ignorable operator operand-formals operator-mode)) ,@(find-forms body))) ',operator)))) @@ -384,7 +384,7 @@ (disassemble-instruction code :16-bit address-size nil)) (define-disassembler (:address-size-override #x67 :32-bit) (code operator opcode operand-size address-size rex) - (declare (ignore operator opcode operand-size rex)) + (declare (ignore operator opcode address-size rex)) (disassemble-instruction code operand-size :16-bit nil)) (define-disassembler (:operand-size-override #x66 :16-bit) (code operator opcode operand-size address-size rex) @@ -392,7 +392,7 @@ (disassemble-instruction code :32-bit address-size nil)) (define-disassembler (:address-size-override #x67 :16-bit) (code operator opcode operand-size address-size rex) - (declare (ignore operator opcode operand-size rex)) + (declare (ignore operator opcode address-size rex)) (disassemble-instruction code operand-size :32-bit nil)) (defmacro define-operator/8 (operator lambda-list &body body) @@ -808,6 +808,7 @@ (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." `(let (tmp) + (declare (ignorable tmp)) (setf (values tmp ,code-place) ,form))) (defun decode-integer (code type) @@ -843,6 +844,7 @@ (defun decode-modrm (code operator opcode operand-size address-size rex) + (declare (ignore opcode rex)) (values (list operator (ecase address-size (:32-bit @@ -852,6 +854,7 @@ code)) (defun decode-imm-modrm (code operator opcode operand-size address-size rex imm-type operand-ordering &key fixed-modrm) + (declare (ignore opcode rex)) (values (list* operator (order-operands operand-ordering :modrm (or fixed-modrm @@ -865,11 +868,13 @@ code)) (defun decode-pc-rel (code operator opcode operand-size address-size rex type) + (declare (ignore opcode operand-size address-size rex)) (values (list operator `(:pc+ ,(code-call (decode-integer code type)))) 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 (order-operands operand-ordering :reg (nth (ldb (byte 3 0) opcode) @@ -903,7 +908,6 @@ "Return a list of the REG, and the MOD/RM operands." (let* ((modrm (pop-code code mod/rm)) (mod (ldb (byte 2 6) modrm)) - (reg (ldb (byte 3 3) modrm)) (r/m (ldb (byte 3 0) modrm))) (values (if (= mod #b11) (nth r/m (register-set-by-mode operand-size))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs