diff --git a/src/asm-tests.ss b/src/asm-tests.ss index 7efb76a..e854a93 100755 --- a/src/asm-tests.ss +++ b/src/asm-tests.ss @@ -1,6 +1,9 @@ #!/usr/bin/env ikarus --script + +(define counter 0) (define (asm-test res ls) - (printf "Testing:\n") + (set! counter (add1 counter)) + (printf "[~s] Testing:\n" counter) (for-each (lambda (x) (printf " ~s\n" x)) ls) @@ -103,6 +106,22 @@ [movl (disp -4 %esp) %eax] [ret])) + +(asm-test 3 + '([movl 4 (disp -4 %esp)] + [movl 8 %eax] + [orl %eax (disp -4 %esp)] + [movl (disp -4 %esp) %eax] + [ret])) + +(asm-test 3 + '([movl 4 (disp -4 %esp)] + [movl 8 %ebx] + [orl %ebx (disp -4 %esp)] + [movl (disp -4 %esp) %eax] + [ret])) + + (asm-test 3 '([movl -1 (disp -4 %esp)] [andl 12 (disp -4 %esp)] @@ -146,5 +165,27 @@ [call (disp 26 (obj car))] [ret])) +(asm-test 8 + '([movl (obj 1) (disp -8 %esp)] + [movl 3 %ecx] + [sall %cl (disp -8 %esp)] + [movl (disp -8 %esp) %eax] + [ret])) + +(asm-test 1 + '([movl (obj 8) (disp -8 %esp)] + [movl 3 %ecx] + [sarl %cl (disp -8 %esp)] + [movl (disp -8 %esp) %eax] + [ret])) + +(asm-test 1 + '([movl (obj 8) (disp -8 %esp)] + [movl 3 %ecx] + [shrl %cl (disp -8 %esp)] + [movl (disp -8 %esp) %eax] + [ret])) + + (printf "Happy Happy Joy Joy\n") (exit) diff --git a/src/ikarus.boot b/src/ikarus.boot index 83b9791..26b18c2 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libaltcogen.ss b/src/libaltcogen.ss index c4765b3..74d32d0 100644 --- a/src/libaltcogen.ss +++ b/src/libaltcogen.ss @@ -887,8 +887,6 @@ ; (print-code x) (Program x)) - - (module ListySet (make-empty-set set-member? set-add set-rem set-difference set-union empty-set? @@ -949,13 +947,219 @@ [(memq (car s1) s2) (union (cdr s1) s2)] [else (cons (car s1) (union (cdr s1) s2))]))) -;(module IntegerSet -; (make-empty-set set-member? set-add set-rem set-difference -; set-union empty-set? set->list list->set) -; -; ) +(module IntegerSet + (make-empty-set set-member? set-add set-rem set-difference + set-union empty-set? set->list list->set set-map set-for-each + set-ormap set-andmap) + + (begin + (define-syntax car (identifier-syntax #%$car)) + (define-syntax cdr (identifier-syntax #%$cdr)) + (define-syntax fxsll (identifier-syntax #%$fxsll)) + (define-syntax fxsra (identifier-syntax #%$fxsra)) + (define-syntax fxlogor (identifier-syntax #%$fxlogor)) + (define-syntax fxlogand (identifier-syntax #%$fxlogand)) + (define-syntax fxlognot (identifier-syntax #%$fxlognot)) + (define-syntax fx+ (identifier-syntax #%$fx+)) + (define-syntax fxzero? (identifier-syntax #%$fxzero?)) + (define-syntax fxeven? + (syntax-rules () + [(_ x) (#%$fxzero? (#%$fxlogand x 1))]))) -(module IntegerSet + (define shift 4) + (define mask #xF) + (define (index-of n) (fxsra n shift)) + (define (mask-of n) (fxsll 1 (fxlogand n mask))) + + (define (make-empty-set) 0) + (define (empty-set? s) (eqv? s 0)) + + (define (set-member? n s) + (let f ([s s] [i (index-of n)] [j (mask-of n)]) + (cond + [(pair? s) + (if (fxeven? i) + (f (car s) (fxsra i 1) j) + (f (cdr s) (fxsra i 1) j))] + [(eq? i 0) (eq? j (fxlogand s j))] + [else #f]))) + + (define (set-add n s) + (let f ([s s] [i (index-of n)] [j (mask-of n)]) + (cond + [(pair? s) + (if (fxeven? i) + (let ([a0 (car s)]) + (let ([a1 (f a0 (fxsra i 1) j)]) + (if (eq? a0 a1) s (cons a1 (cdr s))))) + (let ([d0 (cdr s)]) + (let ([d1 (f d0 (fxsra i 1) j)]) + (if (eq? d0 d1) s (cons (car s) d1)))))] + [(eq? i 0) (fxlogor s j)] + [else + (if (fxeven? i) + (cons (f s (fxsra i 1) j) 0) + (cons s (f 0 (fxsra i 1) j)))]))) + + (define (cons^ a d) + (if (and (eq? d 0) (fixnum? a)) + a + (cons a d))) + + (define (set-rem n s) + (let f ([s s] [i (index-of n)] [j (mask-of n)]) + (cond + [(pair? s) + (if (fxeven? i) + (let ([a0 (car s)]) + (let ([a1 (f a0 (fxsra i 1) j)]) + (if (eq? a0 a1) s (cons^ a1 (cdr s))))) + (let ([d0 (cdr s)]) + (let ([d1 (f d0 (fxsra i 1) j)]) + (if (eq? d0 d1) s (cons^ (car s) d1)))))] + [(eq? i 0) (fxlogand s (fxlognot j))] + [else s]))) + + (define (set-union^ s1 m2) + (if (pair? s1) + (let ([a0 (car s1)]) + (let ([a1 (set-union^ a0 m2)]) + (if (eq? a0 a1) s1 (cons a1 (cdr s1))))) + (fxlogor s1 m2))) + + (define (set-union s1 s2) + (if (pair? s1) + (if (pair? s2) + (if (eq? s1 s2) + s1 + (cons (set-union (car s1) (car s2)) + (set-union (cdr s1) (cdr s2)))) + (let ([a0 (car s1)]) + (let ([a1 (set-union^ a0 s2)]) + (if (eq? a0 a1) s1 (cons a1 (cdr s1)))))) + (if (pair? s2) + (let ([a0 (car s2)]) + (let ([a1 (set-union^ a0 s1)]) + (if (eq? a0 a1) s2 (cons a1 (cdr s2))))) + (fxlogor s1 s2)))) + + (define (set-difference^ s1 m2) + (if (pair? s1) + (let ([a0 (car s1)]) + (let ([a1 (set-difference^ a0 m2)]) + (if (eq? a0 a1) s1 (cons^ a1 (cdr s1))))) + (fxlogand s1 (fxlognot m2)))) + + (define (set-difference^^ m1 s2) + (if (pair? s2) + (set-difference^^ m1 (car s2)) + (fxlogand m1 (fxlognot s2)))) + + (define (set-difference s1 s2) + (if (pair? s1) + (if (pair? s2) + (if (eq? s1 s2) + 0 + (cons^ (set-difference (car s1) (car s2)) + (set-difference (cdr s1) (cdr s2)))) + (let ([a0 (car s1)]) + (let ([a1 (set-difference^ a0 s2)]) + (if (eq? a0 a1) s1 (cons^ a1 (cdr s1)))))) + (if (pair? s2) + (set-difference^^ s1 (car s2)) + (fxlogand s1 (fxlognot s2))))) + + (define (list->set ls) + (let f ([ls ls] [s 0]) + (cond + [(null? ls) s] + [else (f (cdr ls) (set-add (car ls) s))]))) + + (define (set->list s) + (let f ([i 0] [j (fxsll 1 shift)] [s s] [ac '()]) + (cond + [(pair? s) + (f i (fxsll j 1) (car s) + (f (fxlogor i j) (fxsll j 1) (cdr s) ac))] + [else + (let f ([i i] [m s] [ac ac]) + (cond + [(fxeven? m) + (if (fxzero? m) + ac + (f (fx+ i 1) (fxsra m 1) ac))] + [else + (f (fx+ i 1) (fxsra m 1) (cons i ac))]))]))) + + + (define (set-map proc s) + (let f ([i 0] [j (fxsll 1 shift)] [s s] [ac '()]) + (cond + [(pair? s) + (f i (fxsll j 1) (car s) + (f (fxlogor i j) (fxsll j 1) (cdr s) ac))] + [else + (let f ([i i] [m s] [ac ac]) + (cond + [(fxeven? m) + (if (fxzero? m) + ac + (f (fx+ i 1) (fxsra m 1) ac))] + [else + (f (fx+ i 1) (fxsra m 1) (cons (proc i) ac))]))]))) + + (define (set-for-each proc s) + (let f ([i 0] [j (fxsll 1 shift)] [s s]) + (cond + [(pair? s) + (f i (fxsll j 1) (car s)) + (f (fxlogor i j) (fxsll j 1) (cdr s))] + [else + (let f ([i i] [m s]) + (cond + [(fxeven? m) + (unless (fxzero? m) + (f (fx+ i 1) (fxsra m 1)))] + [else + (proc i) + (f (fx+ i 1) (fxsra m 1))]))]))) + + (define (set-ormap proc s) + (let f ([i 0] [j (fxsll 1 shift)] [s s]) + (cond + [(pair? s) + (or (f i (fxsll j 1) (car s)) + (f (fxlogor i j) (fxsll j 1) (cdr s)))] + [else + (let f ([i i] [m s]) + (cond + [(fxeven? m) + (if (fxzero? m) + #f + (f (fx+ i 1) (fxsra m 1)))] + [else + (or (proc i) + (f (fx+ i 1) (fxsra m 1)))]))]))) + + (define (set-andmap proc s) + (let f ([i 0] [j (fxsll 1 shift)] [s s]) + (cond + [(pair? s) + (and (f i (fxsll j 1) (car s)) + (f (fxlogor i j) (fxsll j 1) (cdr s)))] + [else + (let f ([i i] [m s]) + (cond + [(fxeven? m) + (if (fxzero? m) + #t + (f (fx+ i 1) (fxsra m 1)))] + [else + (and (proc i) + (f (fx+ i 1) (fxsra m 1)))]))]))) +#|IntegerSet|#) + +(module IntegerSet-list (make-empty-set set-member? set-add set-rem set-difference set-union empty-set? set->list list->set) @@ -1020,6 +1224,106 @@ [(memq (car s1) s2) (union (cdr s1) s2)] [else (cons (car s1) (union (cdr s1) s2))]))) +;;;(module IntegerSet +;;; (make-empty-set set-member? set-add set-rem set-difference set-union +;;; empty-set? set->list list->set) +;;; +;;; (define-syntax L +;;; (lambda (x) +;;; (syntax-case x () +;;; [(L expr) +;;; (with-syntax ([w +;;; (datum->syntax-object #'L +;;; '(import IntegerSet-list))]) +;;; #'(let () w expr))]))) +;;; +;;; (define-syntax T +;;; (lambda (x) +;;; (syntax-case x () +;;; [(L expr) +;;; (with-syntax ([w +;;; (datum->syntax-object #'L +;;; '(import IntegerSet-tree))]) +;;; #'(let () w expr))]))) +;;; +;;; (define-record set (ls tr)) +;;; +;;; (define (make-empty-set) +;;; (make-set (L (make-empty-set)) +;;; (T (make-empty-set)))) +;;; +;;; (define (set-member? x s) +;;; (if (L (set-member? x (set-ls s))) +;;; (if (T (set-member? x (set-tr s))) +;;; #t +;;; (error "mismatch member ~s in ~s" x s)) +;;; (if (T (set-member? x (set-tr s))) +;;; (error "mismatch member ~s in ~s" x s) +;;; #f))) +;;; +;;; (define (set-add x s) +;;; (verify-set 'set-add +;;; (make-set (L (set-add x (set-ls s))) +;;; (T (set-add x (set-tr s)))))) +;;; +;;; (define (set-rem x s) +;;; (verify-set 'set-rem +;;; (make-set (L (set-rem x (set-ls s))) +;;; (T (set-rem x (set-tr s)))))) +;;; +;;; (define (set-difference s1 s2) +;;; (verify-set 'set-difference +;;; (make-set (L (set-difference (set-ls s1) (set-ls s2))) +;;; (T (set-difference (set-tr s1) (set-tr s2)))))) +;;; +;;; +;;; (define (set-union s1 s2) +;;; (verify-set 'set-union +;;; (make-set (L (set-union (set-ls s1) (set-ls s2))) +;;; (T (set-union (set-tr s1) (set-tr s2)))))) +;;; +;;; (define (empty-set? s) +;;; (if (L (empty-set? (set-ls s))) +;;; (if (T (empty-set? (set-tr s))) +;;; #t +;;; (error "mismatch empty-set in ~s" s)) +;;; (if (T (empty-set? (set-tr s))) +;;; (error "mismatch empty-set in ~s" s) +;;; #f))) +;;; +;;; (define (verify-set who s) +;;; (let ([ls1 (L (set->list (set-ls s)))] +;;; [ls2 (T (set->list (set-tr s)))]) +;;; (for-each (lambda (i) +;;; (unless (memq i ls2) +;;; (error who "mismatch ~s ~s ~s" s ls1 ls2))) +;;; ls1) +;;; (for-each (lambda (i) +;;; (unless (memq i ls1) +;;; (error who "mismatch ~s ~s ~s" s ls2 ls2))) +;;; ls2)) +;;; s) +;;; +;;; (define (set->list s) +;;; (let ([ls1 (L (set->list (set-ls s)))] +;;; [ls2 (T (set->list (set-tr s)))]) +;;; (for-each (lambda (i) +;;; (unless (memq i ls2) +;;; (error 'set->list "mismatch ~s" s))) +;;; ls1) +;;; (for-each (lambda (i) +;;; (unless (memq i ls1) +;;; (error 'set->list "mismatch ~s" s))) +;;; ls2) +;;; ls1)) +;;; +;;; (define (list->set ls) +;;; (verify-set 'list->set +;;; (make-set (L (list->set ls)) +;;; (T (list->set ls))))) +;;; +;;; ) + (module ListyGraphs (empty-graph add-edge! empty-graph? print-graph node-neighbors delete-node!) diff --git a/src/libintelasm.ss b/src/libintelasm.ss index db4fac2..ff36945 100644 --- a/src/libintelasm.ss +++ b/src/libintelasm.ss @@ -124,9 +124,6 @@ (error 'with-args "too few args")))])) -;(define byte -; (lambda (x) -; (cons 'byte (fxlogand x 255)))) (define-syntax byte (syntax-rules () @@ -532,6 +529,8 @@ ((CODE/digit #xC1 '/4) dst (IMM8 src ac))] [(and (eq? src '%cl) (reg? dst)) (CODE #xD3 (ModRM 3 '/4 dst ac))] + [(and (eq? src '%cl) (mem? dst)) + ((CODE/digit #xD3 '/4) dst ac)] [else (error who "invalid ~s" instr)])] [(shrl src dst) (cond @@ -543,6 +542,8 @@ (CODE #xD3 (ModRM 3 '/5 dst ac))] [(and (imm8? src) (mem? dst)) ((CODE/digit #xC1 '/5) dst (IMM8 src ac))] + [(and (eq? src '%cl) (mem? dst)) + ((CODE/digit #xD3 '/5) dst ac)] [else (error who "invalid ~s" instr)])] [(sarl src dst) (cond @@ -554,6 +555,8 @@ ((CODE/digit #xC1 '/7) dst (IMM8 src ac))] [(and (eq? src '%cl) (reg? dst)) (CODE #xD3 (ModRM 3 '/7 dst ac))] + [(and (eq? src '%cl) (mem? dst)) + ((CODE/digit #xD3 '/7) dst ac)] [else (error who "invalid ~s" instr)])] [(andl src dst) (cond @@ -576,6 +579,8 @@ (cond [(and (imm? src) (mem? dst)) ((CODE/digit #x81 '/1) dst (IMM32 src ac))] + [(and (reg? src) (mem? dst)) + ((CODE/digit #x09 src) dst ac)] [(and (imm8? src) (reg? dst)) (CODE #x83 (ModRM 3 '/1 dst (IMM8 src ac)))] [(and (imm? src) (eq? dst '%eax))