stacks.d 19.1 KB
Newer Older
1
2
/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
3

jjgarcia's avatar
jjgarcia committed
4
/*
5
6
7
8
9
10
11
12
13
 * stacks.d - binding/history/frame stacks
 *
 * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
 * Copyright (c) 1990 Giuseppe Attardi
 * Copyright (c) 2001 Juan Jose Garcia Ripoll
 *
 * See file 'LICENSE' for the copyright details.
 *
 */
jjgarcia's avatar
jjgarcia committed
14

15
#include <ecl/ecl.h>
16
#include <signal.h>
17
#include <string.h>
jjgarcia's avatar
jjgarcia committed
18
19
20
21
#ifdef HAVE_SYS_RESOURCE_H
# include <sys/time.h>
# include <sys/resource.h>
#endif
22
#include <ecl/internal.h>
23
#include <ecl/stack-resize.h>
jjgarcia's avatar
jjgarcia committed
24

25
26
27
/************************ C STACK ***************************/

static void
28
cs_set_size(cl_env_ptr env, cl_index new_size)
29
{
30
31
  volatile char foo = 0;
  cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA];
32
#if defined(ECL_CAN_SET_STACK_SIZE)
33
34
35
36
37
38
39
40
41
42
  {
    struct rlimit rl;

    if (!getrlimit(RLIMIT_STACK, &rl)) {
      env->cs_max_size = rl.rlim_max;
      if (new_size > rl.rlim_cur) {
        rl.rlim_cur = (new_size > rl.rlim_max) ? rl.rlim_max : new_size;
        if (setrlimit(RLIMIT_STACK, &rl))
          ecl_internal_error("Can't set the size of the C stack");
      }
43
44
45
46
47
48
49
50
51
    } else {
      rl.rlim_cur = new_size;
    }
    if (rl.rlim_cur == 0 || rl.rlim_cur == RLIM_INFINITY || rl.rlim_cur > (cl_index)(-1)) {
      /* Either getrlimit failed or returned nonsense, either way we
       * don't know the stack size. Use a default of 1 MB and hope for
       * the best. */
      new_size = 1048576;
    } else {
52
      new_size = rl.rlim_cur;
53
    }
54
#ifdef ECL_DOWN_STACK
55
    env->cs_barrier = env->cs_org - new_size;
56
#else
57
    env->cs_barrier = env->cs_org + new_size;
58
59
60
#endif
  }
#endif
61
  env->cs_limit_size = new_size - (2*margin);
62
#ifdef ECL_DOWN_STACK
63
64
  if (&foo > (env->cs_org - new_size) + 16) {
    env->cs_limit = (env->cs_org - new_size) + (2*margin);
65
66
67
    if (env->cs_limit < env->cs_barrier)
      env->cs_barrier = env->cs_limit;
  }
68
#else
69
70
  if (&foo < (env->cs_org + new_size) - 16) {
    env->cs_limit = (env->cs_org + new_size) - (2*margin);
71
72
73
    if (env->cs_limit > env->cs_barrier)
      env->cs_barrier = env->cs_limit;
  }
74
#endif
75
  else
76
    ecl_internal_error("Can't set the size of the C stack: sanity check failed");
77
  env->cs_size = new_size;
78
79
80
81
82
}

void
ecl_cs_overflow(void)
{
83
84
85
86
87
88
89
  static const char *stack_overflow_msg =
    "\n;;;\n;;; Stack overflow.\n"
    ";;; Jumping to the outermost toplevel prompt\n"
    ";;;\n\n";
  cl_env_ptr env = ecl_process_env();
  cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA];
  cl_index size = env->cs_size;
90
#ifdef ECL_DOWN_STACK
91
92
  if (env->cs_limit > env->cs_org - size)
    env->cs_limit -= margin;
93
#else
94
95
  if (env->cs_limit < env->cs_org + size)
    env->cs_limit += margin;
96
#endif
97
98
99
100
  else
    ecl_unrecoverable_error(env, stack_overflow_msg);

  if (env->cs_max_size == (cl_index)0 || env->cs_size < env->cs_max_size)
