* last commit on alt-cogen and beginning of alt-alt-cogen :-)
This commit is contained in:
Abdulaziz Ghuloum
parent
893a2decc8
commit
5bb666bf7f
|
|
@ -1204,10 +1204,10 @@ chicken-int) NAME='Chicken-int'
|
||||||
SUFFIXCODE="; %s %s"
|
SUFFIXCODE="; %s %s"
|
||||||
case "$setting" in
|
case "$setting" in
|
||||||
r5rs)
|
r5rs)
|
||||||
REPLCOMMANDS="(begin (load \"%s.scm\") (main))"
|
REPLCOMMANDS="(begin (time (load \"%s.scm\")) (main))"
|
||||||
;;
|
;;
|
||||||
r6rs)
|
r6rs)
|
||||||
REPLCOMMANDS="(begin (import scheme) (load \"%s.scm\") (main))"
|
REPLCOMMANDS="(begin (import scheme) (time (load \"%s.scm\")) (main))"
|
||||||
;;
|
;;
|
||||||
esac
|
esac
|
||||||
;;
|
;;
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,14 @@
|
||||||
;INSERTCODE
|
;INSERTCODE
|
||||||
;------------------------------------------------------------------------------
|
;------------------------------------------------------------------------------
|
||||||
|
|
||||||
(current-eval alt-compile)
|
;(define depth (make-parameter 0))
|
||||||
|
;(current-eval
|
||||||
|
; (lambda (x)
|
||||||
|
; (parameterize ([depth (+ (depth) 1)])
|
||||||
|
; (printf "[~s] compiling \n" (depth))
|
||||||
|
; (pretty-print x)
|
||||||
|
; (alt-compile x))))
|
||||||
|
;(current-eval alt-compile)
|
||||||
|
|
||||||
(define (run-bench name count ok? run)
|
(define (run-bench name count ok? run)
|
||||||
(let loop ((i 0) (result (list 'undefined)))
|
(let loop ((i 0) (result (list 'undefined)))
|
||||||
|
|
|
||||||
|
|
@ -5289,3 +5289,214 @@ Words allocated: 0
|
||||||
Words reclaimed: 0
|
Words reclaimed: 0
|
||||||
Elapsed time...: 500 ms (User: 373 ms; System: 126 ms)
|
Elapsed time...: 500 ms (User: 373 ms; System: 126 ms)
|
||||||
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)
|
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)
|
||||||
|
|
||||||
|
****************************
|
||||||
|
Benchmarking Larceny-r6rs on Sun Mar 4 13:36:56 EST 2007 under Darwin adsl-68-254-37-107.dsl.bltnin.sbcglobal.net 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
|
||||||
|
|
||||||
|
Testing sumfp under Larceny-r6rs
|
||||||
|
Compiling...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
>
|
||||||
|
Running...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
Words allocated: 400031744
|
||||||
|
Words reclaimed: 0
|
||||||
|
Elapsed time...: 1812 ms (User: 1804 ms; System: 8 ms)
|
||||||
|
Elapsed GC time: 549 ms (CPU: 542 in 1526 collections.)
|
||||||
|
|
||||||
|
****************************
|
||||||
|
Benchmarking Larceny-r6rs on Sun Mar 4 13:37:23 EST 2007 under Darwin adsl-68-254-37-107.dsl.bltnin.sbcglobal.net 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
|
||||||
|
|
||||||
|
Testing sumfp under Larceny-r6rs
|
||||||
|
Compiling...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
>
|
||||||
|
Running...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
Words allocated: 400031744
|
||||||
|
Words reclaimed: 0
|
||||||
|
Elapsed time...: 1812 ms (User: 1804 ms; System: 7 ms)
|
||||||
|
Elapsed GC time: 540 ms (CPU: 542 in 1526 collections.)
|
||||||
|
|
||||||
|
****************************
|
||||||
|
Benchmarking Larceny-r6rs on Sun Mar 4 23:21:03 EST 2007 under Darwin 10-231-85-69.dhcp-bl.indiana.edu 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
|
||||||
|
|
||||||
|
Testing cat under Larceny-r6rs
|
||||||
|
Compiling...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
>
|
||||||
|
Running...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
Words allocated: 0
|
||||||
|
Words reclaimed: 0
|
||||||
|
Elapsed time...: 504 ms (User: 373 ms; System: 128 ms)
|
||||||
|
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)
|
||||||
|
|
||||||
|
****************************
|
||||||
|
Benchmarking Larceny-r6rs on Mon Mar 5 01:33:34 EST 2007 under Darwin adsl-75-19-178-131.dsl.bltnin.sbcglobal.net 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
|
||||||
|
|
||||||
|
Testing graphs under Larceny-r6rs
|
||||||
|
Compiling...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
>
|
||||||
|
Running...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
Words allocated: 157021446
|
||||||
|
Words reclaimed: 0
|
||||||
|
Elapsed time...: 1653 ms (User: 1628 ms; System: 24 ms)
|
||||||
|
Elapsed GC time: 269 ms (CPU: 272 in 599 collections.)
|
||||||
|
|
||||||
|
****************************
|
||||||
|
Benchmarking Larceny-r6rs on Mon Mar 5 01:42:11 EST 2007 under Darwin adsl-75-19-178-131.dsl.bltnin.sbcglobal.net 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
|
||||||
|
|
||||||
|
Testing compiler under Larceny-r6rs
|
||||||
|
Compiling...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
> WARNING from macro expander:
|
||||||
|
Redefining
|
||||||
|
bound?
|
||||||
|
|
||||||
|
>
|
||||||
|
Running...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
> bench DIED!
|
||||||
|
|
||||||
|
****************************
|
||||||
|
Benchmarking Larceny-r6rs on Mon Mar 5 02:15:14 EST 2007 under Darwin adsl-75-19-178-131.dsl.bltnin.sbcglobal.net 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
|
||||||
|
|
||||||
|
Testing compiler under Larceny-r6rs
|
||||||
|
Compiling...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
****************************
|
||||||
|
Benchmarking Larceny-r6rs on Mon Mar 5 02:25:03 EST 2007 under Darwin adsl-75-19-178-131.dsl.bltnin.sbcglobal.net 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
|
||||||
|
|
||||||
|
Testing nucleic under Larceny-r6rs
|
||||||
|
Compiling...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
>
|
||||||
|
Running...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
Words allocated: 151779492
|
||||||
|
Words reclaimed: 0
|
||||||
|
Elapsed time...: 4645 ms (User: 3144 ms; System: 1474 ms)
|
||||||
|
Elapsed GC time: 255 ms (CPU: 253 in 579 collections.)
|
||||||
|
|
||||||
|
****************************
|
||||||
|
Benchmarking Larceny-r6rs on Mon Mar 5 02:56:59 EST 2007 under Darwin adsl-75-19-178-131.dsl.bltnin.sbcglobal.net 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
|
||||||
|
|
||||||
|
Testing nucleic under Larceny-r6rs
|
||||||
|
Compiling...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
>
|
||||||
|
Running...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
Words allocated: 151779492
|
||||||
|
Words reclaimed: 0
|
||||||
|
Elapsed time...: 4588 ms (User: 3124 ms; System: 1461 ms)
|
||||||
|
Elapsed GC time: 253 ms (CPU: 238 in 579 collections.)
|
||||||
|
|
||||||
|
****************************
|
||||||
|
Benchmarking Larceny-r6rs on Mon Mar 5 02:58:00 EST 2007 under Darwin adsl-75-19-178-131.dsl.bltnin.sbcglobal.net 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
|
||||||
|
|
||||||
|
Testing nucleic under Larceny-r6rs
|
||||||
|
Compiling...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
****************************
|
||||||
|
Benchmarking Larceny-r6rs on Mon Mar 5 02:58:57 EST 2007 under Darwin adsl-75-19-178-131.dsl.bltnin.sbcglobal.net 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
|
||||||
|
|
||||||
|
Testing nucleic under Larceny-r6rs
|
||||||
|
Compiling...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
>
|
||||||
|
Running...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
Words allocated: 151779492
|
||||||
|
Words reclaimed: 0
|
||||||
|
Elapsed time...: 4589 ms (User: 3125 ms; System: 1463 ms)
|
||||||
|
Elapsed GC time: 236 ms (CPU: 256 in 579 collections.)
|
||||||
|
|
||||||
|
****************************
|
||||||
|
Benchmarking Larceny-r6rs on Mon Mar 5 03:17:17 EST 2007 under Darwin iub-vpn-199-79.noc.indiana.edu 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
|
||||||
|
|
||||||
|
Testing pi under Larceny-r6rs
|
||||||
|
Compiling...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
>
|
||||||
|
Running...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
|
||||||
|
****************************
|
||||||
|
Benchmarking Larceny-r6rs on Fri Mar 9 13:58:55 EST 2007 under Darwin dhcp-cs-244-155.cs.indiana.edu 8.8.3 Darwin Kernel Version 8.8.3: Wed Oct 18 21:57:10 PDT 2006; root:xnu-792.15.4.obj~4/RELEASE_I386 i386 i386
|
||||||
|
|
||||||
|
Testing peval under Larceny-r6rs
|
||||||
|
Compiling...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
>
|
||||||
|
Running...
|
||||||
|
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||||
|
|
||||||
|
|
||||||
|
>
|
||||||
|
Words allocated: 34340444
|
||||||
|
Words reclaimed: 0
|
||||||
|
Elapsed time...: 1262 ms (User: 1254 ms; System: 7 ms)
|
||||||
|
Elapsed GC time: 55 ms (CPU: 61 in 131 collections.)
|
||||||
|
|
|
||||||
BIN
bin/ikarus
BIN
bin/ikarus
Binary file not shown.
|
|
@ -6,18 +6,6 @@
|
||||||
#include <math.h>
|
#include <math.h>
|
||||||
|
|
||||||
|
|
||||||
#if 0
|
|
||||||
ikp
|
|
||||||
ikrt_is_flonum(ikp x){
|
|
||||||
if(tagof(x) == vector_tag){
|
|
||||||
if (ref(x, -vector_tag) == flonum_tag){
|
|
||||||
return true_object;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
return false_object;
|
|
||||||
}
|
|
||||||
#endif
|
|
||||||
|
|
||||||
ikp
|
ikp
|
||||||
ikrt_string_to_flonum(ikp x, ikpcb* pcb){
|
ikrt_string_to_flonum(ikp x, ikpcb* pcb){
|
||||||
double v = strtod(string_data(x), NULL);
|
double v = strtod(string_data(x), NULL);
|
||||||
|
|
@ -75,6 +63,36 @@ ikrt_fl_sin(ikp x, ikpcb* pcb){
|
||||||
return r;
|
return r;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
ikp
|
||||||
|
ikrt_fl_cos(ikp x, ikpcb* pcb){
|
||||||
|
ikp r = ik_alloc(pcb, flonum_size) + vector_tag;
|
||||||
|
ref(r, -vector_tag) = (ikp)flonum_tag;
|
||||||
|
flonum_data(r) = cos(flonum_data(x));
|
||||||
|
return r;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
ikp
|
||||||
|
ikrt_fl_sqrt(ikp x, ikpcb* pcb){
|
||||||
|
ikp r = ik_alloc(pcb, flonum_size) + vector_tag;
|
||||||
|
ref(r, -vector_tag) = (ikp)flonum_tag;
|
||||||
|
flonum_data(r) = sqrt(flonum_data(x));
|
||||||
|
return r;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
ikp
|
||||||
|
ikrt_fl_atan(ikp x, ikpcb* pcb){
|
||||||
|
ikp r = ik_alloc(pcb, flonum_size) + vector_tag;
|
||||||
|
ref(r, -vector_tag) = (ikp)flonum_tag;
|
||||||
|
flonum_data(r) = atan(flonum_data(x));
|
||||||
|
return r;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
ikp
|
ikp
|
||||||
ikrt_fx_sin(ikp x, ikpcb* pcb){
|
ikrt_fx_sin(ikp x, ikpcb* pcb){
|
||||||
ikp r = ik_alloc(pcb, flonum_size) + vector_tag;
|
ikp r = ik_alloc(pcb, flonum_size) + vector_tag;
|
||||||
|
|
@ -83,6 +101,34 @@ ikrt_fx_sin(ikp x, ikpcb* pcb){
|
||||||
return r;
|
return r;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
ikp
|
||||||
|
ikrt_fx_cos(ikp x, ikpcb* pcb){
|
||||||
|
ikp r = ik_alloc(pcb, flonum_size) + vector_tag;
|
||||||
|
ref(r, -vector_tag) = (ikp)flonum_tag;
|
||||||
|
flonum_data(r) = cos(unfix(x));
|
||||||
|
return r;
|
||||||
|
}
|
||||||
|
|
||||||
|
ikp
|
||||||
|
ikrt_fx_sqrt(ikp x, ikpcb* pcb){
|
||||||
|
ikp r = ik_alloc(pcb, flonum_size) + vector_tag;
|
||||||
|
ref(r, -vector_tag) = (ikp)flonum_tag;
|
||||||
|
flonum_data(r) = sqrt(unfix(x));
|
||||||
|
return r;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
ikp
|
||||||
|
ikrt_fx_atan(ikp x, ikpcb* pcb){
|
||||||
|
ikp r = ik_alloc(pcb, flonum_size) + vector_tag;
|
||||||
|
ref(r, -vector_tag) = (ikp)flonum_tag;
|
||||||
|
flonum_data(r) = atan(unfix(x));
|
||||||
|
return r;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -124,8 +170,34 @@ ikrt_fixnum_to_flonum(ikp x, ikpcb* pcb){
|
||||||
|
|
||||||
ikp
|
ikp
|
||||||
ikrt_bignum_to_flonum(ikp x, ikpcb* pcb){
|
ikrt_bignum_to_flonum(ikp x, ikpcb* pcb){
|
||||||
fprintf(stderr, "ERR in bignum_to_flonum\n");
|
ikp r = ik_alloc(pcb, flonum_size) + vector_tag;
|
||||||
exit(-1);
|
ref(r, -vector_tag) = (ikp)flonum_tag;
|
||||||
|
unsigned int fst = (unsigned int) ref(x, -vector_tag);
|
||||||
|
int limbs = (fst >> bignum_length_shift);
|
||||||
|
double fl;
|
||||||
|
if(limbs == 1){
|
||||||
|
fl = ((unsigned int)ref(x, disp_bignum_data - vector_tag));
|
||||||
|
} else if(limbs == 2){
|
||||||
|
fl = ((unsigned int)ref(x, wordsize+disp_bignum_data - vector_tag));
|
||||||
|
fl *= exp2(32);
|
||||||
|
fl += ((unsigned int)ref(x, disp_bignum_data - vector_tag));
|
||||||
|
} else {
|
||||||
|
fl =
|
||||||
|
((unsigned int)ref(x, limbs * wordsize - wordsize +
|
||||||
|
disp_bignum_data - vector_tag));
|
||||||
|
fl *= exp2(32);
|
||||||
|
fl += ((unsigned int)ref(x, limbs * wordsize - (wordsize*2) +
|
||||||
|
disp_bignum_data - vector_tag));
|
||||||
|
fl *= exp2(32);
|
||||||
|
fl += ((unsigned int)ref(x, limbs * wordsize - (wordsize*3) +
|
||||||
|
disp_bignum_data - vector_tag));
|
||||||
|
fl *= exp2(limbs*wordsize*8-wordsize*8*3);
|
||||||
|
}
|
||||||
|
if((fst & bignum_sign_mask) != 0){
|
||||||
|
fl = -fl;
|
||||||
|
}
|
||||||
|
flonum_data(r) = fl;
|
||||||
|
return r;
|
||||||
}
|
}
|
||||||
|
|
||||||
ikp
|
ikp
|
||||||
|
|
|
||||||
|
|
@ -156,7 +156,7 @@ ikrt_fxbnplus(ikp x, ikp y, ikpcb* pcb){
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
fprintf(stderr, "this case 0x%08x\n", intx);
|
//fprintf(stderr, "this case 0x%08x\n", intx);
|
||||||
/* positive fx + negative bn = smaller negative bn */
|
/* positive fx + negative bn = smaller negative bn */
|
||||||
ikp r = ik_alloc(pcb, align(disp_bignum_data+limb_count*wordsize));
|
ikp r = ik_alloc(pcb, align(disp_bignum_data+limb_count*wordsize));
|
||||||
int borrow = mpn_sub_1((mp_limb_t*)(r+disp_bignum_data),
|
int borrow = mpn_sub_1((mp_limb_t*)(r+disp_bignum_data),
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,327 @@
|
||||||
|
#!/usr/bin/env ikarus -b ikarus.boot --script
|
||||||
|
|
||||||
|
;;; 9.1: * starting with libnumerics
|
||||||
|
;;; 9.0: * graph marks for both reader and writer
|
||||||
|
;;; * circularity detection during read
|
||||||
|
;;; 8.1: * using chez-style io ports
|
||||||
|
;;; 6.9: * creating a *system* environment
|
||||||
|
;;; 6.8: * creating a core-primitive form in the expander
|
||||||
|
;;; 6.2: * side-effects now modify the dirty-vector
|
||||||
|
;;; * added bwp-object?
|
||||||
|
;;; * added pointer-value
|
||||||
|
;;; * added tcbuckets
|
||||||
|
;;; 6.1: * added case-lambda, dropped lambda
|
||||||
|
;;; 6.0: * basic compiler
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(define macros
|
||||||
|
'(|#primitive| lambda case-lambda set! quote begin define if letrec
|
||||||
|
foreign-call
|
||||||
|
quasiquote unquote unquote-splicing
|
||||||
|
define-syntax identifier-syntax let-syntax letrec-syntax
|
||||||
|
fluid-let-syntax alias meta eval-when with-implicit with-syntax
|
||||||
|
type-descriptor
|
||||||
|
syntax-case syntax-rules module $module import $import import-only
|
||||||
|
syntax quasisyntax unsyntax unsyntax-splicing datum
|
||||||
|
let let* let-values cond case define-record or and when unless do
|
||||||
|
include parameterize trace untrace trace-lambda trace-define
|
||||||
|
rec
|
||||||
|
time))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(define public-primitives
|
||||||
|
'(
|
||||||
|
|
||||||
|
null? pair? char? fixnum? symbol? gensym? string? vector? list?
|
||||||
|
boolean? procedure? not eof-object eof-object? bwp-object?
|
||||||
|
void fx= fx< fx<= fx> fx>= fxzero? fx+ fx- fx* fxadd1 fxsub1
|
||||||
|
fxquotient fxremainder fxmodulo fxsll fxsra fxlognot fxlogor
|
||||||
|
fxlogand fxlogxor integer->char char->integer char=? char<?
|
||||||
|
char<=? char>? char>=? cons car cdr set-car! set-cdr! caar
|
||||||
|
cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
|
||||||
|
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar
|
||||||
|
cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr list list*
|
||||||
|
make-list length list-ref append make-vector vector-ref
|
||||||
|
vector-set! vector-length vector vector->list list->vector
|
||||||
|
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 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
|
||||||
|
gensym->unique-string call-with-values values make-parameter
|
||||||
|
dynamic-wind display write print-graph fasl-write printf fprintf format
|
||||||
|
print-error read-token read comment-handler error warning exit call/cc
|
||||||
|
error-handler eval current-eval compile alt-compile compile-file
|
||||||
|
alt-compile-file
|
||||||
|
new-cafe load system expand sc-expand current-expand expand-mode
|
||||||
|
environment? interaction-environment identifier?
|
||||||
|
free-identifier=? bound-identifier=? literal-identifier=?
|
||||||
|
datum->syntax-object syntax-object->datum syntax-error
|
||||||
|
syntax->list generate-temporaries record? record-set! record-ref
|
||||||
|
record-length record-type-descriptor make-record-type
|
||||||
|
record-printer record-name record-field-accessor
|
||||||
|
record-field-mutator record-predicate record-constructor
|
||||||
|
record-type-name record-type-symbol record-type-field-names
|
||||||
|
hash-table? make-hash-table get-hash-table put-hash-table!
|
||||||
|
assembler-output $make-environment features
|
||||||
|
command-line-arguments port? input-port? output-port?
|
||||||
|
make-input-port make-output-port make-input/output-port
|
||||||
|
port-handler port-input-buffer port-input-index port-input-size
|
||||||
|
port-output-buffer port-output-index port-output-size
|
||||||
|
set-port-input-index! set-port-input-size!
|
||||||
|
set-port-output-index! set-port-output-size! port-name
|
||||||
|
input-port-name output-port-name write-char read-char
|
||||||
|
unread-char peek-char newline reset-input-port!
|
||||||
|
flush-output-port close-input-port close-output-port
|
||||||
|
console-input-port current-input-port standard-output-port
|
||||||
|
standard-error-port console-output-port current-output-port
|
||||||
|
open-output-file open-input-file open-output-string
|
||||||
|
with-output-to-string
|
||||||
|
get-output-string with-output-to-file call-with-output-file
|
||||||
|
open-input-string
|
||||||
|
with-input-from-file call-with-input-file date-string
|
||||||
|
file-exists? delete-file + - add1 sub1 * / expt
|
||||||
|
quotient+remainder quotient remainder modulo number? positive?
|
||||||
|
negative? zero? number->string logand = < > <= >=
|
||||||
|
last-pair
|
||||||
|
make-guardian weak-cons collect
|
||||||
|
interrupt-handler
|
||||||
|
time-it
|
||||||
|
posix-fork fork waitpid env environ
|
||||||
|
pretty-print
|
||||||
|
even? odd? member char-whitespace? char-alphabetic?
|
||||||
|
char-downcase max min complex? real? rational?
|
||||||
|
exact? inexact? integer?
|
||||||
|
string->number exact->inexact
|
||||||
|
|
||||||
|
flonum? flonum->string string->flonum
|
||||||
|
sin cos atan sqrt
|
||||||
|
))
|
||||||
|
|
||||||
|
(define system-primitives
|
||||||
|
'(
|
||||||
|
$primitive-call/cc
|
||||||
|
$closure-code immediate? $unbound-object? $forward-ptr?
|
||||||
|
pointer-value primitive-ref primitive-set! $fx= $fx< $fx<= $fx>
|
||||||
|
$fx>= $fxzero? $fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient
|
||||||
|
$fxremainder $fxmodulo $fxsll $fxsra $fxlognot $fxlogor
|
||||||
|
$fxlogand $fxlogxor $fixnum->char $char->fixnum $char= $char<
|
||||||
|
$char<= $char> $char>= $car $cdr $set-car! $set-cdr!
|
||||||
|
$make-vector $vector-ref $vector-set! $vector-length
|
||||||
|
$make-string $string-ref $string-set! $string-length $string
|
||||||
|
$symbol-string $symbol-unique-string $symbol-value
|
||||||
|
$set-symbol-string! $set-symbol-unique-string!
|
||||||
|
$set-symbol-value! $make-symbol $set-symbol-plist!
|
||||||
|
$symbol-plist $sc-put-cte $record? $record/rtd? $record-set!
|
||||||
|
$record-ref $record-rtd $make-record $record $base-rtd $code?
|
||||||
|
$code-reloc-vector $code-freevars $code-size $code-ref
|
||||||
|
$code-set! $code->closure list*->code* make-code code?
|
||||||
|
set-code-reloc-vector! code-reloc-vector code-freevars
|
||||||
|
code-size code-ref code-set! $frame->continuation $fp-at-base
|
||||||
|
$current-frame $arg-list $seal-frame-and-call
|
||||||
|
$make-call-with-values-procedure $make-values-procedure
|
||||||
|
do-overflow $make-tcbucket $tcbucket-next $tcbucket-key
|
||||||
|
$tcbucket-val $set-tcbucket-next! $set-tcbucket-val!
|
||||||
|
$set-tcbucket-tconc!
|
||||||
|
call/cf
|
||||||
|
trace-symbol! untrace-symbol! make-traced-procedure
|
||||||
|
fixnum->string
|
||||||
|
$interrupted? $unset-interrupted! $do-event
|
||||||
|
$fasl-read
|
||||||
|
;;; TODO: must open-code
|
||||||
|
|
||||||
|
$make-port/input $make-port/output $make-port/both
|
||||||
|
$make-input-port $make-output-port $make-input/output-port
|
||||||
|
$port-handler $port-input-buffer $port-input-index
|
||||||
|
$port-input-size $port-output-buffer $port-output-index
|
||||||
|
$port-output-size $set-port-input-index! $set-port-input-size!
|
||||||
|
$set-port-output-index! $set-port-output-size!
|
||||||
|
|
||||||
|
;;; better open-code
|
||||||
|
|
||||||
|
$write-char $read-char $peek-char $unread-char
|
||||||
|
|
||||||
|
;;; never open-code
|
||||||
|
|
||||||
|
$reset-input-port! $close-input-port $close-output-port
|
||||||
|
$flush-output-port *standard-output-port* *standard-error-port*
|
||||||
|
*current-output-port* *standard-input-port* *current-input-port*
|
||||||
|
|
||||||
|
;;;
|
||||||
|
compiler-giveup-tally
|
||||||
|
))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(define (whack-system-env setenv?)
|
||||||
|
(define add-prim
|
||||||
|
(lambda (x)
|
||||||
|
(let ([g (gensym (symbol->string x))])
|
||||||
|
(putprop x '|#system| g)
|
||||||
|
(putprop g '*sc-expander* (cons 'core-primitive x)))))
|
||||||
|
(define add-macro
|
||||||
|
(lambda (x)
|
||||||
|
(let ([g (gensym (symbol->string x))]
|
||||||
|
[e (getprop x '*sc-expander*)])
|
||||||
|
(when e
|
||||||
|
(putprop x '|#system| g)
|
||||||
|
(putprop g '*sc-expander* e)))))
|
||||||
|
(define (foo)
|
||||||
|
(eval
|
||||||
|
`(begin
|
||||||
|
(define-syntax compile-time-date-string
|
||||||
|
(lambda (x)
|
||||||
|
#'(quote ,(date-string))))
|
||||||
|
(define-syntax public-primitives
|
||||||
|
(lambda (x)
|
||||||
|
#'(quote ,public-primitives)))
|
||||||
|
(define-syntax system-primitives
|
||||||
|
(lambda (x)
|
||||||
|
#'(quote ,system-primitives)))
|
||||||
|
(define-syntax macros
|
||||||
|
(lambda (x)
|
||||||
|
#'(quote ,macros))))))
|
||||||
|
(set! system-env ($make-environment '|#system| #t))
|
||||||
|
(for-each add-macro macros)
|
||||||
|
(for-each add-prim public-primitives)
|
||||||
|
(for-each add-prim system-primitives)
|
||||||
|
(if setenv?
|
||||||
|
(parameterize ([interaction-environment system-env])
|
||||||
|
(foo))
|
||||||
|
(foo)))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(when (eq? "" "")
|
||||||
|
(error #f "SEVERELY OUT OF DATE!\n")
|
||||||
|
(load "chez-compat.ss")
|
||||||
|
(set! primitive-ref top-level-value)
|
||||||
|
(set! primitive-set! set-top-level-value!)
|
||||||
|
(set! chez-expand sc-expand)
|
||||||
|
(set! chez-current-expand current-expand)
|
||||||
|
(printf "loading psyntax.pp ...\n")
|
||||||
|
(load "psyntax-7.1.pp")
|
||||||
|
(chez-current-expand
|
||||||
|
(lambda (x . args)
|
||||||
|
(apply chez-expand (sc-expand x) args)))
|
||||||
|
(whack-system-env #f)
|
||||||
|
(printf "loading psyntax.ss ...\n")
|
||||||
|
(load "psyntax-7.1-6.9.ss")
|
||||||
|
(chez-current-expand
|
||||||
|
(lambda (x . args)
|
||||||
|
(apply chez-expand (sc-expand x) args)))
|
||||||
|
(whack-system-env #t)
|
||||||
|
(printf "ok\n")
|
||||||
|
(load "libassembler-compat-6.7.ss") ; defines make-code etc.
|
||||||
|
(load "libintelasm-6.9.ss") ; uses make-code, etc.
|
||||||
|
(load "libfasl-6.7.ss") ; uses code? etc.
|
||||||
|
(load "libcompile-8.1.ss") ; uses fasl-write
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
(whack-system-env #t)
|
||||||
|
|
||||||
|
(define scheme-library-files
|
||||||
|
'(["libhandlers.ss" "libhandlers.fasl" p0 chaitin]
|
||||||
|
["libcontrol0.ss" "libcontrol0.fasl" p0 chaitin]
|
||||||
|
["libcontrol1.ss" "libcontrol1.fasl" p0 chaitin]
|
||||||
|
["libcollect.ss" "libcollect.fasl" p0 chaitin]
|
||||||
|
["librecord.ss" "librecord.fasl" p0 chaitin]
|
||||||
|
["libcxr.ss" "libcxr.fasl" p0 chaitin]
|
||||||
|
["libnumerics.ss" "libnumerics.fasl" p0 chaitin]
|
||||||
|
["libguardians.ss" "libguardians.fasl" p0 chaitin]
|
||||||
|
["libcore.ss" "libcore.fasl" p0 chaitin]
|
||||||
|
["libchezio.ss" "libchezio.fasl" p0 chaitin]
|
||||||
|
["libhash.ss" "libhash.fasl" p0 chaitin]
|
||||||
|
["libwriter.ss" "libwriter.fasl" p0 chaitin]
|
||||||
|
["libtokenizer.ss" "libtokenizer.fasl" p0 chaitin]
|
||||||
|
["libassembler.ss" "libassembler.fasl" p0 chaitin]
|
||||||
|
["libintelasm.ss" "libintelasm.fasl" p0 chaitin]
|
||||||
|
["libfasl.ss" "libfasl.fasl" p0 chaitin]
|
||||||
|
["libtrace.ss" "libtrace.fasl" p0 chaitin]
|
||||||
|
["libcompile.ss" "libcompile.fasl" p1 chaitin]
|
||||||
|
["psyntax-7.1.ss" "psyntax.fasl" p0 chaitin]
|
||||||
|
["libpp.ss" "libpp.fasl" p0 chaitin]
|
||||||
|
["libcafe.ss" "libcafe.fasl" p0 chaitin]
|
||||||
|
["libposix.ss" "libposix.fasl" p0 chaitin]
|
||||||
|
["libtimers.ss" "libtimers.fasl" p0 chaitin]
|
||||||
|
["libtoplevel.ss" "libtoplevel.fasl" p0 chaitin]
|
||||||
|
))
|
||||||
|
|
||||||
|
|
||||||
|
(define (read-file ifile)
|
||||||
|
(with-input-from-file ifile
|
||||||
|
(lambda ()
|
||||||
|
(let f ()
|
||||||
|
(let ([x (read)])
|
||||||
|
(if (eof-object? x)
|
||||||
|
'()
|
||||||
|
(cons x (f))))))))
|
||||||
|
|
||||||
|
(define (expand-file ifile)
|
||||||
|
(map sc-expand (read-file ifile)))
|
||||||
|
|
||||||
|
(define (compile-library ifile ofile which-compile)
|
||||||
|
(parameterize ([assembler-output #f]
|
||||||
|
[expand-mode 'bootstrap]
|
||||||
|
[interaction-environment system-env])
|
||||||
|
(let ([proc
|
||||||
|
(case which-compile
|
||||||
|
[(onepass) compile-file]
|
||||||
|
[(chaitin) alt-compile-file]
|
||||||
|
[else (error 'compile-library "unknown compile ~s"
|
||||||
|
which-compile)])])
|
||||||
|
(printf "compiling ~a ... \n" ifile)
|
||||||
|
(proc ifile ofile 'replace))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;(let ()
|
||||||
|
; (define (compile-all who)
|
||||||
|
; (for-each
|
||||||
|
; (lambda (x)
|
||||||
|
; (when (eq? who (caddr x))
|
||||||
|
; (compile-library (car x) (cadr x) (cadddr x))))
|
||||||
|
; scheme-library-files))
|
||||||
|
; (define (time x) x)
|
||||||
|
; (fork
|
||||||
|
; (lambda (pid)
|
||||||
|
; (time (compile-all 'p1))
|
||||||
|
; (unless (fxzero? (waitpid pid))
|
||||||
|
; (exit -1)))
|
||||||
|
; (lambda ()
|
||||||
|
; (time (compile-all 'p0))
|
||||||
|
; (exit))))
|
||||||
|
|
||||||
|
(for-each
|
||||||
|
(lambda (x)
|
||||||
|
(compile-library (car x) (cadr x) (cadddr x)))
|
||||||
|
scheme-library-files)
|
||||||
|
|
||||||
|
(define (join s ls)
|
||||||
|
(cond
|
||||||
|
[(null? ls) ""]
|
||||||
|
[else
|
||||||
|
(let ([str (open-output-string)])
|
||||||
|
(let f ([a (car ls)] [d (cdr ls)])
|
||||||
|
(cond
|
||||||
|
[(null? d)
|
||||||
|
(display a str)
|
||||||
|
(get-output-string str)]
|
||||||
|
[else
|
||||||
|
(display a str)
|
||||||
|
(display s str)
|
||||||
|
(f (car d) (cdr d))])))]))
|
||||||
|
|
||||||
|
|
||||||
|
(system
|
||||||
|
(format "cat ~a > ikarus.boot"
|
||||||
|
(join " " (map cadr scheme-library-files))))
|
||||||
|
|
||||||
|
(printf "Happy Happy Joy Joy!\n")
|
||||||
|
;(#%compiler-giveup-tally)
|
||||||
|
; vim:syntax=scheme
|
||||||
|
|
@ -0,0 +1,45 @@
|
||||||
|
#!/usr/bin/env ikarus --script
|
||||||
|
|
||||||
|
(import scheme)
|
||||||
|
|
||||||
|
(define (test-one input str)
|
||||||
|
(printf " T: ~s " input)
|
||||||
|
(let ([v0 (eval input)])
|
||||||
|
(printf "c")
|
||||||
|
; (collect)
|
||||||
|
(let ([v1 (alt-compile input)])
|
||||||
|
(printf "r")
|
||||||
|
(if (equal? v0 v1)
|
||||||
|
(printf "d ok\n")
|
||||||
|
(error "values differed, expected ~s, got ~s" v0 v1)))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(define-syntax add-tests-with-string-output
|
||||||
|
(syntax-rules (=>)
|
||||||
|
[(_ name [test => res] ...)
|
||||||
|
(begin
|
||||||
|
(printf "TESTING ~a ...\n" 'name)
|
||||||
|
(test-one 'test 'res) ...
|
||||||
|
(printf "OK\n"))]))
|
||||||
|
|
||||||
|
(load "tests/tests-1.1-req.scm")
|
||||||
|
(load "tests/tests-1.2-req.scm")
|
||||||
|
(load "tests/tests-1.3-req.scm")
|
||||||
|
(load "tests/tests-1.4-req.scm")
|
||||||
|
(load "tests/tests-1.5-req.scm")
|
||||||
|
(load "tests/tests-1.6-req.scm")
|
||||||
|
(load "tests/tests-1.7-req.scm")
|
||||||
|
(load "tests/tests-1.8-req.scm")
|
||||||
|
(load "tests/tests-1.9-req.scm")
|
||||||
|
(load "tests/tests-2.1-req.scm")
|
||||||
|
(load "tests/tests-2.2-req.scm")
|
||||||
|
(load "tests/tests-2.3-req.scm")
|
||||||
|
(load "tests/tests-2.4-req.scm")
|
||||||
|
(load "tests/tests-2.6-req.scm")
|
||||||
|
(load "tests/tests-4.1-req.scm")
|
||||||
|
(load "tests/tests-new.scm")
|
||||||
|
;(load "tests/tests-5.2-req.scm")
|
||||||
|
;(load "tests/tests-5.3-req.scm")
|
||||||
|
(printf "HAPPY HAPPY JOY JOY\n")
|
||||||
|
(exit)
|
||||||
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -19,12 +19,6 @@
|
||||||
|
|
||||||
(let ()
|
(let ()
|
||||||
|
|
||||||
;;; (define bignum?
|
|
||||||
;;; ; FIXME: temporary definition. Compiler should be made aware
|
|
||||||
;;; ; of numeric representation once it's stable enough.
|
|
||||||
;;; (lambda (x)
|
|
||||||
;;; (foreign-call "ikrt_isbignum" x)))
|
|
||||||
|
|
||||||
(define (fixnum->flonum x)
|
(define (fixnum->flonum x)
|
||||||
(foreign-call "ikrt_fixnum_to_flonum" x))
|
(foreign-call "ikrt_fixnum_to_flonum" x))
|
||||||
(define (bignum->flonum x)
|
(define (bignum->flonum x)
|
||||||
|
|
@ -806,6 +800,27 @@
|
||||||
[(fixnum? x) (foreign-call "ikrt_fx_sin" x)]
|
[(fixnum? x) (foreign-call "ikrt_fx_sin" x)]
|
||||||
[else (error 'sin "unsupported ~s" x)])))
|
[else (error 'sin "unsupported ~s" x)])))
|
||||||
|
|
||||||
|
(primitive-set! 'cos
|
||||||
|
(lambda (x)
|
||||||
|
(cond
|
||||||
|
[(flonum? x) (foreign-call "ikrt_fl_cos" x)]
|
||||||
|
[(fixnum? x) (foreign-call "ikrt_fx_cos" x)]
|
||||||
|
[else (error 'cos "unsupported ~s" x)])))
|
||||||
|
|
||||||
|
(primitive-set! 'atan
|
||||||
|
(lambda (x)
|
||||||
|
(cond
|
||||||
|
[(flonum? x) (foreign-call "ikrt_fl_atan" x)]
|
||||||
|
[(fixnum? x) (foreign-call "ikrt_fx_atan" x)]
|
||||||
|
[else (error 'atan "unsupported ~s" x)])))
|
||||||
|
|
||||||
|
(primitive-set! 'sqrt
|
||||||
|
(lambda (x)
|
||||||
|
(cond
|
||||||
|
[(flonum? x) (foreign-call "ikrt_fl_sqrt" x)]
|
||||||
|
[(fixnum? x) (foreign-call "ikrt_fx_sqrt" x)]
|
||||||
|
[else (error 'sqrt "unsupported ~s" x)])))
|
||||||
|
|
||||||
(primitive-set! 'even? even?)
|
(primitive-set! 'even? even?)
|
||||||
(primitive-set! 'odd? odd?)
|
(primitive-set! 'odd? odd?)
|
||||||
(primitive-set! 'max max)
|
(primitive-set! 'max max)
|
||||||
|
|
|
||||||
|
|
@ -99,7 +99,7 @@
|
||||||
string->number exact->inexact
|
string->number exact->inexact
|
||||||
|
|
||||||
flonum? flonum->string string->flonum
|
flonum? flonum->string string->flonum
|
||||||
sin
|
sin cos atan sqrt
|
||||||
))
|
))
|
||||||
|
|
||||||
(define system-primitives
|
(define system-primitives
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,10 @@
|
||||||
|
|
||||||
|
(define-syntax section
|
||||||
|
(syntax-rules (/section)
|
||||||
|
[(section e* ... /section) (begin e* ...)]))
|
||||||
|
|
||||||
|
(section ;;; helpers
|
||||||
|
|
||||||
(define (prm op . arg*)
|
(define (prm op . arg*)
|
||||||
(make-primcall op arg*))
|
(make-primcall op arg*))
|
||||||
|
|
||||||
|
|
@ -22,7 +29,6 @@
|
||||||
(interrupt-unless (tag-test x mask tag))
|
(interrupt-unless (tag-test x mask tag))
|
||||||
(prm 'mref x (K (- disp tag)))))
|
(prm 'mref x (K (- disp tag)))))
|
||||||
|
|
||||||
|
|
||||||
(define (dirty-vector-set address)
|
(define (dirty-vector-set address)
|
||||||
(prm 'mset
|
(prm 'mset
|
||||||
(prm 'int+
|
(prm 'int+
|
||||||
|
|
@ -53,7 +59,6 @@
|
||||||
(mem-assign v x i))]
|
(mem-assign v x i))]
|
||||||
[else (mem-assign v x i)]))
|
[else (mem-assign v x i)]))
|
||||||
|
|
||||||
|
|
||||||
(define (align-code unknown-amt known-amt)
|
(define (align-code unknown-amt known-amt)
|
||||||
(prm 'sll
|
(prm 'sll
|
||||||
(prm 'sra
|
(prm 'sra
|
||||||
|
|
@ -61,11 +66,7 @@
|
||||||
(K (+ known-amt (sub1 object-alignment))))
|
(K (+ known-amt (sub1 object-alignment))))
|
||||||
(K align-shift))
|
(K align-shift))
|
||||||
(K align-shift)))
|
(K align-shift)))
|
||||||
|
/section)
|
||||||
|
|
||||||
(define-syntax section
|
|
||||||
(syntax-rules (/section)
|
|
||||||
[(section e* ... /section) (begin e* ...)]))
|
|
||||||
|
|
||||||
(section ;;; simple objects section
|
(section ;;; simple objects section
|
||||||
|
|
||||||
|
|
@ -659,7 +660,23 @@
|
||||||
|
|
||||||
/section)
|
/section)
|
||||||
|
|
||||||
(section ;;; numbers
|
(section ;;; bignums
|
||||||
|
|
||||||
|
(define-primop bignum? safe
|
||||||
|
[(P x) (sec-tag-test (T x) vector-mask vector-tag bignum-mask bignum-tag)]
|
||||||
|
[(E x) (nop)])
|
||||||
|
|
||||||
|
/section)
|
||||||
|
|
||||||
|
(section ;;; flonums
|
||||||
|
|
||||||
|
(define-primop flonum? safe
|
||||||
|
[(P x) (sec-tag-test (T x) vector-mask vector-tag #f flonum-tag)]
|
||||||
|
[(E x) (nop)])
|
||||||
|
|
||||||
|
/section)
|
||||||
|
|
||||||
|
(section ;;; generic arithmetic
|
||||||
|
|
||||||
(define (non-fixnum? x)
|
(define (non-fixnum? x)
|
||||||
(record-case x
|
(record-case x
|
||||||
|
|
@ -1323,140 +1340,4 @@
|
||||||
|
|
||||||
/section)
|
/section)
|
||||||
|
|
||||||
#!eof
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
[($procedure-check)
|
|
||||||
(tbind ([x (Value (car arg*))])
|
|
||||||
(make-shortcut
|
|
||||||
(make-seq
|
|
||||||
(make-conditional
|
|
||||||
(tag-test x closure-mask closure-tag)
|
|
||||||
(prm 'nop)
|
|
||||||
(prm 'interrupt))
|
|
||||||
x)
|
|
||||||
(Value
|
|
||||||
(make-funcall (make-primref 'error)
|
|
||||||
(list (make-constant 'apply)
|
|
||||||
(make-constant "~s is not a procedure")
|
|
||||||
x)))))]
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(include "libprimops.ss")
|
|
||||||
|
|
||||||
(define (specify-representation x)
|
|
||||||
(define who 'specify-representation)
|
|
||||||
;;;
|
|
||||||
(define fixnum-scale 4)
|
|
||||||
(define fixnum-shift 2)
|
|
||||||
(define fixnum-tag 0)
|
|
||||||
(define fixnum-mask 3)
|
|
||||||
(define pcb-dirty-vector-offset 28)
|
|
||||||
;;;
|
|
||||||
(define nop (make-primcall 'nop '()))
|
|
||||||
;;;
|
|
||||||
(define (Effect x)
|
|
||||||
]
|
|
||||||
[(forcall op arg*)
|
|
||||||
(make-forcall op (map Value arg*))]
|
|
||||||
[(funcall rator arg*)
|
|
||||||
(make-funcall (Function rator) (map Value arg*))]
|
|
||||||
[(jmpcall label rator arg*)
|
|
||||||
(make-jmpcall label (Value rator) (map Value arg*))]
|
|
||||||
[(mvcall rator x)
|
|
||||||
(make-mvcall (Value rator) (Clambda x Effect))]
|
|
||||||
[else (error who "invalid effect expr ~s" x)]))
|
|
||||||
;;;
|
|
||||||
;;;
|
|
||||||
;;;
|
|
||||||
;;;
|
|
||||||
;;; value
|
|
||||||
;;;
|
|
||||||
(define (ClambdaCase x k)
|
|
||||||
(record-case x
|
|
||||||
[(clambda-case info body)
|
|
||||||
(make-clambda-case info (k body))]
|
|
||||||
[else (error who "invalid clambda-case ~s" x)]))
|
|
||||||
;;;
|
|
||||||
(define (Clambda x k)
|
|
||||||
(record-case x
|
|
||||||
[(clambda label case* free*)
|
|
||||||
(make-clambda label
|
|
||||||
(map (lambda (x) (ClambdaCase x k)) case*)
|
|
||||||
free*)]
|
|
||||||
[else (error who "invalid clambda ~s" x)]))
|
|
||||||
;;;
|
|
||||||
(define (error-codes)
|
|
||||||
(define (code-list symbol)
|
|
||||||
(define L1 (gensym))
|
|
||||||
(define L2 (gensym))
|
|
||||||
`(0
|
|
||||||
[movl (disp ,(- disp-symbol-value symbol-tag) (obj ,symbol)) ,cp-register]
|
|
||||||
[andl ,closure-mask ,cp-register]
|
|
||||||
[cmpl ,closure-tag ,cp-register]
|
|
||||||
[jne (label ,L1)]
|
|
||||||
[movl (disp ,(- disp-symbol-value symbol-tag) (obj ,symbol)) ,cp-register]
|
|
||||||
[movl ,cp-register (disp ,(- disp-symbol-function symbol-tag) (obj ,symbol))]
|
|
||||||
[jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]
|
|
||||||
[label ,L1]
|
|
||||||
[movl (disp ,(- disp-symbol-value symbol-tag) (obj ,symbol)) %eax]
|
|
||||||
[cmpl ,unbound %eax]
|
|
||||||
[je (label ,L2)]
|
|
||||||
[movl (obj apply) (disp -4 %esp)]
|
|
||||||
[movl (obj "~s is not a procedure") (disp -8 %esp)]
|
|
||||||
[movl %eax (disp -12 %esp)]
|
|
||||||
[movl (obj error) ,cp-register]
|
|
||||||
[movl (disp ,(- disp-symbol-system-value symbol-tag)
|
|
||||||
,cp-register) ,cp-register]
|
|
||||||
[movl ,(argc-convention 3) %eax]
|
|
||||||
[jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]
|
|
||||||
[label ,L2]
|
|
||||||
[movl (obj ,symbol) (disp -4 %esp)]
|
|
||||||
[movl (obj top-level-value) ,cp-register]
|
|
||||||
[movl (disp ,(- disp-symbol-system-value symbol-tag)
|
|
||||||
,cp-register) ,cp-register]
|
|
||||||
[movl ,(argc-convention 1) %eax]
|
|
||||||
[jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]))
|
|
||||||
(let ([ls encountered-symbol-calls])
|
|
||||||
(let ([c* (map code-list ls)])
|
|
||||||
(let ([c* (list*->code* (lambda (x) #f) c*)])
|
|
||||||
(let ([p* (map (lambda (x) ($code->closure x)) c*)])
|
|
||||||
(let f ([ls ls] [p* p*])
|
|
||||||
(cond
|
|
||||||
[(null? ls) (prm 'nop)]
|
|
||||||
[else
|
|
||||||
(make-seq
|
|
||||||
(tbind ([p (Value (K (car p*)))] [s (Value (K (car ls)))])
|
|
||||||
(Effect (prm '$init-symbol-function! s p)))
|
|
||||||
(f (cdr ls) (cdr p*)))])))))))
|
|
||||||
(define (Program x)
|
|
||||||
(record-case x
|
|
||||||
[(codes code* body)
|
|
||||||
(let ([code* (map (lambda (x) (Clambda x Value)) code*)]
|
|
||||||
[body (Value body)])
|
|
||||||
(make-codes code*
|
|
||||||
(make-seq (error-codes) body)))]
|
|
||||||
[else (error who "invalid program ~s" x)]))
|
|
||||||
;;;
|
|
||||||
;(print-code x)
|
|
||||||
(Program x))
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -100,8 +100,10 @@
|
||||||
(let-values ([(lhs* rhs* arg*) (S* (cdr ls))])
|
(let-values ([(lhs* rhs* arg*) (S* (cdr ls))])
|
||||||
(let ([a (car ls)])
|
(let ([a (car ls)])
|
||||||
(cond
|
(cond
|
||||||
[(or (constant? a) (var? a))
|
[(constant? a)
|
||||||
(values lhs* rhs* (cons a arg*))]
|
(values lhs* rhs* (cons a arg*))]
|
||||||
|
;[(var? a)
|
||||||
|
; (values lhs* rhs* (cons a arg*))]
|
||||||
[else
|
[else
|
||||||
(let ([t (unique-var 'tmp)])
|
(let ([t (unique-var 'tmp)])
|
||||||
(values (cons t lhs*) (cons (V a) rhs*) (cons t arg*)))])))]))
|
(values (cons t lhs*) (cons (V a) rhs*) (cons t arg*)))])))]))
|
||||||
|
|
@ -110,8 +112,11 @@
|
||||||
[(null? lhs*) (k args)]
|
[(null? lhs*) (k args)]
|
||||||
[else
|
[else
|
||||||
(make-bind lhs* rhs* (k args))])))
|
(make-bind lhs* rhs* (k args))])))
|
||||||
|
|
||||||
(define (cogen-primop x ctxt args)
|
(define (cogen-primop x ctxt args)
|
||||||
|
(define (interrupt? x)
|
||||||
|
(record-case x
|
||||||
|
[(primcall x) (eq? x 'interrupt)]
|
||||||
|
[else #f]))
|
||||||
(cond
|
(cond
|
||||||
[(getprop x cookie) =>
|
[(getprop x cookie) =>
|
||||||
(lambda (p)
|
(lambda (p)
|
||||||
|
|
@ -125,36 +130,39 @@
|
||||||
[(PH-p-handled? p)
|
[(PH-p-handled? p)
|
||||||
(apply (PH-p-handler p) args)]
|
(apply (PH-p-handler p) args)]
|
||||||
[(PH-v-handled? p)
|
[(PH-v-handled? p)
|
||||||
(prm '!=
|
(let ([e (apply (PH-v-handler p) args)])
|
||||||
(apply (PH-v-handler p) args)
|
(if (interrupt? e) e (prm '!= e (K bool-f))))]
|
||||||
(K bool-f))]
|
|
||||||
[(PH-e-handled? p)
|
[(PH-e-handled? p)
|
||||||
(make-seq (apply (PH-e-handler p) args) (K #t))]
|
(let ([e (apply (PH-e-handler p) args)])
|
||||||
|
(if (interrupt? e) e (make-seq e (K #t))))]
|
||||||
[else (error 'cogen-primop "~s is not handled" x)])]
|
[else (error 'cogen-primop "~s is not handled" x)])]
|
||||||
[(V)
|
[(V)
|
||||||
(cond
|
(cond
|
||||||
[(PH-v-handled? p)
|
[(PH-v-handled? p)
|
||||||
(apply (PH-v-handler p) args)]
|
(apply (PH-v-handler p) args)]
|
||||||
[(PH-p-handled? p)
|
[(PH-p-handled? p)
|
||||||
(make-conditional
|
(let ([e (apply (PH-p-handler p) args)])
|
||||||
(apply (PH-p-handler p) args)
|
(if (interrupt? e)
|
||||||
(K bool-t)
|
e
|
||||||
(K bool-f))]
|
(make-conditional e (K bool-t) (K bool-f))))]
|
||||||
[(PH-e-handled? p)
|
[(PH-e-handled? p)
|
||||||
(make-seq (apply (PH-e-handler p) args) (K void-object))]
|
(let ([e (apply (PH-e-handler p) args)])
|
||||||
|
(if (interrupt? e) e (make-seq e (K void-object))))]
|
||||||
[else (error 'cogen-primop "~s is not handled" x)])]
|
[else (error 'cogen-primop "~s is not handled" x)])]
|
||||||
[(E)
|
[(E)
|
||||||
(cond
|
(cond
|
||||||
[(PH-e-handled? p)
|
[(PH-e-handled? p)
|
||||||
(apply (PH-e-handler p) args)]
|
(apply (PH-e-handler p) args)]
|
||||||
[(PH-p-handled? p)
|
[(PH-p-handled? p)
|
||||||
(make-conditional
|
(let ([e (apply (PH-p-handler p) args)])
|
||||||
(apply (PH-p-handler p) args)
|
(if (interrupt? e)
|
||||||
(prm 'nop)
|
e
|
||||||
(prm 'nop))]
|
(make-conditional e (prm 'nop) (prm 'nop))))]
|
||||||
[(PH-v-handled? p)
|
[(PH-v-handled? p)
|
||||||
(with-tmp ([t (apply (PH-v-handler p) args)])
|
(let ([e (apply (PH-v-handler p) args)])
|
||||||
(prm 'nop))]
|
(if (interrupt? e)
|
||||||
|
e
|
||||||
|
(with-tmp ([t e]) (prm 'nop))))]
|
||||||
[else (error 'cogen-primop "~s is not handled" x)])]
|
[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)]))
|
[else (error 'cogen-primop "~s is not a prim" x)]))
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,21 @@
|
||||||
|
|
||||||
|
(add-tests-with-string-output "allocating procedures live-across a call"
|
||||||
|
[(let ([g
|
||||||
|
(lambda (y)
|
||||||
|
(let ([f (lambda (x) y)])
|
||||||
|
(map f '(1 2 3))
|
||||||
|
(map f '(1 2 3))))])
|
||||||
|
(g 2)) => "(2 2 2)\n"]
|
||||||
|
[(let ()
|
||||||
|
(define (mklist i ac)
|
||||||
|
(cond
|
||||||
|
[(#%$fxzero? i) ac]
|
||||||
|
[else (mklist (#%$fxsub1 i) (#%cons i ac))]))
|
||||||
|
(define (leng ls n)
|
||||||
|
(cond
|
||||||
|
[(null? ls) n]
|
||||||
|
[else (leng (#%$cdr ls) (#%$fxadd1 n))]))
|
||||||
|
(leng (mklist 10000000 '()) 0)) => "10000000\n"]
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
Loading…
Reference in New Issue