← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/c/stacks.d

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-05-17 02:46:26 UTC
  • Revision ID: james.westby@ubuntu.com-20060517024626-lljr08ftv9g9vefl
Tags: upstream-0.9h-20060510
Import upstream version 0.9h-20060510

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/c/stacks.d
 
1
/*
 
2
    stacks.c -- Binding/History/Frame stacks.
 
3
*/
 
4
/*
 
5
    Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
 
6
    Copyright (c) 1990, Giuseppe Attardi.
 
7
    Copyright (c) 2001, Juan Jose Garcia Ripoll.
 
8
 
 
9
    ECL is free software; you can redistribute it and/or
 
10
    modify it under the terms of the GNU Library General Public
 
11
    License as published by the Free Software Foundation; either
 
12
    version 2 of the License, or (at your option) any later version.
 
13
 
 
14
    See file '../Copyright' for full details.
 
15
*/
 
16
 
 
17
#include <ecl/ecl.h>
 
18
#ifdef HAVE_SYS_RESOURCE_H
 
19
# include <sys/time.h>
 
20
# include <sys/resource.h>
 
21
#endif
 
22
 
 
23
/********************* BINDING STACK ************************/
 
24
 
 
25
#ifdef ECL_THREADS
 
26
void
 
27
bds_bind(cl_object s, cl_object value)
 
28
{
 
29
        struct ecl_hashtable_entry *h = ecl_search_hash(s, cl_env.bindings_hash);
 
30
        struct bds_bd *slot = ++cl_env.bds_top;
 
31
        if (h->key == OBJNULL) {
 
32
                /* The previous binding was at most global */
 
33
                slot->symbol = s;
 
34
                slot->value = OBJNULL;
 
35
                sethash(s, cl_env.bindings_hash, value);
 
36
        } else {
 
37
                /* We have to save a dynamic binding */
 
38
                slot->symbol = h->key;
 
39
                slot->value = h->value;
 
40
                h->value = value;
 
41
        }
 
42
        s->symbol.dynamic |= 1;
 
43
}
 
44
 
 
45
void
 
46
bds_push(cl_object s)
 
47
{
 
48
        struct ecl_hashtable_entry *h = ecl_search_hash(s, cl_env.bindings_hash);
 
49
        struct bds_bd *slot = ++cl_env.bds_top;
 
50
        if (h->key == OBJNULL) {
 
51
                /* The previous binding was at most global */
 
52
                slot->symbol = s;
 
53
                slot->value = OBJNULL;
 
54
                sethash(s, cl_env.bindings_hash, s->symbol.value);
 
55
        } else {
 
56
                /* We have to save a dynamic binding */
 
57
                slot->symbol = h->key;
 
58
                slot->value = h->value;
 
59
        }
 
60
        s->symbol.dynamic |= 1;
 
61
}
 
62
 
 
63
void
 
64
bds_unwind1(void)
 
65
{
 
66
        struct bds_bd *slot = cl_env.bds_top--;
 
67
        cl_object s = slot->symbol;
 
68
        struct ecl_hashtable_entry *h = ecl_search_hash(s, cl_env.bindings_hash);
 
69
        if (slot->value == OBJNULL) {
 
70
                /* We have deleted all dynamic bindings */
 
71
                h->key = OBJNULL;
 
72
                h->value = OBJNULL;
 
73
                cl_env.bindings_hash->hash.entries--;
 
74
        } else {
 
75
                /* We restore the previous dynamic binding */
 
76
                h->value = slot->value;
 
77
        }
 
78
}
 
79
 
 
80
void
 
81
bds_unwind_n(int n)
 
82
{
 
83
        while (n--) bds_unwind1();
 
84
}
 
85
 
 
86
cl_object *
 
87
ecl_symbol_slot(cl_object s)
 
88
{
 
89
        if (s->symbol.dynamic) {
 
90
                struct ecl_hashtable_entry *h = ecl_search_hash(s, cl_env.bindings_hash);
 
91
                if (h->key != OBJNULL)
 
92
                        return &h->value;
 
93
        }
 
94
        return &s->symbol.value;
 
95
}
 
96
 
 
97
cl_object
 
98
ecl_set_symbol(cl_object s, cl_object value)
 