101
    si_serror(6, @"Extend stack size",
102
103
104
105
106
107
108
109
110
111
112
113
              @'ext::stack-overflow',
              @':size', ecl_make_fixnum(size),
              @':type', @'ext::c-stack');
  else
    si_serror(6, ECL_NIL,
              @'ext::stack-overflow',
              @':size', ECL_NIL,
              @':type', @'ext::c-stack');
  size += size/2;
  if (size > env->cs_max_size)
    size = env->cs_max_size;
  cs_set_size(env, size);
114
115
}

116
117
118
void
ecl_cs_set_org(cl_env_ptr env)
{
119
120
121
122
123
#ifdef GBC_BOEHM
  struct GC_stack_base base;
  if (GC_get_stack_base(&base) == GC_SUCCESS)
    env->cs_org = (char*)base.mem_base;
  else
124
#endif
125
126
127
128
129
    {
      /* Rough estimate. Not very safe. We assume that cl_boot()
       * is invoked from the main() routine of the program.
       */
      env->cs_org = (char*)(&env);
130
    }
131
132
  env->cs_barrier = env->cs_org;
  env->cs_max_size = 0;
133
  cs_set_size(env, ecl_option_values[ECL_OPT_C_STACK_SIZE]);
134
135
}

136

jjgarcia's avatar
jjgarcia committed
137
138
/********************* BINDING STACK ************************/

139
void
140
ecl_bds_unwind_n(cl_env_ptr env, int n)
141
{
142
  while (n--) ecl_bds_unwind1(env);
143
144
}

145
static void
146
ecl_bds_set_size(cl_env_ptr env, cl_index new_size)
147
{
148
149
150
151
152
153
154
155
156
157
158
  ecl_bds_ptr old_org = env->bds_org;
  cl_index limit = env->bds_top - old_org;
  if (new_size <= limit) {
    FEerror("Cannot shrink the binding stack below ~D.", 1,
            ecl_make_unsigned_integer(limit));
  } else {
    cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA];
    ecl_bds_ptr org;
    env->bds_limit_size = new_size - 2*margin;
    org = ecl_alloc_atomic(new_size * sizeof(*org));

159
    ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env);
160
161
162
163
164
    memcpy(org, old_org, (limit + 1) * sizeof(*org));
    env->bds_top = org + limit;
    env->bds_org = org;
    env->bds_limit = org + (new_size - 2*margin);
    env->bds_size = new_size;
165
    ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env);
166
167
168

    ecl_dealloc(old_org);
  }
169
170
}

171
ecl_bds_ptr 
172
ecl_bds_overflow(void)
jjgarcia's avatar
jjgarcia committed
173
{
174
175
176
177
178
179
180
181
182
183
184
185
186
  static const char *stack_overflow_msg =
    "\n;;;\n;;; Binding stack overflow.\n"
    ";;; Jumping to the outermost toplevel prompt\n"
    ";;;\n\n";
  cl_env_ptr env = ecl_process_env();
  cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA];
  cl_index size = env->bds_size;
  ecl_bds_ptr org = env->bds_org;
  ecl_bds_ptr last = org + size;
  if (env->bds_limit >= last) {
    ecl_unrecoverable_error(env, stack_overflow_msg);
  }
  env->bds_limit += margin;
187
  si_serror(6, @"Extend stack size",
188
189
190
191
            @'ext::stack-overflow', @':size', ecl_make_fixnum(size),
            @':type', @'ext::binding-stack');
  ecl_bds_set_size(env, size + (size / 2));
  return env->bds_top;
jjgarcia's avatar
jjgarcia committed
192
193
194
}

void
195
ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_top_index)
196
{
197
198
199
  ecl_bds_ptr new_bds_top = new_bds_top_index + env->bds_org;
  ecl_bds_ptr bds = env->bds_top;
  for (;  bds > new_bds_top;  bds--)
200
#ifdef ECL_THREADS
201
    ecl_bds_unwind1(env);
202
#else
203
    bds->symbol->symbol.value = bds->value;
204
#endif
205
  env->bds_top = new_bds_top;
jjgarcia's avatar
jjgarcia committed
206
207
}

