ikarus/scheme/pass-specify-rep-primops.ss

2471 lines
71 KiB
Scheme
Raw Normal View History

;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(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 (dirty-vector-set address)
2008-04-07 12:32:55 -04:00
(define shift-bits 2)
2007-03-02 02:47:36 -05:00
(prm 'mset
(prm 'int+
(prm 'mref pcr (K pcb-dirty-vector))
2008-04-07 12:32:55 -04:00
(prm 'sll (prm 'srl address (K pageshift)) (K shift-bits)))
2007-03-02 02:47:36 -05:00
(K 0)
(K dirty-word)))
(define (smart-dirty-vector-set addr what)
(struct-case what
2007-03-02 02:47:36 -05:00
[(constant t)
(if (or (fixnum? t) (immediate? t))
(prm 'nop)
(dirty-vector-set addr))]
[(known x t)
(cond
[(eq? (T:immediate? t) 'yes)
(record-optimization 'smart-dirty-vec t)
(nop)]
[else (smart-dirty-vector-set addr x)])]
2007-03-02 02:47:36 -05:00
[else (dirty-vector-set addr)]))
(define (slow-mem-assign v x i)
2007-03-02 02:47:36 -05:00
(with-tmp ([t (prm 'int+ x (K i))])
(make-seq
(prm 'mset t (K 0) (T v))
(dirty-vector-set t))))
(define (mem-assign v x i)
(struct-case v
2007-03-02 02:47:36 -05:00
[(constant t)
(if (or (fixnum? t) (immediate? t))
(prm 'mset x (K i) (T v))
(slow-mem-assign v x i))]
[(known expr t)
(cond
[(eq? (T:immediate? t) 'yes)
(record-optimization 'mem-assign v)
(prm 'mset x (K i) (T expr))]
[else (slow-mem-assign expr x i)])]
[else (slow-mem-assign v x i)]))
2007-03-02 02:47:36 -05:00
(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)))
/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 pcb-base-rtd))]
2007-06-02 21:55:40 -04:00
[(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 (equable-constant? x)
(struct-case x
[(constant xv) (equable? xv)]
[(known x t) (equable-constant? x)]
[else #f]))
(define-primop eqv? safe
[(P x y)
(if (or (equable-constant? x)
(equable-constant? y))
(prm '= (T x) (T y))
(interrupt))]
[(E x y) (nop)])
2007-03-02 02:47:36 -05:00
(define-primop null? safe
[(P x) (prm '= (T x) (K nil))]
[(E x) (nop)])
(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) fx-mask fx-tag)
2007-03-02 02:47:36 -05:00
(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)]
2007-03-02 02:47:36 -05:00
[(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
2007-08-30 19:40:01 -04:00
[(V x) (prm 'logand
(prm 'srl (T x) (K 1))
(K (* -1 fx-scale)))]
2007-03-02 02:47:36 -05:00
[(P x) (K #t)]
[(E x) (nop)])
(define-primop $arg-list unsafe
[(V) (prm 'mref pcr (K pcb-arg-list))]
2007-03-02 02:47:36 -05:00
[(P) (K #t)]
[(E) (nop)])
(define-primop $collect-key unsafe
[(V) (prm 'mref pcr (K pcb-collect-key))]
[(E x) (prm 'mset pcr (K pcb-collect-key) (T x))])
(define-primop $memq safe
[(P x ls)
(struct-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)))])))])]
[(known expr t)
(cogen-pred-$memq x expr)]
[else (interrupt)])]
[(V x ls)
(struct-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)))])))])]
[(known expr t)
(cogen-value-$memq x expr)]
[else (interrupt)])]
[(E x ls) (nop)])
(define-primop memq safe
[(P x ls) (cogen-pred-$memq x ls)]
[(V x ls) (cogen-value-$memq x ls)]
[(E x ls)
(struct-case ls
[(constant ls)
(cond
[(list? ls) (nop)]
[else (interrupt)])]
[(known) (error 'translate "memq")]
[else (interrupt)])])
(define (equable? x)
(or (fixnum? x) (not (number? x))))
(define-primop memv safe
[(V x ls)
(struct-case ls
[(constant lsv)
(cond
[(and (list? lsv) (andmap equable? lsv))
(cogen-value-$memq x ls)]
[else (interrupt)])]
[(known) (error 'translate "memv")]
[else (interrupt)])]
[(P x ls)
(struct-case ls
[(constant lsv)
(cond
[(and (list? lsv) (andmap equable? lsv))
(cogen-pred-$memq x ls)]
[else (interrupt)])]
[(known) (error 'translate "memv")]
[else (interrupt)])]
[(E x ls)
(struct-case ls
[(constant lsv)
(cond
[(list? lsv) (nop)]
[else (interrupt)])]
[(known) (error 'translate "memv")]
[else (interrupt)])])
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)]
2007-03-02 02:47:36 -05:00
[(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 (assert-pair x)
(struct-case x
[(known x t)
(case (T:pair? t)
[(yes) (record-optimization 'assert-pair x) (nop)]
[(no) (interrupt)]
[else (assert-pair x)])]
[else
(interrupt-unless (tag-test x pair-mask pair-tag))]))
2007-03-02 02:47:36 -05:00
(define-primop car safe
[(V x)
(with-tmp ([x (T x)])
(assert-pair x)
(prm 'mref x (K (- disp-car pair-tag))))]
[(E x) (assert-pair (T x))])
2007-03-02 02:47:36 -05:00
(define-primop cdr safe
[(V x)
(with-tmp ([x (T x)])
(assert-pair x)
(prm 'mref x (K (- disp-cdr pair-tag))))]
[(E x) (assert-pair (T x))])
2007-03-02 02:47:36 -05:00
(define-primop set-car! safe
[(E x v)
(with-tmp ([x (T x)])
(assert-pair x)
2007-03-02 02:47:36 -05:00
(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)])
(assert-pair x)
2007-03-02 02:47:36 -05:00
(prm 'mset x (K (- disp-cdr pair-tag)) (T v))
(smart-dirty-vector-set x v))])
(define (expand-cxr val ls)
(cond
[(null? ls) (T val)]
[else
(with-tmp ([x (expand-cxr val (cdr ls))])
(assert-pair x)
(prm 'mref x
(case (car ls)
[(a) (K (- disp-car pair-tag))]
[else (K (- disp-cdr pair-tag))])))]))
(define-primop caar safe [(V x) (expand-cxr x '(a a))])
(define-primop cadr safe [(V x) (expand-cxr x '(a d))])
(define-primop cdar safe [(V x) (expand-cxr x '(d a))])
(define-primop cddr safe [(V x) (expand-cxr x '(d d))])
(define-primop caaar safe [(V x) (expand-cxr x '(a a a))])
(define-primop caadr safe [(V x) (expand-cxr x '(a a d))])
(define-primop cadar safe [(V x) (expand-cxr x '(a d a))])
(define-primop caddr safe [(V x) (expand-cxr x '(a d d))])
(define-primop cdaar safe [(V x) (expand-cxr x '(d a a))])
(define-primop cdadr safe [(V x) (expand-cxr x '(d a d))])
(define-primop cddar safe [(V x) (expand-cxr x '(d d a))])
(define-primop cdddr safe [(V x) (expand-cxr x '(d d d))])
;(define-primop caaaar safe [(V x) (expand-cxr x '(a a a a))])
;(define-primop caaadr safe [(V x) (expand-cxr x '(a a a d))])
;(define-primop caadar safe [(V x) (expand-cxr x '(a a d a))])
;(define-primop caaddr safe [(V x) (expand-cxr x '(a a d d))])
;(define-primop cadaar safe [(V x) (expand-cxr x '(a d a a))])
;(define-primop cadadr safe [(V x) (expand-cxr x '(a d a d))])
;(define-primop caddar safe [(V x) (expand-cxr x '(a d d a))])
(define-primop cadddr safe [(V x) (expand-cxr x '(a d d d))])
;(define-primop cdaaar safe [(V x) (expand-cxr x '(d a a a))])
;(define-primop cdaadr safe [(V x) (expand-cxr x '(d a a d))])
;(define-primop cdadar safe [(V x) (expand-cxr x '(d a d a))])
;(define-primop cdaddr safe [(V x) (expand-cxr x '(d a d d))])
;(define-primop cddaar safe [(V x) (expand-cxr x '(d d a a))])
;(define-primop cddadr safe [(V x) (expand-cxr x '(d d a d))])
;(define-primop cdddar safe [(V x) (expand-cxr x '(d d d a))])
;(define-primop cddddr safe [(V x) (expand-cxr x '(d d d d))])
2007-03-02 02:47:36 -05:00
(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)])
2007-09-09 23:31:19 -04:00
(define-primop cons* 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)])
2007-03-02 02:47:36 -05:00
/section)
(section ;;; vectors
(section ;;; helpers
(define (vector-range-check x idx)
(define (check-non-vector x idx)
(define (check-fx 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))
(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)))))
(struct-case idx
[(constant i)
(if (and (fixnum? i) (fx>= i 0))
(check-fx idx)
(check-? idx))]
[(known idx idx-t)
(case (T:fixnum? idx-t)
[(yes) (check-fx idx)]
[(maybe) (vector-range-check x idx)]
[else
(printf "vector check with mismatch index tag ~s" idx-t)
(vector-range-check x idx)])]
[else (check-? idx)]))
(define (check-vector x idx)
(define (check-fx idx)
(with-tmp ([len (cogen-value-$vector-length x)])
(interrupt-unless (prm 'u< (T idx) len))))
(define (check-? idx)
(seq*
(interrupt-unless-fixnum (T idx))
(with-tmp ([len (cogen-value-$vector-length x)])
(interrupt-unless (prm 'u< (T idx) len)))))
(struct-case idx
[(constant i)
(if (and (fixnum? i) (fx>= i 0))
(check-fx idx)
(check-? idx))]
[(known idx idx-t)
(case (T:fixnum? idx-t)
[(yes) (check-fx idx)]
[(no) (interrupt)]
[else (check-vector x idx)])]
[else (check-? idx)]))
(struct-case x
[(known x t)
(case (T:vector? t)
[(yes) (record-optimization 'check-vector x) (check-vector x idx)]
[(no) (interrupt)]
[else (check-non-vector x idx)])]
[else (check-non-vector x 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 fx-mask fx-tag)]
2007-03-02 02:47:36 -05:00
[(E x) (nop)])
(define-primop $make-vector unsafe
[(V len)
(struct-case len
2007-03-02 02:47:36 -05:00
[(constant i)
(if (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 (* i fx-scale)))
v))]
[(known expr t)
(cogen-value-$make-vector expr)]
2007-03-02 02:47:36 -05:00
[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))])]
2007-03-02 02:47:36 -05:00
[(P len) (K #t)]
[(E len) (nop)])
(define-primop make-vector safe
[(V len)
(with-tmp ([x (make-forcall "ikrt_make_vector1" (list (T len)))])
(interrupt-when (prm '= x (K 0)))
x)])
2007-03-02 02:47:36 -05:00
(define-primop $vector-ref unsafe
[(V x i)
(or
(struct-case i
2007-03-02 02:47:36 -05:00
[(constant i)
(and (fixnum? i)
(fx>= i 0)
(prm 'mref (T x)
(K (+ (* i wordsize) (- disp-vector-data vector-tag)))))]
[(known i t)
(cogen-value-$vector-ref x i)]
2007-03-02 02:47:36 -05:00
[else #f])
(prm 'mref (T x)
(prm 'int+ (T i) (K (- disp-vector-data vector-tag)))))]
[(E x i) (nop)])
2007-03-02 02:47:36 -05:00
(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)
(struct-case x
[(known x t)
(case (T:vector? t)
[(yes) (record-optimization 'vector-length x) (cogen-value-$vector-length x)]
[(no) (interrupt)]
[else (cogen-value-vector-length x)])]
[else
(seq*
(interrupt-unless (tag-test (T x) vector-mask vector-tag))
(with-tmp ([t (cogen-value-$vector-length x)])
(interrupt-unless-fixnum t)
t))])]
2007-03-02 02:47:36 -05:00
[(E x)
(struct-case x
[(known x t)
(case (T:vector? t)
[(yes) (record-optimization 'vector-length x) (nop)]
[(no) (interrupt)]
[else (cogen-effect-vector-length x)])]
[else
(seq*
(interrupt-unless (tag-test (T x) vector-mask vector-tag))
(with-tmp ([t (cogen-value-$vector-length x)])
(interrupt-unless-fixnum t)))])]
2007-03-02 02:47:36 -05:00
[(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)
(struct-case i
2007-03-02 02:47:36 -05:00
[(constant i)
(unless (fixnum? i) (interrupt))
(mem-assign v (T x)
(+ (* i wordsize)
(- disp-vector-data vector-tag)))]
[(known i t)
(cogen-effect-$vector-set! x i v)]
2007-03-02 02:47:36 -05:00
[else
(mem-assign v
(prm 'int+ (T x) (T i))
(- disp-vector-data vector-tag))])])
(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)
(struct-case i
2007-03-02 02:47:36 -05:00
[(constant i)
(unless (fixnum? i) (interrupt))
(prm 'mref (T x)
(K (+ (- disp-closure-data closure-tag)
(* i wordsize))))]
[(known) (error 'translate "$cpref")]
2007-03-02 02:47:36 -05:00
[else (interrupt)])])
/section)
(section ;;; symbols
(define-primop symbol? safe
[(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)
(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))
2007-03-02 02:47:36 -05:00
x)]
[(P str) (K #t)]
[(E str) (nop)])
(define-primop $symbol-string unsafe
[(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
[(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
[(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
[(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
[(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
[(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
[(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)])
(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-08-28 23:49:50 -04:00
(define-primop $set-symbol-proc! unsafe
[(E x v)
(with-tmp ([x (T x)])
(prm 'mset x (K (- disp-symbol-record-proc symbol-ptag)) (T v))
(dirty-vector-set x))])
2007-06-02 21:55:40 -04:00
2008-02-10 05:24:16 -05:00
(define-primop $set-symbol-value/proc! unsafe
[(E x v)
(with-tmp ([x (T x)] [v (T v)])
(prm 'mset x (K (- disp-symbol-record-value symbol-ptag)) v)
(prm 'mset x (K (- disp-symbol-record-proc symbol-ptag)) v)
(dirty-vector-set x))])
2007-03-02 02:47:36 -05:00
(define-primop top-level-value safe
[(V x)
(struct-case x
2007-03-02 02:47:36 -05:00
[(constant s)
(if (symbol? s)
(with-tmp ([v (cogen-value-$symbol-value x)])
(interrupt-when (cogen-pred-$unbound-object? v))
v)
(interrupt))]
[(known) (error 'translate "top-level-value")]
2007-03-02 02:47:36 -05:00
[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)
(struct-case x
2007-03-02 02:47:36 -05:00
[(constant s)
(if (symbol? s)
(with-tmp ([v (cogen-value-$symbol-value x)])
(interrupt-when (cogen-pred-$unbound-object? v)))
(interrupt))]
[(known) (error 'translate "top-level-value")]
2007-03-02 02:47:36 -05:00
[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))))])])
(define-primop $init-symbol-function! unsafe
[(E x v)
(with-tmp ([x (T x)] [v (T v)])
(prm 'mset x (K (- disp-symbol-record-proc symbol-ptag)) v)
(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) fx-mask fx-tag)]
2007-03-02 02:47:36 -05:00
[(E x) (nop)])
(define-primop fixnum-width safe
[(V) (K (fxsll (- (* wordsize 8) fx-shift) fx-shift))]
[(E) (nop)]
[(P) (K #t)])
(define-primop least-fixnum safe
[(V) (K (sll (- (expt 2 (- (- (* wordsize 8) fx-shift) 1)))
fx-shift))]
[(E) (nop)]
[(P) (K #t)])
(define-primop greatest-fixnum safe
[(V) (K (sll (- (expt 2 (- (- (* wordsize 8) fx-shift) 1)) 1)
fx-shift))]
[(E) (nop)]
[(P) (K #t)])
2007-03-02 02:47:36 -05:00
(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)
(struct-case a
2007-03-02 02:47:36 -05:00
[(constant a)
(unless (fixnum? a) (interrupt))
(prm 'int* (T b) (K a))]
[(known a t) (cogen-value-$fx* a b)]
2007-03-02 02:47:36 -05:00
[else
(struct-case b
2007-03-02 02:47:36 -05:00
[(constant b)
(unless (fixnum? b) (interrupt))
(prm 'int* (T a) (K b))]
[(known b t) (cogen-value-$fx* a b)]
2007-03-02 02:47:36 -05:00
[else
(prm 'int* (T a) (prm 'sra (T b) (K fx-shift)))])])]
2007-03-02 02:47:36 -05:00
[(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)
(struct-case i
2007-03-02 02:47:36 -05:00
[(constant i)
(unless (fixnum? i) (interrupt))
(prm 'sll (T x) (K i))]
[(known i t) (cogen-value-$fxsll x i)]
2007-03-02 02:47:36 -05:00
[else
(prm 'sll (T x) (prm 'sra (T i) (K fx-shift)))])]
2007-03-02 02:47:36 -05:00
[(P x i) (K #t)]
[(E x i) (nop)])
(define-primop $fxsra unsafe
[(V x i)
(struct-case i
2007-03-02 02:47:36 -05:00
[(constant i)
(unless (fixnum? i) (interrupt))
(prm 'logand
(prm 'sra (T x) (K (if (> i 31) 31 i)))
(K (* -1 fx-scale)))]
[(known i t) (cogen-value-$fxsra x i)]
2007-03-02 02:47:36 -05:00
[else
(with-tmp ([i (prm 'sra (T i) (K fx-shift))])
(with-tmp ([i (make-conditional
(prm '< i (K 32))
i
(K 31))])
(prm 'logand
(prm 'sra (T x) i)
(K (*