diff --git a/benchmarks/bench b/benchmarks/bench index 7b658a9..d965173 100755 --- a/benchmarks/bench +++ b/benchmarks/bench @@ -1189,7 +1189,7 @@ chicken-int) NAME='Chicken-int' esac ;; - ikarus) NAME='Ikarus-Scheme' + ikarus) NAME='Ikarus' COMP=ikarus_comp COMPOPTS="" EXEC=ikarus_exec diff --git a/benchmarks/results.Ikarus-Scheme-r6rs b/benchmarks/results.Ikarus-Scheme-r6rs deleted file mode 100644 index 87ea31e..0000000 --- a/benchmarks/results.Ikarus-Scheme-r6rs +++ /dev/null @@ -1,585 +0,0 @@ - -**************************** -Benchmarking Ikarus-Scheme-r6rs on Sat Jan 20 19:09:21 EST 2007 under Darwin 10-231-80-30.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 boyer under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 17 collections - 1.024s real 1.008s user 0.010s sys - 72832056 bytes allocated - -Testing browse under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 151 collections - 2.578s real 2.526s user 0.039s sys - 633609656 bytes allocated - -Testing cpstak under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 243 collections - 2.605s real 2.534s user 0.053s sys - 1017728056 bytes allocated - -Testing ctak under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 127 collections - 1.363s real 1.118s user 0.236s sys - 534317320 bytes allocated - -Testing dderiv under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 248 collections - 1.486s real 1.463s user 0.016s sys - 1040000056 bytes allocated - -Testing deriv under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 187 collections - 0.984s real 0.963s user 0.015s sys - 784000056 bytes allocated - -Testing destruc under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 61 collections - 3.416s real 3.378s user 0.022s sys - 257444056 bytes allocated - -Testing diviter under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 191 collections - 1.973s real 1.944s user 0.017s sys - 800000056 bytes allocated - -Testing divrec under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 191 collections - 1.995s real 1.972s user 0.016s sys - 800000056 bytes allocated - -Testing puzzle under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 17 collections - 4.453s real 4.426s user 0.017s sys - 70742488 bytes allocated - -Testing takl under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - no collections - 1.524s real 1.519s user 0.002s sys - 48 bytes allocated - -Testing triangl under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - no collections - 5.408s real 5.387s user 0.007s sys - 930048 bytes allocated - -Testing fft under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -Error in top-level-value: / is unbound. -> - -Testing fib under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - no collections - 7.563s real 7.531s user 0.010s sys - 48 bytes allocated - -Testing fibfp under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -Error in <: 35.0 is not a number. -> - -Testing mbrot under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -Error in >: 0.4138 is not a number. -> - -Testing pnpoly under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> Error in andmap: vararg not supported yet. -> - -Testing sum under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - no collections - 6.137s real 6.116s user 0.008s sys - 80048 bytes allocated - -Testing sumfp under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -Error in <: 10000.0 is not a number. -> - -Testing tak under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - no collections - 3.974s real 3.960s user 0.005s sys - 48 bytes allocated - -Testing ack under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - no collections - 0.500s real 0.498s user 0.000s sys - 48 bytes allocated - -Testing array1 under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 40 collections - 2.139s real 2.094s user 0.039s sys - 160005672 bytes allocated - -Testing cat under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - no collections - 0.220s real 0.175s user 0.043s sys - 34520 bytes allocated - -Testing string under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 10 collections - 0.303s real 0.291s user 0.011s sys - 31464952 bytes allocated - -Testing sum1 under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -./bench: line 1400: 29584 Done printf "$REPLCOMMANDS" "$1" - 29585 Segmentation fault | ikarus - -Testing sumloop under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - no collections - 5.110s real 5.090s user 0.005s sys - 64 bytes allocated - -Testing tail under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 18 collections - 0.567s real 0.478s user 0.087s sys - 77128368 bytes allocated - -Testing wc under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - no collections - 0.350s real 0.344s user 0.005s sys - 12960 bytes allocated - -Testing conform under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 38 collections - 1.370s real 1.352s user 0.017s sys - 162415416 bytes allocated - -Testing dynamic under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 11 collections - 0.618s real 0.604s user 0.013s sys - 44168760 bytes allocated - -Testing earley under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -Error: BUG in borrow - -Testing fibc under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 80 collections - 1.468s real 1.320s user 0.146s sys - 334408904 bytes allocated - -Testing graphs under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 189 collections - 2.292s real 2.244s user 0.048s sys - 790269656 bytes allocated - -Testing lattice under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 91 collections - 1.646s real 1.620s user 0.025s sys - 381967088 bytes allocated - -Testing matrix under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -Error in top-level-value: modulo is unbound. -> - -Testing maze under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -Error in top-level-value: modulo is unbound. -> - -Testing mazefun under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -Error in top-level-value: modulo is unbound. -> - -Testing nqueens under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 65 collections - 3.409s real 3.396s user 0.012s sys - 274320056 bytes allocated - -Testing paraffins under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 198 collections - 1.478s real 1.192s user 0.285s sys - 831232056 bytes allocated - -Testing peval under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 36 collections - 1.026s real 1.012s user 0.013s sys - 151770008 bytes allocated - -Testing primes under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -Error in top-level-value: modulo is unbound. -> - -Testing ray under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> Error in tokenize: invalid number syntax: 1e. -> - -Testing scheme under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> Error in top-level-value: / is unbound. -> - -Testing simplex under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> Error in tokenize: invalid number syntax: 1e. -> - -Testing slatex under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 9 collections - 1.944s real 0.499s user 0.992s sys - 36085736 bytes allocated - -Testing perm9 under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 40 collections - 2.512s real 2.314s user 0.197s sys - 170498936 bytes allocated - -Testing nboyer under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 49 collections - 1.562s real 1.551s user 0.009s sys - 203661656 bytes allocated - -Testing sboyer under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 16 collections - 1.590s real 1.580s user 0.008s sys - 66159256 bytes allocated - -Testing gcbench under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> The garbage collector should touch about 32 megabytes of heap storage. -The use of more or less memory will skew the results. - -Garbage Collector Test - Stretching memory with a binary tree of depth 18 - Total memory available= ???????? bytes Free memory= ???????? bytes -GCBench: Main - Creating a long-lived binary tree of depth 16 - Creating a long-lived array of 524284 inexact reals -Error in top-level-value: / is unbound. -> - -Testing parsing under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> -running stats for (run-bench name count ok? run): - 41 collections - 4.876s real 4.859s user 0.017s sys - 171456072 bytes allocated - -Testing gcold under Ikarus-Scheme-r6rs -Compiling... -Running... -Ikarus Scheme (Build 2007-01-20) -Copyright (c) 2006-2007 Abdulaziz Ghuloum - -> Error in top-level-value: gcold is unbound. -> diff --git a/benchmarks/src/gcold.scm b/benchmarks/src/gcold.scm index 9c4247a..7d01ac7 100644 --- a/benchmarks/src/gcold.scm +++ b/benchmarks/src/gcold.scm @@ -193,7 +193,7 @@ (do ((i 0 (+ i 1))) ((>= i ntrees)) (vector-set! trees i (makeTree treeHeight)) - (doYoungGenAlloc (* promoteRate ntrees treesize) words/dead)) + (doYoungGenAlloc (* promoteRate ntrees treeSize) words/dead)) (println " (" nodes " nodes)"))) ; Confirms that all trees are balanced and have the correct height. @@ -381,4 +381,4 @@ (+ mutatorSum (vector-length aexport)))) (define (main . args) - (gcold 25 0 10 10 gcold-iters)) + (GCOld 25 0 10 10 gcold-iters)) diff --git a/benchmarks/summarize.sch b/benchmarks/summarize.sch index e78ec3b..d1113dd 100644 --- a/benchmarks/summarize.sch +++ b/benchmarks/summarize.sch @@ -9,13 +9,15 @@ (string-append in setting) (string-append out setting)))))) - ((summarize bigloo-results) "results.Bigloo" "summary.Bigloo") - ((summarize chez-results) "results.Chez-Scheme" "summary.Chez") - ((summarize chicken-results) "results.Chicken" "summary.Chicken") - ((summarize gambit-results) "results.Gambit-C" "summary.Gambit") + ;((summarize bigloo-results) "results.Bigloo" "summary.Bigloo") + ;((summarize chez-results) "results.Chez-Scheme" "summary.Chez") + ((summarize ikarus-results) "results.Ikarus-Scheme" "summary.Ikarus") + ;((summarize chicken-results) "results.Chicken" "summary.Chicken") + ;((summarize gambit-results) "results.Gambit-C" "summary.Gambit") ((summarize larceny-results) "results.Larceny" "summary.Larceny") - ((summarize mzscheme-results) "results.MzScheme" "summary.MzScheme") - ((summarize scheme48-results) "results.Scheme48" "summary.Scheme48"))) + ;((summarize mzscheme-results) "results.MzScheme" "summary.MzScheme") + ;((summarize scheme48-results) "results.Scheme48" "summary.Scheme48") + )) (define (decode-usual-suspects . rest) (let* ((setting (if (null? rest) "-r6rs" (car rest))) @@ -24,12 +26,14 @@ (decode-summary (string-append in setting))))) (map decode-summary '("summary.Larceny" - "summary.Bigloo" - "summary.Chez" - "summary.Chicken" - "summary.Gambit" - "summary.MzScheme" - "summary.Scheme48")))) + ;"summary.Bigloo" + ;"summary.Chez" + ;"summary.Chicken" + ;"summary.Gambit" + "summary.Ikarus" + ;"summary.MzScheme" + ;"summary.Scheme48" + )))) (define (summarize-usual-suspects-linux . rest) (let* ((setting (if (null? rest) "-r6rs" (car rest))) @@ -47,6 +51,7 @@ ((summarize larceny-results) "results.Larceny" "summary.Larceny") ((summarize mit-results) "results.MIT-Scheme" "summary.MIT") ((summarize mzscheme-results) "results.MzScheme" "summary.MzScheme") + ((summarize ikarus-results) "results.Ikarus" "summary.Ikarus") ((summarize petite-chez-results) "results.Petite-Chez-Scheme" "summary.Petite") ((summarize scheme48-results) "results.Scheme48" "summary.Scheme48"))) @@ -58,13 +63,15 @@ (map decode-summary '(;"summary.Henchman" "summary.Larceny" - "summary.Bigloo" - "summary.Chicken" - "summary.Gambit" - "summary.MIT" - "summary.MzScheme" - "summary.Petite" - "summary.Scheme48")))) + ;"summary.Bigloo" + ;"summary.Chicken" + ;"summary.Gambit" + "summary.Ikarus" + ;"summary.MIT" + ;"summary.MzScheme" + ;"summary.Petite" + ;"summary.Scheme48" + )))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; @@ -356,7 +363,7 @@ (display (make-string name-width #\space) out))) (loop (cdr lines) real))))))) -; Chez Scheme. +; Chez and Ikarus Scheme. (define (chez-results lines out) (chez-results-proto "Chez-Scheme" lines out)) @@ -364,6 +371,9 @@ (define (petite-chez-results lines out) (chez-results-proto "Petite-Chez-Scheme" lines out)) +(define (ikarus-results lines out) + (chez-results-proto "Ikarus" lines out)) + (define (chez-results-proto sysname lines out) (let ((system-key "Benchmarking ") (test-key "Testing ") @@ -371,7 +381,7 @@ (cpu-key " ms elapsed cpu time") (real-key " ms elapsed real time") (space-key " ") - (error-key "Error: ") + (error-key "Error") (wrong-key "*** wrong result ***")) (let ((n-system-key (string-length system-key)) (n-test-key (string-length test-key)) @@ -407,17 +417,18 @@ (let ((x (substring line n-space-key (substring? real-key line)))) - (right-justify x timing-width out) - (newline out))) + (right-justify x timing-width out))) ((substring=? error-key line 0 n-error-key) (display line out) - (newline out) - (display (make-string name-width #\space) out)) + ;(newline out) + ;(display (make-string name-width #\space) out) + ) ((substring=? wrong-key line 0 n-wrong-key) (display " " out) (display line out) (newline out) (display (make-string name-width #\space) out))) + ;(flush-output-port out) (loop (cdr lines)))))))) ; Larceny diff --git a/bin/ikarus b/bin/ikarus index cc1f21f..c865636 100755 Binary files a/bin/ikarus and b/bin/ikarus differ diff --git a/bin/ikarus-collect.c b/bin/ikarus-collect.c index 60d7330..0c5f459 100644 --- a/bin/ikarus-collect.c +++ b/bin/ikarus-collect.c @@ -1053,6 +1053,14 @@ add_object_proc(gc_t* gc, ikp x) ref(x, wordsize-vector_tag) = new; return new; } + else if(fst == flonum_tag){ + ikp new = gc_alloc_new_data(flonum_size, gen, gc) + vector_tag; + ref(new, -vector_tag) = flonum_tag; + flonum_data(new) = flonum_data(x); + ref(x, -vector_tag) = forward_ptr; + ref(x, wordsize-vector_tag) = new; + return new; + } else { fprintf(stderr, "unhandled vector with fst=0x%08x\n", (int)fst); exit(-1); diff --git a/bin/ikarus-data.h b/bin/ikarus-data.h index b45f849..b1faae8 100644 --- a/bin/ikarus-data.h +++ b/bin/ikarus-data.h @@ -196,9 +196,10 @@ #define disp_bignum_data wordsize #define off_bignum_data (disp_bignum_data - vector_tag) -#define flonum_tag ((ikp)0xFF) +#define flonum_tag ((ikp)0x6F) #define flonum_size 16 #define disp_flonum_data 8 #define off_flonum_data (disp_flonum_data - vector_tag) +#define flonum_data(x) (*((double*)(((ikp)(x))+off_flonum_data))) #endif diff --git a/bin/ikarus-flonums.c b/bin/ikarus-flonums.c new file mode 100644 index 0000000..244c7aa --- /dev/null +++ b/bin/ikarus-flonums.c @@ -0,0 +1,154 @@ + +#include "ikarus.h" +#include +#include +#include +#include + + +ikp +ikrt_is_flonum(ikp x){ + if(tagof(x) == vector_tag){ + if (ref(x, -vector_tag) == flonum_tag){ + return true_object; + } + } + return false_object; +} + +ikp +ikrt_string_to_flonum(ikp x, ikpcb* pcb){ + double v = strtod(string_data(x), NULL); + ikp r = ik_alloc(pcb, flonum_size) + vector_tag; + ref(r, -vector_tag) = (ikp)flonum_tag; + flonum_data(r) = v; + return r; +} + +ikp +ikrt_fl_plus(ikp x, ikp y,ikpcb* pcb){ + ikp r = ik_alloc(pcb, flonum_size) + vector_tag; + ref(r, -vector_tag) = (ikp)flonum_tag; + flonum_data(r) = flonum_data(x) + flonum_data(y); + return r; +} + +ikp +ikrt_fl_minus(ikp x, ikp y,ikpcb* pcb){ + ikp r = ik_alloc(pcb, flonum_size) + vector_tag; + ref(r, -vector_tag) = (ikp)flonum_tag; + flonum_data(r) = flonum_data(x) - flonum_data(y); + return r; +} + +ikp +ikrt_fl_times(ikp x, ikp y,ikpcb* pcb){ + ikp r = ik_alloc(pcb, flonum_size) + vector_tag; + ref(r, -vector_tag) = (ikp)flonum_tag; + flonum_data(r) = flonum_data(x) * flonum_data(y); + return r; +} + +ikp +ikrt_fl_div(ikp x, ikp y,ikpcb* pcb){ + ikp r = ik_alloc(pcb, flonum_size) + vector_tag; + ref(r, -vector_tag) = (ikp)flonum_tag; + flonum_data(r) = flonum_data(x) / flonum_data(y); + return r; +} + +ikp +ikrt_fl_invert(ikp x, ikpcb* pcb){ + ikp r = ik_alloc(pcb, flonum_size) + vector_tag; + ref(r, -vector_tag) = (ikp)flonum_tag; + flonum_data(r) = 1.0 / flonum_data(x); + return r; +} + +ikp +ikrt_fl_sin(ikp x, ikpcb* pcb){ + ikp r = ik_alloc(pcb, flonum_size) + vector_tag; + ref(r, -vector_tag) = (ikp)flonum_tag; + flonum_data(r) = sin(flonum_data(x)); + return r; +} + +ikp +ikrt_fx_sin(ikp x, ikpcb* pcb){ + ikp r = ik_alloc(pcb, flonum_size) + vector_tag; + ref(r, -vector_tag) = (ikp)flonum_tag; + flonum_data(r) = sin(unfix(x)); + return r; +} + + + + + + + +ikp +ikrt_flonum_to_string(ikp x, ikpcb* pcb){ + if(tagof(x) == vector_tag){ + if(ref(x,-vector_tag) == flonum_tag){ + char buff[80]; + int n = snprintf(buff, sizeof(buff)-2, "%.12G", flonum_data(x)); + if(n >= 0){ + int i=0; + while ((i> bignum_length_shift; + if(limb_count <= 0){ + fprintf(stderr, + "Error in (%s) invalid limb count in fst=0x%08x\n", + caller, (int)fst); + exit(-1); + } + int pos; + if((int)fst & bignum_sign_mask){ + pos = 0; + } else { + pos = 1; + } + unsigned int last_limb = + (unsigned int) ref(x, off_bignum_data + (limb_count - 1) * wordsize); + if(last_limb == 0){ + fprintf(stderr, + "Error in (%s) invalid last limb = 0x%08x", caller, last_limb); + exit(-1); + } + if(limb_count == 1){ + if(pos){ + if(last_limb <= most_positive_fixnum){ + fprintf(stderr, + "Error in (%s) should be a positive fixnum: 0x%08x\n", + caller, last_limb); + exit(-1); + } + } else { + if(last_limb <= most_negative_fixnum){ + fprintf(stderr, + "Error in (%s) should be a negative fixnum: 0x%08x\n", + caller, last_limb); + exit(-1); + } + } + } + /* ok */ + return x; +} + +#define BN(x) verify_bignum(x,"BN") + ikp ikrt_isbignum(ikp x){ if(tagof(x) == vector_tag){ @@ -66,7 +116,7 @@ ikrt_fxfxplus(ikp x, ikp y, ikpcb* pcb){ (1 << bignum_sign_shift)); ref(bn, disp_bignum_data) = (ikp)-r; } - return bn+vector_tag; + return verify_bignum(bn+vector_tag, "fxfx+"); } } @@ -90,16 +140,17 @@ ikrt_fxbnplus(ikp x, ikp y, ikpcb* pcb){ (((limb_count + 1) << bignum_length_shift) | (0 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag, "fxbn+1"); } else { ref(r, 0) = (ikp) ((limb_count << bignum_length_shift) | (0 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag, "fxbn+2"); } } else { + 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), @@ -107,7 +158,7 @@ ikrt_fxbnplus(ikp x, ikp y, ikpcb* pcb){ limb_count, intx); if(borrow){ - fprintf(stderr, "Error: BUG in borrow\n"); + fprintf(stderr, "Error: BUG in borrow1 %d\n", borrow); exit(-1); } int result_size = @@ -128,7 +179,7 @@ ikrt_fxbnplus(ikp x, ikp y, ikpcb* pcb){ ((result_size << bignum_length_shift) | (1 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag, "fxbn+3"); } } else { @@ -140,7 +191,7 @@ ikrt_fxbnplus(ikp x, ikp y, ikpcb* pcb){ limb_count, - intx); if(borrow){ - fprintf(stderr, "Error: BUG in borrow\n"); + fprintf(stderr, "Error: BUG in borrow2\n"); exit(-1); } int result_size = @@ -161,7 +212,7 @@ ikrt_fxbnplus(ikp x, ikp y, ikpcb* pcb){ ((result_size << bignum_length_shift) | (0 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag, "fxbn+4"); } else { /* negative fx + negative bn = larger negative */ ikp r = ik_alloc(pcb, align(disp_bignum_data+(limb_count+1)*wordsize)); @@ -175,13 +226,13 @@ ikrt_fxbnplus(ikp x, ikp y, ikpcb* pcb){ (((limb_count + 1) << bignum_length_shift) | (1 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag, "fxbn+5"); } else { ref(r, 0) = (ikp) ((limb_count << bignum_length_shift) | (1 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag, "fxbn+5"); } } } @@ -218,13 +269,13 @@ ikrt_bnbnplus(ikp x, ikp y, ikpcb* pcb){ (((n1+1) << bignum_length_shift) | xsign | bignum_tag); - return res+vector_tag; + return verify_bignum(res+vector_tag, "bnbn+1"); } else { ref(res, 0) = (ikp) ((n1 << bignum_length_shift) | xsign | bignum_tag); - return res+vector_tag; + return verify_bignum(res+vector_tag, "bnbn+2"); } } else { @@ -283,7 +334,7 @@ ikrt_bnbnplus(ikp x, ikp y, ikpcb* pcb){ ((len << bignum_length_shift) | result_sign | bignum_tag); - return res+vector_tag; + return verify_bignum(res+vector_tag, "bnbn+3"); } else { /* negative result */ if(len == 1){ @@ -296,7 +347,7 @@ ikrt_bnbnplus(ikp x, ikp y, ikpcb* pcb){ ((len << bignum_length_shift) | result_sign | bignum_tag); - return res+vector_tag; + return verify_bignum(res+vector_tag, "bnbn+4"); } } } @@ -316,11 +367,12 @@ ikrt_fxfxminus(ikp x, ikp y, ikpcb* pcb){ ikp bn = ik_alloc(pcb, align(disp_bignum_data + wordsize)); ref(bn, 0) = (ikp) (bignum_tag | (1 << bignum_length_shift)); ref(bn, disp_bignum_data) = (ikp)r; - return bn+vector_tag; + return verify_bignum(bn+vector_tag,"fxfx-1"); } } else { - if(((unsigned int)r) <= most_negative_fixnum){ - return fix(r); + ikp fxr = fix(r); + if(unfix(fxr) == r){ + return fxr; } else { ikp bn = ik_alloc(pcb, align(disp_bignum_data + wordsize)); ref(bn, 0) = (ikp) @@ -328,7 +380,7 @@ ikrt_fxfxminus(ikp x, ikp y, ikpcb* pcb){ (1 << bignum_sign_shift) | (1 << bignum_length_shift)); ref(bn, disp_bignum_data) = (ikp)(-r); - return bn+vector_tag; + return verify_bignum(bn+vector_tag, "fxfx-2"); } } } @@ -355,7 +407,7 @@ ikrt_bnnegate(ikp x, ikpcb* pcb){ (bignum_tag | ((1 << bignum_sign_shift) - (bignum_sign_mask & (int)fst)) | (limb_count << bignum_length_shift)); - return bn+vector_tag; + return verify_bignum(bn+vector_tag, "bnneg"); } ikp @@ -378,13 +430,13 @@ ikrt_fxbnminus(ikp x, ikp y, ikpcb* pcb){ (((limb_count + 1) << bignum_length_shift) | (0 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag, "fxbn-1"); } else { ref(r, 0) = (ikp) ((limb_count << bignum_length_shift) | (0 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag, "fxbn-2"); } } else { @@ -395,7 +447,7 @@ ikrt_fxbnminus(ikp x, ikp y, ikpcb* pcb){ limb_count, intx); if(borrow){ - fprintf(stderr, "Error: BUG in borrow\n"); + fprintf(stderr, "Error: BUG in borrow3\n"); exit(-1); } int result_size = @@ -416,7 +468,7 @@ ikrt_fxbnminus(ikp x, ikp y, ikpcb* pcb){ ((result_size << bignum_length_shift) | (1 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag, "fxbn-"); } } else { @@ -428,7 +480,7 @@ ikrt_fxbnminus(ikp x, ikp y, ikpcb* pcb){ limb_count, - intx); if(borrow){ - fprintf(stderr, "Error: BUG in borrow\n"); + fprintf(stderr, "Error: BUG in borrow4\n"); exit(-1); } int result_size = @@ -449,7 +501,7 @@ ikrt_fxbnminus(ikp x, ikp y, ikpcb* pcb){ ((result_size << bignum_length_shift) | (0 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag,"fxbn-"); } else { /* negative fx - positive bn = larger negative */ ikp r = ik_alloc(pcb, align(disp_bignum_data+(limb_count+1)*wordsize)); @@ -463,13 +515,13 @@ ikrt_fxbnminus(ikp x, ikp y, ikpcb* pcb){ (((limb_count + 1) << bignum_length_shift) | (1 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag, "fxbn-"); } else { ref(r, 0) = (ikp) ((limb_count << bignum_length_shift) | (1 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag, "fxbn-"); } } } @@ -495,13 +547,13 @@ ikrt_bnfxminus(ikp x, ikp y, ikpcb* pcb){ (((limb_count + 1) << bignum_length_shift) | (0 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag,"bnfx-"); } else { ref(r, 0) = (ikp) ((limb_count << bignum_length_shift) | (0 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag,"bnfx-"); } } else { @@ -512,7 +564,7 @@ ikrt_bnfxminus(ikp x, ikp y, ikpcb* pcb){ limb_count, -inty); if(borrow){ - fprintf(stderr, "Error: BUG in borrow\n"); + fprintf(stderr, "Error: BUG in borrow5\n"); exit(-1); } int result_size = @@ -533,7 +585,7 @@ ikrt_bnfxminus(ikp x, ikp y, ikpcb* pcb){ ((result_size << bignum_length_shift) | (1 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag,"bnfx-"); } } else { @@ -545,7 +597,7 @@ ikrt_bnfxminus(ikp x, ikp y, ikpcb* pcb){ limb_count, inty); if(borrow){ - fprintf(stderr, "Error: BUG in borrow\n"); + fprintf(stderr, "Error: BUG in borrow6\n"); exit(-1); } int result_size = @@ -566,7 +618,7 @@ ikrt_bnfxminus(ikp x, ikp y, ikpcb* pcb){ ((result_size << bignum_length_shift) | (0 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag, "bnfx-"); } else { /* - positive fx + negative bn = larger negative */ ikp r = ik_alloc(pcb, align(disp_bignum_data+(limb_count+1)*wordsize)); @@ -580,13 +632,13 @@ ikrt_bnfxminus(ikp x, ikp y, ikpcb* pcb){ (((limb_count + 1) << bignum_length_shift) | (1 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag, "bnfx-"); } else { ref(r, 0) = (ikp) ((limb_count << bignum_length_shift) | (1 << bignum_sign_shift) | bignum_tag); - return r+vector_tag; + return verify_bignum(r+vector_tag, "bnfx-"); } } } @@ -623,13 +675,13 @@ ikrt_bnbnminus(ikp x, ikp y, ikpcb* pcb){ (((n1+1) << bignum_length_shift) | xsign | bignum_tag); - return res+vector_tag; + return verify_bignum(res+vector_tag, "bnbn-"); } else { ref(res, 0) = (ikp) ((n1 << bignum_length_shift) | xsign | bignum_tag); - return res+vector_tag; + return verify_bignum(res+vector_tag, "bnbn-"); } } else { @@ -690,7 +742,7 @@ ikrt_bnbnminus(ikp x, ikp y, ikpcb* pcb){ ((len << bignum_length_shift) | result_sign | bignum_tag); - return res+vector_tag; + return verify_bignum(res+vector_tag, "bnbn-"); } else { /* negative result */ if(len == 1){ @@ -703,7 +755,7 @@ ikrt_bnbnminus(ikp x, ikp y, ikpcb* pcb){ ((len << bignum_length_shift) | result_sign | bignum_tag); - return res+vector_tag; + return verify_bignum(res+vector_tag, "bnbn-"); } } } @@ -742,7 +794,7 @@ ikrt_fxfxmult(ikp x, ikp y, ikpcb* pcb){ (sign << bignum_sign_shift) | (1 << bignum_length_shift)); ref(r, disp_bignum_data) = (ikp)lo; - return r+vector_tag; + return BN(r+vector_tag); } else { ikp r = ik_alloc(pcb, align(disp_bignum_data + 2*wordsize)); ref(r, 0) = (ikp) @@ -751,7 +803,7 @@ ikrt_fxfxmult(ikp x, ikp y, ikpcb* pcb){ (2 << bignum_length_shift)); ref(r, disp_bignum_data) = (ikp)lo; ref(r, disp_bignum_data+wordsize) = (ikp)hi; - return r+vector_tag; + return BN(r+vector_tag); } } @@ -777,7 +829,7 @@ normalize_bignum(int limbs, int sign, ikp r){ (bignum_tag | sign | (limbs << bignum_length_shift)); - return r+vector_tag; + return BN(r+vector_tag); } @@ -926,7 +978,7 @@ ikrt_fxbnlogand(ikp x, ikp y, ikpcb* pcb){ ref(r, disp_bignum_data+i*wordsize) = ref(y, disp_bignum_data-vector_tag+i*wordsize); } - return r+vector_tag; + return BN(r+vector_tag); } else { /* y is positive */ int len = (((unsigned int) fst) >> bignum_length_shift); @@ -939,7 +991,7 @@ ikrt_fxbnlogand(ikp x, ikp y, ikpcb* pcb){ ref(r, disp_bignum_data+i*wordsize) = ref(y, disp_bignum_data-vector_tag+i*wordsize); } - return r+vector_tag; + return BN(r+vector_tag); } } } diff --git a/src/ikarus.boot b/src/ikarus.boot index ec7bf93..7dd6b96 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libcore.ss b/src/libcore.ss index c1e75c1..4eb4b8c 100644 --- a/src/libcore.ss +++ b/src/libcore.ss @@ -1469,6 +1469,29 @@ reference-implementation: (f a) (error who "list was altered"))] [else (error who "list was altered")]))) + (define andmap2 + (lambda (f a1 a2 d1 d2 n) + (cond + [(pair? d1) + (cond + [(pair? d2) + (if ($fxzero? n) + (error who "list was altered") + (and + (f a1 a2) + (andmap2 f + ($car d1) ($car d2) + ($cdr d1) ($cdr d2) + ($fxsub1 n))))] + [else (error who "length mismatch")])] + [(null? d1) + (cond + [(null? d2) + (if ($fxzero? n) + (f a1 a2) + (error who "list was altered"))] + [else (error who "length mismatch")])] + [else (error who "list was altered")]))) (primitive-set! 'andmap (case-lambda [(f ls) @@ -1480,7 +1503,23 @@ reference-implementation: (andmap1 f ($car ls) d (len d d 0)))] [(null? ls) #t] [else (error who "improper list")])] - [_ (error who "vararg not supported yet")]))) + [(f ls ls2) + (unless (procedure? f) + (error who "~s is not a procedure" f)) + (cond + [(pair? ls) + (if (pair? ls2) + (let ([d ($cdr ls)]) + (andmap2 f + ($car ls) ($car ls2) d ($cdr ls2) (len d d 0))) + (error who "length mismatch"))] + [(null? ls) + (if (null? ls2) + #t + (error who "length mismatch"))] + [else (error who "not a list")])] + [(f . ls*) (error who "vararg not supported yet in ~s" + (length ls*))]))) (let () diff --git a/src/libnumerics.ss b/src/libnumerics.ss index 17435e6..f475177 100644 --- a/src/libnumerics.ss +++ b/src/libnumerics.ss @@ -226,6 +226,36 @@ [(null? e*) ac] [else (f (binary* ac (car e*)) (cdr e*))]))])) + (define binary/ + (lambda (x y) + (cond + [(flonum? x) + (cond + [(flonum? y) + (foreign-call "ikrt_fl_div" x y)] + [(fixnum? y) + (foreign-call "ikrt_fl_div" x (fixnum->flonum y))] + [else (error '/ "unspported ~s ~s" x y)])] + [(fixnum? x) + (cond + [(flonum? y) + (foreign-call "ikrt_fl_div" (fixnum->flonum x) y)] + [else (error '/ "unsupported ~s ~s" x y)])] + [else (error '/ "unsupported ~s ~s" x y)]))) + + (define / + (case-lambda + [(x y) (binary/ x y)] + [(x) + (cond + [(flonum? x) (foreign-call "ikrt_fl_invert" x)] + [else (error '/ "unspported argument ~s" x)])] + [(x y z . rest) + (let f ([a (binary/ x y)] [b z] [ls rest]) + (cond + [(null? rest) (binary/ a b)] + [else (f (binary/ a b) (car ls) (cdr ls))]))])) + (define expt (lambda (n m) (cond @@ -377,9 +407,19 @@ [(flonum? x) (foreign-call "ikrt_flonum_to_string" x)] [else (error 'number->string "~s is not a number" x)]))) + (define modulo + (lambda (n m) + (cond + [(fixnum? n) + (cond + [(fixnum? m) ($fxmodulo n m)] + [else (error 'modulo "unsupported ~s" m)])] + [else (error 'modulo "unsupported ~s" n)]))) + (define-syntax mk< (syntax-rules () - [(_ name fxfx< fxbn< bnfx< bnbn<) + [(_ name fxfx< fxbn< bnfx< bnbn< + fxfl< flfx< bnfl< flbn< flfl<) (let () (define err (lambda (x) (error 'name "~s is not a number" x))) @@ -398,6 +438,12 @@ (if (fxbn< x y) (bnloopt y (car ls) (cdr ls)) (loopf (car ls) (cdr ls))))] + [(flonum? y) + (if (null? ls) + (fxfl< x y) + (if (fxfl< x y) + (flloopt y (car ls) (cdr ls)) + (loopf (car ls) (cdr ls))))] [else (err y)]))) (define bnloopt (lambda (x y ls) @@ -414,6 +460,34 @@ (if (bnbn< x y) (bnloopt y (car ls) (cdr ls)) (loopf (car ls) (cdr ls))))] + [(flonum? y) + (if (null? ls) + (bnfl< x y) + (if (bnfl< x y) + (flloopt y (car ls) (cdr ls)) + (loopf (car ls) (cdr ls))))] + [else (err y)]))) + (define flloopt + (lambda (x y ls) + (cond + [(fixnum? y) + (if (null? ls) + (flfx< x y) + (if (flfx< x y) + (fxloopt y (car ls) (cdr ls)) + (loopf (car ls) (cdr ls))))] + [(bignum? y) + (if (null? ls) + (flbn< x y) + (if (flbn< x y) + (bnloopt y (car ls) (cdr ls)) + (loopf (car ls) (cdr ls))))] + [(flonum? y) + (if (null? ls) + (flfl< x y) + (if (flfl< x y) + (flloopt y (car ls) (cdr ls)) + (loopf (car ls) (cdr ls))))] [else (err y)]))) (define loopf (lambda (x ls) @@ -428,11 +502,19 @@ (cond [(fixnum? y) (fxfx< x y)] [(bignum? y) (fxbn< x y)] + [(flonum? y) (fxfl< x y)] [else (err y)])] [(bignum? x) (cond [(fixnum? y) (bnfx< x y)] [(bignum? y) (bnbn< x y)] + [(flonum? y) (bnfl< x y)] + [else (err y)])] + [(flonum? x) + (cond + [(fixnum? y) (flfx< x y)] + [(bignum? y) (flbn< x y)] + [(flonum? y) (flfl< x y)] [else (err y)])] [else (err x)])] [(x y z) @@ -444,12 +526,30 @@ [(fixnum? z) (and (fxfx< x y) (fxfx< y z))] [(bignum? z) (and (fxfx< x y) (fxbn< y z))] + [(flonum? z) + (and (fxfx< x y) (fxfl< y z))] [else (err z)])] [(bignum? y) (cond [(fixnum? z) #f] [(bignum? z) (and (fxbn< x y) (bnbn< y z))] + [(flonum? z) + (and (fxbn< x y) (bnfl< y z))] + [else (err z)])] + [(flonum? y) + (cond + [(fixnum? z) + (and (fxfx< x z) + (fxfl< x y) + (flfx< y z))] + [(bignum? z) + (and (fxbn< x z) + (fxfl< x y) + (flbn< y z))] + [(flonum? z) + (and (flfl< y z) + (fxfl< x y))] [else (err z)])] [else (err y)])] [(bignum? x) @@ -459,11 +559,53 @@ [(fixnum? z) (and (fxfx< y z) (bnfx< x y))] [(bignum? z) (and (bnfx< x y) (bnfx< y z))] + [(flonum? z) + (and (bnfx< x y) (fxfl< y z))] [else (err z)])] [(bignum? y) (cond [(fixnum? z) (and (bnfx< y z) (bnbn< x y))] [(bignum? z) (and (bnbn< x y) (bnbn< y z))] + [(flonum? z) (and (bnfl< y z) (bnbn< x y))] + [else (err z)])] + [(flonum? y) + (cond + [(fixnum? z) + (and (flfx< y z) (bnfl< x y))] + [(bignum? z) + (and (bnfl< x y) (flbn< y z))] + [(flonum? z) + (and (flfl< y z) (bnfl< x y))] + [else (err z)])] + [else (err y)])] + [(flonum? x) + (cond + [(fixnum? y) + (cond + [(fixnum? z) + (and (fxfx< y z) (flfx< x y))] + [(bignum? z) + (and (flfx< x y) (fxbn< y z))] + [(flonum? z) + (and (flfx< x y) (fxfl< y z))] + [else (err z)])] + [(bignum? y) + (cond + [(fixnum? z) + (and (bnfx< y z) (flbn< x y))] + [(bignum? z) + (and (bnbn< y z) (flbn< x y))] + [(flonum? z) + (and (flbn< x y) (bnfl< y z))] + [else (err z)])] + [(flonum? y) + (cond + [(fixnum? z) + (and (flfx< y z) (flfl< x y))] + [(bignum? z) + (and (flfl< x y) (flbn< y z))] + [(flonum? z) + (and (flfl< x y) (flfl< y z))] [else (err z)])] [else (err y)])] [else (err x)])] @@ -472,6 +614,7 @@ (cond [(fixnum? x) (fxloopt x y ls)] [(bignum? x) (bnloopt x y ls)] + [(flonum? x) (flloopt x y ls)] [else (err x)])]))])) (define-syntax false (syntax-rules () [(_ x y) #f])) @@ -489,17 +632,53 @@ (define-syntax fxbn> (syntax-rules () [(_ x y) (not (positive-bignum? y))])) (define-syntax bnfx> (syntax-rules () [(_ x y) (positive-bignum? x)])) + (define-syntax flcmp + (syntax-rules () + [(_ flfl? flfx? fxfl? flbn? bnfl? fl?) + (begin + (define-syntax flfl? + (syntax-rules () [(_ x y) (fl? x y)])) + (define-syntax flfx? + (syntax-rules () [(_ x y) (fl? x (fixnum->flonum y))])) + (define-syntax flbn? + (syntax-rules () [(_ x y) (fl? x (bignum->flonum y))])) + (define-syntax fxfl? + (syntax-rules () [(_ x y) (fl? (fixnum->flonum x) y)])) + (define-syntax bnfl? + (syntax-rules () [(_ x y) (fl? (bignum->flonum x) y)])))])) + (define-syntax $fl= + (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_equal" x y)])) + (define-syntax $fl< + (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less" x y)])) + (define-syntax $fl<= + (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less_or_equal" x y)])) + (define-syntax $fl> + (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less" y x)])) + (define-syntax $fl>= + (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less_or_equal" y x)])) + + (flcmp flfl= flfx= fxfl= flbn= bnfl= $fl=) + (flcmp flfl< flfx< fxfl< flbn< bnfl< $fl<) + (flcmp flfl> flfx> fxfl> flbn> bnfl> $fl>) + (flcmp flfl<= flfx<= fxfl<= flbn<= bnfl<= $fl<=) + (flcmp flfl>= flfx>= fxfl>= flbn>= bnfl>= $fl>=) (primitive-set! '+ +) (primitive-set! '- -) (primitive-set! '* *) - (primitive-set! '= (mk< = #%$fx= false false bnbn=)) - (primitive-set! '< (mk< < #%$fx< fxbn< bnfx< bnbn<)) - (primitive-set! '> (mk< > #%$fx> fxbn> bnfx> bnbn>)) - (primitive-set! '<= (mk< <= #%$fx<= fxbn< bnfx< bnbn<=)) - (primitive-set! '>= (mk< >= #%$fx>= fxbn> bnfx> bnbn>=)) + (primitive-set! '/ /) + (primitive-set! '= (mk< = #%$fx= false false bnbn= + fxfl= flfx= bnfl= flbn= flfl=)) + (primitive-set! '< (mk< < #%$fx< fxbn< bnfx< bnbn< + fxfl< flfx< bnfl< flbn< flfl<)) + (primitive-set! '> (mk< > #%$fx> fxbn> bnfx> bnbn> + fxfl> flfx> bnfl> flbn> flfl>)) + (primitive-set! '<= (mk< <= #%$fx<= fxbn< bnfx< bnbn<= + fxfl<= flfx<= bnfl<= flbn<= flfl<=)) + (primitive-set! '>= (mk< >= #%$fx>= fxbn> bnfx> bnbn>= + fxfl>= flfx>= bnfl>= flbn>= flfl>=)) (primitive-set! 'logand logand) (primitive-set! 'number? number?) (primitive-set! 'number->string number->string) @@ -605,6 +784,13 @@ [(bignum? x) (not (positive-bignum? x))] [else (error 'negative? "~s is not a number" x)]))) + (primitive-set! 'sin + (lambda (x) + (cond + [(flonum? x) (foreign-call "ikrt_fl_sin" x)] + [(fixnum? x) (foreign-call "ikrt_fx_sin" x)] + [else (error 'sin "unsupported ~s" x)]))) + (primitive-set! 'even? even?) (primitive-set! 'odd? odd?) (primitive-set! 'max max) @@ -616,4 +802,6 @@ (primitive-set! 'inexact? inexact?) (primitive-set! 'integer? integer?) (primitive-set! 'exact->inexact exact->inexact) + (primitive-set! 'modulo modulo) + ) diff --git a/src/libtimers.ss b/src/libtimers.ss index 4a69417..32cbd49 100644 --- a/src/libtimers.ss +++ b/src/libtimers.ss @@ -11,6 +11,30 @@ (foreign-call "ikrt_stats_now" t)) (define (print-stats message bytes t1 t0) + (define (print-time msg msecs) + (printf " ~a ms elapsed ~a time\n" msecs msg)) + (define (msecs s1 s0 u1 u0) + (+ (* (- s1 s0) 1000) (quotient (- u1 u0) 1000))) + (if message + (printf "running stats for ~a:\n" message) + (printf "running stats:\n")) + (let ([collections + (fx- (stats-collection-id t1) (stats-collection-id t0))]) + (case collections + [(0) (display " no collections\n")] + [(1) (display " 1 collection\n")] + [else (printf " ~a collections\n" collections)])) + (print-time "cpu" + (+ (msecs (stats-user-secs t1) (stats-user-secs t0) + (stats-user-usecs t1) (stats-user-usecs t0)) + (msecs (stats-sys-secs t1) (stats-sys-secs t0) + (stats-sys-usecs t1) (stats-sys-usecs t0)))) + (print-time "real" + (msecs (stats-real-secs t1) (stats-real-secs t0) + (stats-real-usecs t1) (stats-real-usecs t0))) + (printf " ~a bytes allocated\n" bytes)) + + (define (print-stats-old message bytes t1 t0) (define (print-time msg secs usecs) (if (fx< usecs 0) (print-time msg (fx- secs 1) (fx+ usecs 1000000)) diff --git a/src/makefile.ss b/src/makefile.ss index c9dde9b..9e68dd5 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -80,8 +80,8 @@ open-output-file open-input-file open-output-string get-output-string with-output-to-file call-with-output-file with-input-from-file call-with-input-file date-string - file-exists? delete-file + - add1 sub1 * expt - quotient+remainder quotient remainder number? positive? + file-exists? delete-file + - add1 sub1 * / expt + quotient+remainder quotient remainder modulo number? positive? negative? zero? number->string logand = < > <= >= make-guardian weak-cons collect interrupt-handler @@ -94,6 +94,7 @@ string->number exact->inexact flonum? flonum->string string->flonum + sin )) (define system-primitives