208
209
210
cl_index
ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0)
{
211
212
213
214
215
216
217
  cl_object vars = vars0, values = values0;
  cl_index n = env->bds_top - env->bds_org;
  for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) {
    if (Null(vars)) {
      return n;
    } else {
      cl_object var = ECL_CONS_CAR(vars);
218
      if (!ECL_SYMBOLP(var))
219
        FEillegal_variable_name(var);
220
221
      if (ecl_symbol_type(var) & ecl_stp_constant)
        FEbinding_a_constant(var);
222
223
224
225
226
227
228
229
230
231
232
      if (Null(values)) {
        ecl_bds_bind(env, var, OBJNULL);
      } else {
        ecl_bds_bind(env, var, ECL_CONS_CAR(values));
        values = ECL_CONS_CDR(values);
      }
    }
  }
  FEerror("Wrong arguments to special form PROGV. Either~%"
          "~A~%or~%~A~%are not proper lists",
          2, vars0, values0);
233
234
}

235
static ecl_bds_ptr
jjgarcia's avatar
jjgarcia committed
236
237
get_bds_ptr(cl_object x)
{
238
239
240
241
242
243
244
  if (ECL_FIXNUMP(x)) {
    cl_env_ptr env = ecl_process_env();
    ecl_bds_ptr p = env->bds_org + ecl_fixnum(x);
    if (env->bds_org <= p && p <= env->bds_top)
      return(p);
  }
  FEerror("~S is an illegal bds index.", 1, x);
jjgarcia's avatar
jjgarcia committed
245
246
}

247
248
249
cl_object
si_bds_top()
{
250
251
  cl_env_ptr env = ecl_process_env();
  @(return ecl_make_fixnum(env->bds_top - env->bds_org));
252
}
jjgarcia's avatar
jjgarcia committed
253

254
255
256
cl_object
si_bds_var(cl_object arg)
{
257
  @(return get_bds_ptr(arg)->symbol);
258
}
jjgarcia's avatar
jjgarcia committed
259

260
261
262
cl_object
si_bds_val(cl_object arg)
{
263
  cl_object v = get_bds_ptr(arg)->value;
264
  @(return ((v == OBJNULL || v == ECL_NO_TL_BINDING)? ECL_UNBOUND : v));
265
}
jjgarcia's avatar
jjgarcia committed
266

267
268
269
270
271
#ifdef ecl_bds_bind
# undef ecl_bds_bind
# undef ecl_bds_push
# undef ecl_bds_unwind1
#endif
272
273
274
#ifdef ecl_bds_read
# undef ecl_bds_read
# undef ecl_bds_set
275
# undef ecl_bds_ref
276
#endif
277

278
#ifdef ECL_THREADS
279
static cl_index
280
ecl_new_binding_index(cl_env_ptr env, cl_object symbol)
281
{
282
283
284
285
286
287
288
289
290
291
292
293
  cl_object pool;
  cl_index new_index = symbol->symbol.binding;
  if (new_index == ECL_MISSING_SPECIAL_BINDING) {
    pool = ecl_atomic_pop(&cl_core.reused_indices);
    if (!Null(pool)) {
      new_index = ecl_fixnum(ECL_CONS_CAR(pool));
    } else {
      new_index = ecl_atomic_index_incf(&cl_core.last_var_index);
    }
    symbol->symbol.binding = new_index;
    symbol->symbol.dynamic |= 1;
  }
294
  ecl_set_finalizer_unprotected(symbol, ECL_T);
295
  return new_index;
296
297
298
299
300
}

static cl_object
ecl_extend_bindings_array(cl_object vector)
{
301
302
303
304
305
306
  cl_index new_size = cl_core.last_var_index * 1.25;
  cl_object new_vector = si_make_vector(ECL_T, ecl_make_fixnum(new_size), ECL_NIL,
                                        ECL_NIL, ECL_NIL, ECL_NIL);
  si_fill_array_with_elt(new_vector, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL);
  ecl_copy_subarray(new_vector, 0, vector, 0, vector->vector.dim);
  return new_vector;
307
308
309
}

