* completed the move to new specify-representation pass infrastructure.

This commit is contained in:
Abdulaziz Ghuloum 2007-03-03 23:17:04 -05:00
parent cf65729971
commit b326fbc07a
13 changed files with 1370 additions and 1636 deletions

File diff suppressed because it is too large Load Diff

View File

@ -303,7 +303,7 @@
(define (oldGenMut n)
(do ((i 0 (+ i 1)))
((>= i (quotient n 2)))
(oldGenSwapSubTrees)))
(oldGenSwapSubtrees)))
; Does the amount of mutator work appropriate for n bytes of young-gen
; garbage allocation.

View File

@ -10,6 +10,7 @@
(define (simplex a m1 m2 m3)
(define *epsilon* 1e-6)
;(define *epsilon* 0.000001)
(if (not (and (>= m1 0)
(>= m2 0)
(>= m3 0)

View File

@ -199,8 +199,8 @@
(define (CProp.terms x) (cadr x))
(define (cterm_to_term x)
(if (Cvar? x)
(Var (Cvar.i x))
(if (CVar? x)
(Var (CVar.i x))
(Prop (get (CProp.name x))
(map cterm_to_term (CProp.terms x)))))

Binary file not shown.

View File

@ -708,12 +708,12 @@ ikrt_bnbnminus(ikp x, ikp y, ikpcb* pcb){
ref(x, -vector_tag+disp_bignum_data+(xlimbs-1)*wordsize))){
s1 = y; n1 = ylimbs;
s2 = x; n2 = xlimbs;
result_sign = (1 << bignum_length_shift) - ysign;
result_sign = (1 << bignum_sign_shift) - ysign;
}
} else {
s1 = y; n1 = ylimbs;
s2 = x; n2 = xlimbs;
result_sign = (1 << bignum_length_shift) - ysign;
result_sign = (1 << bignum_sign_shift) - ysign;
}
}
/* |s1| > |s2| */

Binary file not shown.

File diff suppressed because it is too large Load Diff

View File

@ -317,18 +317,14 @@ reference-implementation:
(and s #t)))))
;;; OLD (primitive-set! 'top-level-value
;;; OLD (lambda (x)
;;; OLD (unless (symbol? x)
;;; OLD (error 'top-level-value "~s is not a symbol" x))
;;; OLD (let ([v ($symbol-value x)])
;;; OLD (when ($unbound-object? v)
;;; OLD (error 'top-level-value "unbound variable ~s" x))
;;; OLD v)))
(primitive-set! 'top-level-value
(lambda (x)
(top-level-value x)))
(unless (symbol? x)
(error 'top-level-value "~s is not a symbol" x))
(let ([v ($symbol-value x)])
(when ($unbound-object? v)
(error 'top-level-value "unbound variable ~s" x))
v)))
(primitive-set! 'top-level-bound?
(lambda (x)
@ -1861,4 +1857,3 @@ reference-implementation:
(convert-sign x ($string-length x))]
[else (error 'string->number "~s is not a string" x)])))
#!eof

View File

@ -240,6 +240,12 @@
(cond
[(flonum? y)
(foreign-call "ikrt_fl_div" (fixnum->flonum x) y)]
[(fixnum? y)
(let ([q (fxquotient x y)]
[r (fxremainder x y)])
(if (fxzero? r)
q
(error '/ "no ratnum for ~s/~s" x y)))]
[else (error '/ "unsupported ~s ~s" x y)])]
[else (error '/ "unsupported ~s ~s" x y)])))
@ -345,8 +351,13 @@
[(flonum? x) #f]
[else (error 'rational? "~s is not a number" x)])))
(define integer?
(lambda (x) (number? x)))
(define integer?
(lambda (x)
(cond
[(fixnum? x) #t]
[(bignum? x) #t]
[(flonum? x) (error 'integer "dunno for ~s" x)]
[else #f])))
(define exact?
(lambda (x)
@ -706,7 +717,12 @@
(cond
[(fixnum? x) (eq? x 0)]
[(bignum? x) #f]
[else (error 'zero? "~s is not a number" x)])))
[(flonum? x) (= x (exact->inexact 0))]
[else (error 'zero? "tag=~s / ~s is not a number"
(#%$fxlogand 255
(#%$fxsll x 2))
(#%$fxlogand x -1)
)])))
(primitive-set! 'expt
(lambda (n m)

View File

@ -794,7 +794,6 @@
(unless (eof-object? x)
(eval x)
(read-and-eval p eval)))))
(primitive-set! 'load
(case-lambda
[(x) (load x eval)]

View File

@ -89,6 +89,10 @@
[(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)])
(define-primop eof-object safe
[(V) (K eof)]
[(P) (K #t)]
@ -132,6 +136,43 @@
[(P) (K #t)]
[(E) (nop)])
(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)])
/section)
(section ;;; pairs
@ -344,7 +385,7 @@
(prm 'int+ (T x) (T i))
(- disp-vector-data vector-tag))])])
#;(define-primop vector-set! safe
(define-primop vector-set! safe
[(E x i v)
(seq*
(vector-range-check x i)
@ -478,6 +519,15 @@
(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-function symbol-tag)) v)
(prm 'mset x (K (- disp-symbol-error-function symbol-tag)) v)
(dirty-vector-set x))])
/section)
(section ;;; fixnums
@ -619,12 +669,20 @@
(define (or* a a*)
(cond
[(null? a*) a]
[(constant? (car a*)) (or* a (cdr a*))]
[else (or* (prm 'logor a (T (car a*))) (cdr a*))]))
(define (assert-fixnums a a*)
(interrupt-unless (tag-test (or* (T a) a*) fixnum-mask fixnum-tag)))
(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))]))
(define (fold-p op a a*)
(define (fixnum-fold-p op a a*)
(cond
[(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
[else
@ -640,40 +698,40 @@
(f b (cdr a*))
(K #f)))])))]))
(define (fold-e a a*)
(define (fixnum-fold-e a a*)
(cond
[(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
[else (assert-fixnums a a*)]))
(define-primop = safe
[(P) (interrupt)]
[(P a . a*) (fold-p '= a a*)]
[(P a . a*) (fixnum-fold-p '= a a*)]
[(E) (interrupt)]
[(E a . a*) (fold-e a a*)])
[(E a . a*) (fixnum-fold-e a a*)])
(define-primop < safe
[(P) (interrupt)]
[(P a . a*) (fold-p '< a a*)]
[(P a . a*) (fixnum-fold-p '< a a*)]
[(E) (interrupt)]
[(E a . a*) (fold-e a a*)])
[(E a . a*) (fixnum-fold-e a a*)])
(define-primop <= safe
[(P) (interrupt)]
[(P a . a*) (fold-p '<= a a*)]
[(P a . a*) (fixnum-fold-p '<= a a*)]
[(E) (interrupt)]
[(E a . a*) (fold-e a a*)])
[(E a . a*) (fixnum-fold-e a a*)])
(define-primop > safe
[(P) (interrupt)]
[(P a . a*) (fold-p '> a a*)]
[(P a . a*) (fixnum-fold-p '> a a*)]
[(E) (interrupt)]
[(E a . a*) (fold-e a a*)])
[(E a . a*) (fixnum-fold-e a a*)])
(define-primop >= safe
[(P) (interrupt)]
[(P a . a*) (fold-p '>= a a*)]
[(P a . a*) (fixnum-fold-p '>= a a*)]
[(E) (interrupt)]
[(E a . a*) (fold-e a a*)])
[(E a . a*) (fixnum-fold-e a a*)])
(define-primop - safe
[(V a)
@ -715,6 +773,12 @@
[(E) (nop)]
[(E a . a*) (assert-fixnums a a*)])
(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))])
/section)
@ -724,7 +788,7 @@
[(P x) (sec-tag-test (T x) vector-mask vector-tag vector-mask vector-tag)]
[(E x) (nop)])
#;(define-primop $record/rtd? unsafe
(define-primop $record/rtd? unsafe
[(P x rtd)
(make-conditional
(tag-test (T x) vector-mask vector-tag)
@ -762,9 +826,13 @@
[(P x i) (cogen-pred-$vector-ref x i)])
(define-primop $record-set! unsafe
[(V x i v) (cogen-value-$vector-set! x i v)]
[(V x i v)
(seq* (cogen-effect-$vector-set! x i v)
(K void-object))]
[(E x i v) (cogen-effect-$vector-set! x i v)]
[(P x i v) (cogen-pred-$vector-set! x i v)])
[(P x i v)
(seq* (cogen-effect-$vector-set! x i v)
(K #t))])
(define-primop $record unsafe
[(V rtd . v*)
@ -826,6 +894,72 @@
[(P x) (K #t)]
[(E x) (nop)])
(define (non-char? x)
(record-case x
[(constant i) (not (char? i))]
[else #f]))
(define (assert-chars a a*)
(cond
[(constant? a)
(if (null? a*)
(nop)
(assert-chars (car a*) (cdr a*)))]
[else
(interrupt-unless
(tag-test (or* (T a) a*) char-mask char-tag))]))
(define (char-fold-p op a a*)
(cond
[(or (non-char? a) (ormap non-char? a*)) (interrupt)]
[else
(seq*
(assert-chars 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)))])))]))
(define (char-fold-e a a*)
(cond
[(or (non-char? a) (ormap non-char? a*)) (interrupt)]
[else (assert-chars a a*)]))
(define-primop char=? safe
[(P) (interrupt)]
[(P a . a*) (char-fold-p '= a a*)]
[(E) (interrupt)]
[(E a . a*) (char-fold-e a a*)])
(define-primop char<? safe
[(P) (interrupt)]
[(P a . a*) (char-fold-p '< a a*)]
[(E) (interrupt)]
[(E a . a*) (char-fold-e a a*)])
(define-primop char<=? safe
[(P) (interrupt)]
[(P a . a*) (char-fold-p '<= a a*)]
[(E) (interrupt)]
[(E a . a*) (char-fold-e a a*)])
(define-primop char>? safe
[(P) (interrupt)]
[(P a . a*) (char-fold-p '> a a*)]
[(E) (interrupt)]
[(E a . a*) (char-fold-e a a*)])
(define-primop char>=? safe
[(P) (interrupt)]
[(P a . a*) (char-fold-p '>= a a*)]
[(E) (interrupt)]
[(E a . a*) (char-fold-e a a*)])
/section)
(section ;;; strings
@ -1192,21 +1326,7 @@
#!eof
[($init-symbol-function!)
(tbind ([x (Value (car arg*))] [v (Value (cadr arg*))])
(seq*
(prm 'mset x (K (- disp-symbol-function symbol-tag)) v)
(prm 'mset x (K (- disp-symbol-error-function symbol-tag)) v)
(dirty-vector-set x)))]
[(zero?)
(tbind ([x (Value (car arg*))])
(make-conditional
(tag-test x fixnum-mask fixnum-tag)
(prm '= x (K 0))
(prm '!=
(make-funcall (Value (make-primref 'zero?)) (list x))
(Value (K #f)))))]
[($procedure-check)
(tbind ([x (Value (car arg*))])
(make-shortcut

View File

@ -17,7 +17,7 @@
(define fixnum-tag 0)
(define fixnum-mask 3))
(module (specify-representation)
(module (specify-representation primop?)
(import object-representation)
(define cookie (gensym))
(define (primop? x)
@ -34,7 +34,8 @@
[(not (PH-interruptable? p))
(parameterize ([interrupt-handler
(lambda ()
(error 'cogen "~s is uninterruptable" x))])
(error 'cogen "~s ~s is uninterruptable in ~s"
x args ctxt))])
(k))]
[else
(let ([interrupted? #f])
@ -44,14 +45,28 @@
(k))])
(cond
[(not interrupted?) body]
[(or (eq? ctxt 'V) (eq? ctxt 'E))
(make-shortcut body
(make-funcall (V (K x)) args))]
[(eq? ctxt 'V)
(let ([h (make-funcall (V (make-primref x)) args)])
(if (record-case body
[(primcall op) (eq? op 'interrupt)]
[else #f])
h
(make-shortcut body h)))]
[(eq? ctxt 'E)
(let ([h (make-funcall (V (make-primref x)) args)])
(if (record-case body
[(primcall op) (eq? op 'interrupt)]
[else #f])
h
(make-shortcut body h)))]
[(eq? ctxt 'P)
(make-shortcut body
(prm '!=
(make-funcall (V (K x)) args)
(K bool-f)))]
(let ([h (prm '!= (make-funcall (V (make-primref x)) args)
(K bool-f))])
(if (record-case body
[(primcall op) (eq? op 'interrupt)]
[else #f])
h
(make-shortcut body h)))]
[else (error 'with-interrupt-handler "invalid context ~s" ctxt)])))]))
(define-syntax with-tmp
(lambda (x)
@ -141,8 +156,7 @@
(with-tmp ([t (apply (PH-v-handler p) args)])
(prm 'nop))]
[else (error 'cogen-primop "~s is not handled" x)])]
[else (error 'cogen-primop "invalid context ~s"
ctxt)]))))))]
[else (error 'cogen-primop "invalid context ~s" ctxt)]))))))]
[else (error 'cogen-primop "~s is not a prim" x)]))
(define-syntax define-primop
@ -315,7 +329,10 @@
(define (P x)
(record-case x
[(constant) x]
[(constant c) (if c (K #t) (K #f))]
[(primref) (K #t)]
[(code-loc) (K #t)]
[(closure) (K #t)]
[(bind lhs* rhs* body)
(make-bind lhs* (map V rhs*) (P body))]
[(conditional e0 e1 e2)
@ -326,10 +343,19 @@
(handle-fix lhs* rhs* (P body))]
[(primcall op arg*)
(cogen-primop op 'P arg*)]
[(var) (prm '!= (V x) (V (K #f)))]
[(funcall) (prm '!= (V x) (V (K #f)))]
[(jmpcall) (prm '!= (V x) (V (K #f)))]
[(forcall) (prm '!= (V x) (V (K #f)))]
[else (error 'cogen-P "invalid pred expr ~s" x)]))
(define (E x)
(record-case x
[(constant) (nop)]
[(var) (nop)]
[(primref) (nop)]
[(code-loc) (nop)]
[(closure) (nop)]
[(bind lhs* rhs* body)
(make-bind lhs* (map V rhs*) (E body))]
[(conditional e0 e1 e2)
@ -468,7 +494,8 @@
[else (error 'specify-rep "invalid program ~s" x)]))
(define (specify-representation x)
(Program x))
(let ([x (Program x)])
x))