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

* The $apply macro and all the appcall forms were removed from the 

compiler after realizing that I was stupid.  
  ($appcall rator rand*)  was just (jmpcal SL_apply rator rand*)
This commit is contained in:
Abdulaziz Ghuloum 2007-02-14 15:50:34 -05:00
parent 8294a8dee9
commit 434ebe9525
13 changed files with 536 additions and 239 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
src/asm-tests.ss
View File

@ -10,6 +10,7 @@
`([0 (label ,(gensym)) . ,ls])))])
(let ([proc (#%$code->closure code)])
(let ([v (proc)])
(printf "running\n")
(unless (equal? v res)
(printf "failed!\n")
(error 'test-asm "expected ~s, got ~s" res v)))))
@ -65,6 +66,27 @@
[movl (disp -8 %esp) %eax]
[ret]))
(asm-test 1
'([movl 0 (disp -4 %esp)]
[movl %esp %eax]
[movl -4 %ebx]
[movb 4 (disp %eax %ebx)]
[movl (disp -4 %esp) %eax]
[ret]))
(asm-test 3
'([movl 4 (disp -4 %esp)]
[orl 8 (disp -4 %esp)]
[movl (disp -4 %esp) %eax]
[ret]))
(asm-test 3
'([movl -1 (disp -4 %esp)]
[andl 12 (disp -4 %esp)]
[movl (disp -4 %esp) %eax]
[ret]))
(printf "Happy Happy Joy Joy\n")

7
src/geninstr/Makefile
View File

@ -1,6 +1,7 @@
all:
./gen.pl > tmp.s
gcc -o tmp.o -c tmp.s
objdump -d tmp.o > tmp.dump
./gen.pl > tmp.s
gcc -o tmp.o -c tmp.s
otool -t tmp.o
otool -tv tmp.o

16
src/geninstr/gen.pl
View File

@ -33,6 +33,20 @@ sub gen2{
}
}
sub gen2_no_esp{
my $tmpl = shift;
foreach my $r1 (@regs){
foreach my $r2 (@regs_no_esp){
my $x = $tmpl;
$x =~ s/r1/$r1/g;
$x =~ s/r2/$r2/g;
print $x;
}
}
}
sub gen3{
my $tmpl = shift;
foreach my $r1 (@regs){
@ -51,7 +65,7 @@ sub gen3{
#gen1 "addl \$0x12345678, 7(r1)\n";
#gen2 "addl 0x23(r1), r2\n";
gen2 "addl r1, 0x23(r2)\n";
gen2_no_esp "movb \$24, 0(r1,r2)\n";
#gen1 "movb \$0, 4(r1)\n";
#gen1 "movb -2(r1), %ah\n";

120
src/geninstr/tmp.s
View File

@ -1,65 +1,57 @@
.text
addl %eax, 0x23(%eax)
addl %eax, 0x23(%ecx)
addl %eax, 0x23(%edx)
addl %eax, 0x23(%ebx)
addl %eax, 0x23(%esp)
addl %eax, 0x23(%ebp)
addl %eax, 0x23(%esi)
addl %eax, 0x23(%edi)
addl %ecx, 0x23(%eax)
addl %ecx, 0x23(%ecx)
addl %ecx, 0x23(%edx)
addl %ecx, 0x23(%ebx)
addl %ecx, 0x23(%esp)
addl %ecx, 0x23(%ebp)
addl %ecx, 0x23(%esi)
addl %ecx, 0x23(%edi)
addl %edx, 0x23(%eax)
addl %edx, 0x23(%ecx)
addl %edx, 0x23(%edx)
addl %edx, 0x23(%ebx)
addl %edx, 0x23(%esp)
addl %edx, 0x23(%ebp)
addl %edx, 0x23(%esi)
addl %edx, 0x23(%edi)
addl %ebx, 0x23(%eax)
addl %ebx, 0x23(%ecx)
addl %ebx, 0x23(%edx)
addl %ebx, 0x23(%ebx)
addl %ebx, 0x23(%esp)
addl %ebx, 0x23(%ebp)
addl %ebx, 0x23(%esi)
addl %ebx, 0x23(%edi)
addl %esp, 0x23(%eax)
addl %esp, 0x23(%ecx)
addl %esp, 0x23(%edx)
addl %esp, 0x23(%ebx)
addl %esp, 0x23(%esp)
addl %esp, 0x23(%ebp)
addl %esp, 0x23(%esi)
addl %esp, 0x23(%edi)
addl %ebp, 0x23(%eax)
addl %ebp, 0x23(%ecx)
addl %ebp, 0x23(%edx)
addl %ebp, 0x23(%ebx)
addl %ebp, 0x23(%esp)
addl %ebp, 0x23(%ebp)
addl %ebp, 0x23(%esi)
addl %ebp, 0x23(%edi)
addl %esi, 0x23(%eax)
addl %esi, 0x23(%ecx)
addl %esi, 0x23(%edx)
addl %esi, 0x23(%ebx)
addl %esi, 0x23(%esp)
addl %esi, 0x23(%ebp)
addl %esi, 0x23(%esi)
addl %esi, 0x23(%edi)
addl %edi, 0x23(%eax)
addl %edi, 0x23(%ecx)
addl %edi, 0x23(%edx)
addl %edi, 0x23(%ebx)
addl %edi, 0x23(%esp)
addl %edi, 0x23(%ebp)
addl %edi, 0x23(%esi)
addl %edi, 0x23(%edi)
movb $24, 0(%eax,%eax)
movb $24, 0(%eax,%ecx)
movb $24, 0(%eax,%edx)
movb $24, 0(%eax,%ebx)
movb $24, 0(%eax,%ebp)
movb $24, 0(%eax,%esi)
movb $24, 0(%eax,%edi)
movb $24, 0(%ecx,%eax)
movb $24, 0(%ecx,%ecx)
movb $24, 0(%ecx,%edx)
movb $24, 0(%ecx,%ebx)
movb $24, 0(%ecx,%ebp)
movb $24, 0(%ecx,%esi)
movb $24, 0(%ecx,%edi)
movb $24, 0(%edx,%eax)
movb $24, 0(%edx,%ecx)
movb $24, 0(%edx,%edx)
movb $24, 0(%edx,%ebx)
movb $24, 0(%edx,%ebp)
movb $24, 0(%edx,%esi)
movb $24, 0(%edx,%edi)
movb $24, 0(%ebx,%eax)
movb $24, 0(%ebx,%ecx)
movb $24, 0(%ebx,%edx)
movb $24, 0(%ebx,%ebx)
movb $24, 0(%ebx,%ebp)
movb $24, 0(%ebx,%esi)
movb $24, 0(%ebx,%edi)
movb $24, 0(%esp,%eax)
movb $24, 0(%esp,%ecx)
movb $24, 0(%esp,%edx)
movb $24, 0(%esp,%ebx)
movb $24, 0(%esp,%ebp)
movb $24, 0(%esp,%esi)
movb $24, 0(%esp,%edi)
movb $24, 0(%ebp,%eax)
movb $24, 0(%ebp,%ecx)
movb $24, 0(%ebp,%edx)
movb $24, 0(%ebp,%ebx)
movb $24, 0(%ebp,%ebp)
movb $24, 0(%ebp,%esi)
movb $24, 0(%ebp,%edi)
movb $24, 0(%esi,%eax)
movb $24, 0(%esi,%ecx)
movb $24, 0(%esi,%edx)
movb $24, 0(%esi,%ebx)
movb $24, 0(%esi,%ebp)
movb $24, 0(%esi,%esi)
movb $24, 0(%esi,%edi)
movb $24, 0(%edi,%eax)
movb $24, 0(%edi,%ecx)
movb $24, 0(%edi,%edx)
movb $24, 0(%edi,%ebx)
movb $24, 0(%edi,%ebp)
movb $24, 0(%edi,%esi)
movb $24, 0(%edi,%edi)

BIN
src/ikarus.boot
View File

Binary file not shown.

430
src/libaltcogen.ss
View File

@ -13,7 +13,6 @@
;;; | (forcall "name" <Expr>*)
;;; | (funcall <Expr> <Expr>*)
;;; | (jmpcall <label> <Expr> <Expr>*)
;;; | (appcall <Expr> <Expr>*)
;;; | (mvcall <Expr> <clambda>)
;;; <codeloc> ::= (code-loc <label>)
;;; <clambda> ::= (clambda <label> <case>* <free var>*)
@ -77,9 +76,6 @@
(check-gensym label)
(Expr rator)
(for-each Expr arg*)]
[(appcall rator arg*)
(Expr rator)
(for-each Expr arg*)]
[(mvcall rator k)
(Expr rator)
(Clambda k)]
@ -125,6 +121,7 @@
[null? p]
[eof-object? p]
[eof-object v]
[$unbound-object? p]
[procedure? p]
[symbol? p]
[boolean? p]
@ -140,15 +137,22 @@
[cons v]
[$car v]
[$cdr v]
[$set-car! e]
[$set-cdr! e]
[$fx+ v]
[$fx- v]
[$fx* v]
[$fxadd1 v]
[$fxsub1 v]
[$fxsll v]
[$fxsra v]
[$fxlogand v]
[$fxlogor v]
[$fxlogxor v]
[$fxlognot v]
[$fxmodulo v]
[$fxquotient v]
[$fxzero? p]
[$fx> p]
[$fx>= p]
@ -157,16 +161,34 @@
[$fx= p]
[$char<= p]
[$char= p]
[$char< p]
[$char<= p]
[$char> p]
[$char>= p]
[$char->fixnum v]
[$fixnum->char v]
[$make-vector v]
[$vector-length v]
[$vector-ref v]
[$vector-set! e]
[$set-symbol-value! e]
[$make-string v]
[$string-length v]
[$string-ref v]
[$string-set! e]
[$make-symbol v]
[$set-symbol-value! e]
[$symbol-string v]
[$symbol-unique-string v]
[$symbol-plist v]
[$set-symbol-plist! e]
[$set-symbol-string! e]
[top-level-value v]
[$symbol-value v]
[$record v]
[$record/rtd? p]
@ -203,7 +225,6 @@
list list*
not
car cdr
top-level-value
))
(define (must-open-code? x)
(and (assq x core-prims) #t))
@ -282,9 +303,6 @@
(mkfuncall (Expr rator) (map Expr arg*))]
[(jmpcall label rator arg*)
(make-jmpcall label (Expr rator) (map Expr arg*))]
[(appcall rator arg*)
(error 'new-cogen "appcall not supported yet")
(make-appcall (Expr rator) (map Expr arg*))]
[(mvcall rator k)
(make-mvcall (Expr rator) (Clambda k))]
[else (error who "invalid expr ~s" x)]))
@ -388,9 +406,6 @@
(make-funcall (Expr rator) (map Expr arg*))]
[(jmpcall label rator arg*)
(make-jmpcall label (Expr rator) (map Expr arg*))]
[(appcall rator arg*)
(error who "appcall not supported yet")
(make-appcall (Expr rator) (map Expr arg*))]
[(mvcall rator k)
(make-mvcall (Expr rator) (Clambda k))]
[else (error who "invalid expr ~s" x)]))
@ -645,7 +660,7 @@
(record-case rhs
[(closure code free*)
(make-seq
(prm 'mset! lhs
(prm 'mset lhs
(K (- disp-closure-code closure-tag))
(Value code))
(let f ([ls free*]
@ -654,7 +669,7 @@
[(null? ls) body]
[else
(make-seq
(prm 'mset! lhs (K i) (Value (car ls)))
(prm 'mset lhs (K i) (Value (car ls)))
(f (cdr ls) (+ i wordsize)))])))]))
(cond
[(null? lhs*) body]
@ -697,17 +712,19 @@
(make-bind (list lhs* ...) ls
b b* ...)))])))
(define (Effect x)
(define (dirty-vector-set address)
(prm 'mset
(prm 'int+
(prm 'mref pcr (K 28)) ;;; FIXME: make srl
(prm 'sll (prm 'sra address (K pageshift)) (K wordshift)))
(K 0)
(K dirty-word)))
(define (mem-assign v x i)
(tbind ([q v])
(tbind ([t (prm 'int+ x (K i))])
(make-seq
(prm 'mset! t (K 0) q)
(prm 'mset!
(prm 'int+
(prm 'mref pcr (K 28))
(prm 'sll (prm 'sra t (K pageshift)) (K wordshift)))
(K 0)
(K dirty-word))))))
(prm 'mset t (K 0) q)
(dirty-vector-set t)))))
(record-case x
[(bind lhs* rhs* body)
(make-bind lhs* (map Value rhs*) (Effect body))]
@ -727,7 +744,7 @@
(record-case i
[(constant i)
(unless (fixnum? i) (err x))
(prm 'mset! x
(prm 'mset x
(K (+ (* i wordsize)
(- disp-closure-data closure-tag)))
v)]
@ -740,6 +757,14 @@
(let ([x (Value (car arg*))] [v (Value (cadr arg*))])
(mem-assign v x
(- disp-symbol-value symbol-tag)))]
[($set-symbol-string!)
(let ([x (Value (car arg*))] [v (Value (cadr arg*))])
(mem-assign v x
(- disp-symbol-string symbol-tag)))]
[($set-symbol-plist!)
(let ([x (Value (car arg*))] [v (Value (cadr arg*))])
(mem-assign v x
(- disp-symbol-plist symbol-tag)))]
[($vector-set! $record-set!)
(let ([x (Value (car arg*))]
[i (cadr arg*)]
@ -754,6 +779,54 @@
(mem-assign v
(prm 'int+ x (Value i))
(- disp-vector-data vector-tag))]))]
[($set-car! $set-cdr!)
(let ([off (if (eq? op '$set-car!)
(- disp-car pair-tag)
(- disp-cdr pair-tag))])
(tbind ([x (Value (car arg*))])
(seq* ;;; car/cdr addresses are in the same
;;; card as the pair address, so no
;;; adjustment is necessary as was the
;;; case with vectors and records.
(prm 'mset x (K off) (Value (cadr arg*)))
(dirty-vector-set x))))]
[($string-set!)
(let ([x (Value (car arg*))]
[i (cadr arg*)]
[c (caddr arg*)])
(record-case i
[(constant i)
(unless (fixnum? i) (err x))
(record-case c
[(constant c)
(unless (char? i) (err x))
(prm 'bset/c x
(K (+ i (- disp-string-data string-tag)))
(K (char->integer c)))]
[else
(unless (= char-shift 8)
(error who "assumption about char-shift"))
(tbind ([c (Value c)])
(prm 'bset/h x
(K (+ i (- disp-string-data string-tag)))
c))])]
[else
(tbind ([i (Value i)])
(record-case c
[(constant c)
(unless (char? i) (err x))
(prm 'bset/c x
(prm 'sra i (K fixnum-shift))
(K (char->integer c)))]
[else
(unless (= char-shift 8)
(error who "assumption about char-shift"))
(tbind ([c (Value c)])
(prm 'bset/h x
(prm 'int+
(prm 'sra i (K fixnum-shift))
(K (- disp-string-data string-tag)))
c))]))]))]
[else (error who "invalid effect prim ~s" op)])]
[(forcall op arg*)
(make-forcall op (map Value arg*))]
@ -761,8 +834,6 @@
(make-funcall (Value rator) (map Value arg*))]
[(jmpcall label rator arg*)
(make-jmpcall label (Value rator) (map Value arg*))]
[(appcall rator arg*)
(error who "appcall not supported yet")]
[(mvcall rator x)
(make-mvcall (Value rator) (Clambda x Effect))]
[else (error who "invalid effect expr ~s" x)]))
@ -801,6 +872,7 @@
[(eof-object?) (prm '= (Value (car arg*)) (K eof))]
[(neq?) (make-primcall '!= (map Value arg*))]
[($fxzero?) (prm '= (Value (car arg*)) (K 0))]
[($unbound-object?) (prm '= (Value (car arg*)) (K unbound))]
[(pair?)
(tag-test (Value (car arg*)) pair-mask pair-tag)]
[(procedure?)
@ -881,6 +953,8 @@
[(constant) (constant-rep x)]
[(var) x]
[(primref name)
(unless (procedure? (primitive-ref name))
(warning who "~s may not be a primitive" name))
(prm 'mref
(K (make-object name))
(K (- disp-symbol-system-value symbol-tag)))]
@ -905,6 +979,43 @@
[(primitive-ref)
(prm 'mref (Value (car arg*))
(K (- disp-symbol-system-value symbol-tag)))]
[($symbol-string)
(prm 'mref (Value (car arg*))
(K (- disp-symbol-string symbol-tag)))]
[($symbol-plist)
(prm 'mref (Value (car arg*))
(K (- disp-symbol-plist symbol-tag)))]
[($symbol-value)
(prm 'mref (Value (car arg*))
(K (- disp-symbol-value symbol-tag)))]
[($symbol-unique-string)
(prm 'mref (Value (car arg*))
(K (- disp-symbol-unique-string symbol-tag)))]
[($make-symbol)
(tbind ([str (Value (car arg*))])
(tbind ([x (prm 'alloc
(K (align symbol-size))
(K symbol-tag))])
(seq*
(prm 'mset x
(K (- disp-symbol-string symbol-tag))
str)
(prm 'mset x
(K (- disp-symbol-unique-string symbol-tag))
(K 0))
(prm 'mset x
(K (- disp-symbol-value symbol-tag))
(K unbound))
(prm 'mset x
(K (- disp-symbol-plist symbol-tag))
(K nil))
(prm 'mset x
(K (- disp-symbol-system-value symbol-tag))
(K unbound))
(prm 'mset x
(K (- disp-symbol-system-plist symbol-tag))
(K nil))
x)))]
[($make-cp)
(let ([label (car arg*)] [len (cadr arg*)])
(record-case len
@ -915,7 +1026,7 @@
(* i wordsize))))
(K closure-tag))])
(seq*
(prm 'mset! t
(prm 'mset t
(K (- disp-closure-code closure-tag))
(Value label))
t))]
@ -931,7 +1042,7 @@
(* (length v*) wordsize))))
(K vector-tag))])
(seq*
(prm 'mset! t
(prm 'mset t
(K (- disp-record-rtd vector-tag))
rtd)
(let f ([t* t*]
@ -940,8 +1051,11 @@
[(null? t*) t]
[else
(make-seq
(prm 'mset! t (K i) (car t*))
(prm 'mset t (K i) (car t*))
(f (cdr t*) (+ i wordsize)))]))))))))]
[($vector-length)
(prm 'mref (Value (car arg*))
(K (- disp-vector-length vector-tag)))]
[($make-vector)
(unless (= (length arg*) 1)
(error who "incorrect args to $make-vector"))
@ -954,7 +1068,7 @@
disp-vector-data)))
(K vector-tag))])
(seq*
(prm 'mset! v
(prm 'mset v
(K (- disp-vector-length vector-tag))
(K (make-constant (* i fixnum-scale))))
v))]
@ -963,10 +1077,73 @@
(tbind ([alen (align-code len disp-vector-data)])
(tbind ([v (prm 'alloc alen (K vector-tag))])
(seq*
(prm 'mset! v
(prm 'mset v
(K (- disp-vector-length vector-tag))
len)
v))))]))]
[($string-length)
(prm 'mref (Value (car arg*))
(K (- disp-string-length string-tag)))]
[($string-ref)
(let ([s (car arg*)] [i (cadr arg*)])
(record-case i
[(constant i)
(unless (fixnum? i) (err x))
(prm 'logor
(prm 'sll
(prm 'logand
(prm 'mref (Value s)
(K (+ i (- disp-string-data string-tag))))
(K 255))
(K char-shift))
(K char-tag))]
[else
(prm 'logor
(prm 'sll
(prm 'logand
(prm 'mref (Value s)
(prm 'int+
(prm 'sra
(Value i)
(K fixnum-shift))
(K (- disp-string-data string-tag))))
(K 255))
(K char-shift))
(K char-tag))]))]
[($make-string)
(unless (= (length arg*) 1) (err x))
(let ([n (car arg*)])
(record-case n
[(constant n)
(unless (fixnum? n) (err x))
(tbind ([s (prm 'alloc
(K (align (+ n 1 disp-string-data)))
(K string-tag))])
(seq*
(prm 'mset s
(K (- disp-string-length string-tag))
(K (* n fixnum-scale)))
(prm 'bset/c s
(K (+ n (- disp-string-data string-tag)))
(K 0))
s))]
[else
(tbind ([n (Value n)])
(tbind ([s (prm 'alloc
(align-code
(prm 'sra n (K fixnum-shift))
(+ disp-string-data 1))
(K string-tag))])
(seq*
(prm 'mset s
(K (- disp-string-length string-tag))
n)
(prm 'bset/c s
(prm 'int+
(prm 'sra n (K fixnum-shift))
(K (- disp-string-data string-tag)))
(K 0))
s)))]))]
[($make-record)
(let ([rtd (car arg*)] [len (cadr arg*)])
(tbind ([rtd (Value rtd)])
@ -979,7 +1156,7 @@
disp-record-data)))
(K vector-tag))])
(seq*
(prm 'mset! t
(prm 'mset t
(K (- disp-record-rtd vector-tag))
rtd)
t))]
@ -988,7 +1165,7 @@
(tbind ([ln (align-code len disp-record-data)])
(tbind ([t (prm 'alloc ln (K vector-tag))])
(seq*
(prm 'mset! t
(prm 'mset t
(K (- disp-record-rtd vector-tag))
rtd)
t))))])))]
@ -1000,8 +1177,8 @@
[d (Value (cadr arg*))])
(tbind ([t (prm 'alloc (K pair-size) (K pair-tag))])
(seq*
(prm 'mset! t (K (- disp-car pair-tag)) a)
(prm 'mset! t (K (- disp-cdr pair-tag)) d)
(prm 'mset t (K (- disp-car pair-tag)) a)
(prm 'mset t (K (- disp-cdr pair-tag)) d)
t)))]
[($fxadd1)
(prm 'int+ (Value (car arg*)) (K (* 1 fixnum-scale)))]
@ -1009,6 +1186,27 @@
(prm 'int+ (Value (car arg*)) (K (* -1 fixnum-scale)))]
[($fx+)
(prm 'int+ (Value (car arg*)) (Value (cadr arg*)))]
[($fx-)
(prm 'int- (Value (car arg*)) (Value (cadr arg*)))]
[($fx*)
(let ([a (car arg*)] [b (cadr arg*)])
(record-case a
[(constant a)
(unless (fixnum? a) (err x))
(prm 'int* (Value b) (K a))]
[else
(record-case b
[(constant b)
(unless (fixnum? b) (err x))
(prm 'int* (Value a) (K b))]
[else
(prm 'int*
(Value a)
(prm 'sra (Value b) (K fixnum-shift)))])]))]
[($fxquotient)
(prm 'sll
(prm 'remainder (Value (car arg*)) (Value (cadr arg*)))
(K fixnum-shift))]
[($fxmodulo)
(tbind ([a (Value (car arg*))]
[b (Value (cadr arg*))])
@ -1016,7 +1214,7 @@
(prm 'sra
(prm 'logxor b a)
(K (sub1 (* 8 wordsize)))))])
(prm 'int+ c (prm 'div a b))))]
(prm 'int+ c (prm 'quotient a b))))]
[($fxsll)
(let ([a (car arg*)] [c (cadr arg*)])
(record-case c
@ -1024,7 +1222,9 @@
(if (fixnum? i)
(prm 'sll (Value a) (K i))
(error who "invalid arg to fxsll ~s" i))]
[else (error who "nonconst arg to fxsll ~s" c)]))]
[else
(prm 'sll (Value a)
(prm 'sra (Value c) (K fixnum-shift)))]))]
[($fxsra)
(let ([a (car arg*)] [c (cadr arg*)])
(record-case c
@ -1032,11 +1232,17 @@
(if (fixnum? i)
(prm 'sra (Value a) (K i))
(error who "invalid arg to fxsra ~s" i))]
[else (error who "nonconst arg to fxsra ~s" c)]))]
[else
(prm 'logand
(prm 'sra (Value a)
(prm 'sra (Value c) (K fixnum-shift)))
(K (* -1 fixnum-scale)))]))]
[($fxlogand)
(prm 'logand (Value (car arg*)) (Value (cadr arg*)))]
[($fxlogxor)
(prm 'logxor (Value (car arg*)) (Value (cadr arg*)))]
[($fxlogor)
(prm 'logor (Value (car arg*)) (Value (cadr arg*)))]
[($fxlognot)
(Value (prm '$fxlogxor (car arg*) (K -1)))]
[($char->fixnum)
@ -1061,20 +1267,20 @@
(tbind ([underflow-handler
(prm 'mref base (K 0))])
(seq*
(prm 'mset! k
(prm 'mset k
(K (- vector-tag))
(K continuation-tag))
(prm 'mset! k
(prm 'mset k
(K (- disp-continuation-top vector-tag))
fpr)
(prm 'mset! k
(prm 'mset k
(K (- disp-continuation-next vector-tag))
(prm 'mref pcr (K 20))) ;;; PCB NEXT CONT
(prm 'mset! k
(prm 'mset k
(K (- disp-continuation-size vector-tag))
(prm 'int- base fpr))
(prm 'mset! pcr (K 20) k)
(prm 'mset! pcr (K 12) fpr)
(prm 'mset pcr (K 20) k)
(prm 'mset pcr (K 12) fpr)
(make-primcall '$call-with-underflow-handler
(list underflow-handler proc k)))))))]
[($frame->continuation)
@ -1083,10 +1289,10 @@
(K (align (+ disp-closure-data wordsize)))
(K closure-tag))])
(seq*
(prm 'mset! t
(prm 'mset t
(K (- disp-closure-code closure-tag))
(K (make-code-loc SL_continuation_code)))
(prm 'mset! t
(prm 'mset t
(K (- disp-closure-data closure-tag))
arg)
t)))]
@ -1128,6 +1334,38 @@
(prm 'mref
(Value (car arg*))
(K (- disp-code-freevars vector-tag)))]
[(top-level-value)
(let ([sym
(record-case (car arg*)
[(constant c)
(if (symbol? c) c #f)]
[else #f])])
(cond
[sym
(Value
(tbind ([v (prm '$symbol-value (car arg*))])
(make-conditional
(make-primcall '$unbound-object? (list v))
(make-funcall
(make-primref 'top-level-value-error)
(list (car arg*)))
v)))]
[else
(Value
(tbind ([sym (car arg*)])
(make-conditional
(make-primcall 'symbol? (list sym))
(tbind ([v (make-primcall
'$symbol-value (list sym))])
(make-conditional
(make-primcall '$unbound-object? (list v))
(make-funcall
(make-primref 'top-level-value-error)
(list sym))
v))
(make-funcall
(make-primref 'top-level-value-error)
(list sym)))))]))]
[else (error who "value prim ~a not supported" (unparse x))])]
[(forcall op arg*)
(make-forcall op (map Value arg*))]
@ -1135,8 +1373,6 @@
(make-funcall (Value rator) (map Value arg*))]
[(jmpcall label rator arg*)
(make-jmpcall label (Value rator) (map Value arg*))]
[(appcall rator arg*)
(error who "appcall not supported yet")]
[(mvcall rator x)
(make-mvcall (Value rator) (Clambda x Value))]
[else (error who "invalid value expr ~s" x)]))
@ -1176,6 +1412,8 @@
(define all-registers '(%eax %edi %ebx %edx))
(define argc-register '%eax)
(define non-8bit-registers '(%edi))
(define (impose-calling-convention/evaluation-order x)
(define who 'impose-calling-convention/evaluation-order)
;;;
@ -1299,13 +1537,21 @@
(S* rands
(lambda (rands)
(make-set d (make-disp (car rands) (cadr rands)))))]
[(logand logxor logor int+ int-)
[(logand logxor logor int+ int- int*)
(make-seq
(V d (car rands))
(S (cadr rands)
(lambda (s)
(make-asm-instr op d s))))]
[(div)
[(remainder)
(S* rands
(lambda (rands)
(seq*
(make-set eax (car rands))
(make-asm-instr 'cltd edx eax)
(make-asm-instr 'idiv eax (cadr rands))
(make-set d eax))))]
[(quotient)
(S* rands
(lambda (rands)
(seq*
@ -1320,7 +1566,13 @@
(make-seq
(V d a)
(make-asm-instr op d b))]
[else (error who "invalid shift ~s" x)]))]
[else
(S b
(lambda (b)
(seq*
(V d a)
(make-set ecx b)
(make-asm-instr op d ecx))))]))]
[else (error who "invalid value op ~s" op)])]
[(funcall rator rands)
(handle-nontail-call rator rands d #f)]
@ -1357,10 +1609,10 @@
(do-bind lhs* rhs* (E e))]
[(primcall op rands)
(case op
[(mset!)
[(mset bset/c bset/h)
(S* rands
(lambda (s*)
(make-asm-instr 'mset
(make-asm-instr op
(make-disp (car s*) (cadr s*))
(caddr s*))))]
[(nop) x]
@ -1624,7 +1876,7 @@
(union (R v) s)]))]
[(asm-instr op d v)
(case op
[(logand logxor int+ int- logor sll sra)
[(logand logxor int+ int- int* logor sll sra)
(let ([s (set-rem d s)])
(record-case d
[(nfvar c i)
@ -1636,6 +1888,14 @@
[else
(for-each (lambda (y) (add-edge! g d y)) s)
(union (union (R v) (R d)) s)]))]
[(bset/c)
(union (union (R v) (R d)) s)]
[(bset/h)
(when (register? eax)
(when (var? v)
(for-each (lambda (r) (add-edge! g v r))
non-8bit-registers)))
(union (union (R v) (R d)) s)]
[(cltd)
(let ([s (set-rem edx s)])
(when (register? edx)
@ -1988,7 +2248,7 @@
(make-conditional (P e0) (E e1) (E e2))]
[(asm-instr op a b)
(case op
[(logor logxor logand int+ int-)
[(logor logxor logand int+ int- int*)
(cond
[(and (mem? a) (mem? b))
(let ([u (mku)])
@ -1996,10 +2256,23 @@
(E (make-set u b))
(E (make-asm-instr op a u))))]
[else x])]
[(sll sra)
(unless (constant? b) (error who "invalid shift ~s" b))
[(cltd)
(unless (and (symbol? a) (symbol? b))
(error who "invalid args to cltd"))
x]
[(mset)
[(idiv)
(unless (symbol? a)
(error who "invalid arg to idiv"))
(cond
[(disp? b)
(error who "invalid arg to idiv ~s" b)]
[else x])]
[(sll sra)
(unless (or (constant? b)
(eq? b ecx))
(error who "invalid shift ~s" b))
x]
[(mset bset/c bset/h)
(cond
[(mem? b)
(let ([u (mku)])
@ -2015,19 +2288,19 @@
(make-seq
(E (make-set u s1))
(E (make-asm-instr 'int+ u s2)))
(make-asm-instr 'mset
(make-asm-instr op
(make-disp u (make-constant 0))
b)))]
[(mem? s1)
(let ([u (mku)])
(make-seq
(E (make-set u s1))
(make-asm-instr 'mset (make-disp u s2) b)))]
(make-asm-instr op (make-disp u s2) b)))]
[(mem? s2)
(let ([u (mku)])
(make-seq
(E (make-set u s2))
(make-asm-instr 'mset (make-disp u s1) b)))]
(make-asm-instr op (make-disp u s1) b)))]
[else x]))])]
[else (error who "invalid effect ~s" op)])]
[(primcall op rands)
@ -2144,6 +2417,13 @@
(if (integer? x)
x
(error who "invalid constant C ~s" x))]))
(define (BYTE x)
(record-case x
[(constant x)
(unless (and (integer? x) (fx<= x 255) (fx<= 0 x))
(error who "invalid byte ~s" x))
x]
[else (error who "invalid byte ~s" x)]))
(define (D x)
(record-case x
[(constant c) (C c)]
@ -2158,6 +2438,21 @@
`(disp ,s0 ,s1))]
[else
(if (symbol? x) x (error who "invalid R ~s" x))]))
(define (reg/h x)
(cond
[(assq x '([%eax %ah] [%ebx %bh] [%ecx %ch] [%edx %dh]))
=> cadr]
[else (error who "invalid reg/h ~s" x)]))
(define (R/cl x)
(record-case x
[(constant i)
(unless (fixnum? i)
(error who "invalid R/cl ~s" x))
(fxlogand i 31)]
[else
(if (eq? x ecx)
'%cl
(error who "invalid R/cl ~s" x))]))
;;; flatten effect
(define (E x ac)
(record-case x
@ -2220,12 +2515,15 @@
(case op
[(logand) (cons `(andl ,(R s) ,(R d)) ac)]
[(int+) (cons `(addl ,(R s) ,(R d)) ac)]
[(int*) (cons `(imull ,(R s) ,(R d)) ac)]
[(int-) (cons `(subl ,(R s) ,(R d)) ac)]
[(logor) (cons `(orl ,(R s) ,(R d)) ac)]
[(logxor) (cons `(xorl ,(R s) ,(R d)) ac)]
[(mset) (cons `(movl ,(R s) ,(R d)) ac)]
[(sll) (cons `(sall ,(R s) ,(R d)) ac)]
[(sra) (cons `(sarl ,(R s) ,(R d)) ac)]
[(bset/c) (cons `(movb ,(BYTE s) ,(R d)) ac)]
[(bset/h) (cons `(movb ,(reg/h s) ,(R d)) ac)]
[(sll) (cons `(sall ,(R/cl s) ,(R d)) ac)]
[(sra) (cons `(sarl ,(R/cl s) ,(R d)) ac)]
[(idiv) (cons `(idivl ,(R s)) ac)]
[(cltd) (cons `(cltd) ac)]
[else (error who "invalid instr ~s" x)])]
@ -2341,7 +2639,7 @@
(define LOOP_HEAD (unique-label))
(define L_CALL (unique-label))
(list* (cmpl (int (argc-convention (fxsub1 fml-count))) eax)
(jg (label SL_invalid_args))
;(jg (label SL_invalid_args))
(jl CONS_LABEL)
(movl (int nil) ebx)
(jmp DONE_LABEL)
@ -2411,9 +2709,9 @@
(cond
[proper `(jne ,lothers)]
[(> (argc-convention 0) (argc-convention 1))
`(jle ,lothers)]
`(jg ,lothers)]
[else
`(jge ,lothers)])
`(jl ,lothers)])
(properize args proper
(cons (label L)
(T body (cons lothers ac))))))])]))
@ -2464,7 +2762,7 @@
[foo (printf "6")]
;[foo (print-code x)]
[ls (flatten-codes x)])
(when #t
(when #f
(parameterize ([gensym-prefix "L"]
[print-gensym #f])
(for-each

74
src/libcompile.ss
View File

@ -246,7 +246,6 @@
(define-record closure (code free*))
(define-record funcall (op rand*))
(define-record jmpcall (label op rand*))
(define-record appcall (op rand*))
(define-record forcall (op rand*))
(define-record codes (list body))
(define-record assign (lhs rhs))
@ -382,11 +381,6 @@
[(set-top-level-value!)
(make-funcall (make-primref 'set-top-level-value!)
(map E (cdr x)))]
[($apply)
(let ([proc (cadr x)] [arg* (cddr x)])
(make-appcall
(E proc)
(map E arg*)))]
[(void)
(make-constant (void))]
[else
@ -446,7 +440,6 @@
[(funcall rator rand*) `(funcall ,(E rator) . ,(map E rand*))]
[(jmpcall label rator rand*)
`(jmpcall ,label ,(E rator) . ,(map E rand*))]
[(appcall rator rand*) `(appcall ,(E rator) . ,(map E rand*))]
[(forcall rator rand*) `(foreign-call ,rator . ,(map E rand*))]
[(assign lhs rhs) `(set! ,(E lhs) ,(E rhs))]
[(return x) `(return ,(E x))]
@ -595,8 +588,6 @@
(make-primcall rator (map Expr rand*))]
[(funcall rator rand*)
(inline (Expr rator) (map Expr rand*))]
[(appcall rator rand*)
(make-appcall (Expr rator) (map Expr rand*))]
[(forcall rator rand*)
(make-forcall rator (map Expr rand*))]
[(assign lhs rhs)
@ -678,8 +669,6 @@
[else #f])
(fx= (length rand*) 2))
(analyze (car rand*) (cadr rand*)))]
[(appcall rator rand*)
(E rator) (for-each E rand*)]
[(forcall rator rand*)
(for-each E rand*)]
[(assign lhs rhs)
@ -808,15 +797,6 @@
(let ([p (E p ref comp)] [c (E c ref comp)])
(comp)
(make-mvcall p c))]
[(appcall rator rand*)
(let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)])
(record-case rator
[(primref op)
(when (memq op '(call/cc call/cf))
(comp))]
[else
(comp)])
(make-appcall rator rand*))]
[(forcall rator rand*)
(make-forcall rator (E* rand* ref comp))]
[else (error who "invalid expression ~s" (unparse x))]))
@ -868,8 +848,6 @@
(make-primcall rator (map Expr rand*))]
[(funcall rator rand*)
(make-funcall (Expr rator) (map Expr rand*))]
[(appcall rator rand*)
(make-appcall (Expr rator) (map Expr rand*))]
[(forcall rator rand*)
(make-forcall rator (map Expr rand*))]
[(assign lhs rhs)
@ -912,8 +890,6 @@
[(primcall rator rand*) (Expr* rand*)]
[(funcall rator rand*)
(begin (Expr rator) (Expr* rand*))]
[(appcall rator rand*)
(begin (Expr rator) (Expr* rand*))]
[(mvcall p c) (begin (Expr p) (Expr c))]
[(forcall rator rand*) (Expr* rand*)]
[(assign lhs rhs)
@ -1430,8 +1406,6 @@
[else
(make-funcall rator (map Value rand*))]))]
[else (make-funcall rator (map Value rand*))]))]
[(appcall rator rand*)
(make-appcall (Value rator) (map Value rand*))]
[(forcall rator rand*)
(make-forcall rator (map Value rand*))]
[(mvcall p c)
@ -1490,8 +1464,6 @@
[else
(make-funcall rator (map Value rand*))]))]
[else (make-funcall rator (map Value rand*))]))]
[(appcall rator rand*)
(make-appcall (Value rator) (map Value rand*))]
[(forcall rator rand*)
(make-forcall rator (map Value rand*))]
[(assign lhs rhs)
@ -1544,8 +1516,6 @@
[else
(make-funcall rator (map Value rand*))]))]
[else (make-funcall rator (map Value rand*))]))]
[(appcall rator rand*)
(make-appcall (Value rator) (map Value rand*))]
[(forcall rator rand*)
(make-forcall rator (map Value rand*))]
[(assign lhs rhs)
@ -1617,8 +1587,6 @@
(make-forcall op (map Expr rand*))]
[(funcall rator rand*)
(make-funcall (Expr rator) (map Expr rand*))]
[(appcall rator rand*)
(make-appcall (Expr rator) (map Expr rand*))]
[(assign lhs rhs)
(unless (var-assigned lhs)
(error 'rewrite-assignments "not assigned ~s in ~s" lhs x))
@ -1704,10 +1672,13 @@
[(and (var? rator) (bound-var rator)) =>
(lambda (c)
(optimize c rator (map Expr rand*)))]
[(and (primref? rator)
(eq? (primref-name rator) '$$apply))
(make-jmpcall SL_apply
(Expr (car rand*))
(map Expr (cdr rand*)))]
[else
(make-funcall rator (map Expr rand*))]))]
[(appcall rator rand*)
(make-appcall (Expr rator) (map Expr rand*))]
[(mvcall p c) (make-mvcall (Expr p) (Expr c))]
[else (error who "invalid expression ~s" (unparse x))]))
(Expr x))
@ -1790,11 +1761,6 @@
[(rand* rand*-free) (Expr* rand*)])
(values (make-jmpcall label rator rand*)
(union rat-free rand*-free)))]
[(appcall rator rand*)
(let-values ([(rator rat-free) (Expr rator)]
[(rand* rand*-free) (Expr* rand*)])
(values (make-appcall rator rand*)
(union rat-free rand*-free)))]
[(mvcall p c)
(let-values ([(p p-free) (Expr p)]
[(c c-free) (Expr c)])
@ -1941,7 +1907,6 @@
[(forcall op rand*) (make-forcall op (map E rand*))]
[(funcall rator rand*) (make-funcall (E rator) (map E rand*))]
[(jmpcall label rator rand*) (make-jmpcall label (E rator) (map E rand*))]
[(appcall rator rand*) (make-appcall (E rator) (map E rand*))]
[(mvcall p c)
(record-case c
[(clambda label cases free)
@ -1996,7 +1961,6 @@
[(primcall op rand*) (make-primcall op (map E rand*))]
[(forcall op rand*) (make-forcall op (map E rand*))]
[(funcall rator rand*) (make-funcall (E rator) (map E rand*))]
[(appcall rator rand*) (make-appcall (E rator) (map E rand*))]
[else (error who "invalid expression ~s" (unparse x))]))
(let ([x (E x)])
(make-codes all-codes x)))
@ -2159,8 +2123,6 @@
(make-funcall (Expr rator) (map Expr rand*))])]
[(jmpcall label op arg*)
(make-jmpcall label (Expr op) (map Expr arg*))]
[(appcall op arg*)
(make-appcall (Expr op) (map Expr arg*))]
[(mvcall p c)
(record-case c
[(clambda label cases free)
@ -2206,8 +2168,6 @@
(make-funcall (Expr rator) (map Expr rand*))])]
[(jmpcall label op arg*)
(make-jmpcall label (Expr op) (map Expr arg*))]
[(appcall op arg*)
(make-appcall (Expr op) (map Expr arg*))]
[(mvcall p c)
(record-case c
[(clambda label cases free)
@ -2300,8 +2260,6 @@
(make-forcall op (map Expr arg*))]
[(funcall rator rand*)
(make-funcall (Expr rator) (map Expr rand*))]
[(appcall op arg*)
(make-appcall (Expr op) (map Expr arg*))]
[(jmpcall label op arg*)
(make-jmpcall label (Expr op) (map Expr arg*))]
[(mvcall p c)
@ -2319,8 +2277,6 @@
[(seq e0 e1) (make-seq (Expr e0) (Tail e1))]
[(funcall rator rand*)
(make-funcall (Expr rator) (map Expr rand*))]
[(appcall op arg*)
(make-appcall (Expr op) (map Expr arg*))]
[(jmpcall label op arg*)
(make-jmpcall label (Expr op) (map Expr arg*))]
[(mvcall p c)
@ -2363,7 +2319,6 @@
[(primcall op arg*) (ormap Expr arg*)]
[(forcall op arg*) (ormap Expr arg*)]
[(funcall rator arg*) #t]
[(appcall rator arg*) #t]
[(jmpcall label rator arg*) #t]
[(mvcall p c) #t]
[else (error who "invalid expression ~s" (unparse x))]))
@ -2377,7 +2332,6 @@
(or (Expr test) (Tail conseq) (Tail altern))]
[(seq e0 e1) (or (Expr e0) (Tail e1))]
[(funcall rator arg*) (or (Expr rator) (ormap Expr arg*))]
[(appcall rator arg*) (or (Expr rator) (ormap Expr arg*))]
[(jmpcall label rator arg*) (or (Expr rator) (ormap Expr arg*))]
[(mvcall p c) #t]
[else (error who "invalid tail expression ~s" (unparse x))]))
@ -2504,8 +2458,6 @@
(make-forcall op (map Expr arg*))]
[(funcall rator rand*)
(make-funcall (Expr rator) (map Expr rand*))]
[(appcall op arg*)
(make-appcall (Expr op) (map Expr arg*))]
[(jmpcall label op arg*)
(make-jmpcall label (Expr op) (map Expr arg*))]
[(interrupt-call e0 e1)
@ -2531,8 +2483,6 @@
(make-funcall (Expr rator) (map Expr rand*))]
[(jmpcall label op arg*)
(make-jmpcall label (Expr op) (map Expr arg*))]
[(appcall op arg*)
(make-appcall (Expr op) (map Expr arg*))]
[(mvcall p c)
(make-mvcall (Expr p) (CodeExpr c))]
[else (error who "invalid tail expression ~s" (unparse x))]))
@ -2751,8 +2701,6 @@
(map (lambda (x) (Expr x si r live)) arg*)))]
[(funcall op rand*)
(do-tail-frame #f op rand* si r 'normal live)]
[(appcall op rand*)
(do-tail-frame #f op rand* si r 'apply live)]
[(jmpcall label op rand*)
(do-tail-frame label op rand* si r 'direct live)]
[(mvcall p c)
@ -2813,8 +2761,6 @@
(do-mvcall p c x si r live Effect)]
[(jmpcall label op rand*)
(do-new-frame label op rand* si r 'direct 'effect live)]
[(appcall op rand*)
(do-new-frame #f op rand* si r 'apply 'effect live)]
[(interrupt-call e0 e1)
(make-interrupt-call
(Expr e0 si r live)
@ -2849,8 +2795,6 @@
(do-new-frame #f op rand* si r 'normal 'value live)]
[(jmpcall label op rand*)
(do-new-frame label op rand* si r 'direct 'value live)]
[(appcall op rand*)
(do-new-frame #f op rand* si r 'apply 'value live)]
[(mvcall p c)
(do-mvcall p c x si r live Expr)]
[else (error who "invalid expression ~s" (unparse x))]))
@ -4321,7 +4265,8 @@
[($unset-interrupted!)
(list* (movl (int 0) (pcb-ref 'interrupted))
ac)]
[(cons pair? void $fxadd1 $fxsub1 $record-ref $fx=)
[(cons pair? void $fxadd1 $fxsub1 $record-ref $fx=
symbol?)
(let f ([arg* arg*])
(cond
[(null? arg*) ac]
@ -4666,7 +4611,10 @@
(jmp (label SL_apply))
ac)]
[(direct)
(list* (jmp (label direct-label)) ac)]
(list*
(movl (int (argc-convention argc)) eax)
(jmp (label direct-label))
ac)]
[else
(error who "invalid tail-call convention ~s"
call-convention)])]

18
src/libcore.ss
View File

@ -889,6 +889,15 @@ reference-implementation:
(race d d x 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
(letrec ([race
(lambda (h t ls x)
@ -1023,6 +1032,7 @@ reference-implementation:
(error 'list-ref "~s is not a valid index" index))
(f list index)))
(primitive-set! 'apply
(let ()
(define (err f ls)
@ -1035,22 +1045,22 @@ reference-implementation:
(let ([last ($car d)])
($set-cdr! p last)
(if (and (procedure? f) (list? last))
($apply f a0 a1 ls)
($$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)
($$apply f ls)
(err f ls))]
[(f a0 ls)
(if (and (procedure? f) (list? ls))
($apply f a0 ls)
($$apply f a0 ls)
(err f ls))]
[(f a0 a1 ls)
(if (and (procedure? f) (list? ls))
($apply f a0 a1 ls)
($$apply f a0 a1 ls)
(err f ls))]
[(f a0 a1 . ls)
(fixandgo f a0 a1 ls ls ($cdr ls))]))

24
src/libintelasm.ss
View File

@ -356,6 +356,14 @@
(error 'CODEdi "unsupported2")]
[else (error 'CODEdi "unhandled ~s" disp)])))))
(define (SIB s i b ac)
(cons (byte
(fxlogor
(register-index b)
(fxlogor
(fxsll (register-index i) 3)
(fxsll s 6))))
ac))
; 81 /0 id ADD r/m32,imm32 Valid Add imm32 to
(define (CODE/digit c /d)
(lambda (dst ac)
@ -366,6 +374,8 @@
(cond
[(and (imm8? a0) (reg? a1))
(CODE c (ModRM 1 /d a1 (IMM8 a0 ac)))]
[(and (reg? a0) (reg? a1))
(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" dst)])))
@ -492,9 +502,10 @@
[(movl src dst) (instr/2 src dst ac #xB8 #xC7 #x89 #x89 #x8B)]
[(movb src dst)
(cond
[(and (imm8? src) (mem? dst)) (CODEdi8 #xC6 '/0 dst src ac)]
[(and (imm8? src) (mem? dst))
((CODE/digit #xC6 '/0) dst (IMM8 src ac))]
[(and (reg8? src) (mem? dst)) (CODErd #x88 src dst ac)]
[(and (mem? src) (reg8? dst)) (CODErd #x8A dst src ac)]
[(and (mem? src) (reg8? dst)) (CODErd #x8A dst src ac)]
[else (error who "invalid ~s" instr)])]
[(addl src dst)
(cond
@ -511,7 +522,6 @@
[(and (imm? src) (mem? dst))
((CODE/digit #x81 '/0) dst (IMM32 src ac))]
[(and (reg? src) (mem? dst))
(printf "code=~s\n" ((CODE/digit #x01 src) dst '()))
((CODE/digit #x01 src) dst ac)]
[else (error who "invalid ~s" instr)])]
[(subl src dst)
@ -534,8 +544,6 @@
[(and (imm8? src) (reg? dst))
(CODE #xC1 (ModRM 3 '/4 dst (IMM8 src ac)))]
[(and (imm8? src) (mem? dst))
(printf "sall ~s ~s\n" src dst)
(printf "=> ~s\n" ((CODE/digit #xC1 '/4) dst (IMM8 src '())))
((CODE/digit #xC1 '/4) dst (IMM8 src ac))]
[(and (eq? src '%cl) (reg? dst))
(CODE #xD3 (ModRM 3 '/4 dst ac))]
@ -556,14 +564,14 @@
[(and (imm8? src) (reg? dst))
(CODE #xC1 (ModRM 3 '/7 dst (IMM8 src ac)))]
[(and (imm8? src) (mem? dst))
(printf "sarl ~s ~s\n" src dst)
(printf "=> ~s\n" ((CODE/digit #xC1 '/7) dst (IMM8 src '())))
((CODE/digit #xC1 '/7) dst (IMM8 src ac))]
[(and (eq? src '%cl) (reg? dst))
(CODE #xD3 (ModRM 3 '/7 dst ac))]
[else (error who "invalid ~s" instr)])]
[(andl src dst)
(cond
[(and (imm? src) (mem? dst))
((CODE/digit #x81 '/4) dst (IMM32 src ac))]
[(and (imm8? src) (reg? dst))
(CODE #x83 (ModRM 3 '/4 dst (IMM8 src ac)))]
[(and (imm? src) (eq? dst '%eax))
@ -577,6 +585,8 @@
[else (error who "invalid ~s" instr)])]
[(orl src dst)
(cond
[(and (imm? src) (mem? dst))
((CODE/digit #x81 '/1) dst (IMM32 src ac))]
[(and (imm8? src) (reg? dst))
(CODE #x83 (ModRM 3 '/1 dst (IMM8 src ac)))]
[(and (imm? src) (eq? dst '%eax))

5
src/makefile.ss
View File

@ -17,7 +17,7 @@
(define macros
'(|#primitive| lambda case-lambda set! quote begin define if letrec
foreign-call $apply
foreign-call ;$apply
quasiquote unquote unquote-splicing
define-syntax identifier-syntax let-syntax letrec-syntax
fluid-let-syntax alias meta eval-when with-implicit with-syntax
@ -48,7 +48,7 @@
make-string string-ref string-set! string-length string
string->list list->string uuid string-append substring string=?
string<? string<=? string>? string>=? remprop putprop getprop
property-list apply map for-each andmap ormap memq memv assq
property-list $$apply apply map for-each andmap ormap memq memv assq
assv assoc eq? eqv? equal? reverse string->symbol symbol->string
top-level-value set-top-level-value! top-level-bound?
gensym gensym-count gensym-prefix print-gensym
@ -325,5 +325,6 @@
(format "cat ~a > ikarus.boot"
(join " " (map cadr scheme-library-files))))
(printf "Happy Happy Joy Joy\n")
;(#%compiler-giveup-tally)
; vim:syntax=scheme

32
src/psyntax-7.1.ss
View File

@ -777,9 +777,9 @@
(define-syntax build-foreign-call
(syntax-rules ()
[(_ ae name arg*) `(foreign-call ,name . ,arg*)]))
(define-syntax build-$apply
(syntax-rules ()
[(_ ae proc arg*) `($apply ,proc . ,arg*)]))
;;;X (define-syntax build-$apply
;;;X (syntax-rules ()
;;;X [(_ ae proc arg*) `($apply ,proc . ,arg*)]))
(define-syntax build-data
(syntax-rules ()
@ -3370,19 +3370,19 @@
(f #'arg*))])))]
[_ (syntax-error (source-wrap e w ae))])))
(global-extend 'core '$apply
(lambda (e r mr w ae m?)
(syntax-case e ()
[(_ proc arg* ...)
(build-$apply ae
(chi #'proc r mr w m?)
(let f ([arg* #'(arg* ...)])
(syntax-case arg* ()
[() '()]
[(a . arg*)
(cons (chi #'a r mr w m?)
(f #'arg*))])))]
[_ (syntax-error (source-wrap e w ae))])))
;;;X (global-extend 'core '$apply
;;;X (lambda (e r mr w ae m?)
;;;X (syntax-case e ()
;;;X [(_ proc arg* ...)
;;;X (build-$apply ae
;;;X (chi #'proc r mr w m?)
;;;X (let f ([arg* #'(arg* ...)])
;;;X (syntax-case arg* ()
;;;X [() '()]
;;;X [(a . arg*)
;;;X (cons (chi #'a r mr w m?)
;;;X (f #'arg*))])))]
;;;X [_ (syntax-error (source-wrap e w ae))])))
;;; AZIZ
(global-extend 'core 'type-descriptor

26
src/tests/tests-1.5-req.scm
View File

@ -69,19 +69,19 @@
[(fx- 1 (fx- 2 (fx- 3 (fx- 4 (fx- 5 (fx- 6 (fx- 7 (fx- 8 9)))))))) => "5\n"]
)
(add-tests-with-string-output "$fx*"
[(fx* 2 3) => "6\n"]
[(fx* 2 -3) => "-6\n"]
[(fx* -2 3) => "-6\n"]
[(fx* -2 -3) => "6\n"]
[(fx* 536870911 1) => "536870911\n"]
[(fx* 536870911 -1) => "-536870911\n"]
[(fx* -536870912 1) => "-536870912\n"]
[(fx* -536870911 -1) => "536870911\n"]
[(fx* 2 (fx* 3 4)) => "24\n"]
[(fx* (fx* 2 3) 4) => "24\n"]
[(fx* (fx* (fx* (fx* (fx* 2 3) 4) 5) 6) 7) => "5040\n"]
[(fx* 2 (fx* 3 (fx* 4 (fx* 5 (fx* 6 7))))) => "5040\n"]
(add-tests-with-string-output "$#%$fx*"
[(#%$fx* 2 3) => "6\n"]
[(#%$fx* 2 -3) => "-6\n"]
[(#%$fx* -2 3) => "-6\n"]
[(#%$fx* -2 -3) => "6\n"]
[(#%$fx* 536870911 1) => "536870911\n"]
[(#%$fx* 536870911 -1) => "-536870911\n"]
[(#%$fx* -536870912 1) => "-536870912\n"]
[(#%$fx* -536870911 -1) => "536870911\n"]
[(#%$fx* 2 (#%$fx* 3 4)) => "24\n"]
[(#%$fx* (#%$fx* 2 3) 4) => "24\n"]
[(#%$fx* (#%$fx* (#%$fx* (#%$fx* (#%$fx* 2 3) 4) 5) 6) 7) => "5040\n"]
[(#%$fx* 2 (#%$fx* 3 (#%$fx* 4 (#%$fx* 5 (#%$fx* 6 7))))) => "5040\n"]
)
(add-tests-with-string-output "$fxlogand and $fxlogor"

1
src/tests/tests-4.1-req.scm
View File

@ -19,6 +19,7 @@
; [(fxmodulo -17 -9) => "-8\n"]
)
#!eof
(add-tests-with-string-output "write-char"
[(begin
(write-char #\a)