static cl_index
310
invalid_or_too_large_binding_index(cl_env_ptr env, cl_object s)
311
{
312
313
314
315
316
317
318
319
320
321
322
  cl_index index = s->symbol.binding;
  if (index == ECL_MISSING_SPECIAL_BINDING) {
    index = ecl_new_binding_index(env, s);
  }
  if (index >= env->thread_local_bindings_size) {
    cl_object vector = env->bindings_array;
    env->bindings_array = vector = ecl_extend_bindings_array(vector);
    env->thread_local_bindings_size = vector->vector.dim;
    env->thread_local_bindings = vector->vector.self.t;
  }
  return index;
323
}
324
#endif /* ECL_THREADS */
325

326
327
328
/*
 * The following routines must match the inline forms in stacks.h
 */
329
330
331
void
ecl_bds_bind(cl_env_ptr env, cl_object s, cl_object v)
{
332
#ifdef ECL_THREADS
333
334
335
336
337
338
339
  cl_object *location;
  ecl_bds_ptr slot;
  cl_index index = s->symbol.binding;
  if (index >= env->thread_local_bindings_size) {
    index = invalid_or_too_large_binding_index(env,s);
  }
  location = env->thread_local_bindings + index;
340
  slot = env->bds_top+1;
341
342
  if (slot >= env->bds_limit) slot = ecl_bds_overflow();
  slot->symbol = ECL_DUMMY_TAG;
343
  AO_nop_full();
344
  ++env->bds_top;
345
  ecl_disable_interrupts_env(env);
346
347
348
  slot->symbol = s;
  slot->value = *location;
  *location = v;
349
  ecl_enable_interrupts_env(env);
350
#else
351
  ecl_bds_check(env);
352
353
354
355
  ecl_bds_ptr slot = ++(env->bds_top);
  ecl_disable_interrupts_env(env);
  slot->symbol = s;
  slot->value = s->symbol.value;
356
  s->symbol.value = v;
357
  ecl_enable_interrupts_env(env);
358
#endif
359
360
361
362
363
}

void
ecl_bds_push(cl_env_ptr env, cl_object s)
{
364
#ifdef ECL_THREADS
365
366
367
368
369
370
371
  cl_object *location;
  ecl_bds_ptr slot;
  cl_index index = s->symbol.binding;
  if (index >= env->thread_local_bindings_size) {
    index = invalid_or_too_large_binding_index(env,s);
  }
  location = env->thread_local_bindings + index;
372
  slot = env->bds_top+1;
373
374
  if (slot >= env->bds_limit) slot = ecl_bds_overflow();
  slot->symbol = ECL_DUMMY_TAG;
375
  AO_nop_full();
376
  ++env->bds_top;
377
  ecl_disable_interrupts_env(env);
378
379
380
  slot->symbol = s;
  slot->value = *location;
  if (*location == ECL_NO_TL_BINDING) *location = s->symbol.value;
381
  ecl_enable_interrupts_env(env);
382
#else
383
  ecl_bds_check(env);
384
385
386
387
388
  ecl_bds_ptr slot = ++(env->bds_top);
  ecl_disable_interrupts_env(env);
  slot->symbol = s;
  slot->value = s->symbol.value;
  ecl_enable_interrupts_env(env);
389
#endif
390
391
392
393
394
}

void
ecl_bds_unwind1(cl_env_ptr env)
{
395
  cl_object s = env->bds_top->symbol;
396
#ifdef ECL_THREADS
397
  cl_object *location = env->thread_local_bindings + s->symbol.binding;
398
  *location = env->bds_top->value;
399
#else
400
  s->symbol.value = env->bds_top->value;
401
#endif
402
  --env->bds_top;
403
404
}

405
#ifdef ECL_THREADS
406
407
cl_object
ecl_bds_read(cl_env_ptr env, cl_object s)
408
{
409
410
411
412
413
414
  cl_index index = s->symbol.binding;
  if (index < env->thread_local_bindings_size) {
    cl_object x = env->thread_local_bindings[index];
    if (x != ECL_NO_TL_BINDING) return x;
  }
  return s->symbol.value;
415
416
}

