* added a few missing instruction sequences where the dest is a

memory location.
* implemented integer sets (based on tree representation).
This commit is contained in:
Abdulaziz Ghuloum 2007-03-10 19:50:24 -05:00
parent 10bdc3dcd6
commit fa94d2f6a1
4 changed files with 362 additions and 12 deletions

View File

@ -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)

Binary file not shown.

View File

@ -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!)

View File

@ -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))