diff --git a/benchmarks/bench b/benchmarks/bench index d9f6871..5d98b2f 100755 --- a/benchmarks/bench +++ b/benchmarks/bench @@ -1204,10 +1204,10 @@ chicken-int) NAME='Chicken-int' SUFFIXCODE="; %s %s" case "$setting" in r5rs) - REPLCOMMANDS="(begin (load \"%s.scm\") (main))" + REPLCOMMANDS="(begin (time (load \"%s.scm\")) (main))" ;; r6rs) - REPLCOMMANDS="(begin (import scheme) (load \"%s.scm\") (main))" + REPLCOMMANDS="(begin (import scheme) (time (load \"%s.scm\")) (main))" ;; esac ;; diff --git a/benchmarks/prefix/prefix-ikarus.scm b/benchmarks/prefix/prefix-ikarus.scm index 25c77e5..ead8ffe 100644 --- a/benchmarks/prefix/prefix-ikarus.scm +++ b/benchmarks/prefix/prefix-ikarus.scm @@ -1,7 +1,14 @@ ;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) (let loop ((i 0) (result (list 'undefined))) diff --git a/benchmarks/results.Larceny-r6rs b/benchmarks/results.Larceny-r6rs index 2cd5db8..531c576 100644 --- a/benchmarks/results.Larceny-r6rs +++ b/benchmarks/results.Larceny-r6rs @@ -5289,3 +5289,214 @@ Words allocated: 0 Words reclaimed: 0 Elapsed time...: 500 ms (User: 373 ms; System: 126 ms) 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.) diff --git a/bin/ikarus b/bin/ikarus index 0f000b3..0e7ab32 100755 Binary files a/bin/ikarus and b/bin/ikarus differ diff --git a/bin/ikarus-flonums.c b/bin/ikarus-flonums.c index d447537..5e62f97 100644 --- a/bin/ikarus-flonums.c +++ b/bin/ikarus-flonums.c @@ -6,18 +6,6 @@ #include -#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 ikrt_string_to_flonum(ikp x, ikpcb* pcb){ double v = strtod(string_data(x), NULL); @@ -75,6 +63,36 @@ ikrt_fl_sin(ikp x, ikpcb* pcb){ 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 ikrt_fx_sin(ikp x, ikpcb* pcb){ ikp r = ik_alloc(pcb, flonum_size) + vector_tag; @@ -83,6 +101,34 @@ ikrt_fx_sin(ikp x, ikpcb* pcb){ 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 ikrt_bignum_to_flonum(ikp x, ikpcb* pcb){ - fprintf(stderr, "ERR in bignum_to_flonum\n"); - exit(-1); + ikp r = ik_alloc(pcb, flonum_size) + vector_tag; + 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 diff --git a/bin/ikarus-numerics.c b/bin/ikarus-numerics.c index 47436dc..e66ba2d 100644 --- a/bin/ikarus-numerics.c +++ b/bin/ikarus-numerics.c @@ -156,7 +156,7 @@ ikrt_fxbnplus(ikp x, ikp y, ikpcb* pcb){ } } else { - fprintf(stderr, "this case 0x%08x\n", intx); + //fprintf(stderr, "this case 0x%08x\n", intx); /* positive fx + negative bn = smaller negative bn */ ikp r = ik_alloc(pcb, align(disp_bignum_data+limb_count*wordsize)); int borrow = mpn_sub_1((mp_limb_t*)(r+disp_bignum_data), diff --git a/src/altmakefile.ss b/src/altmakefile.ss new file mode 100755 index 0000000..f6cd0c6 --- /dev/null +++ b/src/altmakefile.ss @@ -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>=? 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>=? 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 diff --git a/src/dotests.ss b/src/dotests.ss new file mode 100755 index 0000000..c83f444 --- /dev/null +++ b/src/dotests.ss @@ -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) diff --git a/src/ikarus.boot b/src/ikarus.boot index 1861a7f..e19318a 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libnumerics.ss b/src/libnumerics.ss index cd10ce6..25b933a 100644 --- a/src/libnumerics.ss +++ b/src/libnumerics.ss @@ -19,12 +19,6 @@ (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) (foreign-call "ikrt_fixnum_to_flonum" x)) (define (bignum->flonum x) @@ -806,6 +800,27 @@ [(fixnum? x) (foreign-call "ikrt_fx_sin" 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! 'odd? odd?) (primitive-set! 'max max) diff --git a/src/makefile.ss b/src/makefile.ss index 152cea9..6338421 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -99,7 +99,7 @@ string->number exact->inexact flonum? flonum->string string->flonum - sin + sin cos atan sqrt )) (define system-primitives diff --git a/src/pass-specify-rep-primops.ss b/src/pass-specify-rep-primops.ss index 68a255b..0d13233 100644 --- a/src/pass-specify-rep-primops.ss +++ b/src/pass-specify-rep-primops.ss @@ -1,3 +1,10 @@ + +(define-syntax section + (syntax-rules (/section) + [(section e* ... /section) (begin e* ...)])) + +(section ;;; helpers + (define (prm op . arg*) (make-primcall op arg*)) @@ -22,7 +29,6 @@ (interrupt-unless (tag-test x mask tag)) (prm 'mref x (K (- disp tag))))) - (define (dirty-vector-set address) (prm 'mset (prm 'int+ @@ -53,7 +59,6 @@ (mem-assign v x i))] [else (mem-assign v x i)])) - (define (align-code unknown-amt known-amt) (prm 'sll (prm 'sra @@ -61,11 +66,7 @@ (K (+ known-amt (sub1 object-alignment)))) (K align-shift)) (K align-shift))) - - -(define-syntax section - (syntax-rules (/section) - [(section e* ... /section) (begin e* ...)])) +/section) (section ;;; simple objects section @@ -659,7 +660,23 @@ /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) (record-case x @@ -1323,140 +1340,4 @@ /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)) diff --git a/src/pass-specify-rep.ss b/src/pass-specify-rep.ss index e310e03..3a1e475 100644 --- a/src/pass-specify-rep.ss +++ b/src/pass-specify-rep.ss @@ -100,8 +100,10 @@ (let-values ([(lhs* rhs* arg*) (S* (cdr ls))]) (let ([a (car ls)]) (cond - [(or (constant? a) (var? a)) + [(constant? a) (values lhs* rhs* (cons a arg*))] + ;[(var? a) + ; (values lhs* rhs* (cons a arg*))] [else (let ([t (unique-var 'tmp)]) (values (cons t lhs*) (cons (V a) rhs*) (cons t arg*)))])))])) @@ -110,8 +112,11 @@ [(null? lhs*) (k args)] [else (make-bind lhs* rhs* (k args))]))) - (define (cogen-primop x ctxt args) + (define (interrupt? x) + (record-case x + [(primcall x) (eq? x 'interrupt)] + [else #f])) (cond [(getprop x cookie) => (lambda (p) @@ -125,36 +130,39 @@ [(PH-p-handled? p) (apply (PH-p-handler p) args)] [(PH-v-handled? p) - (prm '!= - (apply (PH-v-handler p) args) - (K bool-f))] + (let ([e (apply (PH-v-handler p) args)]) + (if (interrupt? e) e (prm '!= e (K bool-f))))] [(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)])] [(V) (cond [(PH-v-handled? p) (apply (PH-v-handler p) args)] [(PH-p-handled? p) - (make-conditional - (apply (PH-p-handler p) args) - (K bool-t) - (K bool-f))] + (let ([e (apply (PH-p-handler p) args)]) + (if (interrupt? e) + e + (make-conditional e (K bool-t) (K bool-f))))] [(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)])] [(E) (cond [(PH-e-handled? p) (apply (PH-e-handler p) args)] [(PH-p-handled? p) - (make-conditional - (apply (PH-p-handler p) args) - (prm 'nop) - (prm 'nop))] + (let ([e (apply (PH-p-handler p) args)]) + (if (interrupt? e) + e + (make-conditional e (prm 'nop) (prm 'nop))))] [(PH-v-handled? p) - (with-tmp ([t (apply (PH-v-handler p) args)]) - (prm 'nop))] + (let ([e (apply (PH-v-handler p) args)]) + (if (interrupt? e) + e + (with-tmp ([t e]) (prm 'nop))))] [else (error 'cogen-primop "~s is not handled" x)])] [else (error 'cogen-primop "invalid context ~s" ctxt)]))))))] [else (error 'cogen-primop "~s is not a prim" x)])) diff --git a/src/tests/tests-new.scm b/src/tests/tests-new.scm new file mode 100644 index 0000000..d6045ab --- /dev/null +++ b/src/tests/tests-new.scm @@ -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"] + ) + +