* changing representation for all non-fixnum numbers.

This commit is contained in:
Abdulaziz Ghuloum 2007-01-21 19:20:37 -05:00
parent 783beb990b
commit 1c37a4ee54
14 changed files with 559 additions and 666 deletions

View File

@ -1189,7 +1189,7 @@ chicken-int) NAME='Chicken-int'
esac
;;
ikarus) NAME='Ikarus-Scheme'
ikarus) NAME='Ikarus'
COMP=ikarus_comp
COMPOPTS=""
EXEC=ikarus_exec

View File

@ -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.
>

View File

@ -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))

View File

@ -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

Binary file not shown.

View File

@ -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);

View File

@ -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

154
bin/ikarus-flonums.c Normal file
View File

@ -0,0 +1,154 @@
#include "ikarus.h"
#include <stdlib.h>
#include <string.h>
#include <errno.h>
#include <math.h>
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<n) && (buff[i] != '.')){ i++; }
if(i == n){
buff[i] = '.';
buff[i+1] = '0';
n += 2;;
}
ikp str = ik_alloc(pcb, align(n+disp_string_data+1)) +
string_tag;
ref(str, -string_tag) = fix(n);
memcpy(string_data(str), buff, n);
return str;
}
}
}
return false_object;
}
ikp
ikrt_fixnum_to_flonum(ikp x, ikpcb* pcb){
ikp r = ik_alloc(pcb, flonum_size) + vector_tag;
ref(r, -vector_tag) = (ikp)flonum_tag;
flonum_data(r) = unfix(x);
return r;
}
ikp
ikrt_bignum_to_flonum(ikp x, ikpcb* pcb){
fprintf(stderr, "ERR in bignum_to_flonum\n");
exit(-1);
}
ikp
ikrt_fl_equal(ikp x, ikp y){
if(flonum_data(x) == flonum_data(y)){
return true_object;
} else {
return false_object;
}
}
ikp
ikrt_fl_less_or_equal(ikp x, ikp y){
if(flonum_data(x) <= flonum_data(y)){
return true_object;
} else {
return false_object;
}
}
ikp
ikrt_fl_less(ikp x, ikp y){
if(flonum_data(x) < flonum_data(y)){
return true_object;
} else {
return false_object;
}
}

View File

@ -11,6 +11,56 @@
#define max_digits_per_limb 10
static ikp
verify_bignum(ikp x, char* caller){
if(tagof(x) != vector_tag){
fprintf(stderr, "Error in (%s) invalid primary tag %p\n", caller, x);
exit(-1);
}
ikp fst = ref(x, -vector_tag);
int limb_count = ((unsigned int) fst) >> 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);
}
}
}

Binary file not shown.

View File

@ -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 ()

View File

@ -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