conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fx+ open-coded

This commit is contained in:
Abdulaziz Ghuloum 2006-12-08 08:42:56 -05:00
parent 96c647b69d
commit 5a0a7068a8
4 changed files with 97 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
lib/ikarus.boot
View File

Binary file not shown.

95
lib/libcompile.ss
View File

@ -1125,7 +1125,7 @@
(make-constant t))))))) (make-constant t)))))))
(make-primcall op rand*)))) (make-primcall op rand*))))
(giveup))] (giveup))]
#;[(fx+) [(fx+)
(or (and (fx= (length rand*) 2) (or (and (fx= (length rand*) 2)
(let ([a0 (car rand*)] [a1 (cadr rand*)]) (let ([a0 (car rand*)] [a1 (cadr rand*)])
(or (constant-value a1 (or (constant-value a1
@ -2936,6 +2936,9 @@
(define unique-label (define unique-label
(lambda () (lambda ()
(label (gensym)))) (label (gensym))))
(define handlers '())
(define (add-handler! ls)
(set-cdr! handlers (append ls (cdr handlers))))
(define (constant-val x) (define (constant-val x)
(cond (cond
[(fixnum? x) (obj x)] [(fixnum? x) (obj x)]
@ -3246,6 +3249,52 @@
(addl (int (fxsll 1 fx-shift)) eax) (addl (int (fxsll 1 fx-shift)) eax)
(jo (label SL_fxadd1_error)) (jo (label SL_fxadd1_error))
ac))] ac))]
[(fx+)
(let foo ([a0 (car arg*)] [a1 (cadr arg*)])
(cond
[(simple? a1)
(cond
[(constant? a1)
(let ([v (constant-value a1)])
(cond
[(fixnum? v)
(let ([L
(let ([L (unique-label)])
(add-handler!
(list L
(movl (Simple a1) ebx)
(jmp (label SL_fx+_overflow))))
L)])
(NonTail a0
(list*
(movl eax ebx)
(andl (int fx-mask) ebx)
;;; arg in eax
(jne (label SL_fx+_type))
(addl (Simple a1) eax)
(jo L)
ac)))]
[else
(NonTail a0
(list*
(movl (Simple a1) eax)
;;; arg in eax
(jmp (label SL_fx+_type))
ac))]))]
[else
(NonTail a0
(list*
(movl eax ecx)
(movl (Simple a1) ebx)
(orl ebx ecx)
(andl (int fx-mask) ecx)
;;; args in eax, ebx
(jne (label SL_fx+_types))
(addl ebx eax)
;;; args in eax (ac),ebx
(jo (label SL_fx+_overflow))
ac))])]
[else (foo a1 a0)]))]
[(fxsub1) [(fxsub1)
(NonTail (car arg*) (NonTail (car arg*)
(list* (movl eax ebx) (list* (movl eax ebx)
@ -4444,14 +4493,14 @@
(jle (label L)) (jle (label L))
(make-dispatcher #t (make-dispatcher #t
(car L*) (cdr L*) (car x*) (cdr x*) ac))])])])]))) (car L*) (cdr L*) (car x*) (cdr x*) ac))])])])])))
(define (handle-cases x x*) (define (handle-cases x x* ac)
(let ([L* (map (lambda (_) (gensym)) x*)] (let ([L* (map (lambda (_) (gensym)) x*)]
[L (gensym)]) [L (gensym)])
(make-dispatcher #f L L* x x* (make-dispatcher #f L L* x x*
(let f ([x x] [x* x*] [L L] [L* L*]) (let f ([x x] [x* x*] [L L] [L* L*])
(cond (cond
[(null? x*) [(null? x*)
(cons (label L) (Entry 'check x '()))] (cons (label L) (Entry 'check x ac))]
[else [else
(cons (label L) (cons (label L)
(Entry #f x (Entry #f x
@ -4459,18 +4508,26 @@
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda L cases free) [(clambda L cases free)
(set! handlers (list '(nop)))
(list* (list*
(length free) (length free)
(label L) (label L)
(handle-cases (car cases) (cdr cases)))])) (handle-cases (car cases) (cdr cases) handlers))]))
(record-case x (record-case x
[(codes list body) [(codes ls body)
(cons (list* 0 (let ([body
(label (gensym)) (begin
(Tail body '())) (set! handlers (list '(nop)))
(map CodeExpr list))])) (Tail body handlers))])
(cons (list* 0
(label (gensym))
body)
(map CodeExpr ls)))]))
(begin ;;; ASSEMBLY HELPERS (begin ;;; ASSEMBLY HELPERS
(define SL_fx+_type (gensym "SL_fx+_type"))
(define SL_fx+_types (gensym "SL_fx+_types"))
(define SL_fx+_overflow (gensym "SL_fx+_overflow"))
(define SL_fxadd1_error (gensym "SL_fxadd1_error")) (define SL_fxadd1_error (gensym "SL_fxadd1_error"))
(define SL_fxsub1_error (gensym "SL_fxsub1_error")) (define SL_fxsub1_error (gensym "SL_fxsub1_error"))
(define SL_nonprocedure (gensym "SL_nonprocedure")) (define SL_nonprocedure (gensym "SL_nonprocedure"))
@ -4498,6 +4555,26 @@
(movl (primref-loc 'fxadd1-error) cpr) (movl (primref-loc 'fxadd1-error) cpr)
(movl (int (argc-convention 1)) eax) (movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call)) (tail-indirect-cpr-call))
(list 0
(label SL_fx+_type)
(movl eax (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'fx+-type-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))
(list 0
(label SL_fx+_overflow)
(movl eax (mem (fx- 0 wordsize) fpr))
(movl ebx (mem (fx- wordsize wordsize) fpr))
(movl (primref-loc 'fx+-overflow-error) cpr)
(movl (int (argc-convention 2)) eax)
(tail-indirect-cpr-call))
(list 0
(label SL_fx+_types)
(movl eax (mem (fx- 0 wordsize) fpr))
(movl ebx (mem (fx- wordsize wordsize) fpr))
(movl (primref-loc 'fx+-types-error) cpr)
(movl (int (argc-convention 2)) eax)
(tail-indirect-cpr-call))
(list 0 (list 0
(label SL_fxsub1_error) (label SL_fxsub1_error)
(movl eax (mem (fx- 0 wordsize) fpr)) (movl eax (mem (fx- 0 wordsize) fpr))

6
lib/libcore.ss
View File

@ -371,11 +371,7 @@ reference-implementation:
(primitive-set! 'fx+ (primitive-set! 'fx+
(lambda (x y) (lambda (x y)
(unless (fixnum? x) (fx+ x y)))
(error 'fx+ "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx+ "~s is not a fixnum" y))
($fx+ x y)))
(primitive-set! 'fx- (primitive-set! 'fx-
(lambda (x y) (lambda (x y)

14
lib/libhandlers.ss
View File

@ -59,9 +59,15 @@
(lambda (x) (lambda (x)
(error 'cadr "invalid list structure in ~s" x))) (error 'cadr "invalid list structure in ~s" x)))
(primitive-set! 'fx+-error (primitive-set! 'fx+-type-error
(lambda (x) (lambda (x)
(if (fixnum? x) (error 'fx+ "~s is not a fixnum" x)))
(error 'fx+ "overflow")
(error 'fx+ "~s is not a fixnum" x))))
(primitive-set! 'fx+-types-error
(lambda (x y)
(error 'fx+ "~s is not a fixnum"
(if (fixnum? x) y x))))
(primitive-set! 'fx+-overflow-error
(lambda (x y)
(error 'fx+ "overflow")))