99
{
 
100
        if (s->symbol.dynamic) {
 
101
                struct ecl_hashtable_entry *h = ecl_search_hash(s, cl_env.bindings_hash);
 
102
                if (h->key != OBJNULL) {
 
103
                        return (h->value = value);
 
104
                }
 
105
        }
 
106
        return (s->symbol.value = value);
 
107
}
 
108
#endif
 
109
 
 
110
void
 
111
bds_overflow(void)
 
112
{
 
113
        --cl_env.bds_top;
 
114
        if (cl_env.bds_limit > cl_env.bds_org + cl_env.bds_size)
 
115
                error("bind stack overflow.");
 
116
        cl_env.bds_limit += BDSGETA;
 
117
        FEerror("Bind stack overflow.", 0);
 
118
}
 
119
 
 
120
void
 
121
bds_unwind(bds_ptr new_bds_top)
 
122
{
 
123
        register bds_ptr bds = cl_env.bds_top;
 
124
        for (;  bds > new_bds_top;  bds--)
 
125
#ifdef ECL_THREADS
 
126
                bds_unwind1();
 
127
#else
 
128
                bds->symbol->symbol.value = bds->value;
 
129
#endif
 
130
        cl_env.bds_top = new_bds_top;
 
131
}
 
132
 
 
133
static bds_ptr
 
134
get_bds_ptr(cl_object x)
 
135
{
 
136
        bds_ptr p;
 
137
 
 
138
        if (FIXNUMP(x)) {
 
139
          p = cl_env.bds_org + fix(x);
 
140
          if (cl_env.bds_org <= p && p <= cl_env.bds_top)
 
141
            return(p);
 
142
        }
 
143
        FEerror("~S is an illegal bds index.", 1, x);
 
144
}
 
145
 
 
146
cl_object
 
147
si_bds_top()
 
148
{
 
149
        @(return MAKE_FIXNUM(cl_env.bds_top - cl_env.bds_org))
 
150
}
 
151
 
 
152
cl_object
 
153
si_bds_var(cl_object arg)
 
154
{
 
155
        @(return get_bds_ptr(arg)->symbol)
 
156
}
 
157
 
 
158
cl_object
 
159
si_bds_val(cl_object arg)
 
160
{
 
161
        @(return get_bds_ptr(arg)->value)
 
162
}
 
163
 
 
164
/******************** INVOCATION STACK **********************/
 
165
 
 
166
static cl_object
 
167
ihs_function_name(cl_object x)
 
168
{
 
169
        cl_object y;
 
170
 
 
171
        switch (type_of(x)) {
 
172
        case t_symbol:
 
173
                return(x);
 
174
 
 
175
        case t_bytecodes:
 
176
                y = x->bytecodes.name;
 
177
                if (Null(y))
 
178
                        return(@'lambda');
 
179
                else
 
180
                        return y;
 
181
 
 
182
        case t_cfun:
 
183
                return(x->cfun.name);
 
184
 
 
185
        default:
 
186
                return(Cnil);
 
187
        }
 
188
}
 
189
 
 
190
static ihs_ptr
 
191
get_ihs_ptr(cl_index n)
 
192
{
 
193
        ihs_ptr p = cl_env.ihs_top;
 
194
        if (n > p->index)
 
195
                FEerror("~D is an illegal IHS index.", 1, MAKE_FIXNUM(n));
 
196
        while (n < p->index)
 
197
                p = p->next;
 
198
        return p;
 
199
}
 
200
 
 
201
cl_object
 
202
ihs_top_function_name(void)
 
203
{
 
204
        return ihs_function_name(cl_env.ihs_top->function);
 
205
}
 
206
 
 
207
cl_object
 
208
si_ihs_top(cl_object name)
 
209
{
 
210
        @(return MAKE_FIXNUM(cl_env.ihs_top->index))
 
211
}
 
212
 
 
213
cl_object
 
214
si_ihs_prev(cl_object x)
 
215
{
 
216
        @(return cl_1M(x))
 
217
}
 
218
 
 
219
cl_object
 
220
si_ihs_next(cl_object x)
 
221
{
 
222
        @(return cl_1P(x))
 
223
}
 
224
 
 
225
cl_object
 
226
si_ihs_fun(cl_object arg)
 
227
{
 
228
        @(return get_ihs_ptr(fixnnint(arg))->function)
 
229
}
 
230
 
 
231
cl_object
 