417
418
cl_object *
ecl_bds_ref(cl_env_ptr env, cl_object s)
419
{
420
421
422
423
424
425
426
  cl_index index = s->symbol.binding;
  if (index < env->thread_local_bindings_size) {
    cl_object *location = env->thread_local_bindings + index;
    if (*location != ECL_NO_TL_BINDING)
      return location;
  }
  return &(s->symbol.value);
427
428
429
430
431
}

cl_object
ecl_bds_set(cl_env_ptr env, cl_object s, cl_object value)
{
432
  return *ecl_bds_ref(env, s) = value;
433
}
434
#endif /* ECL_THREADS */
435

jjgarcia's avatar
jjgarcia committed
436
437
/******************** INVOCATION STACK **********************/

438
static ecl_ihs_ptr
439
get_ihs_ptr(cl_index n)
jjgarcia's avatar
jjgarcia committed
440
{
441
442
443
444
445
446
447
  cl_env_ptr env = ecl_process_env();
  ecl_ihs_ptr p = env->ihs_top;
  if (n > p->index)
    FEerror("~D is an illegal IHS index.", 1, ecl_make_fixnum(n));
  while (n < p->index)
    p = p->next;
  return p;
448
449
}

450
cl_object
451
si_ihs_top(void)
452
{
453
454
  cl_env_ptr env = ecl_process_env();
  @(return ecl_make_fixnum(env->ihs_top->index));
455
}
456

457
458
459
cl_object
si_ihs_prev(cl_object x)
{
460
  @(return cl_1M(x));
461
}
462

463
464
465
cl_object
si_ihs_next(cl_object x)
{
466
  @(return cl_1P(x));
467
}
jjgarcia's avatar
jjgarcia committed
468

469
470
471
cl_object
si_ihs_bds(cl_object arg)
{
472
  @(return ecl_make_fixnum(get_ihs_ptr(ecl_to_size(arg))->bds));
473
474
}

475
476
477
cl_object
si_ihs_fun(cl_object arg)
{
478
  @(return get_ihs_ptr(ecl_to_size(arg))->function);
479
}
jjgarcia's avatar
jjgarcia committed
480

481
482
483
cl_object
si_ihs_env(cl_object arg)
{
484
  @(return get_ihs_ptr(ecl_to_size(arg))->lex_env);
485
}
jjgarcia's avatar
jjgarcia committed
486
487
488

/********************** FRAME STACK *************************/

489
static void
490
frs_set_size(cl_env_ptr env, cl_index new_size)
491
{
492
493
494
495
496
497
498
499
500
501
502
  ecl_frame_ptr old_org = env->frs_org;
  cl_index limit = env->frs_top - old_org;
  if (new_size <= limit) {
    FEerror("Cannot shrink frame stack below ~D.", 1,
            ecl_make_unsigned_integer(limit));
  } else {
    cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA];
    ecl_frame_ptr org;
    env->frs_limit_size = new_size - 2*margin;
    org = ecl_alloc_atomic(new_size * sizeof(*org));

Marius Gerbershagen's avatar
Marius Gerbershagen committed
503
    ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env);
504
505
506
507
508
    memcpy(org, old_org, (limit + 1) * sizeof(*org));
    env->frs_top = org + limit;
    env->frs_org = org;
    env->frs_limit = org + (new_size - 2*margin);
    env->frs_size = new_size;
Marius Gerbershagen's avatar
Marius Gerbershagen committed
509
    ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env);
510
511
512

    ecl_dealloc(old_org);
  }
513
514
515
}

static void
Daniel Kochmański's avatar
Daniel Kochmański committed
516
frs_overflow(void)              /* used as condition in list.d */
jjgarcia's avatar
jjgarcia committed
517
{
518
519
520
521
522
523
524
525
526
527
528
529
530
  static const char *stack_overflow_msg =
    "\n;;;\n;;; Frame stack overflow.\n"
    ";;; Jumping to the outermost toplevel prompt\n"
    ";;;\n\n";
  cl_env_ptr env = ecl_process_env();
  cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA];
  cl_index size = env->frs_size;
  ecl_frame_ptr org = env->frs_org;
  ecl_frame_ptr last = org + size;
  if (env->frs_limit >= last) {
    ecl_unrecoverable_error(env, stack_overflow_msg);
  }
  env->frs_limit += margin;
