2007-03-09 14:01:17 -05:00
|
|
|
|
|
|
|
(define-syntax section
|
|
|
|
(syntax-rules (/section)
|
|
|
|
[(section e* ... /section) (begin e* ...)]))
|
|
|
|
|
|
|
|
(section ;;; helpers
|
|
|
|
|
2007-03-02 02:47:36 -05:00
|
|
|
(define (prm op . arg*)
|
|
|
|
(make-primcall op arg*))
|
|
|
|
|
|
|
|
(define (nop) (make-primcall 'nop '()))
|
|
|
|
|
|
|
|
(define (K x) (make-constant x))
|
|
|
|
|
|
|
|
|
|
|
|
(define (tag-test x mask tag)
|
|
|
|
(if mask
|
|
|
|
(prm '= (prm 'logand x (K mask)) (K tag))
|
|
|
|
(prm '= x (K tag))))
|
|
|
|
|
|
|
|
(define (sec-tag-test x pmask ptag smask stag)
|
|
|
|
(make-conditional
|
|
|
|
(tag-test x pmask ptag)
|
|
|
|
(tag-test (prm 'mref x (K (- ptag))) smask stag)
|
|
|
|
(make-constant #f)))
|
|
|
|
|
|
|
|
(define (safe-ref x disp mask tag)
|
|
|
|
(seq*
|
|
|
|
(interrupt-unless (tag-test x mask tag))
|
|
|
|
(prm 'mref x (K (- disp tag)))))
|
|
|
|
|
|
|
|
(define (dirty-vector-set address)
|
|
|
|
(prm 'mset
|
|
|
|
(prm 'int+
|
2007-08-28 19:47:14 -04:00
|
|
|
(prm 'mref pcr (K 28))
|
|
|
|
(prm 'sll (prm 'srl address (K pageshift)) (K wordshift)))
|
2007-03-02 02:47:36 -05:00
|
|
|
(K 0)
|
|
|
|
(K dirty-word)))
|
|
|
|
|
|
|
|
(define (smart-dirty-vector-set addr what)
|
|
|
|
(record-case what
|
|
|
|
[(constant t)
|
|
|
|
(if (or (fixnum? t) (immediate? t))
|
|
|
|
(prm 'nop)
|
|
|
|
(dirty-vector-set addr))]
|
|
|
|
[else (dirty-vector-set addr)]))
|
|
|
|
|
|
|
|
(define (mem-assign v x i)
|
|
|
|
(with-tmp ([t (prm 'int+ x (K i))])
|
|
|
|
(make-seq
|
|
|
|
(prm 'mset t (K 0) (T v))
|
|
|
|
(dirty-vector-set t))))
|
|
|
|
|
|
|
|
(define (smart-mem-assign what v x i)
|
|
|
|
(record-case what
|
|
|
|
[(constant t)
|
|
|
|
(if (or (fixnum? t) (immediate? t))
|
|
|
|
(prm 'mset x (K i) v)
|
|
|
|
(mem-assign v x i))]
|
|
|
|
[else (mem-assign v x i)]))
|
|
|
|
|
|
|
|
(define (align-code unknown-amt known-amt)
|
|
|
|
(prm 'sll
|
|
|
|
(prm 'sra
|
|
|
|
(prm 'int+ unknown-amt
|
|
|
|
(K (+ known-amt (sub1 object-alignment))))
|
|
|
|
(K align-shift))
|
|
|
|
(K align-shift)))
|
2007-03-09 14:01:17 -05:00
|
|
|
/section)
|
2007-03-02 02:47:36 -05:00
|
|
|
|
|
|
|
(section ;;; simple objects section
|
|
|
|
|
2007-06-02 21:55:40 -04:00
|
|
|
(define-primop base-rtd safe
|
|
|
|
[(V) (prm 'mref pcr (K 44))]
|
|
|
|
[(P) (K #t)]
|
|
|
|
[(E) (prm 'nop)])
|
|
|
|
|
2007-03-02 02:47:36 -05:00
|
|
|
(define-primop void safe
|
|
|
|
[(V) (K void-object)]
|
|
|
|
[(P) (K #t)]
|
|
|
|
[(E) (prm 'nop)])
|
|
|
|
|
|
|
|
(define-primop nop unsafe
|
|
|
|
[(E) (prm 'nop)])
|
|
|
|
|
|
|
|
(define-primop neq? unsafe
|
|
|
|
[(P x y) (prm '!= (T x) (T y))]
|
|
|
|
[(E x y) (nop)])
|
|
|
|
|
|
|
|
(define-primop eq? safe
|
|
|
|
[(P x y) (prm '= (T x) (T y))]
|
|
|
|
[(E x y) (nop)])
|
|
|
|
|
|
|
|
(define-primop null? safe
|
|
|
|
[(P x) (prm '= (T x) (K nil))]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
2007-03-03 23:17:04 -05:00
|
|
|
(define-primop not safe
|
|
|
|
[(P x) (prm '= (T x) (K bool-f))]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
2007-03-02 02:47:36 -05:00
|
|
|
(define-primop eof-object safe
|
|
|
|
[(V) (K eof)]
|
|
|
|
[(P) (K #t)]
|
|
|
|
[(E) (nop)])
|
|
|
|
|
|
|
|
(define-primop eof-object? safe
|
|
|
|
[(P x) (prm '= (T x) (K eof))]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $unbound-object? unsafe
|
|
|
|
[(P x) (prm '= (T x) (K unbound))]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop immediate? safe
|
|
|
|
[(P x)
|
|
|
|
(make-conditional
|
|
|
|
(tag-test (T x) fixnum-mask fixnum-tag)
|
|
|
|
(make-constant #t)
|
|
|
|
(tag-test (T x) 7 7))]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop boolean? safe
|
|
|
|
[(P x) (tag-test (T x) bool-mask bool-tag)]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop bwp-object? safe
|
|
|
|
[(P x) (prm '= (T x) (K bwp-object))]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $forward-ptr? unsafe
|
|
|
|
[(P x) (prm '= (T x) (K -1))]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop pointer-value unsafe
|
|
|
|
[(V x) (prm 'logand (T x) (K (* -1 fixnum-scale)))]
|
|
|
|
[(P x) (K #t)]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $arg-list unsafe
|
|
|
|
[(V) (prm 'mref pcr (K 32))] ;; PCB ARGS-LIST
|
|
|
|
[(P) (K #t)]
|
|
|
|
[(E) (nop)])
|
|
|
|
|
2007-03-03 23:17:04 -05:00
|
|
|
(define-primop $memq safe
|
|
|
|
[(P x ls)
|
|
|
|
(record-case ls
|
|
|
|
[(constant ls)
|
|
|
|
(cond
|
|
|
|
[(not (list? ls)) (interrupt)]
|
|
|
|
[else
|
|
|
|
(with-tmp ([x (T x)])
|
|
|
|
(let f ([ls ls])
|
|
|
|
(cond
|
|
|
|
[(null? ls) (K #f)]
|
|
|
|
[(null? (cdr ls)) (prm '= x (T (K (car ls))))]
|
|
|
|
[else
|
|
|
|
(make-conditional
|
|
|
|
(prm '= x (T (K (car ls))))
|
|
|
|
(K #t)
|
|
|
|
(f (cdr ls)))])))])]
|
|
|
|
[else (interrupt)])]
|
|
|
|
[(V x ls)
|
|
|
|
(record-case ls
|
|
|
|
[(constant ls)
|
|
|
|
(cond
|
|
|
|
[(not (list? ls)) (interrupt)]
|
|
|
|
[else
|
|
|
|
(with-tmp ([x (T x)])
|
|
|
|
(let f ([ls ls])
|
|
|
|
(cond
|
|
|
|
[(null? ls) (K bool-f)]
|
|
|
|
[else
|
|
|
|
(make-conditional
|
|
|
|
(prm '= x (T (K (car ls))))
|
|
|
|
(T (K ls))
|
|
|
|
(f (cdr ls)))])))])]
|
|
|
|
[else (interrupt)])]
|
|
|
|
[(E x ls) (nop)])
|
|
|
|
|
|
|
|
|
2007-03-02 02:47:36 -05:00
|
|
|
/section)
|
|
|
|
|
|
|
|
(section ;;; pairs
|
|
|
|
|
|
|
|
(define-primop pair? safe
|
|
|
|
[(P x) (tag-test (T x) pair-mask pair-tag)]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop cons safe
|
|
|
|
[(V a d)
|
|
|
|
(with-tmp ([t (prm 'alloc (K pair-size) (K pair-tag))])
|
|
|
|
(prm 'mset t (K (- disp-car pair-tag)) (T a))
|
|
|
|
(prm 'mset t (K (- disp-cdr pair-tag)) (T d))
|
|
|
|
t)]
|
|
|
|
[(P a d) (K #t)]
|
|
|
|
[(E a d) (prm 'nop)])
|
|
|
|
|
|
|
|
(define-primop $car unsafe
|
|
|
|
[(V x) (prm 'mref (T x) (K (- disp-car pair-tag)))]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $cdr unsafe
|
|
|
|
[(V x) (prm 'mref (T x) (K (- disp-cdr pair-tag)))]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $set-car! unsafe
|
|
|
|
[(E x v)
|
|
|
|
(with-tmp ([x (T x)])
|
|
|
|
(prm 'mset x (K (- disp-car pair-tag)) (T v))
|
|
|
|
(smart-dirty-vector-set x v))])
|
|
|
|
|
|
|
|
(define-primop $set-cdr! unsafe
|
|
|
|
[(E x v)
|
|
|
|
(with-tmp ([x (T x)])
|
|
|
|
(prm 'mset x (K (- disp-cdr pair-tag)) (T v))
|
|
|
|
(smart-dirty-vector-set x v))])
|
|
|
|
|
|
|
|
(define-primop car safe
|
|
|
|
[(V x)
|
|
|
|
(safe-ref (T x) disp-car pair-mask pair-tag)]
|
|
|
|
[(E x)
|
|
|
|
(interrupt-unless (tag-test (T x) pair-mask pair-tag))])
|
|
|
|
|
|
|
|
(define-primop cdr safe
|
|
|
|
[(V x)
|
|
|
|
(safe-ref (T x) disp-cdr pair-mask pair-tag)]
|
|
|
|
[(E x)
|
|
|
|
(interrupt-unless (tag-test (T x) pair-mask pair-tag))])
|
|
|
|
|
|
|
|
(define-primop set-car! safe
|
|
|
|
[(E x v)
|
|
|
|
(with-tmp ([x (T x)])
|
|
|
|
(interrupt-unless (tag-test x pair-mask pair-tag))
|
|
|
|
(prm 'mset x (K (- disp-car pair-tag)) (T v))
|
|
|
|
(smart-dirty-vector-set x v))])
|
|
|
|
|
|
|
|
(define-primop set-cdr! safe
|
|
|
|
[(E x v)
|
|
|
|
(with-tmp ([x (T x)])
|
|
|
|
(interrupt-unless (tag-test x pair-mask pair-tag))
|
|
|
|
(prm 'mset x (K (- disp-cdr pair-tag)) (T v))
|
|
|
|
(smart-dirty-vector-set x v))])
|
|
|
|
|
|
|
|
(define-primop list safe
|
|
|
|
[(V) (K nil)]
|
|
|
|
[(V . arg*)
|
|
|
|
(let ([n (length arg*)] [t* (map T arg*)])
|
|
|
|
(with-tmp ([v (prm 'alloc (K (align (* n pair-size))) (K pair-tag))])
|
|
|
|
(prm 'mset v (K (- disp-car pair-tag)) (car t*))
|
|
|
|
(prm 'mset v
|
|
|
|
(K (- (+ disp-cdr (* (sub1 n) pair-size)) pair-tag))
|
|
|
|
(K nil))
|
|
|
|
(let f ([t* (cdr t*)] [i pair-size])
|
|
|
|
(cond
|
|
|
|
[(null? t*) v]
|
|
|
|
[else
|
|
|
|
(with-tmp ([tmp (prm 'int+ v (K i))])
|
|
|
|
(prm 'mset tmp (K (- disp-car pair-tag)) (car t*))
|
|
|
|
(prm 'mset tmp (K (+ disp-cdr (- pair-size) (- pair-tag))) tmp)
|
|
|
|
(f (cdr t*) (+ i pair-size)))]))))]
|
|
|
|
[(P . arg*) (K #t)]
|
|
|
|
[(E . arg*) (nop)])
|
|
|
|
|
|
|
|
|
|
|
|
(define-primop list* safe
|
|
|
|
[(V) (interrupt)]
|
|
|
|
[(V x) (T x)]
|
|
|
|
[(V a . a*)
|
|
|
|
(let ([t* (map T a*)] [n (length a*)])
|
|
|
|
(with-tmp ([v (prm 'alloc (K (* n pair-size)) (K pair-tag))])
|
|
|
|
(prm 'mset v (K (- disp-car pair-tag)) (T a))
|
|
|
|
(let f ([t* t*] [i pair-size])
|
|
|
|
(cond
|
|
|
|
[(null? (cdr t*))
|
|
|
|
(seq* (prm 'mset v (K (- i disp-cdr pair-tag)) (car t*)) v)]
|
|
|
|
[else
|
|
|
|
(with-tmp ([tmp (prm 'int+ v (K i))])
|
|
|
|
(prm 'mset tmp (K (- disp-car pair-tag)) (car t*))
|
|
|
|
(prm 'mset tmp (K (- (- disp-cdr pair-tag) pair-size)) tmp)
|
|
|
|
(f (cdr t*) (+ i pair-size)))]))))]
|
|
|
|
[(P) (interrupt)]
|
|
|
|
[(P x) (P x)]
|
|
|
|
[(P a . a*) (K #t)]
|
|
|
|
[(E) (interrupt)]
|
|
|
|
[(E . a*) (nop)])
|
|
|
|
|
|
|
|
|
|
|
|
/section)
|
|
|
|
|
|
|
|
(section ;;; vectors
|
2007-06-02 03:21:05 -04:00
|
|
|
(section ;;; helpers
|
|
|
|
(define (vector-range-check x idx)
|
|
|
|
(define (check-fx i)
|
|
|
|
(seq*
|
|
|
|
(interrupt-unless (tag-test (T x) vector-mask vector-tag))
|
|
|
|
(with-tmp ([len (cogen-value-$vector-length x)])
|
|
|
|
(interrupt-unless (prm 'u< (K (* i wordsize)) len))
|
|
|
|
(interrupt-unless-fixnum len))))
|
|
|
|
(define (check-? idx)
|
|
|
|
(seq*
|
|
|
|
(interrupt-unless (tag-test (T x) vector-mask vector-tag))
|
|
|
|
(with-tmp ([len (cogen-value-$vector-length x)])
|
|
|
|
(interrupt-unless (prm 'u< (T idx) len))
|
|
|
|
(with-tmp ([t (prm 'logor len (T idx))])
|
|
|
|
(interrupt-unless-fixnum t)))))
|
|
|
|
(record-case idx
|
|
|
|
[(constant i)
|
|
|
|
(if (and (fixnum? i) (fx>= i 0))
|
|
|
|
(check-fx i)
|
|
|
|
(check-? idx))]
|
|
|
|
[else (check-? idx)]))
|
|
|
|
/section)
|
2007-03-02 02:47:36 -05:00
|
|
|
|
|
|
|
(define-primop vector? unsafe
|
|
|
|
[(P x) (sec-tag-test (T x) vector-mask vector-tag fixnum-mask fixnum-tag)]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $make-vector unsafe
|
|
|
|
[(V len)
|
|
|
|
(record-case len
|
|
|
|
[(constant i)
|
|
|
|
(unless (fixnum? i) (interrupt))
|
|
|
|
(with-tmp ([v (prm 'alloc
|
|
|
|
(K (align (+ (* i wordsize) disp-vector-data)))
|
|
|
|
(K vector-tag))])
|
|
|
|
(prm 'mset v
|
|
|
|
(K (- disp-vector-length vector-tag))
|
|
|
|
(K (make-constant (* i fixnum-scale))))
|
|
|
|
v)]
|
|
|
|
[else
|
|
|
|
(with-tmp ([alen (align-code (T len) disp-vector-data)])
|
|
|
|
(with-tmp ([v (prm 'alloc alen (K vector-tag))])
|
|
|
|
(prm 'mset v (K (- disp-vector-length vector-tag)) (T len))
|
|
|
|
v))])]
|
|
|
|
[(P len) (K #t)]
|
|
|
|
[(E len) (nop)])
|
|
|
|
|
|
|
|
(define-primop $vector-ref unsafe
|
|
|
|
[(V x i)
|
|
|
|
(or
|
|
|
|
(record-case i
|
|
|
|
[(constant i)
|
|
|
|
(and (fixnum? i)
|
|
|
|
(fx>= i 0)
|
|
|
|
(prm 'mref (T x)
|
|
|
|
(K (+ (* i wordsize) (- disp-vector-data vector-tag)))))]
|
|
|
|
[else #f])
|
|
|
|
(prm 'mref (T x)
|
|
|
|
(prm 'int+ (T i) (K (- disp-vector-data vector-tag)))))])
|
|
|
|
|
|
|
|
(define-primop $vector-length unsafe
|
|
|
|
[(V x) (prm 'mref (T x) (K (- disp-vector-length vector-tag)))]
|
|
|
|
[(E x) (prm 'nop)]
|
|
|
|
[(P x) (K #t)])
|
|
|
|
|
|
|
|
(define-primop vector-length safe
|
|
|
|
[(V x)
|
|
|
|
(seq*
|
|
|
|
(interrupt-unless (tag-test (T x) vector-mask vector-tag))
|
|
|
|
(with-tmp ([t (cogen-value-$vector-length x)])
|
|
|
|
(interrupt-unless-fixnum t)
|
|
|
|
t))]
|
|
|
|
[(E x)
|
|
|
|
(seq*
|
|
|
|
(interrupt-unless (tag-test (T x) vector-mask vector-tag))
|
|
|
|
(with-tmp ([t (cogen-value-$vector-length x)])
|
|
|
|
(interrupt-unless-fixnum t)))]
|
|
|
|
[(P x)
|
|
|
|
(seq* (cogen-effect-vector-length x) (K #t))])
|
|
|
|
|
|
|
|
(define-primop vector-ref safe
|
|
|
|
[(V x i)
|
|
|
|
(seq*
|
|
|
|
(vector-range-check x i)
|
|
|
|
(cogen-value-$vector-ref x i))]
|
|
|
|
[(E x i)
|
|
|
|
(vector-range-check x i)])
|
|
|
|
|
|
|
|
|
|
|
|
(define-primop $vector-set! unsafe
|
|
|
|
[(E x i v)
|
|
|
|
(record-case i
|
|
|
|
[(constant i)
|
|
|
|
(unless (fixnum? i) (interrupt))
|
|
|
|
(mem-assign v (T x)
|
|
|
|
(+ (* i wordsize)
|
|
|
|
(- disp-vector-data vector-tag)))]
|
|
|
|
[else
|
|
|
|
(mem-assign v
|
|
|
|
(prm 'int+ (T x) (T i))
|
|
|
|
(- disp-vector-data vector-tag))])])
|
|
|
|
|
2007-03-03 23:17:04 -05:00
|
|
|
(define-primop vector-set! safe
|
2007-03-02 02:47:36 -05:00
|
|
|
[(E x i v)
|
|
|
|
(seq*
|
|
|
|
(vector-range-check x i)
|
|
|
|
(cogen-effect-$vector-set! x i v))])
|
|
|
|
|
|
|
|
(define-primop vector safe
|
|
|
|
[(V . arg*)
|
|
|
|
(with-tmp ([v (prm 'alloc
|
|
|
|
(K (align (+ disp-vector-data
|
|
|
|
(* (length arg*) wordsize))))
|
|
|
|
(K vector-tag))])
|
|
|
|
(seq*
|
|
|
|
(prm 'mset v (K (- disp-vector-length vector-tag))
|
|
|
|
(K (* (length arg*) wordsize)))
|
|
|
|
(let f ([t* (map T arg*)]
|
|
|
|
[i (- disp-vector-data vector-tag)])
|
|
|
|
(cond
|
|
|
|
[(null? t*) v]
|
|
|
|
[else
|
|
|
|
(make-seq
|
|
|
|
(prm 'mset v (K i) (car t*))
|
|
|
|
(f (cdr t*) (+ i wordsize)))]))))]
|
|
|
|
[(E . arg*) (prm 'nop)]
|
|
|
|
[(P . arg*) (K #t)])
|
|
|
|
|
|
|
|
/section)
|
|
|
|
|
|
|
|
(section ;;; closures
|
|
|
|
|
|
|
|
(define-primop procedure? safe
|
|
|
|
[(P x) (tag-test (T x) closure-mask closure-tag)])
|
|
|
|
|
|
|
|
(define-primop $cpref unsafe
|
|
|
|
[(V x i)
|
|
|
|
(record-case i
|
|
|
|
[(constant i)
|
|
|
|
(unless (fixnum? i) (interrupt))
|
|
|
|
(prm 'mref (T x)
|
|
|
|
(K (+ (- disp-closure-data closure-tag)
|
|
|
|
(* i wordsize))))]
|
|
|
|
[else (interrupt)])])
|
|
|
|
|
|
|
|
/section)
|
|
|
|
|
|
|
|
(section ;;; symbols
|
|
|
|
|
|
|
|
(define-primop symbol? safe
|
2007-06-03 19:55:04 -04:00
|
|
|
[(P x)
|
|
|
|
(sec-tag-test (T x) vector-mask vector-tag #f symbol-record-tag)]
|
2007-03-02 02:47:36 -05:00
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $make-symbol unsafe
|
|
|
|
[(V str)
|
2007-06-02 03:21:05 -04:00
|
|
|
(with-tmp ([x (prm 'alloc (K (align symbol-record-size)) (K symbol-ptag))])
|
|
|
|
(prm 'mset x (K (- symbol-ptag)) (K symbol-record-tag))
|
|
|
|
(prm 'mset x (K (- disp-symbol-record-string symbol-ptag)) (T str))
|
|
|
|
(prm 'mset x (K (- disp-symbol-record-ustring symbol-ptag)) (K 0))
|
|
|
|
(prm 'mset x (K (- disp-symbol-record-value symbol-ptag)) (K unbound))
|
|
|
|
(prm 'mset x (K (- disp-symbol-record-proc symbol-ptag)) (K unbound))
|
|
|
|
(prm 'mset x (K (- disp-symbol-record-plist symbol-ptag)) (K nil))
|
|
|
|
;(prm 'mset x (K (- disp-symbol-system-value symbol-tag)) (K unbound))
|
|
|
|
;(prm 'mset x (K (- disp-symbol-function symbol-ptag)) (K 0))
|
|
|
|
;(prm 'mset x (K (- disp-symbol-error-function symbol-ptag)) (K 0))
|
|
|
|
;(prm 'mset x (K (- disp-symbol-unused symbol-tag)) (K 0))
|
2007-03-02 02:47:36 -05:00
|
|
|
x)]
|
|
|
|
[(P str) (K #t)]
|
|
|
|
[(E str) (nop)])
|
|
|
|
|
|
|
|
(define-primop $symbol-string unsafe
|
2007-06-02 03:21:05 -04:00
|
|
|
[(V x) (prm 'mref (T x) (K (- disp-symbol-record-string symbol-ptag)))]
|
2007-03-02 02:47:36 -05:00
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $set-symbol-string! unsafe
|
2007-06-02 03:21:05 -04:00
|
|
|
[(E x v) (mem-assign v (T x) (- disp-symbol-record-string symbol-ptag))])
|
2007-03-02 02:47:36 -05:00
|
|
|
|
|
|
|
(define-primop $symbol-unique-string unsafe
|
2007-06-02 03:21:05 -04:00
|
|
|
[(V x) (prm 'mref (T x) (K (- disp-symbol-record-ustring symbol-ptag)))]
|
2007-03-02 02:47:36 -05:00
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $set-symbol-unique-string! unsafe
|
2007-06-02 03:21:05 -04:00
|
|
|
[(E x v) (mem-assign v (T x) (- disp-symbol-record-ustring symbol-ptag))])
|
2007-03-02 02:47:36 -05:00
|
|
|
|
|
|
|
(define-primop $symbol-plist unsafe
|
2007-06-02 03:21:05 -04:00
|
|
|
[(V x) (prm 'mref (T x) (K (- disp-symbol-record-plist symbol-ptag)))]
|
2007-03-02 02:47:36 -05:00
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $set-symbol-plist! unsafe
|
2007-06-02 03:21:05 -04:00
|
|
|
[(E x v) (mem-assign v (T x) (- disp-symbol-record-plist symbol-ptag))])
|
2007-03-02 02:47:36 -05:00
|
|
|
|
|
|
|
(define-primop $symbol-value unsafe
|
2007-06-02 03:21:05 -04:00
|
|
|
[(V x) (prm 'mref (T x) (K (- disp-symbol-record-value symbol-ptag)))]
|
2007-03-02 02:47:36 -05:00
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $set-symbol-value! unsafe
|
|
|
|
[(E x v)
|
|
|
|
(with-tmp ([x (T x)])
|
2007-06-02 03:21:05 -04:00
|
|
|
(prm 'mset x (K (- disp-symbol-record-value symbol-ptag)) (T v))
|
2007-03-02 02:47:36 -05:00
|
|
|
(dirty-vector-set x))])
|
|
|
|
|
2007-06-02 21:55:40 -04:00
|
|
|
|
2007-03-02 02:47:36 -05:00
|
|
|
(define-primop top-level-value safe
|
|
|
|
[(V x)
|
|
|
|
(record-case x
|
|
|
|
[(constant s)
|
|
|
|
(if (symbol? s)
|
|
|
|
(with-tmp ([v (cogen-value-$symbol-value x)])
|
|
|
|
(interrupt-when (cogen-pred-$unbound-object? v))
|
|
|
|
v)
|
|
|
|
(interrupt))]
|
|
|
|
[else
|
|
|
|
(with-tmp ([x (T x)])
|
|
|
|
(interrupt-unless (cogen-pred-symbol? x))
|
|
|
|
(with-tmp ([v (cogen-value-$symbol-value x)])
|
|
|
|
(interrupt-when (cogen-pred-$unbound-object? v))
|
|
|
|
v))])]
|
|
|
|
[(E x)
|
|
|
|
(record-case x
|
|
|
|
[(constant s)
|
|
|
|
(if (symbol? s)
|
|
|
|
(with-tmp ([v (cogen-value-$symbol-value x)])
|
|
|
|
(interrupt-when (cogen-pred-$unbound-object? v)))
|
|
|
|
(interrupt))]
|
|
|
|
[else
|
|
|
|
(with-tmp ([x (T x)])
|
|
|
|
(interrupt-unless (cogen-pred-symbol? x))
|
|
|
|
(with-tmp ([v (cogen-value-$symbol-value x)])
|
|
|
|
(interrupt-when (cogen-pred-$unbound-object? v))))])])
|
|
|
|
|
2007-03-03 23:17:04 -05:00
|
|
|
|
|
|
|
(define-primop $init-symbol-function! unsafe
|
|
|
|
[(E x v)
|
|
|
|
(with-tmp ([x (T x)] [v (T v)])
|
2007-06-02 03:21:05 -04:00
|
|
|
(prm 'mset x (K (- disp-symbol-record-proc symbol-ptag)) v)
|
|
|
|
;(prm 'mset x (K (- disp-symbol-error-function symbol-tag)) v)
|
2007-03-03 23:17:04 -05:00
|
|
|
(dirty-vector-set x))])
|
|
|
|
|
|
|
|
|
2007-03-02 02:47:36 -05:00
|
|
|
/section)
|
|
|
|
|
|
|
|
(section ;;; fixnums
|
|
|
|
|
|
|
|
(define-primop fixnum? safe
|
|
|
|
[(P x) (tag-test (T x) fixnum-mask fixnum-tag)]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fxzero? unsafe
|
|
|
|
[(P x) (prm '= (T x) (K 0))]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fx= unsafe
|
|
|
|
[(P x y) (prm '= (T x) (T y))]
|
|
|
|
[(E x y) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fx< unsafe
|
|
|
|
[(P x y) (prm '< (T x) (T y))]
|
|
|
|
[(E x y) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fx<= unsafe
|
|
|
|
[(P x y) (prm '<= (T x) (T y))]
|
|
|
|
[(E x y) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fx> unsafe
|
|
|
|
[(P x y) (prm '> (T x) (T y))]
|
|
|
|
[(E x y) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fx>= unsafe
|
|
|
|
[(P x y) (prm '>= (T x) (T y))]
|
|
|
|
[(E x y) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fxadd1 unsafe
|
|
|
|
[(V x) (cogen-value-$fx+ x (K 1))]
|
|
|
|
[(P x) (K #t)]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fxsub1 unsafe
|
|
|
|
[(V x) (cogen-value-$fx+ x (K -1))]
|
|
|
|
[(P x) (K #t)]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fx+ unsafe
|
|
|
|
[(V x y) (prm 'int+ (T x) (T y))]
|
|
|
|
[(P x y) (K #t)]
|
|
|
|
[(E x y) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fx* unsafe
|
|
|
|
[(V a b)
|
|
|
|
(record-case a
|
|
|
|
[(constant a)
|
|
|
|
(unless (fixnum? a) (interrupt))
|
|
|
|
(prm 'int* (T b) (K a))]
|
|
|
|
[else
|
|
|
|
(record-case b
|
|
|
|
[(constant b)
|
|
|
|
(unless (fixnum? b) (interrupt))
|
|
|
|
(prm 'int* (T a) (K b))]
|
|
|
|
[else
|
|
|
|
(prm 'int* (T a) (prm 'sra (T b) (K fixnum-shift)))])])]
|
|
|
|
[(P x y) (K #t)]
|
|
|
|
[(E x y) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fxlognot unsafe
|
|
|
|
[(V x) (cogen-value-$fxlogxor x (K -1))]
|
|
|
|
[(P x) (K #t)]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fxlogand unsafe
|
|
|
|
[(V x y) (prm 'logand (T x) (T y))]
|
|
|
|
[(P x y) (K #t)]
|
|
|
|
[(E x y) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fxlogor unsafe
|
|
|
|
[(V x y) (prm 'logor (T x) (T y))]
|
|
|
|
[(P x y) (K #t)]
|
|
|
|
[(E x y) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fxlogxor unsafe
|
|
|
|
[(V x y) (prm 'logxor (T x) (T y))]
|
|
|
|
[(P x y) (K #t)]
|
|
|
|
[(E x y) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fx- unsafe
|
|
|
|
[(V x y) (prm 'int- (T x) (T y))]
|
|
|
|
[(P x y) (K #t)]
|
|
|
|
[(E x y) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fxsll unsafe
|
|
|
|
[(V x i)
|
|
|
|
(record-case i
|
|
|
|
[(constant i)
|
|
|
|
(unless (fixnum? i) (interrupt))
|
|
|
|
(prm 'sll (T x) (K i))]
|
|
|
|
[else
|
|
|
|
(prm 'sll (T x) (prm 'sra (T i) (K fixnum-shift)))])]
|
|
|
|
[(P x i) (K #t)]
|
|
|
|
[(E x i) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fxsra unsafe
|
|
|
|
[(V x i)
|
|
|
|
(record-case i
|
|
|
|
[(constant i)
|
|
|
|
(unless (fixnum? i) (interrupt))
|
|
|
|
(prm 'logand (prm 'sra (T x) (K i)) (K (* -1 fixnum-scale)))]
|
|
|
|
[else
|
|
|
|
(prm 'logand
|
|
|
|
(prm 'sra (T x) (prm 'sra (T i) (K fixnum-shift)))
|
|
|
|
(K (* -1 fixnum-scale)))])]
|
|
|
|
[(P x i) (K #t)]
|
|
|
|
[(E x i) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fxquotient unsafe
|
|
|
|
[(V a b)
|
|
|
|
(with-tmp ([b (T b)])
|
|
|
|
(prm 'sll (prm 'remainder (T a) b) (K fixnum-shift)))]
|
|
|
|
[(P a b) (K #t)]
|
|
|
|
[(E a b) (nop)])
|
|
|
|
|
|
|
|
(define-primop $fxmodulo unsafe
|
|
|
|
[(V a b)
|
|
|
|
(with-tmp ([b (T b)])
|
|
|
|
(with-tmp ([c (prm 'logand b
|
|
|
|
(prm 'sra (prm 'logxor b (T a))
|
|
|
|
(K (sub1 (* 8 wordsize)))))])
|
|
|
|
(prm 'int+ c (prm 'quotient (T a) b))))]
|
|
|
|
[(P a b) (K #t)]
|
|
|
|
[(E a b) (nop)])
|
|
|
|
|
2007-07-04 10:42:18 -04:00
|
|
|
(define-primop $fxinthash unsafe
|
|
|
|
[(V key)
|
|
|
|
(with-tmp ([k (T key)])
|
|
|
|
(with-tmp ([k (prm 'int+ k (prm 'logxor (prm 'sll k (K 15)) (K -1)))])
|
|
|
|
(with-tmp ([k (prm 'logxor k (prm 'sra k (K 10)))])
|
|
|
|
(with-tmp ([k (prm 'int+ k (prm 'sll k (K 3)))])
|
|
|
|
(with-tmp ([k (prm 'logxor k (prm 'sra k (K 6)))])
|
|
|
|
(with-tmp ([k (prm 'int+ k (prm 'logxor (prm 'sll k (K 11)) (K -1)))])
|
|
|
|
(with-tmp ([k (prm 'logxor k (prm 'sra k (K 16)))])
|
|
|
|
(prm 'sll k (K fx-shift)))))))))])
|
|
|
|
|
|
|
|
|
|
|
|
;(define inthash
|
|
|
|
; (lambda (key)
|
|
|
|
; ;static int inthash(int key) { /* from Bob Jenkin's */
|
|
|
|
; ; key += ~(key << 15);
|
|
|
|
; ; key ^= (key >> 10);
|
|
|
|
; ; key += (key << 3);
|
|
|
|
; ; key ^= (key >> 6);
|
|
|
|
; ; key += ~(key << 11);
|
|
|
|
; ; key ^= (key >> 16);
|
|
|
|
; ; return key;
|
|
|
|
; ;}
|
|
|
|
; (let* ([key ($fx+ key ($fxlognot ($fxsll key 15)))]
|
|
|
|
; [key ($fxlogxor key ($fxsra key 10))]
|
|
|
|
; [key ($fx+ key ($fxsll key 3))]
|
|
|
|
; [key ($fxlogxor key ($fxsra key 6))]
|
|
|
|
; [key ($fx+ key ($fxlognot ($fxsll key 11)))]
|
|
|
|
; [key ($fxlogxor key ($fxsra key 16))])
|
|
|
|
; key)))
|
|
|
|
|
|
|
|
|
2007-03-02 02:47:36 -05:00
|
|
|
/section)
|
|
|
|
|
2007-03-09 14:01:17 -05:00
|
|
|
(section ;;; bignums
|
|
|
|
|
|
|
|
(define-primop bignum? safe
|
|
|
|
[(P x) (sec-tag-test (T x) vector-mask vector-tag bignum-mask bignum-tag)]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
2007-06-02 21:55:40 -04:00
|
|
|
(define-primop $bignum-positive? unsafe
|
|
|
|
[(P x)
|
|
|
|
(prm '= (prm 'logand
|
|
|
|
(prm 'mref (T x) (K (- vector-tag)))
|
|
|
|
(K bignum-sign-mask))
|
|
|
|
(K 0))]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $bignum-byte-ref unsafe
|
|
|
|
[(V s i)
|
|
|
|
(record-case i
|
|
|
|
[(constant i)
|
|
|
|
(unless (fixnum? i) (interrupt))
|
|
|
|
(prm 'sll
|
|
|
|
(prm 'logand
|
|
|
|
(prm 'mref (T s)
|
|
|
|
(K (+ i (- disp-bignum-data record-tag))))
|
|
|
|
(K 255))
|
|
|
|
(K fx-shift))]
|
|
|
|
[else
|
|
|
|
(prm 'sll
|
|
|
|
(prm 'srl ;;; FIXME: bref
|
|
|
|
(prm 'mref (T s)
|
|
|
|
(prm 'int+
|
|
|
|
(prm 'sra (T i) (K fixnum-shift))
|
|
|
|
;;; ENDIANNESS DEPENDENCY
|
|
|
|
(K (- disp-bignum-data
|
|
|
|
(- wordsize 1)
|
|
|
|
record-tag))))
|
|
|
|
(K (* (- wordsize 1) 8)))
|
|
|
|
(K fx-shift))])]
|
|
|
|
[(P s i) (K #t)]
|
|
|
|
[(E s i) (nop)])
|
|
|
|
|
|
|
|
(define-primop $bignum-size unsafe
|
|
|
|
[(V x)
|
|
|
|
(prm 'sll
|
|
|
|
(prm 'sra
|
|
|
|
(prm 'mref (T x) (K (- record-tag)))
|
|
|
|
(K bignum-length-shift))
|
|
|
|
(K (* 2 fx-shift)))])
|
|
|
|
|
2007-03-09 14:01:17 -05:00
|
|
|
/section)
|
|
|
|
|
|
|
|
(section ;;; flonums
|
|
|
|
|
2007-06-15 01:53:34 -04:00
|
|
|
(define ($flop-aux op fl0 fl1)
|
|
|
|
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
|
|
|
|
(prm 'mset x (K (- vector-tag)) (K flonum-tag))
|
|
|
|
(prm 'fl:load (T fl0) (K (- disp-flonum-data vector-tag)))
|
|
|
|
(prm op (T fl1) (K (- disp-flonum-data vector-tag)))
|
|
|
|
(prm 'fl:store x (K (- disp-flonum-data vector-tag)))
|
|
|
|
x))
|
|
|
|
|
2007-06-15 05:19:28 -04:00
|
|
|
(define ($flcmp-aux op fl0 fl1)
|
|
|
|
(make-seq
|
|
|
|
(prm 'fl:load (T fl0) (K (- disp-flonum-data vector-tag)))
|
|
|
|
(prm op (T fl1) (K (- disp-flonum-data vector-tag)))))
|
|
|
|
|
2007-03-09 14:01:17 -05:00
|
|
|
(define-primop flonum? safe
|
|
|
|
[(P x) (sec-tag-test (T x) vector-mask vector-tag #f flonum-tag)]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
2007-06-08 02:07:02 -04:00
|
|
|
(define-primop $flonum-u8-ref unsafe
|
|
|
|
[(V s i)
|
|
|
|
(record-case i
|
|
|
|
[(constant i)
|
|
|
|
(unless (and (fixnum? i) (fx<= 0 i) (fx<= i 7))
|
|
|
|
(interrupt))
|
|
|
|
(prm 'sll
|
|
|
|
(prm 'logand
|
|
|
|
(prm 'bref (T s)
|
2007-06-08 02:15:25 -04:00
|
|
|
(K (+ (- 7 i) (- disp-flonum-data record-tag))))
|
2007-06-08 02:07:02 -04:00
|
|
|
(K 255))
|
|
|
|
(K fx-shift))]
|
|
|
|
[else (interrupt)])]
|
|
|
|
[(P s i) (K #t)]
|
|
|
|
[(E s i) (nop)])
|
2007-06-08 01:54:10 -04:00
|
|
|
|
2007-06-10 05:09:01 -04:00
|
|
|
(define-primop $make-flonum unsafe
|
|
|
|
[(V)
|
|
|
|
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
|
|
|
|
(prm 'mset x (K (- vector-tag)) (K flonum-tag))
|
|
|
|
x)]
|
|
|
|
[(P str) (K #t)]
|
|
|
|
[(E str) (nop)])
|
|
|
|
|
|
|
|
(define-primop $flonum-set! unsafe
|
|
|
|
[(E x i v)
|
|
|
|
(record-case i
|
|
|
|
[(constant i)
|
|
|
|
(unless (and (fixnum? i) (fx<= 0 i) (fx<= i 7))
|
|
|
|
(interrupt))
|
|
|
|
(prm 'bset/h (T x)
|
2007-06-10 13:21:41 -04:00
|
|
|
(K (+ (- 7 i) (- disp-flonum-data vector-tag)))
|
2007-06-10 05:09:01 -04:00
|
|
|
(prm 'sll (T v) (K (- 8 fx-shift))))]
|
|
|
|
[else (interrupt)])])
|
|
|
|
|
2007-06-18 07:06:13 -04:00
|
|
|
(define-primop $fixnum->flonum unsafe
|
|
|
|
[(V fx)
|
|
|
|
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
|
|
|
|
(prm 'mset x (K (- vector-tag)) (K flonum-tag))
|
2007-06-18 07:29:39 -04:00
|
|
|
(prm 'fl:from-int
|
|
|
|
(K 0) ; dummy
|
|
|
|
(prm 'sra (T fx) (K fx-shift)))
|
2007-06-18 07:06:13 -04:00
|
|
|
(prm 'fl:store x (K (- disp-flonum-data vector-tag)))
|
|
|
|
x)])
|
|
|
|
|
2007-06-15 01:53:34 -04:00
|
|
|
(define-primop $fl+ unsafe
|
|
|
|
[(V x y) ($flop-aux 'fl:add! x y)])
|
|
|
|
(define-primop $fl- unsafe
|
|
|
|
[(V x y) ($flop-aux 'fl:sub! x y)])
|
|
|
|
(define-primop $fl* unsafe
|
|
|
|
[(V x y) ($flop-aux 'fl:mul! x y)])
|
|
|
|
(define-primop $fl/ unsafe
|
|
|
|
[(V x y) ($flop-aux 'fl:div! x y)])
|
2007-06-10 05:09:01 -04:00
|
|
|
|
2007-06-15 05:19:28 -04:00
|
|
|
(define-primop $fl= unsafe
|
|
|
|
[(P x y) ($flcmp-aux 'fl:= x y)])
|
|
|
|
(define-primop $fl< unsafe
|
|
|
|
[(P x y) ($flcmp-aux 'fl:< x y)])
|
|
|
|
(define-primop $fl<= unsafe
|
|
|
|
[(P x y) ($flcmp-aux 'fl:<= x y)])
|
|
|
|
(define-primop $fl> unsafe
|
|
|
|
[(P x y) ($flcmp-aux 'fl:> x y)])
|
|
|
|
(define-primop $fl>= unsafe
|
|
|
|
[(P x y) ($flcmp-aux 'fl:>= x y)])
|
|
|
|
|
2007-03-09 14:01:17 -05:00
|
|
|
/section)
|
|
|
|
|
2007-06-02 21:55:40 -04:00
|
|
|
(section ;;; ratnums
|
|
|
|
|
|
|
|
(define-primop ratnum? safe
|
|
|
|
[(P x) (sec-tag-test (T x) vector-mask vector-tag #f ratnum-tag)]
|
|
|
|
[(E x) (nop)])
|
|
|
|
|
|
|
|
(define-primop $make-ratnum unsafe
|
|
|
|
[(V num den)
|
|
|
|
(with-tmp ([x (prm 'alloc (K (align ratnum-size)) (K vector-tag))])
|
|
|
|
(prm 'mset x (K (- vector-tag)) (K ratnum-tag))
|
|
|
|
(prm 'mset x (K (- disp-ratnum-num vector-tag)) (T num))
|
|
|
|
(prm 'mset x (K (- disp-ratnum-den vector-tag)) (T den))
|
|
|
|
x)]
|
|
|
|
[(P str) (K #t)]
|
|
|
|
[(E str) (nop)])
|
|
|
|
|
|
|
|
|
|
|
|
(define-primop $ratnum-n unsafe
|
2007-06-08 03:30:25 -04:00
|
|
|
[(V x) (prm 'mref (T x) (K (- disp-ratnum-num vector-tag)))])
|
2007-06-02 21:55:40 -04:00
|
|
|
|
|
|
|
(define-primop $ratnum-d unsafe
|
2007-06-08 03:30:25 -04:00
|
|
|
[(V x) (prm 'mref (T x) (K (- disp-ratnum-den vector-tag)))])
|
2007-06-02 21:55:40 -04:00
|
|
|
|
|
|
|
/section)
|
|
|
|
|
2007-03-09 14:01:17 -05:00
|
|
|
(section ;;; generic arithmetic
|
2007-03-02 02:47:36 -05:00
|
|
|
|
|
|
|
(define (non-fixnum? x)
|
|
|
|
(record-case x
|
|
|
|
[(constant i) (not (fixnum? i))]
|
|
|
|
[else #f]))
|
|
|
|
|
|
|
|
(define (or* a a*)
|
|
|
|
(cond
|
|
|
|
[(null? a*) a]
|
2007-03-03 23:17:04 -05:00
|
|
|
[(constant? (car a*)) (or* a (cdr a*))]
|
2007-03-02 02:47:36 -05:00
|
|
|
[else (or* (prm 'logor a (T (car a*))) (cdr a*))]))
|
|
|
|
|
|
|
|
(define (assert-fixnums a a*)
|
2007-03-03 23:17:04 -05:00
|
|
|
(cond
|
|
|
|
[(constant? a)
|
|
|
|
(if (null? a*)
|
|
|
|
(nop)
|
|
|
|
(assert-fixnums (car a*) (cdr a*)))]
|
|
|
|
[else
|
|
|
|
(interrupt-unless
|
|
|
|
(tag-test (or* (T a) a*) fixnum-mask fixnum-tag))]))
|
2007-03-02 02:47:36 -05:00
|
|
|
|
2007-03-03 23:17:04 -05:00
|
|
|
(define (fixnum-fold-p op a a*)
|
2007-03-02 02:47:36 -05:00
|
|
|
(cond
|
|
|
|
[(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
|
|
|
|
[else
|
|
|
|
(seq*
|
|
|
|
(assert-fixnums a a*)
|
|
|
|
(let f ([a a] [a* a*])
|
|
|
|
(cond
|
|
|
|
[(null? a*) (K #t)]
|
|
|
|
[else
|
|
|
|
(let ([b (car a*)])
|
|
|
|
(make-conditional
|
|
|
|
(prm op (T a) (T b))
|
|
|
|
(f b (cdr a*))
|
|
|
|
(K #f)))])))]))
|
|
|
|
|
2007-03-03 23:17:04 -05:00
|
|
|
(define (fixnum-fold-e a a*)
|
2007-03-02 02:47:36 -05:00
|
|
|
(cond
|
|
|
|
[(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
|
|
|
|
[else (assert-fixnums a a*)]))
|
|
|
|
|
|
|
|
(define-primop = safe
|
|
|
|
[(P) (interrupt)]
|
2007-03-03 23:17:04 -05:00
|
|
|
[(P a . a*) (fixnum-fold-p '= a a*)]
|
2007-03-02 02:47:36 -05:00
|
|
|
[(E) (interrupt)]
|
2007-03-03 23:17:04 -05:00
|
|
|
[(E a . a*) (fixnum-fold-e a a*)])
|
2007-03-02 02:47:36 -05:00
|
|
|
|
|
|
|
(define-primop < safe
|
|
|
|
[(P) (interrupt)]
|
2007-03-03 23:17:04 -05:00
|
|
|
[(P a . a*) (fixnum-fold-p '< a a*)]
|
2007-03-02 02:47:36 -05:00
|
|
|
[(E) (interrupt)]
|
2007-03-03 23:17:04 -05:00
|
|
|
[(E a . a*) (fixnum-fold-e a a*)])
|
2007-03-02 02:47:36 -05:00
|
|
|
|
|
|
|
(define-primop <= safe
|
|
|
|
[(P) (interrupt)]
|
2007-03-03 23:17:04 -05:00
|
|
|
[(P a . a*) (fixnum-fold-p '<= a a*)]
|
2007-03-02 02:47:36 -05:00
|
|
|
[(E) (interrupt)]
|
2007-03-03 23:17:04 -05:00
|
|
|
[(E a . a*) (fixnum-fold-e a a*)])
|
2007-03-02 02:47:36 -05:00
|
|
|
|
|
|
|
(define-primop > safe
|
|
|
|
[(P) (interrupt)]
|
2007-03-03 23:17:04 -05:00
|
|
|
[(P a . a*) (fixnum-fold-p '> a a*)]
|
2007-03-02 02:47:36 -05:00
|
|
|
[(E) (interrupt)]
|
2007-03-03 23:17:04 -05:00
|
|
|
[(E a . a*) (fixnum-fold-e a a*)])
|
2007-03-02 02:47:36 -05:00
|
|
|
|
|
|
|
(define-primop >= safe
|
|
|
|
[(P) (interrupt)]
|
2007-03-03 23:17:04 -05:00
|
|
|
[(P a . a*) (fixnum-fold-p '>= a a*)]
|
2007-03-02 02:47:36 -05:00
|
|
|
[(E) (interrupt)]
|
2007-03-03 23:17:04 -05:00
|
|
|
[(E a . a*) (fixnum-fold-e a a*)])
|
2007-03-02 02:47:36 -05:00
|
|
|
|
|
|
|
(define-primop - safe
|
|
|
|
[(V a)
|
|
|
|
(cond
|
|
|
|
[(non-fixnum? a) (interrupt)]
|
|
|
|
[else
|
2007-06-06 03:14:07 -04:00
|
|
|
(interrupt)
|
2007-03-02 02:47:36 -05:00
|
|
|
(seq*
|
|
|
|
(assert-fixnums a '())
|
|
|
|
(prm 'int-/overflow (K 0) (T a)))])]
|
|
|
|
[(V a . a*)
|
|
|
|
(cond
|
|
|
|
[(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
|
|
|
|
[else
|
2007-06-06 03:14:07 -04:00
|
|
|
(interrupt)
|
2007-03-02 02:47:36 -05:00
|
|
|
(seq*
|
|
|
|
(assert-fixnums a a*)
|
|
|
|
(let f ([a (T a)] [a* a*])
|
|
|
|
(cond
|
|
|
|
[(null? a*) a]
|
|
|
|
[else
|
|
|
|
(f (prm 'int-/overflow a (T (car a*))) (cdr a*))])))])]
|
|
|
|
[(P a . a*) (seq* (assert-fixnums a a*) (K #t))]
|
|
|
|
[(E a . a*) (assert-fixnums a a*)])
|
|
|
|
|
|
|
|
(define-primop + safe
|
|
|
|
[(V) (K 0)]
|
|
|
|
[(V a . a*)
|
|
|
|
(cond
|
|
|
|
[(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
|
|
|
|
[else
|
2007-06-06 03:14:07 -04:00
|
|
|
(interrupt)
|
2007-03-02 02:47:36 -05:00
|
|
|
(seq*
|
|
|
|
(assert-fixnums a a*)
|
|
|
|
(let f ([a (T a)] [a* a*])
|
|
|
|
(cond
|
|
|
|
[(null? a*) a]
|
|
|
|
[else
|
|
|
|
(f (prm 'int+/overflow a (T (car a*))) (cdr a*))])))])]
|
|
|
|
[(P) (K #t)]
|
|
|
|
[(P a . a*) (seq* (assert-fixnums a a*) (K #t))]
|
|
|
|
[(E) (nop)]
|
|
|
|
[(E a . a*) (assert-fixnums a a*)])
|
|
|
|
|
2007-03-03 23:17:04 -05:00
|
|
|
(define-primop zero? safe
|
|
|
|
[(P x)
|
|
|
|
(seq*
|
|
|
|
(interrupt-unless (cogen-pred-fixnum? x))
|
|
|
|
(cogen-pred-$fxzero? x))]
|
|
|
|
[(E x) (interrupt-unless (cogen-pred-fixnum? x))])
|
2007-03-02 02:47:36 -05:00
|
|
|
|
2007-06-18 11:04:02 -04:00
|
|
|
(define-primop quotient safe
|
|
|
|
[(V x n)
|
|
|
|
(record-case n
|
|
|
|
[(constant i)
|
|
|
|
(if (eqv? i 2)
|
|
|
|
(seq*
|
|
|
|
(interrupt-unless (cogen-pred-fixnum? x))
|
|
|
|
(make-conditional
|
|
|
|
(prm '< (T x) (K 0))
|
|
|
|
(prm 'logand
|
|
|
|
(prm 'int+
|
|
|
|
(prm 'sra (T x) (K 1))
|
|
|
|
(K (fxsll 1 (sub1 fx-shift))))
|
|
|
|
(K (fxsll -1 fx-shift)))
|
|
|
|
(prm 'logand
|
|
|
|
(prm 'sra (T x) (K 1))
|
|
|
|
(K (fxsll -1 fx-shift)))))
|
|
|
|
(interrupt))]
|
|
|
|
[else (interrupt)])])
|
|
|
|
|
2007-03-02 02:47:36 -05:00
|
|
|
/section)
|
|
|
|
|
|