232
si_ihs_env(cl_object arg)
 
233
{
 
234
        @(return get_ihs_ptr(fixnnint(si_ihs_next(arg)))->lex_env)
 
235
}
 
236
 
 
237
/********************** FRAME STACK *************************/
 
238
 
 
239
static int frame_id = 0;
 
240
 
 
241
cl_object
 
242
new_frame_id(void)
 
243
{
 
244
  return(MAKE_FIXNUM(frame_id++));
 
245
}
 
246
 
 
247
int
 
248
frs_overflow(void)              /* used as condition in list.d */
 
249
{
 
250
        --cl_env.frs_top;
 
251
        if (cl_env.frs_limit > cl_env.frs_org + cl_env.frs_size)
 
252
                error("frame stack overflow.");
 
253
        cl_env.frs_limit += FRSGETA;
 
254
        FEerror("Frame stack overflow.", 0);
 
255
}
 
256
 
 
257
ecl_frame_ptr
 
258
_frs_push(register cl_object val)
 
259
{
 
260
        ecl_frame_ptr output = ++cl_env.frs_top;
 
261
        if (output >= cl_env.frs_limit) frs_overflow();
 
262
        output->frs_lex = cl_env.lex_env;
 
263
        output->frs_bds_top = cl_env.bds_top;
 
264
        output->frs_val = val;
 
265
        output->frs_ihs = cl_env.ihs_top;
 
266
        output->frs_sp = cl_stack_index();
 
267
        return output;
 
268
}
 
269
 
 
270
void
 
271
unwind(ecl_frame_ptr fr)
 
272
{
 
273
        cl_env.nlj_fr = fr;
 
274
        while (cl_env.frs_top != fr && cl_env.frs_top->frs_val != ECL_PROTECT_TAG)
 
275
                --cl_env.frs_top;
 
276
        cl_env.lex_env = cl_env.frs_top->frs_lex;
 
277
        cl_env.ihs_top = cl_env.frs_top->frs_ihs;
 
278
        bds_unwind(cl_env.frs_top->frs_bds_top);
 
279
        cl_stack_set_index(cl_env.frs_top->frs_sp);
 
280
        ecl_longjmp(cl_env.frs_top->frs_jmpbuf, 1);
 
281
        /* never reached */
 
282
}
 
283
 
 
284
ecl_frame_ptr
 
285
frs_sch (cl_object frame_id)
 
286
{
 
287
        ecl_frame_ptr top;
 
288
 
 
289
        for (top = cl_env.frs_top;  top >= cl_env.frs_org;  top--)
 
290
                if (top->frs_val == frame_id)
 
291
                        return(top);
 
292
        return(NULL);
 
293
}
 
294
 
 
295
static ecl_frame_ptr
 
296
get_frame_ptr(cl_object x)
 
297
{
 
298
        ecl_frame_ptr p;
 
299
 
 
300
        if (FIXNUMP(x)) {
 
301
          p = cl_env.frs_org + fix(x);
 
302
          if (cl_env.frs_org <= p && p <= cl_env.frs_top)
 
303
            return(p);
 
304
        }
 
305
        FEerror("~S is an illegal frs index.", 1, x);
 
306
}
 
307
 
 
308
cl_object
 
309
si_frs_top()
 
310
{
 
311
        @(return MAKE_FIXNUM(cl_env.frs_top - cl_env.frs_org))
 
312
}
 
313
 
 
314
cl_object
 
315
si_frs_bds(cl_object arg)
 
316
{
 
317
        @(return MAKE_FIXNUM(get_frame_ptr(arg)->frs_bds_top - cl_env.bds_org))
 
318
}
 
319
 
 
320
cl_object
 
321
si_frs_tag(cl_object arg)
 
322
{
 
323
        @(return get_frame_ptr(arg)->frs_val)
 
324
}
 
325
 
 
326
cl_object
 
327
si_frs_ihs(cl_object arg)
 
328
{
 
329
        @(return MAKE_FIXNUM(get_frame_ptr(arg)->frs_ihs->index))
 
330
}
 
331
 
 
332
cl_object
 
333
si_sch_frs_base(cl_object fr, cl_object ihs)
 