531
  si_serror(6, @"Extend stack size",
532
533
534
            @'ext::stack-overflow', @':size', ecl_make_fixnum(size),
            @':type', @'ext::frame-stack');
  frs_set_size(env, size + size / 2);
jjgarcia's avatar
jjgarcia committed
535
536
}

537
ecl_frame_ptr
538
_ecl_frs_push(cl_env_ptr env)
jjgarcia's avatar
jjgarcia committed
539
{
540
541
  /* We store a dummy tag first, to make sure that it is safe to
   * interrupt this method with a call to ecl_unwind. Otherwise, a
542
   * stray ECL_PROTECT_TAG will lead to segfaults. AO_nop_full is
543
544
   * needed to ensure that the CPU doesn't reorder the memory
   * stores. */
545
  ecl_frame_ptr output = env->frs_top+1;
546
  if (output >= env->frs_limit) {
547
    frs_overflow();
548
    output = env->frs_top+1;
549
  }
550
  output->frs_val = ECL_DUMMY_TAG;
551
  AO_nop_full();
552
  ++env->frs_top;
553
554
555
556
  output->frs_bds_top_index = env->bds_top - env->bds_org;
  output->frs_ihs = env->ihs_top;
  output->frs_sp = ECL_STACK_INDEX(env);
  return output;
jjgarcia's avatar
jjgarcia committed
557
558
559
}

void
560
ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr)
jjgarcia's avatar
jjgarcia committed
561
{
562
  env->nlj_fr = fr;
563
  ecl_frame_ptr top = env->frs_top;
564
565
  while (top != fr && top->frs_val != ECL_PROTECT_TAG){
    top->frs_val = ECL_DUMMY_TAG;
566
    --top;
567
  }
568
569
570
571
  env->ihs_top = top->frs_ihs;
  ecl_bds_unwind(env, top->frs_bds_top_index);
  ECL_STACK_SET_INDEX(env, top->frs_sp);
  env->frs_top = top;
572
573
  ecl_longjmp(env->frs_top->frs_jmpbuf, 1);
  /* never reached */
jjgarcia's avatar
jjgarcia committed
574
575
}

576
ecl_frame_ptr
jjgarcia's avatar
jjgarcia committed
577
578
frs_sch (cl_object frame_id)
{
579
580
581
582
583
584
  cl_env_ptr env = ecl_process_env();
  ecl_frame_ptr top;
  for (top = env->frs_top;  top >= env->frs_org;  top--)
    if (top->frs_val == frame_id)
      return(top);
  return(NULL);
jjgarcia's avatar
jjgarcia committed
585
586
}

587
static ecl_frame_ptr
jjgarcia's avatar
jjgarcia committed
588
589
get_frame_ptr(cl_object x)
{
590
591
592
593
594
595
596
  if (ECL_FIXNUMP(x)) {
    cl_env_ptr env = ecl_process_env();
    ecl_frame_ptr p = env->frs_org + ecl_fixnum(x);
    if (env->frs_org <= p && p <= env->frs_top)
      return p;
  }
  FEerror("~S is an illegal frs index.", 1, x);
jjgarcia's avatar
jjgarcia committed
597
598
}

599
600
601
cl_object
si_frs_top()
{
602
603
  cl_env_ptr env = ecl_process_env();
  @(return ecl_make_fixnum(env->frs_top - env->frs_org));
604
}
jjgarcia's avatar
jjgarcia committed
605

606
607
608
cl_object
si_frs_bds(cl_object arg)
{
609
  @(return ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_top_index));
610
}
jjgarcia's avatar
jjgarcia committed
611

612
613
614
cl_object
si_frs_tag(cl_object arg)
{
615
  @(return get_frame_ptr(arg)->frs_val);
616
}
jjgarcia's avatar
jjgarcia committed
617

618
619
620
cl_object
si_frs_ihs(cl_object arg)
{
621
  @(return ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index));
622
}
jjgarcia's avatar
jjgarcia committed
623

