1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
/*-----------------------------------------------------------------*-C-*---
* File: handc/runtime/fluid.c
*
* Copyright (C)1997 Donovan Kolbly <d.kolbly@rscheme.org>
* as part of the RScheme project, licensed for free use.
* See <http://www.rscheme.org/> for the latest information.
*
* File version: 1.3
* File mod date: 1997.11.29 23:10:50
* System build: v0.7.2, 97.12.21
*
*------------------------------------------------------------------------*/
#include <rscheme/scheme.h>
#include <rscheme/smemory.h>
#include <rscheme/allocns.h>
/* support for fluid variables
(this style of fluid variable is deprecated in 0.9, but we
need some context-switch performance improvement in the meantime...)
*/
/* winding a fluid TL contour;
store TL bindings in `saved' values
and load `inside' values into TL bindings
*/
#define FTLC_BINDINGS SLOT(0)
#define FTLC_INSIDE_VALUES SLOT(1)
#define FTLC_SAVED_VALUES SLOT(2)
static void shift_tl_values( obj var_vec, obj save_into, obj load_from )
{
UINT_32 i, sz;
obj tlv;
sz = SIZEOF_PTR(var_vec);
for (i=0; i<sz; i+=SLOT(1))
{
tlv = gvec_ref( var_vec, i );
#if 0
fprintf( stdout, "updating %s ", symbol_text( gvec_ref(tlv,SLOT(0)) ) );
fprinto( stdout, gvec_ref(tlv,SLOT(1)) );
fprintf( stdout, " ==> " );
fprinto( stdout, gvec_ref(load_from,i) );
fprintf( stdout, "\n" );
#endif
gvec_write( save_into, i, gvec_ref(tlv,SLOT(1)) );
gvec_write( tlv, SLOT(1), gvec_ref(load_from,i) );
}
}
void wind_fluid_tl_contour( obj ftlc )
{
shift_tl_values( gvec_ref( ftlc, FTLC_BINDINGS ),
gvec_ref( ftlc, FTLC_SAVED_VALUES ),
gvec_ref( ftlc, FTLC_INSIDE_VALUES ) );
}
void unwind_fluid_tl_contour( obj ftlc )
{
shift_tl_values( gvec_ref( ftlc, FTLC_BINDINGS ),
gvec_ref( ftlc, FTLC_INSIDE_VALUES ),
gvec_ref( ftlc, FTLC_SAVED_VALUES ) );
}
/* returns an "ancestor descriptor", which is a vector
* whose first element is the common cell and whose remaining
* elements are the car's of the chain from the common cell
* to the `to' cell (not including the common cell).
*
* this technique costs an allocation at context switch time,
* but is MUCH easier than avoiding the mass of continuations
* that would be allocated in the rewinder
*/
obj find_common_ancestor( obj from, obj to )
{
obj f, t, v, k;
unsigned n;
if (EQ(from,to))
return make1( vector_class, from );
/* this is not MP safe! */
/* mark the cells in the `from' list */
for (f=from; PAIR_P(f); f=pair_cdr(f))
{
PTR_TO_HDRPTR(f)->pob_size += 1;
}
/* crawl up the `to' list looking for something with the bit set */
n = SLOT(1);
for (t=to; PAIR_P(t); t=pair_cdr(t))
{
if (PTR_TO_HDRPTR(t)->pob_size & 1)
break;
if (!VECTOR_P(pair_car(t)))
n += SLOT(1);
}
/* found a common ancestor or ran out of `to' list;
* in either case, `n' is the number of slots we need
* in the ancestor vector (initially one for the common
* cell, and incremented once for each value we'll put
* in it)
*/
/*
* remove the marks from the `from' list...
*/
for (f=from; PAIR_P(f); f=pair_cdr(f))
{
PTR_TO_HDRPTR(f)->pob_size -= 1;
}
/* construct the ancestor descriptor */
v = alloc( n, vector_class );
gvec_write_init( v, SLOT(0), t );
for (n=SLOT(1), k=to; !EQ(k,t); k=pair_cdr(k))
{
if (!VECTOR_P(pair_car(k)))
{
gvec_write_init( v, n, pair_car(k) );
n += SLOT(1);
}
}
return v;
}
|