334
{
 
335
        ecl_frame_ptr x;
 
336
        cl_index y;
 
337
 
 
338
        y = fixnnint(ihs);
 
339
        for (x = get_frame_ptr(fr); 
 
340
             x <= cl_env.frs_top && x->frs_ihs->index < y;
 
341
             x++);
 
342
        @(return ((x > cl_env.frs_top) ? Cnil : MAKE_FIXNUM(x - cl_env.frs_org)))
 
343
}
 
344
 
 
345
/********************* INITIALIZATION ***********************/
 
346
 
 
347
cl_object
 
348
si_reset_stack_limits()
 
349
{
 
350
        volatile int foo = 0;
 
351
        if (cl_env.bds_top < cl_env.bds_org + (cl_env.bds_size - 2*BDSGETA))
 
352
                cl_env.bds_limit = cl_env.bds_org + (cl_env.bds_size - 2*BDSGETA);
 
353
        else
 
354
                error("can't reset bds_limit.");
 
355
        if (cl_env.frs_top < cl_env.frs_org + (cl_env.frs_size - 2*FRSGETA))
 
356
                cl_env.frs_limit = cl_env.frs_org + (cl_env.frs_size - 2*FRSGETA);
 
357
        else
 
358
                error("can't reset frs_limit.");
 
359
#ifdef DOWN_STACK
 
360
        if (&foo > cl_env.cs_org - cl_env.cs_size + 16)
 
361
                cl_env.cs_limit = cl_env.cs_org - cl_env.cs_size;
 
362
#else
 
363
        if (&foo < cl_env.cs_org + cl_env.cs_size - 16)
 
364
                cl_env.cs_limit = cl_env.cs_org + cl_env.cs_size;
 
365
#endif
 
366
        else
 
367
                error("can't reset cl_env.cs_limit.");
 
368
 
 
369
        @(return Cnil)
 
370
}
 
371
 
 
372
void
 
373
init_stacks(int *new_cs_org)
 
374
{
 
375
        static struct ihs_frame ihs_org = { NULL, NULL, NULL, 0};
 
376
        cl_index size;
 
377
 
 
378
        cl_env.frs_size = size = FRSSIZE + 2*FRSGETA;
 
379
        cl_env.frs_org = (ecl_frame_ptr)cl_alloc_atomic(size * sizeof(*cl_env.frs_org));
 
380
        cl_env.frs_top = cl_env.frs_org-1;
 
381
        cl_env.frs_limit = &cl_env.frs_org[size - 2*FRSGETA];
 
382
        cl_env.bds_size = size = BDSSIZE + 2*BDSGETA;
 
383
        cl_env.bds_org = (bds_ptr)cl_alloc_atomic(size * sizeof(*cl_env.bds_org));
 
384
        cl_env.bds_top = cl_env.bds_org-1;
 
385
        cl_env.bds_limit = &cl_env.bds_org[size - 2*BDSGETA];
 
386
 
 
387
        cl_env.ihs_top = &ihs_org;
 
388
        ihs_org.function = @'si::top-level';
 
389
        ihs_org.lex_env = Cnil;
 
390
        ihs_org.index = 0;
 
391
 
 
392
        cl_env.cs_org = new_cs_org;
 
393
#if defined(HAVE_SYS_RESOURCE_H) && defined(RLIMIT_STACK)
 
394
        {
 
395
          struct rlimit rl;
 
396
          getrlimit(RLIMIT_STACK, &rl);
 
397
          cl_env.cs_size = rl.rlim_cur/4 - 4*CSGETA;
 
398
        }
 
399
#else
 
400
        cl_env.cs_size = CSSIZE;
 
401
#endif
 
402
#ifdef DOWN_STACK
 
403
        /* Sanity check - in case rlimit is set too high */
 
404
        if (cl_env.cs_org - cl_env.cs_size > cl_env.cs_org) {
 
405
          cl_env.cs_size = CSSIZE;
 
406
        }
 
407
        cl_env.cs_limit = cl_env.cs_org - cl_env.cs_size; /* in THREADS I'm assigning to the main thread clwp */
 
408
#else
 
409
        /* Sanity check - in case rlimit is set too high */
 
410
        if (cl_env.cs_org + cl_env.cs_size < cl_env.cs_org) {
 
411
          cl_env.cs_size = CSSIZE;
 
412
        }
 
413
        cl_env.cs_limit = cl_env.cs_org + cl_env.cs_size;
 
414
#endif
 
415
}