624
625
626
cl_object
si_sch_frs_base(cl_object fr, cl_object ihs)
{
627
628
629
630
631
632
633
  cl_env_ptr env = ecl_process_env();
  ecl_frame_ptr x;
  cl_index y = ecl_to_size(ihs);
  for (x = get_frame_ptr(fr); 
       x <= env->frs_top && x->frs_ihs->index < y;
       x++);
  @(return ((x > env->frs_top) ? ECL_NIL : ecl_make_fixnum(x - env->frs_org)));
634
}
jjgarcia's avatar
jjgarcia committed
635
636
637

/********************* INITIALIZATION ***********************/

638
cl_object
639
si_set_limit(cl_object type, cl_object limit)
640
{
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
  cl_env_ptr env = ecl_process_env();
  cl_index margin;
  if (type == @'ext::frame-stack') {
    cl_index the_size = ecl_to_size(limit);
    margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA];
    frs_set_size(env, the_size + 2*margin);
  } else if (type == @'ext::binding-stack') {
    cl_index the_size = ecl_to_size(limit);
    margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA];
    ecl_bds_set_size(env, the_size + 2*margin);
  } else if (type == @'ext::c-stack') {
    cl_index the_size = ecl_to_size(limit);
    margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA];
    cs_set_size(env, the_size + 2*margin);
  } else if (type == @'ext::lisp-stack') {
    cl_index the_size = ecl_to_size(limit);
    ecl_stack_set_size(env, the_size);
  } else {
    /*
     * size_t can be larger than cl_index, and ecl_to_size()
     * creates a fixnum which is too small for size_t on 32-bit.
     */
    size_t the_size = (size_t)ecl_to_ulong(limit);
    _ecl_set_max_heap_size(the_size);
  }

  return si_get_limit(type);
668
669
}

670
671
672
cl_object
si_get_limit(cl_object type)
{
673
674
675
676
677
678
679
680
681
682
683
684
685
686
  cl_env_ptr env = ecl_process_env();
  cl_index output;
  if (type == @'ext::frame-stack')
    output = env->frs_limit_size;
  else if (type == @'ext::binding-stack')
    output = env->bds_limit_size;
  else if (type == @'ext::c-stack')
    output = env->cs_limit_size;
  else if (type == @'ext::lisp-stack')
    output = env->stack_limit_size;
  else {
    /* size_t can be larger than cl_index */
    @(return ecl_make_unsigned_integer(cl_core.max_heap_size));
  }
687

688
  @(return ecl_make_unsigned_integer(output));
689
690
}

691
692
693
cl_object
si_reset_margin(cl_object type)
{
694
695
696
697
698
699
700
701
702
  cl_env_ptr env = ecl_process_env();
  if (type == @'ext::frame-stack')
    frs_set_size(env, env->frs_size);
  else if (type == @'ext::binding-stack')
    ecl_bds_set_size(env, env->bds_size);
  else if (type == @'ext::c-stack')
    cs_set_size(env, env->cs_size);
  else
    return ECL_NIL;
703

704
  return ECL_T;
705
706
}

jjgarcia's avatar
jjgarcia committed
707
void
708
init_stacks(cl_env_ptr env)
jjgarcia's avatar
jjgarcia committed
709
{
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
  static struct ecl_ihs_frame ihs_org = { NULL, NULL, NULL, 0};
  cl_index size, margin;

  margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA];
  size = ecl_option_values[ECL_OPT_FRAME_STACK_SIZE] + 2 * margin;
  env->frs_size = size;
  env->frs_org = (ecl_frame_ptr)ecl_alloc_atomic(size * sizeof(*env->frs_org));
  env->frs_top = env->frs_org-1;
  env->frs_limit = &env->frs_org[size - 2*margin];

  margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA];
  size = ecl_option_values[ECL_OPT_BIND_STACK_SIZE] + 2 * margin;
  env->bds_size = size;
  env->bds_org = (ecl_bds_ptr)ecl_alloc_atomic(size * sizeof(*env->bds_org));
  env->bds_top = env->bds_org-1;
  env->bds_limit = &env->bds_org[size - 2*margin];

  env->ihs_top = &ihs_org;
  ihs_org.function = ECL_NIL;
  ihs_org.lex_env = ECL_NIL;
  ihs_org.index = 0;
jjgarcia's avatar
jjgarcia committed
731
}