diff --git a/scheme/Makefile.am b/scheme/Makefile.am index 0c4036f..dfa7745 100644 --- a/scheme/Makefile.am +++ b/scheme/Makefile.am @@ -27,7 +27,7 @@ EXTRA_DIST=ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \ ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \ ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \ ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \ - ikarus.reader.annotated.ss + ikarus.reader.annotated.ss ikarus.pointers.ss all: $(nodist_pkglib_DATA) diff --git a/scheme/Makefile.in b/scheme/Makefile.in index f5e9a6f..c55f5d8 100644 --- a/scheme/Makefile.in +++ b/scheme/Makefile.in @@ -181,7 +181,7 @@ EXTRA_DIST = ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \ ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \ ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \ ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \ - ikarus.reader.annotated.ss + ikarus.reader.annotated.ss ikarus.pointers.ss revno = "$(shell sed 's/ .*//' ../.bzr/branch/last-revision 2>/dev/null)" sizeofvoidp = $(shell grep SIZEOF_VOID_P ../config.h | sed "s/.*\(.\)/\1/g") diff --git a/scheme/ikarus.boot.4.prebuilt b/scheme/ikarus.boot.4.prebuilt index b5f2fe8..2172bc5 100644 Binary files a/scheme/ikarus.boot.4.prebuilt and b/scheme/ikarus.boot.4.prebuilt differ diff --git a/scheme/ikarus.boot.8.prebuilt b/scheme/ikarus.boot.8.prebuilt index ca74071..90ff0bf 100644 Binary files a/scheme/ikarus.boot.8.prebuilt and b/scheme/ikarus.boot.8.prebuilt differ diff --git a/scheme/ikarus.pointers.ss b/scheme/ikarus.pointers.ss new file mode 100644 index 0000000..2f223ee --- /dev/null +++ b/scheme/ikarus.pointers.ss @@ -0,0 +1,25 @@ + +(library (ikarus.pointers) + (export pointer? integer->pointer pointer->integer) + (import (except (ikarus) pointer? integer->pointer pointer->integer)) + + (define (pointer? x) + (foreign-call "ikrt_isapointer" x)) + + (define (integer->pointer x) + (cond + [(fixnum? x) + (foreign-call "ikrt_fx_to_pointer" x)] + [(bignum? x) + (foreign-call "ikrt_bn_to_pointer" x)] + [else + (die 'integer->pointer "not an integer" x)])) + + (define (pointer->integer x) + (cond + [(pointer? x) + (foreign-call "ikrt_pointer_to_int" x)] + [else + (die 'pointer->integer "not a pointer" x)]))) + + diff --git a/scheme/ikarus.writer.ss b/scheme/ikarus.writer.ss index 0254aea..33ef19f 100644 --- a/scheme/ikarus.writer.ss +++ b/scheme/ikarus.writer.ss @@ -391,6 +391,12 @@ (write-positive-hex-fx b p)) (write-char #\; p))) + (define (write-hex x n p) + (define s "0123456789ABCDEF") + (unless (zero? n) + (write-hex (sra x 4) (- n 1) p) + (write-char (string-ref s (bitwise-and x #xF)) p))) + (define write-string-escape (lambda (x p) (define loop @@ -605,6 +611,13 @@ (let ([n ($transcoder->data x)]) (write-char* (number->string n) p)) (write-char* ">" p)] + [(pointer? x) + (write-char* "#integer x) + (if (<= (fixnum-width) 32) 8 16) + p) + (write-char* ">" p)] [else (write-char* "#" p) i]))) diff --git a/scheme/last-revision b/scheme/last-revision index af13b1c..8ba317e 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1588 +1589 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 2b52cdf..ffd7725 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -104,6 +104,7 @@ "ikarus.promises.ss" "ikarus.enumerations.ss" "ikarus.command-line.ss" + "ikarus.pointers.ss" "ikarus.not-yet-implemented.ss" "ikarus.main.ss" )) @@ -1450,6 +1451,9 @@ [cp0-effort-limit i] [tag-analysis-output i] [perform-tag-analysis i] + [pointer? i] + [pointer->integer i] + [integer->pointer i] )) (define (macro-identifier? x) diff --git a/scheme/run-tests.ss b/scheme/run-tests.ss index 96ea31c..370eb34 100755 --- a/scheme/run-tests.ss +++ b/scheme/run-tests.ss @@ -39,6 +39,7 @@ (tests case-folding) (tests sorting) (tests fasl) + (tests pointers) ) (define (test-exact-integer-sqrt) @@ -84,4 +85,5 @@ (test-fasl) (test-numerics) (test-enums) +(test-pointers) (printf "Happy Happy Joy Joy\n") diff --git a/scheme/tests/pointers.ss b/scheme/tests/pointers.ss new file mode 100644 index 0000000..4a08d07 --- /dev/null +++ b/scheme/tests/pointers.ss @@ -0,0 +1,42 @@ + +(library (tests pointers) + (export test-pointers) + (import (ikarus)) + + (define bits + (if (<= (fixnum-width) 32) 32 64)) + + (define mask (sub1 (sll 1 bits))) + + (define (test-pointer n) + (let* ([np (integer->pointer n)] + [m (pointer->integer np)] + [mp (integer->pointer m)]) + (printf "test ~x/~s => ~x/~s\n" n np m mp) + (unless (= (bitwise-and n mask) (bitwise-and m mask)) + (error 'test "failed/got" n m + (bitwise-and n mask) (bitwise-and m mask))))) + + (define (test-pointers) + (test-pointer 0) + (test-pointer 100) + (test-pointer -100) + (test-pointer (greatest-fixnum)) + (test-pointer (least-fixnum)) + (test-pointer (+ 1 (greatest-fixnum))) + (test-pointer (+ 1 (least-fixnum))) + (test-pointer (- 1 (greatest-fixnum))) + (test-pointer (- 1 (least-fixnum))) + (test-pointer (+ -1 (greatest-fixnum))) + (test-pointer (+ -1 (least-fixnum))) + (test-pointer (- -1 (greatest-fixnum))) + (test-pointer (- -1 (least-fixnum))) + (test-pointer (* 2 (greatest-fixnum))) + (test-pointer (* 2 (least-fixnum))) + (test-pointer (* 4 (greatest-fixnum))) + (test-pointer (* 4 (least-fixnum))) + (test-pointer (* 8 (greatest-fixnum))) + (test-pointer (* 8 (least-fixnum))) + (test-pointer (* 16 (greatest-fixnum))) + (test-pointer (* 16 (least-fixnum))))) + diff --git a/src/Makefile.am b/src/Makefile.am index 3a16ea1..65e812f 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -7,7 +7,7 @@ SRCS = ikarus-collect.c ikarus-exec.c ikarus-fasl.c \ ikarus-weak-pairs.c ikarus-winmmap.c ikarus-data.h \ ikarus-winmmap.h ikarus-enter.S cpu_has_sse2.S ikarus-io.c \ ikarus-process.c ikarus-getaddrinfo.h ikarus-getaddrinfo.c \ - ikarus-errno.c ikarus-main.h + ikarus-errno.c ikarus-main.h ikarus-pointers.c ikarus_SOURCES = $(SRCS) ikarus.c scheme_script_SOURCES = $(SRCS) scheme-script.c diff --git a/src/Makefile.in b/src/Makefile.in index e20c4ac..6d2d0b8 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -55,7 +55,7 @@ am__objects_1 = ikarus-collect.$(OBJEXT) ikarus-exec.$(OBJEXT) \ ikarus-winmmap.$(OBJEXT) ikarus-enter.$(OBJEXT) \ cpu_has_sse2.$(OBJEXT) ikarus-io.$(OBJEXT) \ ikarus-process.$(OBJEXT) ikarus-getaddrinfo.$(OBJEXT) \ - ikarus-errno.$(OBJEXT) + ikarus-errno.$(OBJEXT) ikarus-pointers.$(OBJEXT) am_ikarus_OBJECTS = $(am__objects_1) ikarus.$(OBJEXT) nodist_ikarus_OBJECTS = ikarus_OBJECTS = $(am_ikarus_OBJECTS) $(nodist_ikarus_OBJECTS) @@ -184,7 +184,7 @@ SRCS = ikarus-collect.c ikarus-exec.c ikarus-fasl.c \ ikarus-weak-pairs.c ikarus-winmmap.c ikarus-data.h \ ikarus-winmmap.h ikarus-enter.S cpu_has_sse2.S ikarus-io.c \ ikarus-process.c ikarus-getaddrinfo.h ikarus-getaddrinfo.c \ - ikarus-errno.c ikarus-main.h + ikarus-errno.c ikarus-main.h ikarus-pointers.c ikarus_SOURCES = $(SRCS) ikarus.c scheme_script_SOURCES = $(SRCS) scheme-script.c @@ -272,6 +272,7 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-io.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-main.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-numerics.Po@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-pointers.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-print.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-process.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-runtime.Po@am__quote@ diff --git a/src/ikarus-collect.c b/src/ikarus-collect.c index d73a005..945c06d 100644 --- a/src/ikarus-collect.c +++ b/src/ikarus-collect.c @@ -1239,6 +1239,14 @@ add_object_proc(gc_t* gc, ikptr x) { ref(y, disp_cflonum_imag-vector_tag) = add_object(gc, im, "imag"); return y; } + else if(fst == pointer_tag){ + ikptr y = gc_alloc_new_data(pointer_size, gc) + vector_tag; + ref(y, -vector_tag) = pointer_tag; + ref(y, wordsize-vector_tag) = ref(x, wordsize-vector_tag); + ref(x, -vector_tag) = forward_ptr; + ref(x, wordsize-vector_tag) = y; + return y; + } else { fprintf(stderr, "unhandled vector with fst=0x%016lx\n", (long int)fst); diff --git a/src/ikarus-data.h b/src/ikarus-data.h index fb80b4e..76a2f60 100644 --- a/src/ikarus-data.h +++ b/src/ikarus-data.h @@ -406,4 +406,7 @@ ikptr ik_safe_alloc(ikpcb* pcb, int size); #define ik_eof_p(x) ((x) == ik_eof_object) #define page_index(x) (((unsigned long int)(x)) >> pageshift) +#define pointer_tag ((ikptr) 0x107) +#define pointer_size (2 * wordsize) + #endif diff --git a/src/ikarus-pointers.c b/src/ikarus-pointers.c new file mode 100644 index 0000000..7738497 --- /dev/null +++ b/src/ikarus-pointers.c @@ -0,0 +1,58 @@ + +#include "ikarus-data.h" + +ikptr +ikrt_isapointer(ikptr x, ikpcb* pcb){ + if ((tagof(x) == vector_tag) && (ref(x, -vector_tag) == pointer_tag)) { + return true_object; + } else { + return false_object; + } +} + +ikptr +ikrt_pointer_to_int(ikptr x, ikpcb* pcb) { + long int p = (long int) ref(x, wordsize-vector_tag); + ikptr pfx = fix(p); + if (unfix(pfx) == p) { + return pfx; + } else { + ikptr bn = ik_safe_alloc(pcb, align(wordsize+disp_bignum_data)); + if (p > 0){ + ref(bn, 0) = (ikptr)(bignum_tag | (1 << bignum_length_shift)); + ref(bn, disp_bignum_data) = (ikptr)p; + } else { + ref(bn, 0) = + (ikptr)(bignum_tag | + (1 << bignum_length_shift) | + (1 << bignum_sign_shift)); + ref(bn, disp_bignum_data) = (ikptr)-p; + } + return bn+vector_tag; + } +} + +static ikptr +make_pointer(long int x, ikpcb* pcb) { + ikptr r = ik_safe_alloc(pcb, pointer_size); + ref(r, 0) = pointer_tag; + ref(r, wordsize) = (ikptr)x; + return r+vector_tag; +} + +ikptr +ikrt_fx_to_pointer(ikptr x, ikpcb* pcb) { + return make_pointer(unfix(x), pcb); +} + +#define bnfst_negative(x) \ + (((unsigned long int)(x)) & bignum_sign_mask) +ikptr +ikrt_bn_to_pointer(ikptr x, ikpcb* pcb) { + if(bnfst_negative(ref(x, -vector_tag))){ + return make_pointer(-ref(x, wordsize-vector_tag), pcb); + } else { + return make_pointer(ref(x, wordsize-vector_tag), pcb); + } +} +