Commit ff3f05b0 authored by Erick's avatar Erick

Optimization of circular list priniting

We use now hash tables (instead of A-lists). This is necessary with
the display/write functions which are now R7RS and try to detect
cycles. This was particularly inefficient on big lists/vectors.
parent 0e8c1f0a
This diff is collapsed.
/*
*
* h a s h . h -- Hash Tables
* h a s h . h -- Hash Tables
*
* Copyright © 1994-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright © 1994-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
+=============================================================================
! This code is a rewriting of the file tclHash.c of the Tcl
......@@ -34,17 +34,17 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 17-Jan-1994 17:49
* Last file update: 11-Apr-2007 17:58 (eg)
* Last file update: 19-Oct-2018 19:13 (eg)
*/
#define SMALL_HASH_TABLE 4
#define REBUILD_MULTIPLIER 3 /* When there are this many entries per bucket, */
/* on average, make the table larger */
#define REBUILD_MULTIPLIER 3 /* When there are this many entries per bucket, */
/* on average, make the table larger */
#define HASH_OBARRAY_FLAG 1 /* Only for the symbol table */
#define HASH_VAR_FLAG 2 /* For modules (keys are symbols) */
#define HASH_SCM_FLAG 3 /* For secheme hash tables */
#define HASH_OBARRAY_FLAG 1 /* Only for the symbol table */
#define HASH_VAR_FLAG 2 /* For modules (keys are symbols) */
#define HASH_SCM_FLAG 3 /* For secheme hash tables */
typedef enum {hash_system, hash_eqp, hash_stringp, hash_general} hash_type;
......@@ -63,18 +63,18 @@ struct hash_table_obj {
SCM hash_fct;
};
#define HASHP(o) (BOXED_TYPE_EQ((o), tc_hash_table))
#define HASH_BUCKETS(h) (((struct hash_table_obj *) (h))->buckets)
#define HASH_SBUCKETS(h) (((struct hash_table_obj *) (h))->static_buckets)
#define HASH_NBUCKETS(h) (((struct hash_table_obj *) (h))->num_buckets)
#define HASH_NENTRIES(h) (((struct hash_table_obj *) (h))->num_entries)
#define HASH_NEWSIZE(h) (((struct hash_table_obj *) (h))->rebuild_size)
#define HASH_SHIFT(h) (((struct hash_table_obj *) (h))->down_shift)
#define HASH_MASK(h) (((struct hash_table_obj *) (h))->mask)
#define HASHP(o) (BOXED_TYPE_EQ((o), tc_hash_table))
#define HASH_BUCKETS(h) (((struct hash_table_obj *) (h))->buckets)
#define HASH_SBUCKETS(h) (((struct hash_table_obj *) (h))->static_buckets)
#define HASH_NBUCKETS(h) (((struct hash_table_obj *) (h))->num_buckets)
#define HASH_NENTRIES(h) (((struct hash_table_obj *) (h))->num_entries)
#define HASH_NEWSIZE(h) (((struct hash_table_obj *) (h))->rebuild_size)
#define HASH_SHIFT(h) (((struct hash_table_obj *) (h))->down_shift)
#define HASH_MASK(h) (((struct hash_table_obj *) (h))->mask)
#define HASH_TYPE(h) (((struct hash_table_obj *) (h))->type)
#define HASH_COMPAR(h) (((struct hash_table_obj *) (h))->comparison)
#define HASH_HASH(h) (((struct hash_table_obj *) (h))->hash_fct)
#define HASH_TYPE(h) (((struct hash_table_obj *) (h))->type)
#define HASH_COMPAR(h) (((struct hash_table_obj *) (h))->comparison)
#define HASH_HASH(h) (((struct hash_table_obj *) (h))->hash_fct)
void STk_hashtable_init(struct hash_table_obj *h, int flag);
......@@ -87,7 +87,7 @@ void STk_hashtable_init(struct hash_table_obj *h, int flag);
* higher level interface instead.
*/
SCM STk_hash_intern_symbol(struct hash_table_obj *h, char *s,
SCM (*create)(char *s));
SCM (*create)(char *s));
/*
* Function for accessing module hash table. Don't use them but the
......@@ -101,6 +101,14 @@ void STk_hash_set_alias(struct hash_table_obj *h, SCM v, SCM value);
* Utilities on hash tables
*/
SCM STk_hash_keys(struct hash_table_obj *h);
SCM STk_make_basic_hash_table(void);
SCM STk_hash_table_search(SCM ht, SCM key);
/*
* Scheme interface
*/
EXTERN_PRIMITIVE("hash-table-ref/default", hash_ref_default, subr3,
(SCM ht, SCM key, SCM def));
EXTERN_PRIMITIVE("hash-table-set!", hash_set, subr3, (SCM ht, SCM key, SCM val));
int STk_init_hash(void);
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: ??-Oct-1993 ??:??
* Last file update: 19-Oct-2018 08:42 (eg)
* Last file update: 19-Oct-2018 21:22 (eg)
*
*/
#include <ctype.h>
......@@ -290,29 +290,35 @@ void STk_print(SCM exp, SCM port, int mode)
* Printing of circular structures
*
*=============================================================================*/
static void pass1(SCM exp, SCM *cycles); /* pass 1: mark cells */
static void pass2(SCM exp, SCM port, int mode, SCM cycles);/* pass 2: print */
#include "hash.h"
typedef struct {
SCM seen;
int label;
} cycles;
static void print_cycle(SCM exp, SCM port, int mode, SCM cycles)
static void pass1(SCM exp, cycles *c); /* pass 1: mark cells */
static void pass2(SCM exp, SCM port, int mode, cycles *c); /* pass 2: print */
static void print_cycle(SCM exp, SCM port, int mode, cycles *c)
{
SCM value, tmp;
SCM value;
if ((tmp = STk_assv(exp, cycles)) != STk_false) {
value= CDR(tmp);
if (INTP(value)) {
STk_fprintf(port, "#%ld#", INT_VAL(value));
return;
}
value = STk_hash_ref_default(c->seen, exp, STk_void);
if (INTP(value)) {
// value= CDR(tmp);
STk_fprintf(port, "#%ld#", INT_VAL(value));
return;
}
/* This is not a cycle. Do a normal print */
pass2(exp, port, mode, cycles); // FIXME: pass2?
pass2(exp, port, mode, c);
}
static void printlist_star(SCM exp, SCM port, int mode, SCM cycles)
static void printlist_star(SCM exp, SCM port, int mode, cycles *c)
{
SCM value, tmp;
SCM value;
char *s;
if (pretty_quotes) {
......@@ -320,7 +326,7 @@ static void printlist_star(SCM exp, SCM port, int mode, SCM cycles)
s = STk_quote2str(CAR(exp));
if (s && !NULLP(CDR(exp)) && NULLP(CDR(CDR(exp)))) {
STk_puts(s, port);
print_cycle(CAR(CDR(exp)), port, mode, cycles);
print_cycle(CAR(CDR(exp)), port, mode, c);
return;
}
}
......@@ -328,15 +334,16 @@ static void printlist_star(SCM exp, SCM port, int mode, SCM cycles)
STk_putc('(', port);
for ( ; ; ) {
print_cycle(CAR(exp), port, mode, cycles);
print_cycle(CAR(exp), port, mode, c);
if (NULLP(exp=CDR(exp))) break;
if (!CONSP(exp) || (tmp = STk_assv(exp, cycles)) != STk_false) {
if (!CONSP(exp) || (value = CDR(tmp)) == STk_true || INTP(value)) {
value = STk_hash_ref_default(c->seen, exp, STk_false);
if (!CONSP(exp) || value != STk_false) {
if (!CONSP(exp) || value == STk_true || INTP(value)) { //FIXME: value == #t??
/* either ". X" or ". #0=(...)" or ". #0#" */
STk_nputs(port, " . ", 3);
print_cycle(exp, port, mode, cycles);
print_cycle(exp, port, mode, c);
break;
}
}
......@@ -346,79 +353,76 @@ static void printlist_star(SCM exp, SCM port, int mode, SCM cycles)
}
static void printvector_star(SCM exp, SCM port, int mode, SCM cycles)
static void printvector_star(SCM exp, SCM port, int mode, cycles *c)
{
int j, n = VECTOR_SIZE(exp);
STk_nputs(port, "#(", 2);
for(j=0; j < n; j++) {
print_cycle(VECTOR_DATA(exp)[j], port, mode, cycles);
print_cycle(VECTOR_DATA(exp)[j], port, mode, c);
if ((j + 1) < n) STk_putc(' ', port);
}
STk_putc(')', port);
}
static void pass1(SCM exp, SCM *cycles)
static void pass1(SCM exp, cycles *c)
{
SCM tmp;
Top:
if (!CONSP(exp) && !VECTORP(exp)) return;
if ((tmp = STk_assv(exp, *cycles)) == STk_false) {
if ((STk_hash_ref_default(c->seen, exp, STk_void)) == STk_void) {
/* We have never seen this cell so far */
*cycles = STk_cons(STk_cons(exp, STk_false), *cycles);
STk_hash_set(c->seen, exp, STk_false);
if (CONSP(exp)) { /* it's a cons */
pass1(CAR(exp), cycles);
pass1(CAR(exp), c);
exp = CDR(exp);
goto Top;
}
else { /* it's a vector */
int i, len = VECTOR_SIZE(exp)-1;
for (i = 0; i < len; i++) pass1(VECTOR_DATA(exp)[i], cycles);
for (i = 0; i < len; i++) pass1(VECTOR_DATA(exp)[i], c);
if (len >= 0) {exp = VECTOR_DATA(exp)[len]; goto Top;}
}
}
else {
/* This item was already seen. Note that this is the second time */
CDR(tmp) = STk_true;
STk_hash_set(c->seen, exp, STk_true);
}
}
static void pass2(SCM exp, SCM port, int mode, SCM cycles)
static void pass2(SCM exp, SCM port, int mode, cycles *c)
{
int label = 0;
if (!CONSP(exp) && !VECTORP(exp))
STk_print(exp, port, mode); /* Normal print */
else {
SCM value, tmp;
/* Eventually print a definition label */
if ((tmp = STk_assv(exp, cycles)) != STk_false) {
if ((value=CDR(tmp)) == STk_true) {
/* First use of this label. Assign it a value */
STk_fprintf(port, "#%d=", label);
CDR(tmp) = MAKE_INT(label++);
}
if (STk_hash_ref_default(c->seen, exp, STk_void) == STk_true) {
/* First use of this label. Assign it a value */
STk_fprintf(port, "#%d=", c->label);
STk_hash_set(c->seen, exp, MAKE_INT(c->label++));
}
if (CONSP(exp)) printlist_star(exp, port, mode, cycles);
else printvector_star(exp, port, mode, cycles);
if (CONSP(exp)) printlist_star(exp, port, mode, c);
else printvector_star(exp, port, mode, c);
}
}
void STk_print_star(SCM exp, SCM port, int mode)
{
SCM cycles = STk_nil;
cycles c;
if (!CONSP(exp) && !VECTORP(exp)) return STk_print(exp, port, mode);
pass1(exp, &cycles);
pass2(exp, port, mode, cycles);
/* Initialize the cycle structure */
c.seen = STk_make_basic_hash_table();
c.label = 0;
pass1(exp, &c);
pass2(exp, port, mode, &c);
}
/*
......
......@@ -22,7 +22,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 11-Jun-2018 15:19
;;;; Last file update: 12-Jun-2018 09:49 (eg)
;;;; Last file update: 22-Oct-2018 17:24 (eg)
;;;;
......@@ -30,10 +30,17 @@
(test-section "Circular structures")
(define (circular-list val1 . vals) ; The SRFI-1 function
(let ((ans (cons val1 vals)))
(set-cdr! (last-pair ans) ans)
ans))
(define (->str lst)
(with-output-to-string (lambda () (write* lst))))
;; ======================================================================
;; Writing
;;
(define (generate-circular n)
(let ((l '(end)))
(dotimes (i n)
......@@ -43,6 +50,7 @@
l))))
l))
(test "write.circular1"
"#0=(a . #0#)"
(let ((x (list 'a)))
......@@ -79,6 +87,69 @@
"((#0=(24 . #0#) #1=((#2=(23 . #2#) #3=((#4=(22 . #4#) #5=((#6=(21 . #6#) #7=((#8=(20 . #8#) #9=((#10=(19 . #10#) #11=((#12=(18 . #12#) #13=((#14=(17 . #14#) #15=((#16=(16 . #16#) #17=((#18=(15 . #18#) #19=((#20=(14 . #20#) #21=((#22=(13 . #22#) #23=((#24=(12 . #24#) #25=((#26=(11 . #26#) #27=((#28=(10 . #28#) #29=((#30=(9 . #30#) #31=((#32=(8 . #32#) #33=((#34=(7 . #34#) #35=((#36=(6 . #36#) #37=((#38=(5 . #38#) #39=((#40=(4 . #40#) #41=((#42=(3 . #42#) #43=((#44=(2 . #44#) #45=((#46=(1 . #46#) #47=((#48=(0 . #48#) #49=(end) ()) . #49#) #49#) . #47#) #47#) . #45#) #45#) . #43#) #43#) . #41#) #41#) . #39#) #39#) . #37#) #37#) . #35#) #35#) . #33#) #33#) . #31#) #31#) . #29#) #29#) . #27#) #27#) . #25#) #25#) . #23#) #23#) . #21#) #21#) . #19#) #19#) . #17#) #17#) . #15#) #15#) . #13#) #13#) . #11#) #11#) . #9#) #9#) . #7#) #7#) . #5#) #5#) . #3#) #3#) . #1#)"
(with-output-to-string (lambda ()
(write* (generate-circular 25)))))
;;; Chibi tests
(test "chibi-circular.1" "#0=(1 . #0#)" (->str (circular-list 1)))
(test "chibi-circular.2" "#0=(1 2 . #0#)" (->str (circular-list 1 2)))
(test "chibi-circular.3" "(1 . #0=(2 . #0#))" (->str (cons 1 (circular-list 2))))
(test "chibi-circular.4" "#0=(1 #0# 3)"
(let ((x (list 1 2 3)))
(set-car! (cdr x) x)
(->str x)))
(test "chibi-circular.5" "(#0=(1 #0# 3))"
(let ((x (list 1 2 3)))
(set-car! (cdr x) x)
(->str (list x))))
(test "chibi-circular.6" "(#0=(1 #0# 3) #0#)"
(let ((x (list 1 2 3)))
(set-car! (cdr x) x)
(->str (list x x))))
(test "chibi-circular.7" "(#0=(1 . #0#) #1=(1 . #1#))"
(->str (list (circular-list 1) (circular-list 1))))
(test "chibi-circular.8" "(#0=(1 . 2) #1=(1 . 2) #2=(3 . 4) #0# #1# #2#)"
(let ((a (cons 1 2))
(b (cons 1 2))
(c (cons 3 4)))
(->str (list a b c a b c))))
(test "chibi-circular.9" "((1 . 2) (1 . 2) (3 . 4) (1 . 2) (1 . 2) (3 . 4))"
(let ((a (cons 1 2)) (b (cons 1 2)) (c (cons 3 4)))
(with-output-to-string (lambda () (write (list a b c a b c))))))
(test "chibi-circular.10" "#0=((1 . 2) (1 . 2) (3 . 4) . #0#)"
(let* ((a (cons 1 2))
(b (cons 1 2))
(c (cons 3 4))
(ls (list a b c)))
(set-cdr! (cddr ls) ls)
(->str ls)))
(test "chibi-circular.11" "#0=#(#0#)"
(let ((x (vector 1)))
(vector-set! x 0 x)
(->str x)))
(test "chibi-circular.12" "#0=#(1 #0#)"
(let ((x (vector 1 2)))
(vector-set! x 1 x)
(->str x)))
(test "chibi-circular.13" "#0=#(1 #0# 3)"
(let ((x (vector 1 2 3)))
(vector-set! x 1 x)
(->str x)))
(test "chibi-circular.14" "(#0=#(1 #0# 3))"
(let ((x (vector 1 2 3)))
(vector-set! x 1 x)
(->str (list x))))
(test "chibi-circular.15" "#0=#(#0# 2 #0#)"
(let ((x (vector 1 2 3)))
(vector-set! x 0 x)
(vector-set! x 2 x)
(->str x)))
;; ======================================================================
;; Reading
;;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment