* libcore now compiles with chaitin

This commit is contained in:
Abdulaziz Ghuloum 2007-02-14 19:42:36 -05:00
parent 434ebe9525
commit 1a4cdcb7b0
5 changed files with 392 additions and 335 deletions

View File

@ -39,6 +39,15 @@
[movl (disp -4 %esp) %eax] [movl (disp -4 %esp) %eax]
[ret])) [ret]))
(asm-test 1
'([movl 8 %eax]
[movl %eax (disp -4 %esp)]
[movl 4 %eax]
[subl %eax (disp -4 %esp)]
[movl -4 %eax]
[movl (disp -4 %esp) %eax]
[ret]))
(asm-test 1 (asm-test 1
'([movl 1 (disp -4 %esp)] '([movl 1 (disp -4 %esp)]
[sall 2 (disp -4 %esp)] [sall 2 (disp -4 %esp)]

Binary file not shown.

View File

@ -119,6 +119,7 @@
'([pair? p] '([pair? p]
[vector? p] [vector? p]
[null? p] [null? p]
[bwp-object? p]
[eof-object? p] [eof-object? p]
[eof-object v] [eof-object v]
[$unbound-object? p] [$unbound-object? p]
@ -183,6 +184,7 @@
[$set-symbol-value! e] [$set-symbol-value! e]
[$symbol-string v] [$symbol-string v]
[$symbol-unique-string v] [$symbol-unique-string v]
[$set-symbol-unique-string! e]
[$symbol-plist v] [$symbol-plist v]
[$set-symbol-plist! e] [$set-symbol-plist! e]
[$set-symbol-string! e] [$set-symbol-string! e]
@ -211,6 +213,7 @@
[primitive-set! e] [primitive-set! e]
[primitive-ref v] [primitive-ref v]
[pointer-value v]
[$fp-at-base p] [$fp-at-base p]
[$current-frame v] [$current-frame v]
[$seal-frame-and-call tail] [$seal-frame-and-call tail]
@ -218,6 +221,7 @@
[$make-call-with-values-procedure v] [$make-call-with-values-procedure v]
[$make-values-procedure v] [$make-values-procedure v]
[$arg-list v]
)) ))
(define library-prims (define library-prims
@ -642,7 +646,7 @@
(cond (cond
[(null? n*) '()] [(null? n*) '()]
[else [else
(cons (prm 'int+ (list lhs (K n))) (cons (prm 'int+ lhs (K n))
(adders lhs (+ n (car n*)) (cdr n*)))])) (adders lhs (+ n (car n*)) (cdr n*)))]))
(define (build-closures lhs* rhs* body) (define (build-closures lhs* rhs* body)
(let ([lhs (car lhs*)] [rhs (car rhs*)] (let ([lhs (car lhs*)] [rhs (car rhs*)]
@ -737,69 +741,78 @@
[(primcall op arg*) [(primcall op arg*)
(case op (case op
[(nop) nop] [(nop) nop]
[($cpset!) ;;;X[($cpset!)
(let ([x (Value (car arg*))] ;;;X (let ([x (Value (car arg*))]
[i (cadr arg*)] ;;;X [i (cadr arg*)]
[v (Value (caddr arg*))]) ;;;X [v (Value (caddr arg*))])
(record-case i ;;;X (record-case i
[(constant i) ;;;X [(constant i)
(unless (fixnum? i) (err x)) ;;;X (unless (fixnum? i) (err x))
(prm 'mset x ;;;X (prm 'mset x
(K (+ (* i wordsize) ;;;X (K (+ (* i wordsize)
(- disp-closure-data closure-tag))) ;;;X (- disp-closure-data closure-tag)))
v)] ;;;X v)]
[else (err x)]))] ;;;X [else (err x)]))]
[(primitive-set!) [(primitive-set!)
(let ([x (Value (car arg*))] [v (Value (cadr arg*))]) (let ([x (Value (car arg*))] [v (Value (cadr arg*))])
(mem-assign v x (mem-assign v x
(- disp-symbol-system-value symbol-tag)))] (- disp-symbol-system-value symbol-tag)))]
[($set-symbol-value!) [($set-symbol-value!)
(let ([x (Value (car arg*))] [v (Value (cadr arg*))]) (tbind ([x (Value (car arg*))]
[v (Value (cadr arg*))])
(mem-assign v x (mem-assign v x
(- disp-symbol-value symbol-tag)))] (- disp-symbol-value symbol-tag)))]
[($set-symbol-string!) [($set-symbol-string!)
(let ([x (Value (car arg*))] [v (Value (cadr arg*))]) (tbind ([x (Value (car arg*))] [v (Value (cadr arg*))])
(mem-assign v x (mem-assign v x
(- disp-symbol-string symbol-tag)))] (- disp-symbol-string symbol-tag)))]
[($set-symbol-unique-string!)
(tbind ([x (Value (car arg*))] [v (Value (cadr arg*))])
(mem-assign v x
(- disp-symbol-unique-string symbol-tag)))]
[($set-symbol-plist!) [($set-symbol-plist!)
(let ([x (Value (car arg*))] [v (Value (cadr arg*))]) (tbind ([x (Value (car arg*))] [v (Value (cadr arg*))])
(mem-assign v x (mem-assign v x
(- disp-symbol-plist symbol-tag)))] (- disp-symbol-plist symbol-tag)))]
[($vector-set! $record-set!) [($vector-set! $record-set!)
(let ([x (Value (car arg*))] (tbind ([x (Value (car arg*))]
[i (cadr arg*)]
[v (Value (caddr arg*))]) [v (Value (caddr arg*))])
(let ([i (cadr arg*)])
(record-case i (record-case i
[(constant i) [(constant i)
(unless (fixnum? i) (err x)) (unless (fixnum? i)
(error who "invalid arg ~s to ~s" i op))
(mem-assign v x (mem-assign v x
(+ (* i wordsize) (+ (* i wordsize)
(- disp-vector-data vector-tag)))] (- disp-vector-data vector-tag)))]
[else [else
(tbind ([i (Value i)])
(mem-assign v (mem-assign v
(prm 'int+ x (Value i)) (prm 'int+ x i)
(- disp-vector-data vector-tag))]))] (- disp-vector-data vector-tag)))])))]
[($set-car! $set-cdr!) [($set-car! $set-cdr!)
(let ([off (if (eq? op '$set-car!) (let ([off (if (eq? op '$set-car!)
(- disp-car pair-tag) (- disp-car pair-tag)
(- disp-cdr pair-tag))]) (- disp-cdr pair-tag))])
(tbind ([x (Value (car arg*))]) (tbind ([x (Value (car arg*))]
[v (Value (cadr arg*))])
(seq* ;;; car/cdr addresses are in the same (seq* ;;; car/cdr addresses are in the same
;;; card as the pair address, so no ;;; card as the pair address, so no
;;; adjustment is necessary as was the ;;; adjustment is necessary as was the
;;; case with vectors and records. ;;; case with vectors and records.
(prm 'mset x (K off) (Value (cadr arg*))) (prm 'mset x (K off) v)
(dirty-vector-set x))))] (dirty-vector-set x))))]
[($string-set!) [($string-set!)
(let ([x (Value (car arg*))] (tbind ([x (Value (car arg*))])
[i (cadr arg*)] (let ([i (cadr arg*)]
[c (caddr arg*)]) [c (caddr arg*)])
(record-case i (record-case i
[(constant i) [(constant i)
(unless (fixnum? i) (err x)) (unless (fixnum? i)
(error who "invalid arg ~s to ~s" i op))
(record-case c (record-case c
[(constant c) [(constant c)
(unless (char? i) (err x)) (unless (char? c) (err x))
(prm 'bset/c x (prm 'bset/c x
(K (+ i (- disp-string-data string-tag))) (K (+ i (- disp-string-data string-tag)))
(K (char->integer c)))] (K (char->integer c)))]
@ -814,7 +827,7 @@
(tbind ([i (Value i)]) (tbind ([i (Value i)])
(record-case c (record-case c
[(constant c) [(constant c)
(unless (char? i) (err x)) (unless (char? c) (err x))
(prm 'bset/c x (prm 'bset/c x
(prm 'sra i (K fixnum-shift)) (prm 'sra i (K fixnum-shift))
(K (char->integer c)))] (K (char->integer c)))]
@ -826,7 +839,7 @@
(prm 'int+ (prm 'int+
(prm 'sra i (K fixnum-shift)) (prm 'sra i (K fixnum-shift))
(K (- disp-string-data string-tag))) (K (- disp-string-data string-tag)))
c))]))]))] c))]))])))]
[else (error who "invalid effect prim ~s" op)])] [else (error who "invalid effect prim ~s" op)])]
[(forcall op arg*) [(forcall op arg*)
(make-forcall op (map Value arg*))] (make-forcall op (map Value arg*))]
@ -839,20 +852,20 @@
[else (error who "invalid effect expr ~s" x)])) [else (error who "invalid effect expr ~s" x)]))
;;; ;;;
(define (tag-test x mask tag) (define (tag-test x mask tag)
(tbind ([x x])
(if mask (if mask
(make-primcall '= (make-primcall '=
(list (make-primcall 'logand (list (make-primcall 'logand
(list x (make-constant mask))) (list x (make-constant mask)))
(make-constant tag))) (make-constant tag)))
(make-primcall '= (make-primcall '=
(list x (make-constant tag))))) (list x (make-constant tag))))))
(define (sec-tag-test x pmask ptag smask stag) (define (sec-tag-test x pmask ptag smask stag)
(let ([t (unique-var 'tmp)]) (tbind ([t x])
(make-bind (list t) (list x)
(make-conditional (make-conditional
(tag-test t pmask ptag) (tag-test t pmask ptag)
(tag-test (prm 'mref t (K (- ptag))) smask stag) (tag-test (prm 'mref t (K (- ptag))) smask stag)
(make-constant #f))))) (make-constant #f))))
;;; ;;;
(define (Pred x) (define (Pred x)
(record-case x (record-case x
@ -870,6 +883,7 @@
[(eq?) (make-primcall '= (map Value arg*))] [(eq?) (make-primcall '= (map Value arg*))]
[(null?) (prm '= (Value (car arg*)) (K nil))] [(null?) (prm '= (Value (car arg*)) (K nil))]
[(eof-object?) (prm '= (Value (car arg*)) (K eof))] [(eof-object?) (prm '= (Value (car arg*)) (K eof))]
[(bwp-object?) (prm '= (Value (car arg*)) (K bwp-object))]
[(neq?) (make-primcall '!= (map Value arg*))] [(neq?) (make-primcall '!= (map Value arg*))]
[($fxzero?) (prm '= (Value (car arg*)) (K 0))] [($fxzero?) (prm '= (Value (car arg*)) (K 0))]
[($unbound-object?) (prm '= (Value (car arg*)) (K unbound))] [($unbound-object?) (prm '= (Value (car arg*)) (K unbound))]
@ -903,12 +917,11 @@
(sec-tag-test (Value (car arg*)) (sec-tag-test (Value (car arg*))
vector-mask vector-tag port-mask port-tag)] vector-mask vector-tag port-mask port-tag)]
[($record/rtd?) [($record/rtd?)
(tbind ([t (Value (car arg*))]) (tbind ([t (Value (car arg*))]
[v (Value (cadr arg*))])
(make-conditional (make-conditional
(tag-test t vector-mask vector-tag) (tag-test t vector-mask vector-tag)
(prm '= (prm '= (prm 'mref t (K (- vector-tag))) v)
(prm 'mref t (K (- vector-tag)))
(Value (cadr arg*)))
(make-constant #f)))] (make-constant #f)))]
[(immediate?) [(immediate?)
(tbind ([t (Value (car arg*))]) (tbind ([t (Value (car arg*))])
@ -973,24 +986,31 @@
[(void) (K void-object)] [(void) (K void-object)]
[(eof-object) (K eof)] [(eof-object) (K eof)]
[($car) [($car)
(prm 'mref (Value (car arg*)) (K (- disp-car pair-tag)))] (tbind ([x (Value (car arg*))])
(prm 'mref x (K (- disp-car pair-tag))))]
[($cdr) [($cdr)
(prm 'mref (Value (car arg*)) (K (- disp-cdr pair-tag)))] (tbind ([x (Value (car arg*))])
(prm 'mref x (K (- disp-cdr pair-tag))))]
[(primitive-ref) [(primitive-ref)
(prm 'mref (Value (car arg*)) (tbind ([x (Value (car arg*))])
(K (- disp-symbol-system-value symbol-tag)))] (prm 'mref x
(K (- disp-symbol-system-value symbol-tag))))]
[($symbol-string) [($symbol-string)
(prm 'mref (Value (car arg*)) (tbind ([x (Value (car arg*))])
(K (- disp-symbol-string symbol-tag)))] (prm 'mref x
(K (- disp-symbol-string symbol-tag))))]
[($symbol-plist) [($symbol-plist)
(prm 'mref (Value (car arg*)) (tbind ([x (Value (car arg*))])
(K (- disp-symbol-plist symbol-tag)))] (prm 'mref x
(K (- disp-symbol-plist symbol-tag))))]
[($symbol-value) [($symbol-value)
(prm 'mref (Value (car arg*)) (tbind ([x (Value (car arg*))])
(K (- disp-symbol-value symbol-tag)))] (prm 'mref x
(K (- disp-symbol-value symbol-tag))))]
[($symbol-unique-string) [($symbol-unique-string)
(prm 'mref (Value (car arg*)) (tbind ([x (Value (car arg*))])
(K (- disp-symbol-unique-string symbol-tag)))] (prm 'mref x
(K (- disp-symbol-unique-string symbol-tag))))]
[($make-symbol) [($make-symbol)
(tbind ([str (Value (car arg*))]) (tbind ([str (Value (car arg*))])
(tbind ([x (prm 'alloc (tbind ([x (prm 'alloc
@ -1016,21 +1036,21 @@
(K (- disp-symbol-system-plist symbol-tag)) (K (- disp-symbol-system-plist symbol-tag))
(K nil)) (K nil))
x)))] x)))]
[($make-cp) ;;;X[($make-cp)
(let ([label (car arg*)] [len (cadr arg*)]) ;;;X (let ([label (car arg*)] [len (cadr arg*)])
(record-case len ;;;X (record-case len
[(constant i) ;;;X [(constant i)
(unless (fixnum? i) (err x)) ;;;X (unless (fixnum? i) (err x))
(tbind ([t (prm 'alloc ;;;X (tbind ([t (prm 'alloc
(K (align (+ disp-closure-data ;;;X (K (align (+ disp-closure-data
(* i wordsize)))) ;;;X (* i wordsize))))
(K closure-tag))]) ;;;X (K closure-tag))])
(seq* ;;;X (seq*
(prm 'mset t ;;;X (prm 'mset t
(K (- disp-closure-code closure-tag)) ;;;X (K (- disp-closure-code closure-tag))
(Value label)) ;;;X (Value label))
t))] ;;;X t))]
[else (err x)]))] ;;;X [else (err x)]))]
[($record) [($record)
(let ([rtd (car arg*)] [v* (map Value (cdr arg*))]) (let ([rtd (car arg*)] [v* (map Value (cdr arg*))])
(tbind ([rtd (Value rtd)]) (tbind ([rtd (Value rtd)])
@ -1054,8 +1074,9 @@
(prm 'mset t (K i) (car t*)) (prm 'mset t (K i) (car t*))
(f (cdr t*) (+ i wordsize)))]))))))))] (f (cdr t*) (+ i wordsize)))]))))))))]
[($vector-length) [($vector-length)
(prm 'mref (Value (car arg*)) (tbind ([x (Value (car arg*))])
(K (- disp-vector-length vector-tag)))] (prm 'mref x
(K (- disp-vector-length vector-tag))))]
[($make-vector) [($make-vector)
(unless (= (length arg*) 1) (unless (= (length arg*) 1)
(error who "incorrect args to $make-vector")) (error who "incorrect args to $make-vector"))
@ -1082,34 +1103,35 @@
len) len)
v))))]))] v))))]))]
[($string-length) [($string-length)
(prm 'mref (Value (car arg*)) (tbind ([x (Value (car arg*))])
(K (- disp-string-length string-tag)))] (prm 'mref x
(K (- disp-string-length string-tag))))]
[($string-ref) [($string-ref)
(let ([s (car arg*)] [i (cadr arg*)]) (tbind ([s (Value (car arg*))])
(let ([i (cadr arg*)])
(record-case i (record-case i
[(constant i) [(constant i)
(unless (fixnum? i) (err x)) (unless (fixnum? i) (err x))
(prm 'logor (prm 'logor
(prm 'sll (prm 'sll
(prm 'logand (prm 'logand
(prm 'mref (Value s) (prm 'mref s
(K (+ i (- disp-string-data string-tag)))) (K (+ i (- disp-string-data string-tag))))
(K 255)) (K 255))
(K char-shift)) (K char-shift))
(K char-tag))] (K char-tag))]
[else [else
(tbind ([i (Value i)])
(prm 'logor (prm 'logor
(prm 'sll (prm 'sll
(prm 'logand (prm 'logand
(prm 'mref (Value s) (prm 'mref s
(prm 'int+ (prm 'int+
(prm 'sra (prm 'sra i (K fixnum-shift))
(Value i)
(K fixnum-shift))
(K (- disp-string-data string-tag)))) (K (- disp-string-data string-tag))))
(K 255)) (K 255))
(K char-shift)) (K char-shift))
(K char-tag))]))] (K char-tag)))])))]
[($make-string) [($make-string)
(unless (= (length arg*) 1) (err x)) (unless (= (length arg*) 1) (err x))
(let ([n (car arg*)]) (let ([n (car arg*)])
@ -1170,8 +1192,9 @@
rtd) rtd)
t))))])))] t))))])))]
[($record-rtd) [($record-rtd)
(prm 'mref (Value (car arg*)) (tbind ([x (Value (car arg*))])
(K (- disp-record-rtd vector-tag)))] (prm 'mref x
(K (- disp-record-rtd vector-tag))))]
[(cons) [(cons)
(tbind ([a (Value (car arg*))] (tbind ([a (Value (car arg*))]
[d (Value (cadr arg*))]) [d (Value (cadr arg*))])
@ -1193,20 +1216,20 @@
(record-case a (record-case a
[(constant a) [(constant a)
(unless (fixnum? a) (err x)) (unless (fixnum? a) (err x))
(prm 'int* (Value b) (K a))] (tbind ([b (Value b)])
(prm 'int* b (K a)))]
[else [else
(record-case b (record-case b
[(constant b) [(constant b)
(unless (fixnum? b) (err x)) (unless (fixnum? b) (err x))
(prm 'int* (Value a) (K b))] (tbind ([a (Value a)])
(prm 'int* a (K b)))]
[else [else
(prm 'int* (tbind ([a (Value a)] [b (Value b)])
(Value a) (prm 'int* a (prm 'sra b (K fixnum-shift))))])]))]
(prm 'sra (Value b) (K fixnum-shift)))])]))]
[($fxquotient) [($fxquotient)
(prm 'sll (tbind ([a (Value (car arg*))] [b (Value (cadr arg*))])
(prm 'remainder (Value (car arg*)) (Value (cadr arg*))) (prm 'sll (prm 'remainder a b) (K fixnum-shift)))]
(K fixnum-shift))]
[($fxmodulo) [($fxmodulo)
(tbind ([a (Value (car arg*))] (tbind ([a (Value (car arg*))]
[b (Value (cadr arg*))]) [b (Value (cadr arg*))])
@ -1220,25 +1243,30 @@
(record-case c (record-case c
[(constant i) [(constant i)
(if (fixnum? i) (if (fixnum? i)
(prm 'sll (Value a) (K i)) (tbind ([a (Value a)])
(prm 'sll a (K i)))
(error who "invalid arg to fxsll ~s" i))] (error who "invalid arg to fxsll ~s" i))]
[else [else
(prm 'sll (Value a) (tbind ([a (Value a)] [c (Value c)])
(prm 'sra (Value c) (K fixnum-shift)))]))] (prm 'sll a (prm 'sra c (K fixnum-shift))))]))]
[($fxsra) [($fxsra)
(let ([a (car arg*)] [c (cadr arg*)]) (let ([a (car arg*)] [c (cadr arg*)])
(record-case c (record-case c
[(constant i) [(constant i)
(if (fixnum? i) (if (fixnum? i)
(prm 'sra (Value a) (K i)) (tbind ([a (Value a)])
(prm 'sra a (K i)))
(error who "invalid arg to fxsra ~s" i))] (error who "invalid arg to fxsra ~s" i))]
[else [else
(tbind ([a (Value a)] [c (Value c)])
(prm 'logand (prm 'logand
(prm 'sra (Value a) (prm 'sra a
(prm 'sra (Value c) (K fixnum-shift))) (prm 'sra c (K fixnum-shift)))
(K (* -1 fixnum-scale)))]))] (K (* -1 fixnum-scale))))]))]
[($fxlogand) [($fxlogand)
(prm 'logand (Value (car arg*)) (Value (cadr arg*)))] (prm 'logand (Value (car arg*)) (Value (cadr arg*)))]
[(pointer-value)
(prm 'logand (Value (car arg*)) (K (* -1 fixnum-scale)))]
[($fxlogxor) [($fxlogxor)
(prm 'logxor (Value (car arg*)) (Value (cadr arg*)))] (prm 'logxor (Value (car arg*)) (Value (cadr arg*)))]
[($fxlogor) [($fxlogor)
@ -1246,16 +1274,18 @@
[($fxlognot) [($fxlognot)
(Value (prm '$fxlogxor (car arg*) (K -1)))] (Value (prm '$fxlogxor (car arg*) (K -1)))]
[($char->fixnum) [($char->fixnum)
(prm 'sra (tbind ([x (Value (car arg*))])
(Value (car arg*)) (prm 'sra x
(K (- char-shift fixnum-shift)))] (K (- char-shift fixnum-shift))))]
[($fixnum->char) [($fixnum->char)
(tbind ([x (Value (car arg*))])
(prm 'logor (prm 'logor
(prm 'sll (Value (car arg*)) (prm 'sll x (K (- char-shift fixnum-shift)))
(K (- char-shift fixnum-shift))) (K char-tag)))]
(K char-tag))]
[($current-frame) ;; PCB NEXT-CONTINUATION [($current-frame) ;; PCB NEXT-CONTINUATION
(prm 'mref pcr (K 20))] (prm 'mref pcr (K 20))]
[($arg-list) ;; PCB ARGS-LIST
(prm 'mref pcr (K 32))]
[($seal-frame-and-call) [($seal-frame-and-call)
(tbind ([proc (Value (car arg*))]) (tbind ([proc (Value (car arg*))])
(tbind ([k (prm 'alloc (tbind ([k (prm 'alloc
@ -1305,35 +1335,34 @@
(record-case a1 (record-case a1
[(constant i) [(constant i)
(unless (fixnum? i) (err x)) (unless (fixnum? i) (err x))
(prm 'mref (Value a0) (tbind ([a0 (Value a0)])
(prm 'mref a0
(K (+ (- disp-closure-data closure-tag) (K (+ (- disp-closure-data closure-tag)
(* i wordsize))))] (* i wordsize)))))]
[else (err x)]))] [else (err x)]))]
[($vector-ref $record-ref) [($vector-ref $record-ref)
(let ([a0 (car arg*)] [a1 (cadr arg*)]) (let ([a0 (car arg*)] [a1 (cadr arg*)])
(record-case a1 (record-case a1
[(constant i) [(constant i)
(unless (fixnum? i) (err x)) (unless (fixnum? i) (err x))
(make-primcall 'mref (tbind ([a0 (Value a0)])
(list (Value a0) (prm 'mref a0
(K (+ (- disp-vector-data vector-tag) (K (+ (- disp-vector-data vector-tag)
(* i wordsize)))))] (* i wordsize)))))]
[else [else
(make-primcall 'mref (tbind ([a0 (Value a0)] [a1 (Value a1)])
(list (make-primcall 'int+ (prm 'mref (prm 'int+ a0 a1)
(list (Value a0)
(Value a1)))
(K (- disp-vector-data vector-tag))))]))] (K (- disp-vector-data vector-tag))))]))]
[($closure-code) [($closure-code)
(tbind ([x (Value (car arg*))])
(prm 'int+ (prm 'int+
(prm 'mref (prm 'mref x
(Value (car arg*))
(K (- disp-closure-code closure-tag))) (K (- disp-closure-code closure-tag)))
(K (- vector-tag disp-code-data)))] (K (- vector-tag disp-code-data))))]
[($code-freevars) [($code-freevars)
(prm 'mref (tbind ([x (Value (car arg*))])
(Value (car arg*)) (prm 'mref x
(K (- disp-code-freevars vector-tag)))] (K (- disp-code-freevars vector-tag))))]
[(top-level-value) [(top-level-value)
(let ([sym (let ([sym
(record-case (car arg*) (record-case (car arg*)
@ -1748,6 +1777,7 @@
[(codes code* body) [(codes code* body)
(make-codes (map Clambda code*) (Main body))])) (make-codes (map Clambda code*) (Main body))]))
;;; ;;;
; (print-code x)
(Program x)) (Program x))
@ -2156,7 +2186,7 @@
(let ([i (actual-frame-size vars (let ([i (actual-frame-size vars
(fx+ 2 (max-live live-fv* 0)))]) (fx+ 2 (max-live live-fv* 0)))])
(assign-frame-vars! vars i) (assign-frame-vars! vars i)
(NFE (fxsub1 i) (make-mask i live-fv*) body)))] (NFE (fxsub1 i) (make-mask (fxsub1 i) live-fv*) body)))]
[(ntcall) x] [(ntcall) x]
[else (error who "invalid effect ~s" x)])) [else (error who "invalid effect ~s" x)]))
(define (P x) (define (P x)
@ -2485,7 +2515,7 @@
'(byte 0) '(byte 0)
LCALL LCALL
`(call %ebx) `(call %ebx)
;;ik_foreign_call adjusts fp back `(addl ,(* (fxsub1 size) wordsize) ,fpr)
ac)] ac)]
[target ;;; known call [target ;;; known call
(list* `(subl ,(* (fxsub1 size) wordsize) ,fpr) (list* `(subl ,(* (fxsub1 size) wordsize) ,fpr)

View File

@ -11,6 +11,7 @@
(primitive-set! 'call-with-values (primitive-set! 'call-with-values
($make-call-with-values-procedure)) ($make-call-with-values-procedure))
(primitive-set! 'values (primitive-set! 'values
($make-values-procedure)) ($make-values-procedure))
@ -28,13 +29,19 @@
(primitive-set! 'eof-object? (primitive-set! 'eof-object?
(lambda (x) (eof-object? x))) (lambda (x) (eof-object? x)))
(primitive-set! 'fxadd1 (primitive-set! 'fxadd1
(lambda (n) (lambda (n)
(fxadd1 n))) (if (fixnum? n)
($fxadd1 n)
(error 'fxadd1 "~s is not a fixnum" n))))
(primitive-set! 'fxsub1 (primitive-set! 'fxsub1
(lambda (n) (lambda (n)
(fxsub1 n))) (if (fixnum? n)
($fxsub1 n)
(error 'fxsub1 "~s is not a fixnum" n))))
(primitive-set! 'integer->char (primitive-set! 'integer->char
(lambda (n) (lambda (n)
@ -97,6 +104,7 @@
(fill! ($make-vector n) 0 n fill)])) (fill! ($make-vector n) 0 n fill)]))
(primitive-set! 'make-vector make-vector)) (primitive-set! 'make-vector make-vector))
(primitive-set! 'vector-length (primitive-set! 'vector-length
(lambda (x) (lambda (x)
(unless (vector? x) (unless (vector? x)
@ -132,6 +140,7 @@
(error 'string-length "~s is not a string" x)) (error 'string-length "~s is not a string" x))
($string-length x))) ($string-length x)))
(primitive-set! 'string->list (primitive-set! 'string->list
(lambda (x) (lambda (x)
(unless (string? x) (unless (string? x)
@ -192,6 +201,35 @@ description:
(strings=? s s* ($string-length s)) (strings=? s s* ($string-length s))
(err s))]))) (err s))])))
(primitive-set! 'string-ref
(lambda (s i)
(unless (string? s)
(error 'string-ref "~s is not a string" s))
(unless (fixnum? i)
(error 'string-ref "~s is not a valid index" i))
(unless (and ($fx< i ($string-length s))
($fx<= 0 i))
(error 'string-ref "index ~s is out of range for ~s" i s))
($string-ref s i)))
(primitive-set! 'string-set!
(lambda (s i c)
(unless (string? s)
(error 'string-set! "~s is not a string" s))
(unless (fixnum? i)
(error 'string-set! "~s is not a valid index" i))
(unless (and ($fx< i ($string-length s))
($fx>= i 0))
(error 'string-set! "index ~s is out of range for ~s" i s))
(unless (char? c)
(error 'string-set! "~s is not a character" c))
($string-set! s i c)))
#|procedure:string-append #|procedure:string-append
synopsis: synopsis:
(string-append str ...) (string-append str ...)
@ -234,6 +272,9 @@ reference-implementation:
(let ([s ($make-string n)]) (let ([s ($make-string n)])
(fill-strings s s* 0)))))) (fill-strings s s* 0))))))
#|procedure:substring #|procedure:substring
(substring str i j) (substring str i j)
Returns a substring of str starting from index i (inclusive) Returns a substring of str starting from index i (inclusive)
@ -267,17 +308,7 @@ reference-implementation:
(primitive-set! 'not (primitive-set! 'not
(lambda (x) (if x #f #t))) (lambda (x) (if x #f #t)))
(primitive-set! 'symbol->string
(lambda (x)
(unless (symbol? x)
(error 'symbol->string "~s is not a symbol" x))
(let ([str ($symbol-string x)])
(or str
(let ([ct (gensym-count)])
(let ([str (string-append (gensym-prefix) (fixnum->string ct))])
($set-symbol-string! x str)
(gensym-count ($fxadd1 ct))
str))))))
(primitive-set! 'gensym? (primitive-set! 'gensym?
(lambda (x) (lambda (x)
@ -285,37 +316,6 @@ reference-implementation:
(let ([s ($symbol-unique-string x)]) (let ([s ($symbol-unique-string x)])
(and s #t))))) (and s #t)))))
(let ()
(define f
(lambda (n i j)
(cond
[($fxzero? n)
(values (make-string i) j)]
[else
(let ([q ($fxquotient n 10)])
(call-with-values
(lambda () (f q ($fxadd1 i) j))
(lambda (str j)
(let ([r ($fx- n ($fx* q 10))])
(string-set! str j
($fixnum->char ($fx+ r ($char->fixnum #\0))))
(values str ($fxadd1 j))))))])))
(primitive-set! 'fixnum->string
(lambda (x)
(unless (fixnum? x) (error 'fixnum->string "~s is not a fixnum" x))
(cond
[($fxzero? x) "0"]
[($fx> x 0)
(call-with-values
(lambda () (f x 0 0))
(lambda (str j) str))]
[($fx= x -536870912) "-536870912"]
[else
(call-with-values
(lambda () (f ($fx- 0 x) 1 1))
(lambda (str j)
($string-set! str 0 #\-)
str))]))))
;;; OLD (primitive-set! 'top-level-value ;;; OLD (primitive-set! 'top-level-value
;;; OLD (lambda (x) ;;; OLD (lambda (x)
@ -366,13 +366,14 @@ reference-implementation:
(primitive-set! x v) (primitive-set! x v)
(set-top-level-value! x v))) (set-top-level-value! x v)))
(primitive-set! 'fx+ (primitive-set! 'fx+
(lambda (x y) (lambda (x y)
(fx+ x y))) (unless (fixnum? x)
(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)
@ -382,6 +383,7 @@ reference-implementation:
(error 'fx- "~s is not a fixnum" y)) (error 'fx- "~s is not a fixnum" y))
($fx- x y))) ($fx- x y)))
(primitive-set! 'fx* (primitive-set! 'fx*
(lambda (x y) (lambda (x y)
(unless (fixnum? x) (unless (fixnum? x)
@ -390,8 +392,6 @@ reference-implementation:
(error 'fx* "~s is not a fixnum" y)) (error 'fx* "~s is not a fixnum" y))
($fx* x y))) ($fx* x y)))
(primitive-set! 'fxquotient (primitive-set! 'fxquotient
(lambda (x y) (lambda (x y)
(unless (fixnum? x) (unless (fixnum? x)
@ -402,7 +402,6 @@ reference-implementation:
(error 'fxquotient "zero dividend ~s" y)) (error 'fxquotient "zero dividend ~s" y))
($fxquotient x y))) ($fxquotient x y)))
(primitive-set! 'fxremainder (primitive-set! 'fxremainder
(lambda (x y) (lambda (x y)
(unless (fixnum? x) (unless (fixnum? x)
@ -414,7 +413,6 @@ reference-implementation:
(let ([q ($fxquotient x y)]) (let ([q ($fxquotient x y)])
($fx- x ($fx* q y))))) ($fx- x ($fx* q y)))))
(primitive-set! 'fxmodulo (primitive-set! 'fxmodulo
(lambda (x y) (lambda (x y)
(unless (fixnum? x) (unless (fixnum? x)
@ -425,7 +423,6 @@ reference-implementation:
(error 'fxmodulo "zero dividend ~s" y)) (error 'fxmodulo "zero dividend ~s" y))
($fxmodulo x y))) ($fxmodulo x y)))
(primitive-set! 'fxlogor (primitive-set! 'fxlogor
(lambda (x y) (lambda (x y)
(unless (fixnum? x) (unless (fixnum? x)
@ -450,6 +447,7 @@ reference-implementation:
(error 'fxlogand "~s is not a fixnum" y)) (error 'fxlogand "~s is not a fixnum" y))
($fxlogand x y))) ($fxlogand x y)))
(primitive-set! 'fxsra (primitive-set! 'fxsra
(lambda (x y) (lambda (x y)
(unless (fixnum? x) (unless (fixnum? x)
@ -697,6 +695,14 @@ reference-implementation:
(err c2))))) (err c2)))))
(err c1))]))) (err c1))])))
(primitive-set! '$memq
(lambda (x ls)
(let f ([x x] [ls ls])
(and (pair? ls)
(if (eq? x (car ls))
ls
(f x (cdr ls)))))))
(primitive-set! 'char-whitespace? (primitive-set! 'char-whitespace?
(lambda (c) (lambda (c)
(cond (cond
@ -765,16 +771,6 @@ reference-implementation:
(error 'vector-ref "index ~s is out of range for ~s" i v)) (error 'vector-ref "index ~s is out of range for ~s" i v))
($vector-ref v i))) ($vector-ref v i)))
(primitive-set! 'string-ref
(lambda (s i)
(unless (string? s)
(error 'string-ref "~s is not a string" s))
(unless (fixnum? i)
(error 'string-ref "~s is not a valid index" i))
(unless (and ($fx< i ($string-length s))
($fx<= 0 i))
(error 'string-ref "index ~s is out of range for ~s" i s))
($string-ref s i)))
(primitive-set! 'vector-set! (primitive-set! 'vector-set!
(lambda (v i c) (lambda (v i c)
@ -788,18 +784,6 @@ reference-implementation:
($vector-set! v i c))) ($vector-set! v i c)))
(primitive-set! 'string-set!
(lambda (s i c)
(unless (string? s)
(error 'string-set! "~s is not a string" s))
(unless (fixnum? i)
(error 'string-set! "~s is not a valid index" i))
(unless (and ($fx< i ($string-length s))
($fx>= i 0))
(error 'string-set! "index ~s is out of range for ~s" i s))
(unless (char? c)
(error 'string-set! "~s is not a character" c))
($string-set! s i c)))
(primitive-set! 'vector (primitive-set! 'vector
;;; FIXME: add case-lambda ;;; FIXME: add case-lambda
@ -889,15 +873,6 @@ reference-implementation:
(race d d x x)) (race d d x x))
(error 'last-pair "~s is not a pair" x))))) (error 'last-pair "~s is not a pair" x)))))
(primitive-set! '$memq
(lambda (x ls)
(let f ([x x] [ls ls])
(and (pair? ls)
(if (eq? x (car ls))
ls
(f x (cdr ls)))))))
(primitive-set! 'memq (primitive-set! 'memq
(letrec ([race (letrec ([race
(lambda (h t ls x) (lambda (h t ls x)
@ -1033,40 +1008,6 @@ reference-implementation:
(f list index))) (f list index)))
(primitive-set! 'apply
(let ()
(define (err f ls)
(if (procedure? f)
(error 'apply "not a list")
(error 'apply "~s is not a procedure" f)))
(define (fixandgo f a0 a1 ls p d)
(cond
[(null? ($cdr d))
(let ([last ($car d)])
($set-cdr! p last)
(if (and (procedure? f) (list? last))
($$apply f a0 a1 ls)
(err f last)))]
[else (fixandgo f a0 a1 ls d ($cdr d))]))
(define apply
(case-lambda
[(f ls)
(if (and (procedure? f) (list? ls))
($$apply f ls)
(err f ls))]
[(f a0 ls)
(if (and (procedure? f) (list? ls))
($$apply f a0 ls)
(err f ls))]
[(f a0 a1 ls)
(if (and (procedure? f) (list? ls))
($$apply f a0 a1 ls)
(err f ls))]
[(f a0 a1 . ls)
(fixandgo f a0 a1 ls ls ($cdr ls))]))
apply))
@ -1224,7 +1165,6 @@ reference-implementation:
(f ($symbol-plist x) '())))) (f ($symbol-plist x) '()))))
(let () (let ()
(define vector-loop (define vector-loop
(lambda (x y i n) (lambda (x y i n)
@ -1259,6 +1199,41 @@ reference-implementation:
(primitive-set! 'equal? equal?)) (primitive-set! 'equal? equal?))
(primitive-set! 'apply
(let ()
(define (err f ls)
(if (procedure? f)
(error 'apply "not a list")
(error 'apply "~s is not a procedure" f)))
(define (fixandgo f a0 a1 ls p d)
(cond
[(null? ($cdr d))
(let ([last ($car d)])
($set-cdr! p last)
(if (and (procedure? f) (list? last))
($$apply f a0 a1 ls)
(err f last)))]
[else (fixandgo f a0 a1 ls d ($cdr d))]))
(define apply
(case-lambda
[(f ls)
(if (and (procedure? f) (list? ls))
($$apply f ls)
(err f ls))]
[(f a0 ls)
(if (and (procedure? f) (list? ls))
($$apply f a0 ls)
(err f ls))]
[(f a0 a1 ls)
(if (and (procedure? f) (list? ls))
($$apply f a0 a1 ls)
(err f ls))]
[(f a0 a1 . ls)
(fixandgo f a0 a1 ls ls ($cdr ls))]))
apply))
(let () (let ()
(define who 'map) (define who 'map)
(define len (define len
@ -1712,7 +1687,7 @@ reference-implementation:
(let ([us ($symbol-unique-string x)]) (let ([us ($symbol-unique-string x)])
(cond (cond
[(string? us) us] [(string? us) us]
[(eq? us #t) [(not us)
(error 'gensym->unique-string "~s is not a gensym" x)] (error 'gensym->unique-string "~s is not a gensym" x)]
[else [else
(let f ([x x]) (let f ([x x])
@ -1722,6 +1697,9 @@ reference-implementation:
[(foreign-call "ikrt_intern_gensym" x) id] [(foreign-call "ikrt_intern_gensym" x) id]
[else (f x)])))])))) [else (f x)])))]))))
(primitive-set! 'gensym-prefix (primitive-set! 'gensym-prefix
(make-parameter (make-parameter
"g" "g"
@ -1746,21 +1724,6 @@ reference-implementation:
(error 'print-gensym "~s is not in #t|#f|pretty" x)) (error 'print-gensym "~s is not in #t|#f|pretty" x))
x))) x)))
;; X (primitive-set! 'make-hash-table
;; X (lambda ()
;; X (make-hash-table)))
;; X
;; X (primitive-set! 'hash-table?
;; X (lambda (x)
;; X (hash-table? x)))
;; X
;; X (primitive-set! 'get-hash-table
;; X (lambda (h k v)
;; X (foreign-call "ik_get_hash_table" h k v)))
;; X
;; X (primitive-set! 'put-hash-table!
;; X (lambda (h k v)
;; X (foreign-call "ik_put_hash_table" h k v)))
(primitive-set! 'bwp-object? (primitive-set! 'bwp-object?
(lambda (x) (lambda (x)
@ -1804,6 +1767,55 @@ reference-implementation:
x x
(error 'command-list "invalid command-line-arguments ~s\n" x))))) (error 'command-list "invalid command-line-arguments ~s\n" x)))))
(let ()
(define f
(lambda (n i j)
(cond
[($fxzero? n)
(values (make-string i) j)]
[else
(let ([q ($fxquotient n 10)])
(call-with-values
(lambda () (f q ($fxadd1 i) j))
(lambda (str j)
(let ([r ($fx- n ($fx* q 10))])
(string-set! str j
($fixnum->char ($fx+ r ($char->fixnum #\0))))
(values str ($fxadd1 j))))))])))
(primitive-set! 'fixnum->string
(lambda (x)
(unless (fixnum? x) (error 'fixnum->string "~s is not a fixnum" x))
(cond
[($fxzero? x) "0"]
[($fx> x 0)
(call-with-values
(lambda () (f x 0 0))
(lambda (str j) str))]
[($fx= x -536870912) "-536870912"]
[else
(call-with-values
(lambda () (f ($fx- 0 x) 1 1))
(lambda (str j)
($string-set! str 0 #\-)
str))]))))
(primitive-set! 'symbol->string
(lambda (x)
(unless (symbol? x)
(error 'symbol->string "~s is not a symbol" x))
(let ([str ($symbol-string x)])
(or str
(let ([ct (gensym-count)])
(let ([str (string-append (gensym-prefix) (fixnum->string ct))])
($set-symbol-string! x str)
(gensym-count ($fxadd1 ct))
str))))))
(primitive-set! 'string->number (primitive-set! 'string->number
(lambda (x) (lambda (x)
(define (convert-data str len pos? idx ac) (define (convert-data str len pos? idx ac)
@ -1849,3 +1861,4 @@ reference-implementation:
(convert-sign x ($string-length x))] (convert-sign x ($string-length x))]
[else (error 'string->number "~s is not a string" x)]))) [else (error 'string->number "~s is not a string" x)])))
#!eof

View File

@ -374,6 +374,8 @@
(cond (cond
[(and (imm8? a0) (reg? a1)) [(and (imm8? a0) (reg? a1))
(CODE c (ModRM 1 /d a1 (IMM8 a0 ac)))] (CODE c (ModRM 1 /d a1 (IMM8 a0 ac)))]
[(and (imm8? a1) (reg? a0))
(CODE c (ModRM 1 /d a0 (IMM8 a1 ac)))]
[(and (reg? a0) (reg? a1)) [(and (reg? a0) (reg? a1))
(CODE c (ModRM 1 /d '/4 (SIB 0 a0 a1 (IMM8 0 ac))))] (CODE c (ModRM 1 /d '/4 (SIB 0 a0 a1 (IMM8 0 ac))))]
[else (error 'CODE/digit "unhandled ~s ~s" a0 a1)])))] [else (error 'CODE/digit "unhandled ~s ~s" a0 a1)])))]
@ -536,6 +538,8 @@
(CODE #x29 (ModRM 3 src dst ac))] (CODE #x29 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst)) [(and (mem? src) (reg? dst))
(CODErd #x2B dst src ac)] (CODErd #x2B dst src ac)]
[(and (reg? src) (mem? dst))
((CODE/digit #x29 src) dst ac)]
[else (error who "invalid ~s" instr)])] [else (error who "invalid ~s" instr)])]
[(sall src dst) [(sall src dst)
(cond (cond
@ -872,6 +876,7 @@
(lambda (thunk?-label code vec) (lambda (thunk?-label code vec)
(define reloc-idx 0) (define reloc-idx 0)
(lambda (r) (lambda (r)
;(printf "r=~s\n" r)
(let ([idx (car r)] [type (cadr r)] (let ([idx (car r)] [type (cadr r)]
[v [v
(let ([v (cddr r)]) (let ([v (cddr r)])