?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
complex http example fix
[k8lst.git] / src / lstcore / lst_interp.c
blobb4dca161f7107f8b459b5879ed3e22fdf03c3703
1 /*
2 * The LittleSmalltalk byte code interpreter
3 *
4 * ---------------------------------------------------------------
5 * Little Smalltalk, Version 5
6 *
7 * Copyright (C) 1987-2005 by Timothy A. Budd
8 * Copyright (C) 2007 by Charles R. Childers
9 * Copyright (C) 2005-2007 by Danny Reinhold
10 * Copyright (C) 2010 by Ketmar // Invisible Vector
11 *
12 * ============================================================================
13 * This license applies to the virtual machine and to the initial image of
14 * the Little Smalltalk system and to all files in the Little Smalltalk
15 * packages except the files explicitly licensed with another license(s).
16 * ============================================================================
17 * Permission is hereby granted, free of charge, to any person obtaining a copy
18 * of this software and associated documentation files (the "Software"), to deal
19 * in the Software without restriction, including without limitation the rights
20 * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
21 * copies of the Software, and to permit persons to whom the Software is
22 * furnished to do so, subject to the following conditions:
23 *
24 * The above copyright notice and this permission notice shall be included in
25 * all copies or substantial portions of the Software.
26 *
27 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
28 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
29 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
30 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
31 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
32 * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
33 * DEALINGS IN THE SOFTWARE.
34 */
35
36 /*
37 * bytecode interpreter module
38 *
39 * given a process object, execute bytecodes in a tight loop.
40 *
41 * performs subroutine calls for
42 * a) garbage collection
43 * b) finding a non-cached method
44 * c) executing a primitive
45 * d) creating an integer
46 *
47 * otherwise simply loops until time slice has ended
48 */
49 #include <assert.h>
50 #include <math.h>
51 #include <stdio.h>
52 #include <stdlib.h>
53 #include <string.h>
54 #include <unistd.h>
55
56 #include "k8lst.h"
57 #include "primlib/lst_primitives.h"
58
59
60 #ifdef DEBUG
61 lstObject *lstPrimCtx = NULL;
62 #endif
63
64
65 /*
66 #define COLLECT_METHOD_STATISTICS
67 */
68
69 #define MARKARG_INLINER_CHECK
70 #define INLINER_ACTIVE
71
72 #define INLINE_SOME_METHODS
73
74 /*
75 #define DEBUG_INLINER
76 */
77
78
79 // windoze msvcrt.dll is idiotic
80 #ifndef _WIN32
81 # ifdef __LP64__
82 # define PRINTF_LLD "%ld"
83 # else
84 # define PRINTF_LLD "%lld"
85 # endif
86 #else
87 # define PRINTF_LLD "%I64d"
88 #endif
89
90 #define BETTER_CACHE_CONTROL
91
92 LstEventCheckFn lstEventCheck = NULL;
93
94 int lstExecUserBreak = 0;
95
96 unsigned int lstDebugFlag = 0;
97
98 unsigned int lstInfoCacheHit = 0;
99 unsigned int lstInfoCacheMiss = 0;
100
101 unsigned int lstInfoLiteralHit = 0;
102 unsigned int lstInfoIVarHit = 0;
103
104 static int lstSuspended = 0;
105
106
107 #define FNV_PRIME 16777619
108 #define FNV_OFFSET_BASIS 2166136261uL
109 #define SIZE_TH 256
110
111 static uint32_t fnvHash (const void *str, int slen) {
112 const unsigned char *buf = (const unsigned char *)str;
113 uint32_t acc = FNV_OFFSET_BASIS;
114 if (slen > SIZE_TH) {
115 int left = slen-SIZE_TH;
116 if (left > SIZE_TH) left = SIZE_TH;
117 const unsigned char *buf1 = (const unsigned char *)str;
118 buf1 = buf1+slen-left;
119 while (slen-- > 0) { acc *= FNV_PRIME; acc ^= *buf++; }
120 while (left-- > 0) { acc *= FNV_PRIME; acc ^= *buf1++; }
121 } else {
122 while (slen-- > 0) { acc *= FNV_PRIME; acc ^= *buf++; }
123 }
124 return acc;
125 }
126
127
128 static inline int LST_RSTACK_NSP (void) {
129 if (lstRootTop >= LST_ROOTSTACK_LIMIT) lstFatal("out of root stack", 0);
130 return lstRootTop++;
131 }
132
133
134 /* The following are roots for the file out */
135 lstObject *lstNilObj = NULL;
136 lstObject *lstTrueObj = NULL;
137 lstObject *lstFalseObj = NULL;
138 lstObject *lstBooleanClass = NULL;
139 lstObject *lstSmallIntClass = NULL;
140 lstObject *lstCharClass = NULL;
141 lstObject *lstArrayClass = NULL;
142 lstObject *lstBlockClass = NULL;
143 lstObject *lstContextClass = NULL;
144 lstObject *lstProcessClass = NULL;
145 lstObject *lstStringClass = NULL;
146 lstObject *lstSymbolClass = NULL;
147 lstObject *lstByteArrayClass = NULL;
148 lstObject *lstByteCodeClass = NULL;
149 lstObject *lstMethodClass = NULL;
150 lstObject *lstGlobalObj = NULL;
151 lstObject *lstBinMsgs[LST_MAX_BIN_MSG] = { NULL };
152 lstObject *lstIntegerClass = NULL;
153 lstObject *lstFloatClass = NULL;
154 lstObject *lstNumberClass = NULL;
155 lstObject *lstBadMethodSym = NULL;
156 lstObject *lstInitMethod = NULL;
157 lstObject *lstLoadMethod = NULL;
158 lstObject *lstDoStrMethod = NULL;
159 lstObject *lstReplMethod = NULL;
160 lstObject *lstNewSymMethod = NULL;
161 lstObject *lstSetGlobMethod = NULL;
162
163
164 #ifdef INLINE_SOME_METHODS
165 static lstObject *lstMetaCharClass = NULL;
166
167 static lstObject *lstArrayAtMethod = NULL;
168 static lstObject *lstArraySizeMethod = NULL;
169 static lstObject *lstMetaCharNewMethod = NULL;
170 static lstObject *lstStringAtIfAbsentMethod = NULL;
171 static lstObject *lstStringAtMethod = NULL;
172 static lstObject *lstStringBasicAtPutMethod = NULL;
173 static lstObject *lstStringPrintStringMethod = NULL;
174 static lstObject *lstSymbolPrintStringMethod = NULL;
175 static lstObject *lstBlockValue1Method = NULL;
176
177 static struct {
178 int argc;
179 const char *name;
180 lstObject **mtclass;
181 lstObject **method;
182 } lstInlineMethodList[] = {
183 {2, "at:", &lstArrayClass, &lstArrayAtMethod},
184 {1, "size", &lstArrayClass, &lstArraySizeMethod},
185 {2, "at:", &lstStringClass, &lstStringAtMethod},
186 {1, "printString", &lstStringClass, &lstStringPrintStringMethod},
187 {1, "printString", &lstSymbolClass, &lstSymbolPrintStringMethod},
188 {3, "basicAt:put:", &lstStringClass, &lstStringBasicAtPutMethod},
189 {2, "new:", &lstMetaCharClass, &lstMetaCharNewMethod},
190 {3, "at:ifAbsent:", &lstStringClass, &lstStringAtIfAbsentMethod},
191 {2, "value:", &lstBlockClass, &lstBlockValue1Method},
192 {0}
193 };
194 #endif
195
196
197 #define DBGCHAN stderr
198
199 /*
200 * Debugging
201 */
202 #if defined(DEBUG)
203 static void indent (lstObject *ctx) {
204 /*static int oldlev = 0;*/
205 int lev = 0;
206 while (ctx && (ctx != lstNilObj)) {
207 ++lev;
208 fputc(' ', DBGCHAN);
209 ctx = ctx->data[lstIVpreviousContextInContext];
210 }
211 /* this lets you use your editor's brace matching to match up opening and closing indentation levels */
212 /*
213 if (lev < oldlev) {
214 int x;
215 for (x = lev; x < oldlev; ++x) fputc('}', DBGCHAN);
216 } else if (lev > oldlev) {
217 int x;
218 for (x = oldlev; x < lev; ++x) fputc('{', DBGCHAN);
219 }
220 */
221 /*oldlev = lev;*/
222 }
223
224
225 # define PC (curIP-1)
226 # define DBG0(msg) if (lstDebugFlag) {indent(context); fprintf(DBGCHAN, "%d: %s\n", PC, msg);}
227 # define DBG1(msg, arg) if (lstDebugFlag) {indent(context); fprintf(DBGCHAN, "%d: %s %d\n", PC, msg, arg);}
228 # define DBG2(msg, arg, arg1) if (lstDebugFlag) {indent(context); fprintf(DBGCHAN, "%d: %s %d %d\n", PC, msg, arg, arg1);}
229 # define DBGS(msg, cl, sel) \
230 if (lstDebugFlag) { \
231 indent(context); \
232 char clnm[1024], selnm[1024]; \
233 lstGetString(clnm, sizeof(clnm), (lstObject *) cl); \
234 lstGetString(selnm, sizeof(selnm), (lstObject *) sel); \
235 fprintf(DBGCHAN, "%d: %s %s %s\n", PC, msg, clnm, selnm); }
236 #else
237 # define DBG0(msg)
238 # define DBG1(msg, arg)
239 # define DBG2(msg, arg, arg1)
240 # define DBGS(msg, cl, sel)
241 #endif
242
243
244 #ifdef DEBUG
245 # define dprintf(...) fprintf(DBGCHAN, __VA_ARGS__)
246 #else
247 # define dprintf(...)
248 #endif
249
250 #ifdef DEBUG_INLINER
251 # define iprintf(...) fprintf(DBGCHAN, __VA_ARGS__)
252 #else
253 # define iprintf(...)
254 #endif
255
256
257 static int symbolcomp (lstObject *left, lstObject *right) {
258 int leftsize = LST_SIZE(left);
259 int rightsize = LST_SIZE(right);
260 int minsize = leftsize;
261 int i;
262 if (rightsize < minsize) minsize = rightsize;
263 /* use faster comparison */
264 if (minsize > 0) {
265 if ((i = memcmp(lstBytePtr(left), lstBytePtr(right), minsize))) return i;
266 }
267 return leftsize-rightsize;
268 }
269
270
271 /* method lookup routine, used when cache miss occurs */
272 static lstObject *lookupMethod (lstObject *selector, lstObject *stclass) {
273 lstObject *dict, *keys, *vals, *val;
274 LstInt low, high, mid;
275 /* scan upward through the class hierarchy */
276 for (; stclass && stclass != lstNilObj; stclass = stclass->data[lstIVparentClassInClass]) {
277 /* consider the Dictionary of methods for this Class */
278 #if 0 & defined(DEBUG)
279 {
280 static char tb[1024];
281 fprintf(stderr, "st=%p; u=%p; sz=%d\n", stclass, lstNilObj, LST_SIZE(stclass));
282 lstGetString(tb, sizeof(tb), stclass->data[lstIVnameInClass]);
283 fprintf(stderr, " [%s]\n", tb);
284 }
285 #endif
286 #if !defined(NDEBUG) || defined(DEBUG)
287 if (LST_IS_SMALLINT(stclass)) lstFatal("lookupMethod: looking in SmallInt instance", 0);
288 if (LST_IS_BYTES(stclass)) lstFatal("lookupMethod: looking in binary object", 0);
289 if (LST_SIZE(stclass) < lstClassSize) lstFatal("lookupMethod: looking in non-class object", 0);
290 #endif
291 dict = stclass->data[lstIVmethodsInClass];
292 #if !defined(NDEBUG) || defined(DEBUG)
293 #define lstFatalX(msg, dummy) {\
294 fprintf(stderr, "ERROR: %s\n", msg);\
295 fprintf(stderr, "class: %s\n", lstGetStringPtr(stclass->data[lstIVnameInClass]));\
296 if (dict && !LST_IS_SMALLINT(dict)) {\
297 while (dict && dict != lstNilObj) {\
298 if (LST_IS_SMALLINT(dict)) { fprintf(stderr, "dict: number\n"); break; }\
299 if (LST_SIZE(dict) < lstClassSize) { fprintf(stderr, "dict: instance (%p)\n", dict); }\
300 else {\
301 fprintf(stderr, "dict: %s\n", lstGetStringPtr(dict->data[lstIVnameInClass]));\
302 break;\
303 }\
304 dict = dict->stclass;\
305 }\
306 }\
307 /* *((char *)0) = 0; */\
308 lstFatal(msg, dummy);\
309 }
310 if (!dict) lstFatalX("lookupMethod: NULL dictionary", 0);
311 if (LST_IS_SMALLINT(dict)) lstFatalX("lookupMethod: SmallInt dictionary", 0);
312 if (dict->stclass != lstFindGlobal("Dictionary")) lstFatalX("lookupMethod: method list is not a dictionary", 0);
313 #endif
314 keys = dict->data[0];
315 low = 0;
316 high = LST_SIZE(keys);
317 /* do a binary search through its keys, which are Symbol's. */
318 while (low < high) {
319 mid = (low+high)/2;
320 val = keys->data[mid];
321 /* if we find the selector, return the method lstObject. */
322 if (val == selector) {
323 vals = dict->data[1];
324 return vals->data[mid];
325 }
326 /* otherwise continue the binary search */
327 if (symbolcomp(selector, val) < 0) high = mid; else low = mid+1;
328 }
329 }
330 /* sorry, couldn't find a method */
331 return NULL;
332 }
333
334
335 /* method cache for speeding method lookup */
336 /* why 703? we have two primes: 701, 709, 719; let's try 719 */
337 #define MTD_CACHE_SIZE 719
338 #define MTD_CACHE_EXTRA 4
339 #define MTD_BAD_HIT_MAX 16
340 static struct {
341 lstObject *name;
342 lstObject *stclass;
343 lstObject *method;
344 int badHits; /* after MTD_BAD_HIT_MAX this cache item will be cleared */
345 int goodHits;
346 int analyzed;
347 lstObject *mConst; /* constant for methods returning constant */
348 int ivarNum; /* ivar number for methods returning ivar */
349 } cache[MTD_CACHE_SIZE+MTD_CACHE_EXTRA];
350
351
352 /* flush dynamic methods when GC occurs */
353 void lstFlushMethodCache (void) {
354 memset(cache, 0, sizeof(cache));
355 }
356
357
358 /* run contexts */
359 typedef struct LstRunContext LstRunContext;
360 struct LstRunContext {
361 /* ticks and locks fields will be filled only on process suspension */
362 int ticksLeft;
363 int lockCount;
364 lstObject *process;
365 LstRunContext *prev; /* previous process in group */
366 };
367
368 typedef struct LstRunGroup LstRunGroup;
369 struct LstRunGroup {
370 LstRunGroup *prev; /* prev group */
371 LstRunGroup *next; /* next group */
372 LstRunContext *group; /* next group */
373 int ticks; /* for the whole group; used on sheduling */
374 int ewait; /* >0: normal process waiting for the event */
375 int finalizer;
376 };
377
378 static LstRunContext *rsFree = NULL; /*TODO: free when too many*/
379 static LstRunGroup *runGroups = NULL; /* list of all process groups */
380 static LstRunGroup *curGroup = NULL; /* current run group */
381 static int finGroupCount = 0;
382 static int runOnlyFins = 0;
383
384 /* allocate new run context in the current group */
385 static LstRunContext *allocRunContext (void) {
386 LstRunContext *res = rsFree;
387 if (res) {
388 rsFree = res->prev;
389 } else {
390 res = calloc(1, sizeof(LstRunContext));
391 }
392 res->prev = curGroup->group;
393 curGroup->group = res;
394 return res;
395 }
396
397
398 /* release top context in the current group; return previous one */
399 static LstRunContext *releaseRunContext (void) {
400 LstRunContext *c = curGroup->group;
401 if (c) {
402 curGroup->group = c->prev;
403 c->prev = rsFree;
404 rsFree = c;
405 }
406 return curGroup->group;
407 }
408
409
410 static void lstCreateFinalizePGroup (lstObject *prc) {
411 LstRunGroup *g = calloc(1, sizeof(LstRunGroup)), *p = curGroup?curGroup:runGroups;
412 LstRunContext *c = calloc(1, sizeof(LstRunContext));
413 g->prev = p;
414 g->next = p->next;
415 p->next = g; /* can't be first group anyway */
416 if (g->next) g->next->prev = g;
417 g->group = c;
418 /* note that we can't allocate objects here, 'cause this thing will be called from inside GC */
419 c->ticksLeft = 10000;
420 c->process = prc;
421 g->finalizer = 1;
422 ++finGroupCount;
423 }
424
425
426 /*
427 * note that process locks locks all groups now;
428 * this MUST be changed: we have to use fine-grained locks,
429 * mutexes and other cool things
430 */
431
432 /* events */
433 typedef struct LstEventHandler LstEventHandler;
434 struct LstEventHandler {
435 LstEventHandler *next;
436 /*lstObject *process;*/
437 LstRunGroup *grp;
438 int eid;
439 };
440 static LstEventHandler *ehList = NULL;
441
442
443 static LstRunGroup *findEventHandler (int eid) {
444 LstEventHandler *cur, *prev;
445 for (cur = ehList, prev = NULL; cur; prev = cur, cur = cur->next) {
446 if (cur->eid == eid) {
447 LstRunGroup *grp = cur->grp;
448 /* remove from the list */
449 if (prev) prev->next = cur->next; else ehList = cur->next;
450 free(cur);
451 return grp;
452 }
453 }
454 return NULL;
455 }
456
457
458 static void addOneShotEventHandler (int eid, LstRunGroup *grp) {
459 LstEventHandler *cur = calloc(1, sizeof(LstEventHandler));
460 cur->eid = eid;
461 cur->next = ehList;
462 ehList = cur;
463 cur->grp = grp;
464 }
465
466
467 #include "lst_memory.c"
468
469
470 static int groupHasProcess (const LstRunGroup *g, const lstObject *prc) {
471 const LstRunContext *c;
472 for (c = g->group; c; c = c->prev) if (c->process == prc) return 1;
473 return 0;
474 }
475
476
477 #define CHECK_MSTACK
478
479 #ifdef CHECK_MSTACK
480 # define POPIT (stack->data[--stackTop])
481 # define PUSHIT(n) if (stackTop >= LST_SIZE(stack)) { lstBackTrace(context); lstFatal("method stack overflow", curIP); } else stack->data[stackTop++] = (n)
482 #else
483 # define POPIT (stack->data[--stackTop])
484 # define PUSHIT(n) stack->data[stackTop++] = (n)
485 #endif
486
487
488 /* Code locations are extracted as VAL's */
489 #define VAL (bp[curIP] | (bp[curIP+1] << 8))
490 /*#define VALSIZE 2*/
491
492
493 #define XRETURN(value) { LST_LEAVE_BLOCK(); return (value); }
494
495 #define GET_BCODE_OP(ip) \
496 low = (high = bp[ip++])&0x0F; high >>= 4; \
497 if (high == lstBCExtended) { high = low; low = bp[ip++]; }
498
499
500 #define CALC_CACHE_HASH(sel, cls) \
501 (LstUInt)((intptr_t)(sel)+(intptr_t)(cls))%MTD_CACHE_SIZE;
502
503 int lstEvtCheckLeft = 1000;
504
505 static int resetEvtCheckLeft = 0;
506 void lstResetEvtCheckLeft (void) { resetEvtCheckLeft = 1; }
507
508 static int lastFailedPrim = 0;
509 static int lastCalledPrim = 0;
510
511 static int lstExecuteInternal (lstObject *aProcess, int ticks, int locked) {
512 int low, high;
513 int stackTop;
514 int curIP;
515 lstObject *retValue = lstNilObj;
516 lstObject *context = NULL;
517 lstObject *method = NULL;
518 lstObject *stack = NULL;
519 lstObject *arguments = NULL;
520 lstObject *temporaries = NULL;
521 lstObject *instanceVariables = NULL;
522 lstObject *literals = NULL;
523 lstObject *ptemp = NULL;
524 lstObject *ptemp1 = NULL;
525 lstObject *messageSelector;
526 lstObject *receiverClass;
527 lstObject *op, *op1;
528 int lockCount = locked>0;
529 const unsigned char *bp;
530 char sbuf[257];
531 int tmp, l0, l1, x;
532 int64_t itmp;
533 LstLInt ll0, ll1;
534 LstFloat fop0, fop1;
535 int evtCheckLeft = lstEvtCheckLeft;
536 int oTicks = curGroup->ticks;
537 int wasRunInWaits = 1;
538 int grpTicks = 10000;
539 int retGSwitch = 0;
540
541 /* reload all the necessary vars from the current context */
542 void reloadFromCtx (void) {
543 method = context->data[lstIVmethodInContext];
544 stack = context->data[lstIVstackInContext];
545 temporaries = context->data[lstIVtemporariesInContext];
546 arguments = context->data[lstIVargumentsInContext];
547 literals = method->data[lstIVliteralsInMethod];
548 instanceVariables = arguments->data[lstIVreceiverInArguments];
549 curIP = lstIntValue(context->data[lstIVbytePointerInContext]);
550 stackTop = lstIntValue(context->data[lstIVstackTopInContext]);
551 }
552
553 /* reloca current group state */
554 void reloadFromGroup (void) {
555 LstRunContext *rc = curGroup->group; /* current context */
556 aProcess = rc->process;
557 ticks = rc->ticksLeft;
558 lockCount = rc->lockCount;
559 context = aProcess->data[lstIVcontextInProcess];
560 reloadFromCtx();
561 if (curGroup->ewait > 0) { lockCount = 0; evtCheckLeft = 1; } /* force event query */
562 }
563
564 /* load new process to the current group */
565 int loadNewProcess (lstObject *newProc) {
566 if (!newProc || newProc == lstNilObj) return lstReturnError;
567 if (newProc->data[lstIVrunningInProcess] != lstNilObj) return lstReturnError; /* already running/suspended */
568 /* get current context information */
569 context = newProc->data[lstIVcontextInProcess];
570 if (!context || context == lstNilObj) return lstReturnError; /* terminated */
571 method = context->data[lstIVmethodInContext];
572 if (!method || method == lstNilObj) return lstReturnError; /* the thing that should not be */
573 aProcess = newProc;
574 reloadFromCtx();
575 newProc->data[lstIVrunningInProcess] = lstTrueObj;
576 /* now create new runnint context */
577 LstRunContext *rc = allocRunContext();
578 rc->process = newProc;
579 rc->lockCount = lockCount;
580 rc->ticksLeft = ticks;
581 return 0;
582 }
583
584 /* fix process and context info */
585 void saveCurrentProcess (void) {
586 if (!curGroup->group) return;
587 if (curGroup->ewait <= 0) {
588 aProcess->data[lstIVresultInProcess] = lstNilObj;
589 aProcess->data[lstIVcontextInProcess] = context;
590 if (context != lstNilObj) {
591 context->data[lstIVbytePointerInContext] = lstNewInt(curIP);
592 context->data[lstIVstackTopInContext] = lstNewInt(stackTop);
593 LstRunContext *rc = curGroup->group; /* current context */
594 rc->ticksLeft = ticks;
595 rc->lockCount = lockCount;
596 }
597 }
598 }
599
600 /* switch to next group and reload it */
601 void nextGroup (int skipIt) {
602 int f;
603 if (skipIt && curGroup) { saveCurrentProcess(); curGroup = curGroup->next; }
604 if (!curGroup) curGroup = runGroups;
605 grpTicks = 10000;
606 if (runOnlyFins) {
607 dprintf("rof: cg=%p\n", curGroup);
608 for (f = 2; f > 0; --f) {
609 do {
610 while (curGroup && !curGroup->group) curGroup = curGroup->next;
611 } while (curGroup && !curGroup->finalizer);
612 if (curGroup) break;
613 curGroup = runGroups;
614 }
615 if (!curGroup) lstFatal("internal error in finalizing stage", 0);
616 dprintf("rof: found cg=%p\n", curGroup);
617 dprintf("rof: ctx=%p\n", curGroup->group);
618 dprintf("rof: fin=%d\n", curGroup->finalizer);
619 dprintf("rof: fin left=%d\n", finGroupCount);
620 if (curGroup && !curGroup->group) {
621 if (finGroupCount > 0) lstFatal("internal error in finalizing stage", 1);
622 return;
623 }
624 } else {
625 for (f = 2; f > 0; --f) {
626 while (curGroup && curGroup->ewait) curGroup = curGroup->next;
627 if (curGroup) break;
628 curGroup = runGroups;
629 }
630 if (!curGroup) curGroup = runGroups;
631 }
632 reloadFromGroup();
633 }
634
635 /* curGroup can be NULL after returning */
636 /* result==NULL: trying to kill main group */
637 LstRunGroup *removeCurrentGroup (void) {
638 if (curGroup == runGroups) return NULL;
639 /* exclude from the list */
640 curGroup->prev->next = curGroup->next; /* it's safe, 'cause we can't remove the first (main) group */
641 if (curGroup->next) curGroup->next->prev = curGroup->prev;
642 LstRunGroup *pg = curGroup;
643 if (!(curGroup = curGroup->next)) curGroup = runGroups;
644 return pg;
645 }
646
647 /* return from process */
648 /* on return: low is the result; tmp!=0: switched to suspended context */
649 int doReturn (int res) {
650 retGSwitch = 0;
651 saveCurrentProcess();
652 LstRunContext *rc = curGroup->group; /* current context */
653 /*saveCurrentProcess();*/
654 low = res; tmp = 0;
655 aProcess->data[lstIVrunningInProcess] = lstNilObj;
656 aProcess->data[lstIVresultInProcess] = retValue;
657 if (res == lstReturnReturned) aProcess->data[lstIVcontextInProcess] = lstNilObj;
658 if ((rc = releaseRunContext())) {
659 /* still marching */
660 aProcess = rc->process;
661 reloadFromGroup();
662 tmp = (curGroup->ewait != 0);
663 return 0; /* ok, the show must go on */
664 }
665 /* group is out of bussines now; exit if this is the main group */
666 if (curGroup == runGroups) {
667 /* 'main group': so get out of here */
668 runGroups->ticks = oTicks;
669 return res;
670 }
671 /* remove empty group */
672 if (curGroup->finalizer) --finGroupCount;
673 retGSwitch = 1;
674 LstRunGroup *pg = removeCurrentGroup();
675 free(pg);
676 nextGroup(0);
677 tmp = (curGroup->ewait != 0);
678 #ifdef DEBUG
679 dprintf("return-switched from %p to %p\n", pg, curGroup);
680 if (lstDebugFlag) {
681 dprintf("ctx=%p; mth=%p; ip=%d; tmp=%d\n", context, method, curIP, tmp);
682 }
683 #endif
684 return 0; /* don't stop at the top */
685 }
686
687
688 lstExecUserBreak = 0;
689
690 assert(runGroups->group == NULL);
691 if (runOnlyFins) {
692 lstSuspended = 0;
693 curGroup = NULL;
694 nextGroup(0);
695 } else {
696 if (lstSuspended) {
697 lstSuspended = 0;
698 reloadFromGroup();
699 } else {
700 curGroup = runGroups; /* switch to 'main' */
701 runGroups->ticks = ticks;
702 if (loadNewProcess(aProcess) != 0) {
703 releaseRunContext(); /* drop dummy context */
704 curGroup = NULL; /* restore old group */
705 return lstReturnError; /* barf */
706 }
707 }
708 }
709
710 LST_ENTER_BLOCK();
711 LST_TEMP(aProcess);
712 LST_TEMP(context);
713 LST_TEMP(method);
714 LST_TEMP(stack);
715 LST_TEMP(arguments);
716 LST_TEMP(temporaries);
717 LST_TEMP(instanceVariables);
718 LST_TEMP(literals);
719 LST_TEMP(ptemp);
720 LST_TEMP(ptemp1);
721
722 /* main loop */
723 for (;;) {
724 doAllAgain:
725 if (curGroup->ewait < 0) {
726 /* new waiting process */
727 saveCurrentProcess();
728 curGroup->ewait = -curGroup->ewait;
729 /*dprintf("%p: suspend for %d: ip=%d; sp=%d\n", curGroup, curGroup->ewait, curIP, stackTop);*/
730 evtCheckLeft = 1; lockCount = 0;
731 }
732 /* gum solution */
733 if (runOnlyFins) {
734 if (finGroupCount < 1) {
735 runOnlyFins = finGroupCount = 0;
736 XRETURN(lstReturnAPISuspended);
737 }
738 if (!curGroup->finalizer) {
739 nextGroup(1);
740 goto doAllAgain;
741 }
742 if (curGroup->ewait > 0) {
743 curGroup->finalizer = 0;
744 --finGroupCount;
745 nextGroup(1);
746 goto doAllAgain;
747 }
748 goto skipForFin;
749 }
750 if (evtCheckLeft > 0 && (--evtCheckLeft == 0)) {
751 evtCheckLeft = lstEvtCheckLeft;
752 if (lstExecUserBreak) {
753 /* C API break; get out of here */
754 saveCurrentProcess();
755 lstSuspended = 1;
756 #ifdef DEBUG
757 fprintf(stderr, "FUCK! SUSPEND!\n");
758 if (curGroup == runGroups) fprintf(stderr, "SUSPEND IN MAIN GROUP!\n");
759 #endif
760 XRETURN(lstReturnAPISuspended);
761 }
762 if (lstEventCheck) {
763 int id;
764 if ((id = lstEventCheck(&ticks)) > 0) {
765 LstRunGroup *grp = findEventHandler(id);
766 if (grp) {
767 /* save current process */
768 if (curGroup->ewait == 0) saveCurrentProcess();
769 /* wake up suspended process */
770 /*dprintf("found process group for %d\n", id);*/
771 /* switch to this context */
772 assert(grp->ewait == id);
773 grp->ewait = 0; /* not waiting anymore */
774 curGroup = grp;
775 reloadFromGroup();
776 /*dprintf("%p: resume: ip=%d; sp=%d\n", curGroup, curIP, stackTop);*/
777 goto doAllAgain; /* continue with the next bytecode */
778 }
779 }
780 }
781 /* other shedulers */
782 if (curGroup->ewait == 0) {
783 /* process group sheduling */
784 if (grpTicks > 0 && (--grpTicks == 0)) {
785 grpTicks = 10000;
786 if (runGroups->next) {
787 dprintf("GRPSHEDULE!\n");
788 LstRunGroup *og = curGroup;
789 nextGroup(1);
790 if (og != curGroup) goto doAllAgain; /* go on with the new process */
791 }
792 }
793 /* if we're running against a CPU tick count, shedule execution when we expire the given number of ticks */
794 if (ticks > 0 && (--ticks == 0)) {
795 if (lockCount) {
796 /* locked; no sheduling */
797 ticks = 1; /* this will slow down the process, but locks shouldn't be held for the long time */
798 } else {
799 dprintf("TimeExpired: lockCount=%d\n", lockCount);
800 int rr = doReturn(lstReturnTimeExpired);
801 if (rr) XRETURN(rr);
802 if (tmp || retGSwitch) goto doAllAgain;
803 goto execComplete;
804 }
805 }
806 }
807 }
808 if (curGroup->ewait > 0) {
809 /* this process is in the wait state */
810 /*dprintf("process are waiting for: %d\n", curGroup->ewait);*/
811 LstRunGroup *og = curGroup;
812 nextGroup(1);
813 #ifdef DEBUG
814 if (og != curGroup) dprintf("switched from %p to %p\n", og, curGroup);
815 #endif
816 if (og == curGroup || !wasRunInWaits) {
817 /*dprintf(" releasing time slice\n");*/
818 usleep(1); /* release timeslice */
819 }
820 wasRunInWaits = 0;
821 goto doAllAgain;
822 }
823
824 skipForFin:
825 wasRunInWaits = 1;
826 /* decode the instruction */
827 bp = (const unsigned char *)lstBytePtr(method->data[lstIVbyteCodesInMethod]);
828 GET_BCODE_OP(curIP)
829 /* and dispatch */
830 switch (high) {
831 case lstBCPushInstance:
832 DBG1("PushInstance", low);
833 PUSHIT(instanceVariables->data[low]);
834 break;
835 case lstBCPushArgument:
836 DBG1("PushArgument", low);
837 PUSHIT(arguments->data[low]);
838 break;
839 case lstBCPushTemporary:
840 DBG1("PushTemporary", low);
841 PUSHIT(temporaries->data[low]);
842 break;
843 case lstBCPushLiteral:
844 DBG1("PushLiteral", low);
845 PUSHIT(literals->data[low]);
846 break;
847 case lstBCPushConstant:
848 switch (low) {
849 case lstBLNilConst:
850 DBG0("PushConstant nil");
851 PUSHIT(lstNilObj);
852 break;
853 case lstBLTrueConst:
854 DBG0("PushConstant true");
855 PUSHIT(lstTrueObj);
856 break;
857 case lstBLFalseConst:
858 DBG0("PushConstant false");
859 PUSHIT(lstFalseObj);
860 break;
861 default:
862 low -= 3;
863 DBG1("PushConstant", low);
864 PUSHIT(lstNewInt(low));
865 break;
866 }
867 break;
868 case lstBCAssignInstance:
869 DBG1("AssignInstance", low);
870 /* don't pop stack, leave result there */
871 lstWriteBarrier(&instanceVariables->data[low], stack->data[stackTop-1]);
872 break;
873 case lstBCAssignArgument:
874 DBG1("AssignArgument", low);
875 /* don't pop stack, leave result there */
876 arguments->data[low] = stack->data[stackTop-1];
877 break;
878 case lstBCAssignTemporary:
879 DBG1("AssignTemporary", low);
880 /* don't pop stack, leave result there */
881 temporaries->data[low] = stack->data[stackTop-1];
882 break;
883 case lstBCMarkArguments:
884 DBG1("MarkArguments", low);
885 #ifdef MARKARG_INLINER_CHECK
886 if (ticks != 1 && low > 1 && low <= 3) {
887 /* check if next opcode is SendMessage */
888 switch (bp[curIP]/16) {
889 case lstBCSendMessage:
890 l0 = bp[curIP]%16;
891 l1 = curIP+1;
892 checkForInline:
893 messageSelector = literals->data[l0];
894 receiverClass = stack->data[stackTop-low];
895 /*iprintf("stackTop: %d; low: %d; rc: %p\n", stackTop, low, receiverClass);*/
896 receiverClass = LST_CLASS(receiverClass);
897 tmp = CALC_CACHE_HASH(messageSelector, receiverClass);
898 if (cache[tmp].name == messageSelector && cache[tmp].stclass == receiverClass) {
899 checkForInlineCacheHit:
900 # ifdef INLINE_SOME_METHODS
901 { int f; op = cache[tmp].method;
902 for (f = 0; lstInlineMethodList[f].name; ++f) {
903 if (low == lstInlineMethodList[f].argc && *(lstInlineMethodList[f].method) == op) {
904 op = stack->data[stackTop-low]; /* self */
905 if (LST_IS_SMALLINT(op)) break; /* invalid object */
906 switch (f) {
907 case 0: /* Array>>at: */
908 /*fprintf(stderr, "Array>>at: hit!\n");*/
909 if (LST_IS_BYTES(op)) break;
910 op1 = stack->data[stackTop-1]; /* index */
911 if (LST_IS_SMALLINT(op1)) {
912 l0 = lstIntValue(op1)-1;
913 if (l0 < 0 || l0 >= LST_SIZE(op)) break; /* out of range */
914 stackTop -= low;
915 retValue = op->data[l0];
916 low = -1;
917 goto markArgsInlined;
918 }
919 break;
920 case 1: /* Array>>size */
921 /*fprintf(stderr, "Array>>size hit!\n");*/
922 stackTop -= low;
923 l0 = LST_SIZE(op);
924 retValue = lstNewInt(l0);
925 low = -1;
926 goto markArgsInlined;
927 case 2: /* String>>at: */
928 if (!LST_IS_BYTES(op)) break; /* not a string */
929 op1 = stack->data[stackTop-1]; /* index */
930 if (LST_IS_SMALLINT(op1)) {
931 l0 = lstIntValue(op1)-1;
932 if (l0 < 0 || l0 >= LST_SIZE(op)) break; /* out of range */
933 stackTop -= low;
934 l0 = lstBytePtr(op)[l0];
935 retValue = lstCharClass->data[lstIVcharsInMetaChar]->data[l0];
936 low = -1;
937 goto markArgsInlined;
938 }
939 break;
940 case 3: /* String>>printString */
941 /*fprintf(stderr, "String>>printString hit!\n");*/
942 if (op->stclass == lstSymbolClass) {
943 ptemp = op;
944 l0 = LST_SIZE(ptemp);
945 retValue = (lstObject *)lstMemAllocBin(l0);
946 retValue->stclass = lstStringClass;
947 if (l0 > 0) memcpy(lstBytePtr(retValue), lstBytePtr(ptemp), l0);
948 ptemp = NULL;
949 } else if (op->stclass == lstStringClass) {
950 retValue = op;
951 } else {
952 break;
953 }
954 stackTop -= low;
955 low = -1;
956 goto markArgsInlined;
957 case 4: /* Symbol>>printString */
958 /*fprintf(stderr, "Symbol>>printString hit!\n");*/
959 if (op->stclass == lstSymbolClass) {
960 ptemp = op;
961 l0 = LST_SIZE(ptemp);
962 retValue = (lstObject *)lstMemAllocBin(l0);
963 retValue->stclass = lstStringClass;
964 if (l0 > 0) memcpy(lstBytePtr(retValue), lstBytePtr(ptemp), l0);
965 ptemp = NULL;
966 } else if (op->stclass == lstStringClass) {
967 retValue = op;
968 } else break;
969 stackTop -= low;
970 low = -1;
971 goto markArgsInlined;
972 case 5: /* String>>basicAt:put: */
973 /*fprintf(stderr, "String>>basicAt:put: hit!\n");*/
974 if (!LST_IS_BYTES(op)) break; /* not a string */
975 op1 = stack->data[stackTop-2]; /* index */
976 if (LST_IS_SMALLINT(op1)) {
977 l0 = lstIntValue(op1)-1;
978 if (l0 < 0 || l0 >= LST_SIZE(op)) break; /* out of range */
979 op1 = stack->data[stackTop-1]; /* value */
980 if (LST_IS_SMALLINT(op1)) {
981 stackTop -= low;
982 lstBytePtr(op)[l0] = lstIntValue(op1);
983 retValue = op;
984 low = -1;
985 goto markArgsInlined;
986 }
987 }
988 break;
989 case 6: /* MetaChar>>new: */
990 /*fprintf(stderr, "MetaChar>>new: hit!\n");*/
991 op1 = stack->data[stackTop-1]; /* value */
992 if (LST_IS_SMALLINT(op1)) {
993 l0 = lstIntValue(op1);
994 if (l0 < 0 || l0 >= 257) break; /* out of range */
995 stackTop -= low;
996 retValue = lstCharClass->data[lstIVcharsInMetaChar]->data[l0];
997 low = -1;
998 goto markArgsInlined;
999 }
1000 break;
1001 case 7: /* String>>at:ifAbsent: */
1002 /*fprintf(stderr, "String>>at:ifAbsent: hit!\n");*/
1003 if (!LST_IS_BYTES(op)) break; /* not a string */
1004 op1 = stack->data[stackTop-2]; /* index */
1005 if (LST_IS_SMALLINT(op1)) {
1006 l0 = lstIntValue(op1)-1;
1007 if (l0 < 0 || l0 >= LST_SIZE(op)) break; /* out of range */
1008 stackTop -= low;
1009 l0 = lstBytePtr(op)[l0];
1010 retValue = lstCharClass->data[lstIVcharsInMetaChar]->data[l0];
1011 low = -1;
1012 goto markArgsInlined;
1013 }
1014 break;
1015 case 8: /* Block>>value: */
1016 /*fprintf(stderr, "Block>>value: hit!\n");*/
1017 curIP = l1;
1018 /* swap argumnets */
1019 op1 = stack->data[stackTop-1];
1020 stack->data[stackTop-1] = op;
1021 stack->data[stackTop-2] = op1;
1022 ptemp = lstNilObj; /* flag */
1023 context->data[lstIVbytePointerInContext] = lstNewInt(curIP);
1024 context->data[lstIVstackTopInContext] = lstNewInt(stackTop-2);
1025 goto doBlockInvocation;
1026 default:
1027 fprintf(stderr, "ready to inline: %s\n", lstInlineMethodList[f].name);
1028 break;
1029 }
1030 break;
1031 }
1032 }
1033 }
1034 if (low != 1 && low != 2) goto markArgsNoInlining;
1035 # endif
1036 if (cache[tmp].analyzed <= 0) break;
1037 /*stackTop -= low;*/ /* remove all args */
1038 /* do inline, omit argument array creation */
1039 markArgsInlined:
1040 cache[tmp].badHits = 0;
1041 l0 = bp[curIP = l1]; /* skip SendMessage */
1042 switch (l0) {
1043 case lstBCDoSpecial*16+lstBXStackReturn:
1044 context = context->data[lstIVpreviousContextInContext];
1045 break;
1046 case lstBCDoSpecial*16+lstBXBlockReturn:
1047 context = context->data[lstIVcreatingContextInBlock]->data[lstIVpreviousContextInContext];
1048 break;
1049 default:
1050 l0 = 0;
1051 break;
1052 }
1053 # ifdef INLINE_SOME_METHODS
1054 if (low < 0) {
1055 if (l0) goto doReturn2;
1056 stack->data[stackTop++] = retValue;
1057 goto markArgsCompleteNoPush;
1058 }
1059 # endif
1060 /* execute inline code */
1061 if ((l1 = cache[tmp].ivarNum) >= 0) {
1062 /* instance variable */
1063 if (cache[tmp].analyzed == 1) {
1064 iprintf("ANALYZER: pushing ivar %d\n", l1);
1065 retValue = stack->data[stackTop-1]->data[l1];
1066 } else {
1067 iprintf("ANALYZER: setting ivar %d\n", l1);
1068 assert(low == 2);
1069 (retValue = stack->data[stackTop-2])->data[l1] = stack->data[stackTop-1];
1070 --stackTop; /* drop argument, return self */
1071 if (l0) { ++lstInfoIVarHit; goto doReturn2; }
1072 goto markArgsCompleteNoPush;
1073 }
1074 ++lstInfoIVarHit;
1075 } else {
1076 /* constant */
1077 iprintf("ANALYZER: pushing constant/literal\n");
1078 ++lstInfoLiteralHit;
1079 retValue = cache[tmp].mConst;
1080 }
1081 if (l0) goto doReturn2;
1082 stack->data[stackTop-1] = retValue;
1083 goto markArgsCompleteNoPush;
1084 } else if (cache[tmp+1].name == messageSelector && cache[tmp+1].stclass == receiverClass) {
1085 /*++cache[tmp++].badHits;*/
1086 ++tmp;
1087 goto checkForInlineCacheHit;
1088 }
1089 break;
1090 case lstBCExtended:
1091 if (bp[curIP]%16 == lstBCSendMessage) {
1092 l0 = bp[curIP+1];
1093 l1 = curIP+2;
1094 goto checkForInline;
1095 }
1096 break;
1097 }
1098 }
1099 # ifdef INLINE_SOME_METHODS
1100 markArgsNoInlining:
1101 # endif
1102 #endif
1103 /* no inlining */
1104 op = lstMemAlloc(low);
1105 op->stclass = lstArrayClass;
1106 /* now load new argument array */
1107 while (--low >= 0) op->data[low] = POPIT;
1108 PUSHIT(op);
1109 markArgsCompleteNoPush:
1110 break;
1111 case lstBCPushBlock:
1112 DBG0("PushBlock");
1113 /* create a block object; low is arg location; next word is goto value; next byte is argCount */
1114 high = VAL;
1115 curIP += VALSIZE;
1116 tmp = bp[curIP++]; /* argCount */
1117 ptemp = lstNewArray(lstIntValue(method->data[lstIVstackSizeInMethod]));
1118 op = lstMemAlloc(lstBlockSize);
1119 op->stclass = lstBlockClass;
1120 /*op = lstAllocInstance(lstBlockSize, lstBlockClass);*/
1121 op->data[lstIVbytePointerInContext] = op->data[lstIVstackTopInBlock] = lstNewInt(0);
1122 op->data[lstIVpreviousContextInBlock] = lstNilObj;
1123 op->data[lstIVbytePointerInBlock] = lstNewInt(curIP);
1124 op->data[lstIVargumentLocationInBlock] = lstNewInt(low);
1125 op->data[lstIVstackInBlock] = ptemp;
1126 op->data[lstIVargCountInBlock] = lstNewInt(tmp);
1127 op->data[lstIVcreatingContextInBlock] =
1128 context->stclass==lstBlockClass ? context->data[lstIVcreatingContextInBlock] : context;
1129 op->data[lstIVprocOwnerInBlock] = aProcess;
1130 op->data[lstIVmethodInBlock] = method;
1131 op->data[lstIVargumentsInBlock] = arguments;
1132 op->data[lstIVtemporariesInBlock] = temporaries;
1133 /***/
1134 PUSHIT(op);
1135 curIP = high;
1136 ptemp = NULL;
1137 break;
1138 case lstBCSendUnary: /* optimize certain unary messages */
1139 DBG1("SendUnary", low);
1140 op = POPIT;
1141 switch (low) {
1142 case 0: /* isNil */
1143 retValue = op==lstNilObj ? lstTrueObj : lstFalseObj;
1144 break;
1145 case 1: /* notNil */
1146 retValue = op==lstNilObj ? lstFalseObj : lstTrueObj;
1147 break;
1148 default:
1149 lstFatal("unimplemented SendUnary", low);
1150 }
1151 PUSHIT(retValue);
1152 break;
1153 case lstBCSendBinary: /* optimize certain binary messages */
1154 DBG1("SendBinary", low);
1155 ptemp1 = POPIT;
1156 ptemp = POPIT;
1157 if (low == 13) {
1158 /* == */
1159 retValue = ptemp==ptemp1 ? lstTrueObj : lstFalseObj;
1160 PUSHIT(retValue);
1161 ptemp = ptemp1 = NULL;
1162 break;
1163 }
1164 /* small integers */
1165 if (LST_IS_SMALLINT(ptemp) && LST_IS_SMALLINT(ptemp1)) {
1166 int i = lstIntValue(ptemp);
1167 int j = lstIntValue(ptemp1);
1168 switch (low) {
1169 case 0: /* < */
1170 retValue = i<j ? lstTrueObj : lstFalseObj;
1171 break;
1172 case 1: /* <= */
1173 retValue = i<=j ? lstTrueObj : lstFalseObj;
1174 break;
1175 case 2: /* + */
1176 itmp = (int64_t)i+j;
1177 retValue = lstNewInteger(itmp);
1178 break;
1179 case 3: /* - */
1180 itmp = (int64_t)i-j;
1181 retValue = lstNewInteger(itmp);
1182 break;
1183 case 4: /* * */
1184 itmp = (int64_t)i*j;
1185 retValue = lstNewInteger(itmp);
1186 break;
1187 case 5: /* / */
1188 if (j == 0) goto binoptfailed;
1189 retValue = lstNewInt(i/j);
1190 break;
1191 case 6: /* % */
1192 if (j == 0) goto binoptfailed;
1193 retValue = lstNewInt(i%j);
1194 break;
1195 case 7: /* > */
1196 retValue = i>j ? lstTrueObj : lstFalseObj;
1197 break;
1198 case 8: /* >= */
1199 retValue = i>=j ? lstTrueObj : lstFalseObj;
1200 break;
1201 case 9: /* ~= */
1202 retValue = i!=j ? lstTrueObj : lstFalseObj;
1203 break;
1204 case 10: /* = */
1205 retValue = i==j ? lstTrueObj : lstFalseObj;
1206 break;
1207 default: goto binoptfailed;
1208 }
1209 PUSHIT(retValue);
1210 ptemp = ptemp1 = NULL;
1211 break;
1212 }
1213 /* chars */
1214 if (LST_CLASS(ptemp) == lstCharClass && LST_CLASS(ptemp1) == lstCharClass) {
1215 int i = lstIntValue(ptemp->data[0]);
1216 int j = lstIntValue(ptemp1->data[0]);
1217 switch (low) {
1218 case 0: /* < */
1219 retValue = i<j ? lstTrueObj : lstFalseObj;
1220 break;
1221 case 1: /* <= */
1222 retValue = i<=j ? lstTrueObj : lstFalseObj;
1223 break;
1224 case 7: /* > */
1225 retValue = i>j ? lstTrueObj : lstFalseObj;
1226 break;
1227 case 8: /* >= */
1228 retValue = i>=j ? lstTrueObj : lstFalseObj;
1229 break;
1230 case 9: /* ~= */
1231 retValue = i!=j ? lstTrueObj : lstFalseObj;
1232 break;
1233 case 10: /* = */
1234 retValue = i==j ? lstTrueObj : lstFalseObj;
1235 break;
1236 default: goto binoptfailed;
1237 }
1238 PUSHIT(retValue);
1239 ptemp = ptemp1 = NULL;
1240 break;
1241 }
1242 /* logics */
1243 if (ptemp == lstTrueObj || ptemp == lstFalseObj) {
1244 /* can only do operations that won't trigger garbage collection */
1245 switch (low) {
1246 case 11: /* & */
1247 retValue = ptemp==lstTrueObj ? ptemp1 : lstFalseObj;
1248 break;
1249 case 12: /* | */
1250 retValue = ptemp==lstTrueObj ? lstTrueObj : ptemp1;
1251 break;
1252 default:
1253 goto binoptfailed;
1254 }
1255 PUSHIT(retValue);
1256 ptemp = ptemp1 = NULL;
1257 break;
1258 }
1259 /* logics */
1260 if (ptemp == lstNilObj) {
1261 /* can only do operations that won't trigger garbage collection */
1262 switch (low) {
1263 case 11: /* & */
1264 retValue = lstFalseObj;
1265 break;
1266 case 12: /* | */
1267 retValue = ptemp1;
1268 break;
1269 default:
1270 goto binoptfailed;
1271 }
1272 PUSHIT(retValue);
1273 ptemp = ptemp1 = NULL;
1274 break;
1275 }
1276 /* logics, not bool, not nil */
1277 if (LST_IS_SMALLINT(ptemp) || ptemp->stclass != lstBooleanClass) {
1278 switch (low) {
1279 case 11: /* & */
1280 retValue = ptemp1;
1281 break;
1282 case 12: /* | */
1283 retValue = ptemp;
1284 break;
1285 default:
1286 goto binoptfailed;
1287 }
1288 PUSHIT(retValue);
1289 ptemp = ptemp1 = NULL;
1290 break;
1291 }
1292 /* byte arrays */
1293 if (LST_IS_BYTES(ptemp) && LST_IS_BYTES(ptemp1)) {
1294 switch (low) {
1295 case 0: /* < */
1296 retValue = symbolcomp(ptemp, ptemp1)<0 ? lstTrueObj : lstFalseObj;
1297 break;
1298 case 1: /* <= */
1299 retValue = symbolcomp(ptemp, ptemp1)<=0 ? lstTrueObj : lstFalseObj;
1300 break;
1301 case 2: /* + */
1302 if (ptemp->stclass == ptemp1->stclass &&
1303 (ptemp->stclass == lstStringClass || ptemp->stclass == lstByteArrayClass ||
1304 ptemp->stclass == lstByteCodeClass)) {
1305 /* string concatenation */
1306 retValue = (lstObject *)lstMemAllocBin(LST_SIZE(ptemp)+LST_SIZE(ptemp1));
1307 retValue->stclass = ptemp->stclass;
1308 tmp = LST_SIZE(ptemp);
1309 if (tmp) memcpy(lstBytePtr(retValue), lstBytePtr(ptemp), tmp);
1310 l0 = LST_SIZE(ptemp1);
1311 if (l0) memcpy(lstBytePtr(retValue)+tmp, lstBytePtr(ptemp1), l0);
1312 break;
1313 }
1314 goto binoptfailed;
1315 case 7: /* > */
1316 retValue = symbolcomp(ptemp, ptemp1)>0 ? lstTrueObj : lstFalseObj;
1317 break;
1318 case 8: /* >= */
1319 retValue = symbolcomp(ptemp, ptemp1)>=0 ? lstTrueObj : lstFalseObj;
1320 break;
1321 case 9: /* ~= */
1322 retValue = symbolcomp(ptemp, ptemp1)!=0 ? lstTrueObj : lstFalseObj;
1323 break;
1324 case 10: /* = */
1325 retValue = symbolcomp(ptemp, ptemp1)==0 ? lstTrueObj : lstFalseObj;
1326 break;
1327 default: goto binoptfailed;
1328 }
1329 PUSHIT(retValue);
1330 ptemp = ptemp1 = NULL;
1331 break;
1332 }
1333 /* do message send */
1334 binoptfailed:
1335 arguments = lstMemAlloc(2);
1336 arguments->stclass = lstArrayClass;
1337 /* now load new argument array */
1338 arguments->data[0] = ptemp;
1339 arguments->data[1] = ptemp1;
1340 /* now go send message */
1341 messageSelector = lstBinMsgs[low];
1342 ptemp = ptemp1 = NULL;
1343 goto findMethodFromSymbol;
1344 case lstBCSendMessage:
1345 /*DBG1("SendMessage, literal", low);*/
1346 messageSelector = literals->data[low];
1347 arguments = POPIT;
1348 findMethodFromSymbol:
1349 /* see if we can optimize tail call */
1350 if (ticks == 1) l0 = 0;
1351 else {
1352 switch (bp[curIP]) {
1353 case lstBCDoSpecial*16+lstBXStackReturn: l0 = 1; break;
1354 case lstBCDoSpecial*16+lstBXBlockReturn: l0 = 2; break;
1355 default: l0 = 0; break;
1356 }
1357 }
1358 findMethodFromSymbol1:
1359 receiverClass = LST_CLASS(arguments->data[lstIVreceiverInArguments]);
1360 assert(LST_CLASS(messageSelector) == lstSymbolClass);
1361 DBGS("SendMessage", receiverClass->data[lstIVnameInClass], messageSelector);
1362 checkCache:
1363 assert(LST_CLASS(messageSelector) == lstSymbolClass);
1364 #if 0
1365 {
1366 char clnm[256], selnm[256];
1367 lstGetString(clnm, sizeof(clnm), (lstObject *)LST_CLASS(receiverClass)->data[lstIVnameInClass]);
1368 lstGetString(selnm, sizeof(selnm), (lstObject *)messageSelector);
1369 fprintf(stderr, "%04d: searching: %s>>%s\n", PC, clnm, selnm);
1370 }
1371 #endif
1372 tmp = CALC_CACHE_HASH(messageSelector, receiverClass);
1373 /*tmp = (LstUInt)((intptr_t)messageSelector+(intptr_t)receiverClass)%MTD_CACHE_SIZE;*/
1374 if (cache[tmp].name == messageSelector && cache[tmp].stclass == receiverClass) {
1375 goto cacheHit;
1376 } else if (cache[tmp+1].name == messageSelector && cache[tmp+1].stclass == receiverClass) {
1377 ++cache[tmp++].badHits;
1378 cacheHit: method = cache[tmp].method;
1379 ++lstInfoCacheHit;
1380 } else {
1381 ++lstInfoCacheMiss;
1382 if (++cache[tmp].badHits >= MTD_BAD_HIT_MAX) cache[tmp].name = NULL; /* clear this cache item */
1383 if (++cache[tmp+1].badHits >= MTD_BAD_HIT_MAX) cache[tmp+1].name = NULL; /* clear this cache item */
1384 method = lookupMethod(messageSelector, receiverClass);
1385 if (!method) {
1386 /* send 'doesNotUnderstand:args:' */
1387 if (messageSelector == lstBadMethodSym) lstFatal("doesNotUnderstand:args: missing", 0);
1388 /* we can reach this code only once */
1389 ptemp = receiverClass;
1390 ptemp1 = messageSelector;
1391 op = lstMemAlloc(3);
1392 op->stclass = lstArrayClass;
1393 op->data[lstIVreceiverInArguments] = arguments->data[lstIVreceiverInArguments];
1394 op->data[1] = ptemp1; /* selector */
1395 op->data[2] = arguments;
1396 arguments = op;
1397 receiverClass = ptemp; /* restore selector */
1398 ptemp = ptemp1 = NULL;
1399 messageSelector = lstBadMethodSym;
1400 goto findMethodFromSymbol1;
1401 }
1402 if (cache[tmp].name && cache[tmp].badHits <= MTD_BAD_HIT_MAX/2) ++tmp;
1403 /*if (cache[tmp].name) ++tmp;*/
1404 cache[tmp].name = messageSelector;
1405 cache[tmp].stclass = receiverClass;
1406 cache[tmp].method = method;
1407 cache[tmp].goodHits = 0; /* perfectly good cache */
1408 /*cache[tmp].analyzed = (LST_SIZE(arguments) != 1) ? -1 : 0*/;
1409 #ifdef INLINER_ACTIVE
1410 if ((op = method->data[lstIVoptimDoneInMethod]) != lstNilObj) {
1411 if (op == lstFalseObj) {
1412 cache[tmp].analyzed = -1; /* should not be analyzed */
1413 } else {
1414 cache[tmp].analyzed = 1; /* already analyzed */
1415 if (LST_IS_SMALLINT(op)) {
1416 /* instance var */
1417 int f = lstIntValue(op);
1418 if (f < 0) {
1419 cache[tmp].analyzed = 2;
1420 f = (-f)-1;
1421 iprintf("ANALYZER: already analyzed setter; ivar %d\n", f);
1422 } else {
1423 iprintf("ANALYZER: already analyzed; ivar %d\n", f);
1424 }
1425 cache[tmp].ivarNum = f;
1426 } else {
1427 cache[tmp].mConst = method->data[lstIVretResInMethod];
1428 cache[tmp].ivarNum = -1;
1429 iprintf("ANALYZER: already analyzed; constant\n");
1430 }
1431 }
1432 } else {
1433 op = method->data[lstIVargCountInMethod];
1434 if (LST_IS_SMALLINT(op) && (lstIntValue(op) == 1 || lstIntValue(op) == 2)) {
1435 iprintf("ANALYZER: to be analyzed (argc=%d)\n", lstIntValue(op));
1436 cache[tmp].analyzed = 0; /* analyze it in the future */
1437 } else {
1438 iprintf("ANALYZER: never be analyzed; argc=%d\n", LST_IS_SMALLINT(op) ? lstIntValue(op) : -666);
1439 cache[tmp].analyzed = -1; /* never */
1440 method->data[lstIVoptimDoneInMethod] = lstFalseObj; /* 'never' flag */
1441 }
1442 }
1443 #endif
1444 }
1445 cache[tmp].badHits = 0; /* good cache */
1446 #ifdef INLINER_ACTIVE
1447 if (cache[tmp].analyzed > 0) {
1448 analyzeSucceed:
1449 if (ticks == 1) goto analyzerJustDoIt;
1450 /* optimized */
1451 switch (l0) {
1452 case 1: context = context->data[lstIVpreviousContextInContext]; break;
1453 case 2: context = context->data[lstIVcreatingContextInBlock]->data[lstIVpreviousContextInContext]; break;
1454 default: l0 = 0; break;
1455 }
1456 /***/
1457 if ((l1 = cache[tmp].ivarNum) >= 0) {
1458 /* instance variable */
1459 if (cache[tmp].analyzed == 1) {
1460 iprintf("ANALYZER!: pushing ivar %d\n", l1);
1461 retValue = arguments->data[lstIVreceiverInArguments]->data[l1];
1462 } else {
1463 iprintf("ANALYZER!: setting ivar %d\n", l1);
1464 assert(cache[tmp].analyzed == 2);
1465 assert(LST_SIZE(arguments) == 2);
1466 (retValue = arguments->data[lstIVreceiverInArguments])->data[l1] = arguments->data[1];
1467 }
1468 ++lstInfoIVarHit;
1469 } else {
1470 /* constant */
1471 iprintf("ANALYZER!: pushing constant/literal\n");
1472 retValue = cache[tmp].mConst;
1473 ++lstInfoLiteralHit;
1474 }
1475 /* restore changed vars */
1476 if (l0) goto doReturn2;
1477 method = context->data[lstIVmethodInContext];
1478 arguments = context->data[lstIVargumentsInContext];
1479 PUSHIT(retValue);
1480 break;
1481 } else if (!cache[tmp].analyzed) {
1482 if (++cache[tmp].goodHits > 3) {
1483 /* analyze method */
1484 bp = (const unsigned char *)lstBytePtr(method->data[lstIVbyteCodesInMethod]);
1485 op = method->data[lstIVargCountInMethod];
1486 if (lstIntValue(op) == 1) {
1487 /* argc == 1 */
1488 switch (bp[0]/16) {
1489 case lstBCPushInstance:
1490 if (bp[1] != lstBCDoSpecial*16+lstBXStackReturn) goto analyzeFailed;
1491 cache[tmp].ivarNum = bp[0]%16;
1492 break;
1493 case lstBCPushLiteral:
1494 if (bp[1] != lstBCDoSpecial*16+lstBXStackReturn) goto analyzeFailed;
1495 cache[tmp].mConst = method->data[lstIVliteralsInMethod]->data[bp[0]%16];
1496 cache[tmp].ivarNum = -1;
1497 break;
1498 case lstBCPushConstant:
1499 if (bp[1] != lstBCDoSpecial*16+lstBXStackReturn) goto analyzeFailed;
1500 cache[tmp].ivarNum = -1;
1501 switch (bp[0]%16) {
1502 case lstBLNilConst: cache[tmp].mConst = lstNilObj; break;
1503 case lstBLTrueConst: cache[tmp].mConst = lstTrueObj; break;
1504 case lstBLFalseConst: cache[tmp].mConst = lstFalseObj; break;
1505 default: l1 = (bp[0]%16)-3; cache[tmp].mConst = lstNewInt(l1); break;
1506 }
1507 break;
1508 case lstBCExtended:
1509 switch (bp[0]%16) {
1510 case lstBCPushInstance:
1511 if (bp[2] != lstBCDoSpecial*16+lstBXStackReturn) goto analyzeFailed;
1512 cache[tmp].ivarNum = bp[1];
1513 break;
1514 case lstBCPushLiteral:
1515 if (bp[2] != lstBCDoSpecial*16+lstBXStackReturn) goto analyzeFailed;
1516 cache[tmp].mConst = method->data[lstIVliteralsInMethod]->data[bp[1]];
1517 cache[tmp].ivarNum = -1;
1518 break;
1519 case lstBCPushConstant:
1520 if (bp[2] != lstBCDoSpecial*16+lstBXStackReturn) goto analyzeFailed;
1521 cache[tmp].ivarNum = -1;
1522 switch (bp[1]) {
1523 case lstBLNilConst: cache[tmp].mConst = lstNilObj; break;
1524 case lstBLTrueConst: cache[tmp].mConst = lstTrueObj; break;
1525 case lstBLFalseConst: cache[tmp].mConst = lstFalseObj; break;
1526 default: l1 = bp[1]-3; cache[tmp].mConst = lstNewInt(l1); break;
1527 }
1528 break;
1529 default: goto analyzeFailed;
1530 }
1531 break;
1532 default: goto analyzeFailed;
1533 }
1534 iprintf("ANALYZER: succeed; ivar=%d\n", cache[tmp].ivarNum);
1535 cache[tmp].analyzed = 1;
1536 } else {
1537 assert(lstIntValue(op) == 2);
1538 /* argc == 2 */
1539 /*
1540 0000: PushArgument 1
1541 0001: AssignInstance n
1542 0002: PopTop
1543 0003: SelfReturn
1544 */
1545 /*TODO: parse extended lstBCAssignInstance*/
1546 if (bp[0] == lstBCPushArgument*16+1 && bp[1]/16 == lstBCAssignInstance &&
1547 bp[2] == lstBCDoSpecial*16+lstBXPopTop && bp[3] == lstBCDoSpecial*16+lstBXSelfReturn) {
1548 /*goto analyzeFailed;*/
1549 iprintf("ANALYZER: setter found; ivar=%d\n", bp[1]%16);
1550 cache[tmp].analyzed = 2;
1551 cache[tmp].ivarNum = bp[1]%16;
1552 } else {
1553 goto analyzeFailed;
1554 }
1555 }
1556 /* setup method info, so we can omit analyze stage in future */
1557 if (cache[tmp].ivarNum >= 0) {
1558 int f = cache[tmp].ivarNum;
1559 if (cache[tmp].analyzed == 2) f = -(f+1);
1560 method->data[lstIVoptimDoneInMethod] = lstNewInt(f);
1561 } else {
1562 method->data[lstIVoptimDoneInMethod] = lstTrueObj;
1563 method->data[lstIVretResInMethod] = cache[tmp].mConst;
1564 }
1565 goto analyzeSucceed;
1566 analyzeFailed:
1567 cache[tmp].analyzed = -1;
1568 method->data[lstIVoptimDoneInMethod] = lstFalseObj;
1569 }
1570 }
1571 #endif
1572 analyzerJustDoIt:
1573 #ifdef COLLECT_METHOD_STATISTICS
1574 l1 = lstIntValue(method->data[lstIVinvokeCountInMethod])+1;
1575 if (LST_64FITS_SMALLINT(l1)) method->data[lstIVinvokeCountInMethod] = lstNewInt(l1);
1576 #endif
1577 ptemp = context;
1578 /* save current IP and SP */
1579 context->data[lstIVstackTopInContext] = lstNewInt(stackTop);
1580 context->data[lstIVbytePointerInContext] = lstNewInt(curIP);
1581 /*context->data[lstIVprocOwnerInContext] = aProcess;*/
1582 /* build environment for new context */
1583 low = lstIntValue(method->data[lstIVtemporarySizeInMethod]);
1584 stack = lstNewArray(lstIntValue(method->data[lstIVstackSizeInMethod]));
1585 temporaries = low>0 ? lstNewArray(low) : lstNilObj;
1586 /* build the new context */
1587 context = lstMemAlloc(lstContextSize);
1588 context->stclass = lstContextClass;
1589 /*context = lstAllocInstance(lstContextSize, lstContextClass);*/
1590 /*context->data[lstIVpreviousContextInContext] = ptemp;*/
1591 switch (l0) {
1592 case 1:
1593 context->data[lstIVpreviousContextInContext] = ptemp->data[lstIVpreviousContextInContext];
1594 break;
1595 case 2:
1596 context->data[lstIVpreviousContextInContext] =
1597 ptemp->data[lstIVcreatingContextInBlock]->data[lstIVpreviousContextInContext];
1598 break;
1599 default:
1600 context->data[lstIVpreviousContextInContext] = ptemp;
1601 break;
1602 }
1603 ptemp = NULL;
1604 context->data[lstIVprocOwnerInContext] = aProcess;
1605 context->data[lstIVtemporariesInContext] = temporaries;
1606 context->data[lstIVstackInContext] = stack;
1607 context->data[lstIVstackTopInContext] =
1608 context->data[lstIVbytePointerInContext] = lstNewInt(0);
1609 context->data[lstIVmethodInContext] = method;
1610 context->data[lstIVargumentsInContext] = arguments;
1611 literals = method->data[lstIVliteralsInMethod];
1612 instanceVariables = arguments->data[lstIVreceiverInArguments];
1613 stackTop = 0;
1614 curIP = 0;
1615 /* now go execute new method */
1616 break;
1617 /* execute primitive */
1618 case lstBCDoPrimitive:
1619 /* low is argument count; next byte is primitive number */
1620 high = bp[curIP++]; /* primitive number */
1621 #ifdef DEBUG
1622 /*DBG2("DoPrimitive", high, low);*/
1623 if (lstDebugFlag) {
1624 const char *pn = lstFindPrimitiveName(high);
1625 char tmsg[1024];
1626 sprintf(tmsg, "DoPrimitive %s; argc=%d", pn, low);
1627 DBG0(tmsg);
1628 }
1629 #endif
1630 lastCalledPrim = high;
1631 switch (high) {
1632 case 1: /* NewObject class size */
1633 if (low != 2) goto failPrimitiveArgs;
1634 op = POPIT; /* size */
1635 op1 = POPIT; /* class */
1636 if (!LST_IS_SMALLINT(op)) goto failPrimitive;
1637 tmp = lstIntValue(op); /* size */
1638 if (tmp < 0) goto failPrimitive;
1639 retValue = lstAllocInstance(tmp, op1);
1640 break;
1641 case 2: /* NewByteArray class size */
1642 if (low != 2) goto failPrimitiveArgs;
1643 op = POPIT; /* size */
1644 op1 = POPIT; /* class */
1645 if (!LST_IS_SMALLINT(op)) goto failPrimitive;
1646 tmp = lstIntValue(op); /* size */
1647 if (tmp < 0) goto failPrimitive;
1648 retValue = (lstObject *)lstMemAllocBin(tmp);
1649 retValue->stclass = op1;
1650 if (tmp > 0) memset(lstBytePtr(retValue), 0, tmp);
1651 break;
1652 case 3: /* ObjectIdentity */
1653 if (low != 2) goto failPrimitiveArgs;
1654 op = POPIT;
1655 op1 = POPIT;
1656 retValue = op==op1 ? lstTrueObj : lstFalseObj;
1657 break;
1658 case 4: /* ObjectClass */
1659 if (low != 1) goto failPrimitiveArgs;
1660 op = POPIT;
1661 retValue = LST_CLASS(op);
1662 break;
1663 case 5: /* ObjectSize */
1664 if (low != 1) goto failPrimitiveArgs;
1665 op = POPIT;
1666 tmp = LST_IS_SMALLINT(op) ? 0 : LST_SIZE(op); /* SmallInt has no size at all; it's ok */
1667 retValue = lstNewInt(tmp);
1668 break;
1669 case 6: /* Array#at: obj index */
1670 if (low != 2) goto failPrimitiveArgs;
1671 op = POPIT; /* index */
1672 op1 = POPIT; /* obj */
1673 if (!LST_IS_SMALLINT(op) || LST_IS_SMALLINT(op1) || LST_IS_BYTES(op1)) goto failPrimitive;
1674 tmp = lstIntValue(op)-1;
1675 /* bounds check */
1676 if (tmp < 0 || (LstUInt)tmp >= LST_SIZE(op1)) goto failPrimitive;
1677 if (LST_IS_SMALLINT(op1) || LST_IS_BYTES(op1)) goto failPrimitive;
1678 retValue = op1->data[tmp];
1679 break;
1680 case 7: /* Array#at:put: value obj index */
1681 if (low != 3) goto failPrimitiveArgs;
1682 op = POPIT; /* index */
1683 retValue = POPIT; /* obj */
1684 op1 = POPIT; /* value */
1685 if (!LST_IS_SMALLINT(op) || LST_IS_SMALLINT(retValue) || LST_IS_BYTES(retValue)) goto failPrimitive;
1686 tmp = lstIntValue(op)-1;
1687 /* bounds check */
1688 if (tmp < 0 || (LstUInt)tmp >= LST_SIZE(retValue)) goto failPrimitive;
1689 if (LST_IS_SMALLINT(retValue) || LST_IS_BYTES(retValue)) goto failPrimitive;
1690 lstWriteBarrier(&retValue->data[tmp], op1);
1691 break;
1692 case 8: /* String#at: */
1693 if (low != 2) goto failPrimitiveArgs;
1694 op = POPIT; /* index */
1695 op1 = POPIT; /* object */
1696 if (!LST_IS_SMALLINT(op) || !LST_IS_BYTES_EX(op1)) goto failPrimitive;
1697 tmp = lstIntValue(op)-1;
1698 /* bounds check */
1699 if (tmp < 0 || (LstUInt)tmp >= LST_SIZE(op1)) goto failPrimitive;
1700 tmp = lstBytePtr(op1)[tmp];
1701 retValue = lstNewInt(tmp);
1702 break;
1703 case 9: /* String#at:put: value obj index */
1704 if (low != 3) goto failPrimitiveArgs;
1705 op = POPIT; /* index */
1706 retValue = POPIT; /* obj */
1707 op1 = POPIT; /* value */
1708 if (!LST_IS_SMALLINT(op) || !LST_IS_BYTES_EX(retValue) || !LST_IS_SMALLINT(op1)) goto failPrimitive;
1709 tmp = lstIntValue(op)-1;
1710 /* bounds check */
1711 if (tmp < 0 || (LstUInt)tmp >= LST_SIZE(retValue)) goto failPrimitive;
1712 lstBytePtr(retValue)[tmp] = lstIntValue(op1);
1713 break;
1714 case 10: /* String#clone: what class */
1715 if (low != 2) goto failPrimitiveArgs;
1716 /*TODO: check args */
1717 ptemp = POPIT; /* class */
1718 ptemp1 = POPIT; /* obj */
1719 if (!LST_IS_BYTES_EX(ptemp1)) { ptemp = ptemp1 = NULL; goto failPrimitive; }
1720 tmp = LST_SIZE(ptemp1);
1721 retValue = (lstObject *)lstMemAllocBin(tmp);
1722 retValue->stclass = ptemp;
1723 if (tmp > 0) memcpy(lstBytePtr(retValue), lstBytePtr(ptemp1), tmp);
1724 ptemp = ptemp1 = NULL;
1725 break;
1726 case 11: /* String#Position: aString from: pos; match substring in a string; return index of substring or nil */
1727 case 12: /* String#LastPosition: aString from: pos; match substring in a string; return index of substring or nil */
1728 if (low != 3) goto failPrimitiveArgs;
1729 /* from */
1730 op = POPIT;
1731 if (LST_IS_SMALLINT(op)) tmp = lstIntValue(op);
1732 else if (op->stclass == lstIntegerClass) tmp = lstLIntValue(op);
1733 else { stackTop -= 2; goto failPrimitive; }
1734 if (tmp < 1) tmp = 1;
1735 tmp--;
1736 /* what */
1737 op1 = POPIT;
1738 if (!LST_IS_BYTES_EX(op1)) {
1739 x = -1;
1740 if (LST_IS_SMALLINT(op1)) {
1741 x = lstIntValue(op1);
1742 } else if (op1->stclass == lstCharClass) {
1743 op1 = op1->data[0];
1744 if (LST_IS_SMALLINT(op1)) x = lstIntValue(op1);
1745 }
1746 if (x < 0 || x > 255) { --stackTop; goto failPrimitive; }
1747 sbuf[0] = x; sbuf[1] = '\0';
1748 op1 = NULL;
1749 }
1750 /* where */
1751 op = POPIT;
1752 if (!LST_IS_BYTES_EX(op)) goto failPrimitive;
1753 l0 = LST_SIZE(op);
1754 l1 = op1 ? LST_SIZE(op1) : strlen(sbuf);
1755 /*FIXME: tmp can be too big and cause the overflow*/
1756 retValue = lstNilObj;
1757 if (tmp >= l0 || l0 < 1 || l1 < 1 || l1 > l0-tmp) {
1758 /* can't be found, do nothing */
1759 } else {
1760 const unsigned char *s0 = lstBytePtr(op);
1761 const unsigned char *s1 = op1 ? (const unsigned char *)lstBytePtr(op1) : (const unsigned char *)sbuf;
1762 s0 += tmp; l0 -= tmp;
1763 /*FIXME: this can be faster, especially for LastPosition; rewrite it! */
1764 for (; l0 >= l1; l0--, s0++, tmp++) {
1765 if (memcmp(s0, s1, l1) == 0) {
1766 retValue = lstNewInt(tmp+1);
1767 if (high == 11) break; /* early exit for Position */
1768 }
1769 }
1770 }
1771 break;
1772 case 13: /* StringCopyFromTo */
1773 if (low != 3) goto failPrimitiveArgs;
1774 /* tmp: to */
1775 op = POPIT;
1776 if (LST_IS_SMALLINT(op)) tmp = lstIntValue(op);
1777 else if (op->stclass == lstIntegerClass) tmp = lstLIntValue(op);
1778 else if (op->stclass == lstFloatClass) tmp = lstFloatValue(op);
1779 else { stackTop -= 2; goto failPrimitive; }
1780 if (tmp < 1) { stackTop -= 2; goto failPrimitive; }
1781 /* x: from */
1782 op = POPIT;
1783 if (LST_IS_SMALLINT(op)) x = lstIntValue(op);
1784 else if (op->stclass == lstIntegerClass) x = lstLIntValue(op);
1785 else if (op->stclass == lstFloatClass) x = lstFloatValue(op);
1786 else { --stackTop; goto failPrimitive; }
1787 if (x < 1) { --stackTop; goto failPrimitive; }
1788 /* op: string */
1789 op = POPIT;
1790 if (!LST_IS_BYTES_EX(op)) goto failPrimitive;
1791 low = LST_SIZE(op);
1792 /*printf("size=%d; from=%d; to=%d\n", low, x, tmp);*/
1793 --x; --tmp;
1794 if (tmp < x || x >= low) low = 0;
1795 else {
1796 low -= x;
1797 tmp -= x-1;
1798 low = tmp<low ? tmp : low;
1799 }
1800 ptemp = op;
1801 retValue = (lstObject *)lstMemAllocBin(low);
1802 op = ptemp;
1803 retValue->stclass = op->stclass;
1804 /*printf("copying from %d, %d bytes\n", x, low);*/
1805 if (low > 0) memcpy(lstBytePtr(retValue), lstBytePtr(op)+x, low);
1806 break;
1807 case 14: /* BulkObjectExchange */
1808 if (low != 2) goto failPrimitiveArgs;
1809 op = POPIT;
1810 if (op->stclass != lstArrayClass) { --stackTop; goto failPrimitive; }
1811 retValue = POPIT;
1812 if (retValue->stclass != lstArrayClass) goto failPrimitive;
1813 if (LST_SIZE(op) != LST_SIZE(retValue)) goto failPrimitive;
1814 lstSwapObjects(op, retValue, LST_SIZE(op));
1815 break;
1816 case 15: { /* replaceFrom:... */ /* <replaceFrom:to:with:startingAt: start stop replacement repStart self> */
1817 if (low != 5) goto failPrimitiveArgs;
1818 /*TODO: check args */
1819 retValue = POPIT; /* object */
1820 lstObject *tmpRepStart = POPIT; /* startingAt */
1821 lstObject *tmpSrc = POPIT; /* with */
1822 lstObject *tmpStop = POPIT; /* to */
1823 lstObject *tmpStart = POPIT; /* from */
1824 if (lstBulkReplace(retValue, tmpStart, tmpStop, tmpSrc, tmpRepStart)) goto failPrimitive;
1825 } break;
1826
1827 case 16: /* BlockInvocation: (args)* block */
1828 if (ptemp != NULL) abort();
1829 doBlockInvocation:
1830 if (low < 1) goto failPrimitiveArgs;
1831 /* low holds number of arguments */
1832 op = POPIT; /* block */
1833 --low;
1834 /*if (op->data[lstIVbytePointerInContext] != lstNilObj) fprintf(stderr, "CALLING ALREADY CALLED BLOCK!\n");*/
1835 if (LST_IS_SMALLINT(op) || LST_IS_BYTES(op)) goto failPrimitiveArgs;
1836 if (op->stclass != lstBlockClass && !lstIsKindOf(op, lstBlockClass)) goto failPrimitiveArgs;
1837 /*if (op->stclass != lstBlockClass) { stackTop -= (low-1); goto failPrimitiveArgs; }*/
1838 /* put arguments in place */
1839 /* get arguments location (tmp) */
1840 op1 = op->data[lstIVargumentLocationInBlock];
1841 if (!LST_IS_SMALLINT(op1)) goto failPrimitiveArgs;
1842 tmp = lstIntValue(op1);
1843 /* get max argument count (l0) */
1844 op1 = op->data[lstIVargCountInBlock];
1845 if (!LST_IS_SMALLINT(op1)) goto failPrimitiveArgs;
1846 l0 = lstIntValue(op1);
1847 /* setup arguments */
1848 temporaries = op->data[lstIVtemporariesInBlock];
1849 /* do not barf if there are too many args; just ignore */
1850 /*fprintf(stderr, "block: args=%d; passed=%d\n", l0, low);*/
1851 if (low > l0) { stackTop -= (low-l0); low = l0; } /* drop extra args */
1852 for (l1 = low; l1 < l0; ++l1) temporaries->data[tmp+l1] = lstNilObj;
1853 while (--low >= 0) temporaries->data[tmp+low] = POPIT;
1854 for (; low >= 0; --low) temporaries->data[tmp+low] = POPIT;
1855 if (!ptemp) {
1856 op->data[lstIVpreviousContextInBlock] = context->data[lstIVpreviousContextInContext];
1857 } else {
1858 /*ptemp = NULL;*/
1859 op->data[lstIVpreviousContextInBlock] = context;
1860 }
1861 context = /*aProcess->data[lstIVcontextInProcess] =*/ op;
1862 context->data[lstIVtemporariesInContext] = temporaries;
1863 reloadFromCtx();
1864 stackTop = 0;
1865 curIP = lstIntValue(context->data[lstIVbytePointerInBlock]);
1866 goto endPrimitive;
1867
1868 case 17: /* flush method cache; invalidate cache for class */
1869 /*
1870 * <#FlushMethodCache>: flush everything
1871 * <#FlushMethodCache oldclass>: flush the cache for the given class
1872 * <#FlushMethodCache oldmethod true>: flush the cache for the given method
1873 */
1874 #ifdef BETTER_CACHE_CONTROL
1875 switch (low) {
1876 case 1: /* for class */
1877 dprintf("FLUSHCLASSCACHE\n");
1878 op = POPIT; /* old class */
1879 for (l0 = MTD_CACHE_SIZE+MTD_CACHE_EXTRA-1; l0 >= 0; --l0) {
1880 if (cache[l0].name && cache[l0].stclass == op) cache[l0].name = NULL;
1881 }
1882 break;
1883 case 2: /* for method */
1884 dprintf("FLUSHMETHODCACHE\n");
1885 --stackTop; /* drop flag */
1886 op = POPIT; /* old method */
1887 for (l0 = MTD_CACHE_SIZE+MTD_CACHE_EXTRA-1; l0 >= 0; --l0) {
1888 if (cache[l0].name && cache[l0].method == op) cache[l0].name = NULL;
1889 }
1890 break;
1891 default:
1892 dprintf("FLUSHCACHE\n");
1893 stackTop -= low;
1894 lstFlushMethodCache();
1895 break;
1896 }
1897 #else
1898 /*if (low == 1 || low > 3) { stackTop -= low; low = 0; }*/
1899 stackTop -= low;
1900 lstFlushMethodCache();
1901 #endif
1902 break;
1903
1904 case 18: /* SmallIntToInteger */
1905 if (low != 1) goto failPrimitiveArgs;
1906 op = POPIT;
1907 if (LST_IS_SMALLINT(op)) retValue = lstNewLongInt(lstIntValue(op));
1908 else if (op->stclass == lstIntegerClass) retValue = lstNewLongInt(lstLIntValue(op));
1909 else goto failPrimitive;
1910 break;
1911 case 19: /* NumberToFloat */
1912 if (low != 1) goto failPrimitiveArgs;
1913 op = POPIT;
1914 if (LST_IS_SMALLINT(op)) retValue = lstNewFloat(lstIntValue(op));
1915 else if (op->stclass == lstIntegerClass) retValue = lstNewFloat(lstLIntValue(op));
1916 else if (op->stclass == lstFloatClass) retValue = lstNewFloat(lstFloatValue(op));
1917 else goto failPrimitive;
1918 break;
1919 case 20: /* FloatToInteger */
1920 if (low < 1 || low > 2) goto failPrimitiveArgs;
1921 op = POPIT; /* float */
1922 if (low > 1) {
1923 op1 = POPIT; /* opcode */
1924 if (!LST_IS_SMALLINT(op1)) goto failPrimitive;
1925 if (!LST_IS_BYTES_EX(op) || op->stclass != lstFloatClass) goto failPrimitive;
1926 fop0 = lstFloatValue(op);
1927 switch (lstIntValue(op1)) {
1928 case 1: fop0 = trunc(fop0); break;
1929 case 2: fop0 = round(fop0); break;
1930 case 3: fop0 = floor(fop0); break;
1931 case 4: fop0 = ceil(fop0); break;
1932 default: goto failPrimitive;
1933 }
1934 ll0 = fop0;
1935 retValue = lstNewInteger(ll0);
1936 } else {
1937 if (LST_IS_SMALLINT(op)) retValue = lstNewLongInt(lstIntValue(op));
1938 else if (op->stclass == lstIntegerClass) retValue = lstNewLongInt(lstLIntValue(op));
1939 else if (op->stclass == lstFloatClass) retValue = lstNewLongInt((LstLInt)lstFloatValue(op));
1940 else goto failPrimitive;
1941 }
1942 break;
1943 case 21: /* IntegerToSmallInt (low order of Integer -> SmallInt) */
1944 if (low != 1) goto failPrimitiveArgs;
1945 op = POPIT;
1946 if (LST_IS_SMALLINT(op)) ll0 = lstIntValue(op);
1947 else if (op->stclass == lstIntegerClass) ll0 = lstLIntValue(op);
1948 else goto failPrimitive;
1949 tmp = (int)ll0;
1950 if (!LST_64FITS_SMALLINT(tmp)) goto failPrimitive;
1951 retValue = lstNewInt(tmp);
1952 break;
1953 case 22: /* IntegerToSmallIntTrunc */
1954 if (low != 1) goto failPrimitiveArgs;
1955 op = POPIT;
1956 if (LST_IS_SMALLINT(op)) retValue = op;
1957 else if (op->stclass == lstIntegerClass) {
1958 ll0 = lstLIntValue(op);
1959 tmp = (int)ll0;
1960 retValue = lstNewInt(tmp);
1961 } else if (op->stclass == lstFloatClass) {
1962 ll0 = (LstLInt)(lstFloatValue(op));
1963 tmp = (int)ll0;
1964 retValue = lstNewInt(tmp);
1965 } else goto failPrimitive;
1966 break;
1967
1968 case 23: /* bit2op: bitOr: bitAnd: bitXor: */
1969 if (low != 3) goto failPrimitiveArgs;
1970 /* operation type */
1971 op = POPIT;
1972 if (!LST_IS_SMALLINT(op)) { stackTop -= 2; goto failPrimitive; }
1973 tmp = lstIntValue(op); /* operation */
1974 /* second arg */
1975 op = POPIT;
1976 if (LST_IS_SMALLINT(op)) ll1 = lstIntValue(op);
1977 else if (op->stclass == lstIntegerClass) ll1 = lstLIntValue(op);
1978 else { --stackTop; goto failPrimitive; }
1979 /* first arg */
1980 op = POPIT;
1981 if (LST_IS_SMALLINT(op)) ll0 = lstIntValue(op);
1982 else if (op->stclass == lstIntegerClass) ll0 = lstLIntValue(op);
1983 else goto failPrimitive;
1984 switch (tmp) {
1985 case 0: ll0 = ll0 | ll1; break;
1986 case 1: ll0 = ll0 & ll1; break;
1987 case 2: ll0 = ll0 ^ ll1; break;
1988 default: goto failPrimitive;
1989 }
1990 retValue = lstNewInteger(ll0);
1991 break;
1992 case 24: /* bitNot */
1993 if (low != 1) goto failPrimitiveArgs;
1994 op = POPIT;
1995 if (LST_IS_SMALLINT(op)) ll0 = lstIntValue(op);
1996 else if (op->stclass == lstIntegerClass) ll0 = lstLIntValue(op);
1997 else goto failPrimitive;
1998 retValue = lstNewInteger(~ll0);
1999 break;
2000 case 25: /* bitShift: */
2001 if (low != 2) goto failPrimitiveArgs;
2002 /* by */
2003 op = POPIT;
2004 if (!LST_IS_SMALLINT(op)) { --stackTop; goto failPrimitive; }
2005 tmp = lstIntValue(op); /* shift count */
2006 /* what */
2007 op = POPIT;
2008 if (LST_IS_SMALLINT(op)) ll0 = lstIntValue(op);
2009 else if (op->stclass == lstIntegerClass) ll0 = lstLIntValue(op);
2010 else goto failPrimitive;
2011 if (tmp < 0) {
2012 /* negative means shift right */
2013 ll0 >>= (-tmp);
2014 } else {
2015 /* shift left */
2016 ll0 <<= tmp;
2017 }
2018 retValue = lstNewInteger(ll0);
2019 break;
2020
2021 case 26: /* SmallIntAdd */
2022 case 27: /* SmallIntSub */
2023 case 28: /* SmallIntMul */
2024 case 29: /* SmallIntDiv */
2025 case 30: /* SmallIntMod */
2026 case 31: /* SmallIntLess */
2027 case 32: /* SmallLessEqu */
2028 case 33: /* SmallIntGreat */
2029 case 34: /* SmallIntGreatEqu */
2030 case 35: /* SmallIntEqu */
2031 case 36: /* SmallIntNotEqu */
2032 if (low != 2) goto failPrimitiveArgs;
2033 op1 = POPIT;
2034 op = POPIT;
2035 if (!LST_IS_SMALLINT(op) || !LST_IS_SMALLINT(op1)) goto failPrimitive;
2036 l1 = lstIntValue(op1);
2037 l0 = lstIntValue(op);
2038 if (high <= 30) {
2039 switch (high) {
2040 case 26: itmp = (int64_t)l0+l1; retValue = lstNewInteger(itmp); break;
2041 case 27: itmp = (int64_t)l0-l1; retValue = lstNewInteger(itmp); break;
2042 case 28: itmp = (int64_t)l0*l1; retValue = lstNewInteger(itmp); break;
2043 case 29: if (l1 == 0) goto failPrimitive; l0 /= l1; retValue = lstNewInt(l0); break;
2044 case 30: if (l1 == 0) goto failPrimitive; l0 %= l1; retValue = lstNewInt(l0); break;
2045 }
2046 } else {
2047 switch (high) {
2048 case 31: retValue = l0<l1 ? lstTrueObj : lstFalseObj; break;
2049 case 32: retValue = l0<=l1 ? lstTrueObj : lstFalseObj; break;
2050 case 33: retValue = l0>l1 ? lstTrueObj : lstFalseObj; break;
2051 case 34: retValue = l0>=l1 ? lstTrueObj : lstFalseObj; break;
2052 case 35: retValue = l0==l1 ? lstTrueObj : lstFalseObj; break;
2053 case 36: retValue = l0!=l1 ? lstTrueObj : lstFalseObj; break;
2054 }
2055 }
2056 break;
2057 case 37: /* IntegerAdd */
2058 case 38: /* IntegerSub */
2059 case 39: /* IntegerMul */
2060 case 40: /* IntegerDiv */
2061 case 41: /* IntegerMod */
2062 case 42: /* IntegerLess */
2063 case 43: /* IntegerLessEqu */
2064 case 44: /* IntegerGreat */
2065 case 45: /* IntegerGreatEqu */
2066 case 46: /* IntegerEqu */
2067 case 47: /* IntegerNotEqu */
2068 if (low != 2) goto failPrimitiveArgs;
2069 op1 = POPIT;
2070 op = POPIT;
2071 if (LST_IS_SMALLINT(op1)) ll1 = lstIntValue(op1);
2072 else if (op1->stclass == lstIntegerClass) ll1 = lstLIntValue(op1);
2073 else goto failPrimitive;
2074 if (LST_IS_SMALLINT(op)) ll0 = lstIntValue(op);
2075 else if (op->stclass == lstIntegerClass) ll0 = lstLIntValue(op);
2076 else goto failPrimitive;
2077 switch (high) {
2078 case 37: retValue = lstNewLongInt(ll0+ll1); break;
2079 case 38: retValue = lstNewLongInt(ll0-ll1); break;
2080 case 39: retValue = lstNewLongInt(ll0*ll1); break;
2081 case 40: if (ll1 == 0) goto failPrimitive; retValue = lstNewLongInt(ll0/ll1); break;
2082 case 41: if (ll1 == 0) goto failPrimitive; retValue = lstNewLongInt(ll0%ll1); break;
2083 case 42: retValue = ll0<ll1 ? lstTrueObj : lstFalseObj; break;
2084 case 43: retValue = ll0<=ll1 ? lstTrueObj : lstFalseObj; break;
2085 case 44: retValue = ll0>ll1 ? lstTrueObj : lstFalseObj; break;
2086 case 45: retValue = ll0>=ll1 ? lstTrueObj : lstFalseObj; break;
2087 case 46: retValue = ll0==ll1 ? lstTrueObj : lstFalseObj; break;
2088 case 47: retValue = ll0!=ll1 ? lstTrueObj : lstFalseObj; break;
2089 }
2090 break;
2091 case 48: /* FloatAdd */
2092 case 49: /* FloatSub */
2093 case 50: /* FloatMul */
2094 case 51: /* FloatDiv */
2095 case 52: /* FloatLess */
2096 case 53: /* FloatLessEqu */
2097 case 54: /* FloatGreat */
2098 case 55: /* FloatGreatEqu */
2099 case 56: /* FloatEqu */
2100 case 57: /* FloatNotEqu */
2101 if (low != 2) goto failPrimitiveArgs;
2102 /* arg1 */
2103 op = POPIT;
2104 if (LST_IS_SMALLINT(op)) fop1 = (LstFloat)lstIntValue(op);
2105 else if (op->stclass == lstIntegerClass) fop1 = (LstFloat)lstLIntValue(op);
2106 else if (op->stclass == lstFloatClass) fop1 = lstFloatValue(op);
2107 else { --stackTop; goto failPrimitive; }
2108 /* arg 0 */
2109 op = POPIT;
2110 if (LST_IS_SMALLINT(op)) fop0 = (LstFloat)lstIntValue(op);
2111 else if (op->stclass == lstIntegerClass) fop0 = (LstFloat)lstLIntValue(op);
2112 else if (op->stclass == lstFloatClass) fop0 = lstFloatValue(op);
2113 else goto failPrimitive;
2114 switch (high) {
2115 case 48: retValue = lstNewFloat(fop0+fop1); break;
2116 case 49: retValue = lstNewFloat(fop0-fop1); break;
2117 case 50: retValue = lstNewFloat(fop0*fop1); break;
2118 case 51: if (fop0 == 0.0) goto failPrimitive; retValue = lstNewFloat(fop0/fop1); break;
2119 case 52: retValue = fop0<fop1 ? lstTrueObj : lstFalseObj; break;
2120 case 53: retValue = fop0<=fop1 ? lstTrueObj : lstFalseObj; break;
2121 case 54: retValue = fop0>fop1 ? lstTrueObj : lstFalseObj; break;
2122 case 55: retValue = fop0>=fop1 ? lstTrueObj : lstFalseObj; break;
2123 case 56: retValue = fop0==fop1 ? lstTrueObj : lstFalseObj; break;
2124 case 57: retValue = fop0!=fop1 ? lstTrueObj : lstFalseObj; break;
2125 }
2126 break;
2127 case 58: /* FloatToString */
2128 if (low != 1) goto failPrimitiveArgs;
2129 op = POPIT;
2130 if (LST_IS_SMALLINT(op)) sprintf(sbuf, "%d", lstIntValue(op));
2131 else if (op->stclass == lstIntegerClass) sprintf(sbuf, PRINTF_LLD, lstLIntValue(op));
2132 else if (op->stclass == lstFloatClass) sprintf(sbuf, "%.15g", lstFloatValue(op));
2133 else goto failPrimitive;
2134 retValue = lstNewString(sbuf);
2135 break;
2136 case 59: /* FloatNegate */
2137 if (low != 1) goto failPrimitiveArgs;
2138 op = POPIT;
2139 if (LST_IS_SMALLINT(op)) fop0 = lstIntValue(op);
2140 else if (op->stclass == lstIntegerClass) fop0 = lstLIntValue(op);
2141 else if (op->stclass == lstFloatClass) fop0 = lstFloatValue(op);
2142 else goto failPrimitive;
2143 retValue = lstNewFloat(-fop0);
2144 break;
2145
2146 case 60: /* PrimIdxName op arg */
2147 if (low != 2) goto failPrimitiveArgs;
2148 op = POPIT; /* arg */
2149 op1 = POPIT; /* opno */
2150 if (!LST_IS_SMALLINT(op1)) goto failPrimitive;
2151 tmp = lstIntValue(op1);
2152 switch (tmp) {
2153 case 0: /* index by name */
2154 if (op->stclass != lstStringClass && op->stclass != lstSymbolClass) goto failPrimitive;
2155 if (LST_SIZE(op) > 126) {
2156 retValue = lstNilObj;
2157 } else {
2158 lstGetString(sbuf, 256, op);
2159 int ix = lstFindPrimitiveIdx(sbuf);
2160 retValue = ix>=0 ? lstNewInt(ix) : lstNilObj;
2161 }
2162 break;
2163 case 1: /* name by index */
2164 if (LST_IS_SMALLINT(op)) tmp = lstIntValue(op);
2165 else if (op == lstIntegerClass) tmp = lstLIntValue(op);
2166 else goto failPrimitive;
2167 {
2168 const char *n = lstFindPrimitiveName(tmp);
2169 retValue = n ? lstNewString(n) : lstNilObj;
2170 }
2171 break;
2172 default: goto failPrimitive;
2173 }
2174 break;
2175
2176 case 61: /* GetCurrentProcess */
2177 if (low != 0) goto failPrimitiveArgs;
2178 retValue = aProcess;
2179 break;
2180
2181 case 62: /* error trap / yield -- halt process; no args: error; else: suspend (yield) */
2182 if (low > 1) goto failPrimitiveArgs;
2183 if (low > 0) {
2184 /* yield */
2185 retValue = POPIT;
2186 stackTop -= (low-1); /* drop other args */
2187 tmp = lstReturnYield; /* no-error flag */
2188 } else {
2189 /* error */
2190 retValue = lstNilObj;
2191 tmp = lstReturnError; /* error flag */
2192 }
2193 int rr = doReturn(tmp);
2194 if (rr) XRETURN(rr);
2195 if (tmp || retGSwitch) goto doAllAgain;
2196 goto execComplete;
2197
2198 case 63: /* ExecuteNewProcessAndWait proc tics */
2199 if (low != 2) goto failPrimitiveArgs;
2200 op1 = POPIT; /* ticks */
2201 op = POPIT; /* new process */
2202 if (!LST_IS_SMALLINT(op1)) goto failPrimitive;
2203 if (!lstIsKindOf(op, lstProcessClass)) goto failPrimitive;
2204 tmp = lstIntValue(op1);
2205 saveCurrentProcess();
2206 if (loadNewProcess(op) == 0) {
2207 /* new process succesfully loaded */
2208 ticks = tmp<1 ? 0 : tmp;
2209 lockCount = lockCount>0; /* start locked if locked */
2210 goto doAllAgain; /* go on with the new process */
2211 }
2212 reloadFromGroup(); /* restore old process */
2213 /* result */
2214 low = lstReturnError;
2215 execComplete: /* low is the result */
2216 retValue = lstNewInt(low);
2217 goto doReturn;
2218
2219 case 64: /* LockUnlockSheduler */
2220 if (low > 1) goto failPrimitiveArgs;
2221 if (low > 0) {
2222 op = POPIT;
2223 stackTop -= (low-1); /* drop other args */
2224 if (op == lstFalseObj) {
2225 /* unlock */
2226 if (--lockCount < 0) {
2227 lockCount = 0;
2228 /*goto failPrimitive;*/
2229 }
2230 } else {
2231 /* lock */
2232 ++lockCount;
2233 }
2234 }
2235 /* query lock state */
2236 retValue = lockCount ? lstTrueObj : lstFalseObj;
2237 break;
2238 case 65: /* TicksGetSet */
2239 if (low > 1) goto failPrimitiveArgs;
2240 if (low > 0) {
2241 op = POPIT;
2242 stackTop -= (low-1); /* drop other args */
2243 if (LST_IS_SMALLINT(op)) tmp = lstIntValue(op);
2244 else if (op == lstIntegerClass) tmp = lstLIntValue(op);
2245 else goto failPrimitive;
2246 if (tmp < 1) tmp = 1;
2247 ticks = tmp;
2248 }
2249 retValue = LST_FITS_SMALLINT(ticks) ? lstNewInt(ticks) : lstNewLongInt(ticks);
2250 break;
2251 case 66: /* RunGC */
2252 if (low != 0) goto failPrimitiveArgs;
2253 lstGC();
2254 retValue = lstNilObj;
2255 break;
2256 case 67: /* UserBreakSignal */
2257 if (low != 0) goto failPrimitiveArgs;
2258 ++lstExecUserBreak;
2259 retValue = lstNilObj;
2260 break;
2261 case 68: /* EventHandlerCtl */
2262 if (low == 0) {
2263 grpTicks = 1;
2264 } else {
2265 if (low != 2) goto failPrimitiveArgs;
2266 /*
2267 * <EventHandlerCtl eid true> -- suspend this process; wait for the event
2268 */
2269 op1 = POPIT;
2270 op = POPIT;
2271 if (!LST_IS_SMALLINT(op)) goto failPrimitive;
2272 tmp = lstIntValue(op);
2273 if (tmp < 1 || tmp > 65535) goto failPrimitive;
2274 if (op1 != lstTrueObj) goto failPrimitive;
2275 /*dprintf("eventWaitFor: %d\n", tmp);*/
2276 addOneShotEventHandler(tmp, curGroup);
2277 curGroup->ewait = -tmp; /* sheduler will save and skip this process */
2278 }
2279 retValue = lstTrueObj;
2280 break;
2281 case 69: /* ProcessGroupCtl */
2282 /*
2283 * <ProcessGroupCtl 0 process [ticks]> -- create new process group
2284 */
2285 if (low < 2 || low > 3) goto failPrimitiveArgs;
2286 if (low == 3) {
2287 op = POPIT; --low;
2288 if (!LST_IS_SMALLINT(op)) goto failPrimitiveArgs;
2289 tmp = lstIntValue(op);
2290 if (tmp < 1) tmp = 10000;
2291 } else tmp = 10000;
2292 op = POPIT;
2293 op1 = POPIT;
2294 if (!LST_IS_SMALLINT(op1)) goto failPrimitive;
2295 if (lstIntValue(op1) != 0) goto failPrimitive;
2296 if (!lstIsKindOf(op, lstProcessClass)) goto failPrimitive;
2297 if (op->data[lstIVrunningInProcess] != lstNilObj) goto failPrimitive;
2298 else {
2299 saveCurrentProcess();
2300 /* create new process group */
2301 LstRunGroup *ng = calloc(1, sizeof(LstRunGroup)); /*TODO: reuse free groups*/
2302 LstRunGroup *pg = curGroup;
2303 /* and switch */
2304 ng->ticks = tmp;
2305 curGroup = ng;
2306 if (loadNewProcess(op) == 0) {
2307 /* new process succesfully loaded, insert group in list (after current) */
2308 /*fprintf(stderr, "OK!\n");*/
2309 saveCurrentProcess();
2310 ng->prev = pg;
2311 ng->next = pg->next;
2312 pg->next = ng;
2313 if (ng->next) ng->next->prev = ng;
2314 } else {
2315 /* remove this group */
2316 free(ng);
2317 ng = NULL;
2318 }
2319 /* restore old process */
2320 curGroup = pg;
2321 reloadFromGroup();
2322 if (!ng) goto failPrimitive;
2323 }
2324 break;
2325
2326 case 70: /* PrintObject */
2327 if (low == 0) {
2328 fflush(stdout);
2329 } else {
2330 if (low > 2) goto failPrimitiveArgs;
2331 op1 = low==2 ? POPIT : lstNilObj;
2332 op = POPIT;
2333 if (LST_IS_SMALLINT(op)) {
2334 tmp = lstIntValue(op);
2335 if (tmp >= 0 && tmp <= 255) fputc(tmp, stdout);
2336 } else if (LST_IS_BYTES(op)) {
2337 fwrite(lstBytePtr(op), LST_SIZE(op), 1, stdout);
2338 } else if (op->stclass == lstCharClass) {
2339 op = op->data[0];
2340 if (!LST_IS_SMALLINT(op)) goto failPrimitive;
2341 tmp = lstIntValue(op);
2342 if (tmp >= 0 && tmp <= 255) fputc(tmp, stdout);
2343 } else goto failPrimitive;
2344 if (op1 != lstNilObj) fputc('\n', stdout);
2345 }
2346 retValue = lstNilObj;
2347 break;
2348 case 71: /* ReadCharacter */
2349 if (low != 0) goto failPrimitiveArgs;
2350 tmp = fgetc(stdin);
2351 retValue = tmp==EOF ? lstNilObj : lstNewInt((int)(((unsigned int)tmp)&0xff));
2352 break;
2353
2354 case 72: /* FloatBAIO opcode num */
2355 if (low != 2) goto failPrimitiveArgs;
2356 op = POPIT; /* num */
2357 op1 = POPIT; /* opcode */
2358 if (!LST_IS_SMALLINT(op1)) goto failPrimitive;
2359 tmp = lstIntValue(op1);
2360 if (tmp < 0 || tmp > 1) goto failPrimitive;
2361 if (tmp == 0) {
2362 /* to byte array */
2363 if (LST_CLASS(op) != lstFloatClass) goto failPrimitive;
2364 ptemp = op;
2365 retValue = lstNewBinary(lstBytePtr(ptemp), sizeof(LstFloat));
2366 ptemp = NULL;
2367 } else {
2368 /* from byte array */
2369 LstFloat n;
2370 if (LST_CLASS(op) != lstByteArrayClass) goto failPrimitive;
2371 if (LST_SIZE(op) != sizeof(n)) goto failPrimitive;
2372 memcpy(&n, lstBytePtr(op), sizeof(n));
2373 retValue = lstNewFloat(n);
2374 }
2375 break;
2376 case 73: /* IntegerBAIO opcode num */
2377 if (low != 2) goto failPrimitiveArgs;
2378 op = POPIT; /* num */
2379 op1 = POPIT; /* opcode */
2380 if (!LST_IS_SMALLINT(op1)) goto failPrimitive;
2381 tmp = lstIntValue(op1);
2382 if (tmp < 0 || tmp > 1) goto failPrimitive;
2383 if (tmp == 0) {
2384 /* to byte array */
2385 if (LST_CLASS(op) != lstIntegerClass) goto failPrimitive;
2386 ptemp = op;
2387 retValue = lstNewBinary(lstBytePtr(ptemp), sizeof(LstLInt));
2388 ptemp = NULL;
2389 } else {
2390 /* from byte array */
2391 LstLInt n;
2392 if (LST_CLASS(op) != lstByteArrayClass) goto failPrimitive;
2393 if (LST_SIZE(op) != sizeof(n)) goto failPrimitive;
2394 memcpy(&n, lstBytePtr(op), sizeof(n));
2395 retValue = lstNewLongInt(n);
2396 }
2397 break;
2398
2399 case 74: /* ExecuteContext ctx */
2400 if (low != 1) goto failPrimitiveArgs;
2401 op = POPIT; /* ctx */
2402 if (LST_CLASS(op) != lstContextClass && !lstIsKindOf(op, lstContextClass)) goto failPrimitive;
2403 op->data[lstIVpreviousContextInContext] = context->data[lstIVpreviousContextInContext];
2404 context = op;
2405 reloadFromCtx();
2406 goto doAllAgain;
2407
2408 case 75: /* StFinalizeCtl obj add-remove-flag */
2409 if (low != 2) goto failPrimitiveArgs;
2410 op1 = POPIT; /* flag */
2411 op = POPIT; /* object */
2412 if (LST_IS_SMALLINT(op)) goto failPrimitive; /* SmallInt can't have finalizer */
2413 if (op1 == lstNilObj || op1 == lstFalseObj) {
2414 /* remove from list */
2415 if (LST_IS_STFIN(op)) {
2416 LST_RESET_STFIN(op);
2417 lstRemoveFromFList(&stFinListHead, op->fin);
2418 free(op->fin);
2419 }
2420 } else {
2421 /* add to list */
2422 if (!LST_IS_STFIN(op)) {
2423 if (op->fin) goto failPrimitive; /* object can have either C or ST finalizer, but not both */
2424 op->fin = calloc(1, sizeof(LstFinLink));
2425 if (!op->fin) lstFatal("out of memory is StFinalizeCtl", 0x29a);
2426 LST_SET_STFIN(op);
2427 op->fin->obj = op; /* owner */
2428 lstAddToFList(&stFinListHead, op->fin);
2429 }
2430 }
2431 retValue = lstNilObj;
2432 break;
2433
2434 case 76: /* StWeakCtl obj */
2435 if (low != 1) goto failPrimitiveArgs;
2436 op = POPIT; /* object */
2437 if (LST_IS_SMALLINT(op)) goto failPrimitive; /* SmallInt can't have finalizer */
2438 /* add to list */
2439 if (!LST_IS_WEAK(op)) {
2440 if (op->fin) goto failPrimitive; /* object can have either C or ST finalizer, or marked as weak, but not all */
2441 op->fin = calloc(1, sizeof(LstFinLink));
2442 if (!op->fin) lstFatal("out of memory is StWeakCtl", 0x29a);
2443 LST_SET_WEAK(op);
2444 op->fin->obj = op; /* owner */
2445 lstAddToFList(&stWeakListHead, op->fin);
2446 }
2447 retValue = lstNilObj;
2448 break;
2449
2450 case 77: /* FloatFunc float idx */
2451 if (low != 2) goto failPrimitiveArgs;
2452 op1 = POPIT; /* idx */
2453 op = POPIT; /* float */
2454 if (!LST_IS_SMALLINT(op1)) goto failPrimitive;
2455 tmp = lstIntValue(op1);
2456 if (LST_IS_SMALLINT(op)) fop0 = lstIntValue(op);
2457 else if (op->stclass == lstIntegerClass) fop0 = lstLIntValue(op);
2458 else if (op->stclass == lstFloatClass) fop0 = lstFloatValue(op);
2459 else goto failPrimitive;
2460 switch (tmp) {
2461 case 0: fop0 = log2(fop0); break;
2462 default: goto failPrimitive;
2463 }
2464 retValue = lstNewFloat(fop0);
2465 break;
2466
2467 case 78: /* LastFailedPrim */
2468 stackTop -= low;
2469 retValue = lstNewInt(lastFailedPrim);
2470 break;
2471
2472 case 79: {/* FNVHash byteobj */
2473 uint32_t h;
2474 if (low != 1) goto failPrimitiveArgs;
2475 op = POPIT; /* obj */
2476 if (!LST_IS_BYTES_EX(op)) goto failPrimitive;
2477 h = fnvHash(lstBytePtr(op), LST_SIZE(op));
2478 tmp = (h%(INT_MAX/2));
2479 retValue = lstNewInt(tmp);
2480 break; }
2481
2482 default:
2483 /* save stack pointers */
2484 l0 = lstRootTop;
2485 l1 = lstTempSP;
2486 {
2487 #ifdef DEBUG
2488 lstPrimCtx = context;
2489 saveCurrentProcess();
2490 #endif
2491 resetEvtCheckLeft = 0;
2492 LSTPrimitiveFn pfn = lstFindExtPrimitiveFn(high);
2493 retValue = pfn ? pfn(high, &(stack->data[stackTop-low]), low) : NULL;
2494 if (resetEvtCheckLeft) { evtCheckLeft = 1; }
2495 }
2496 stackTop -= low; /* remove primitive args */
2497 /* restore stacks */
2498 if (lstRootTop < l0) lstFatal("root stack error in primitive", high);
2499 if (lstTempSP < l1) lstFatal("temp stack error in primitive", high);
2500 lstRootTop = l0;
2501 lstTempSP = l1;
2502 if (!retValue) goto failPrimitive;
2503 break;
2504 }
2505 /* force a stack return due to successful primitive */
2506 ptemp = NULL;
2507 goto doReturn;
2508 failPrimitiveArgs:
2509 stackTop -= low;
2510 failPrimitive:
2511 lastFailedPrim = lastCalledPrim;
2512 /* supply a return value for the failed primitive */
2513 PUSHIT(lstNilObj);
2514 endPrimitive:
2515 /* done with primitive, continue execution loop */
2516 ptemp = NULL;
2517 break;
2518
2519 case lstBCDoSpecial:
2520 switch (low) {
2521 case lstBXSelfReturn:
2522 DBG0("DoSpecial: SelfReturn");
2523 retValue = arguments->data[lstIVreceiverInArguments];
2524 goto doReturn;
2525 case lstBXStackReturn:
2526 DBG0("DoSpecial: StackReturn");
2527 retValue = POPIT;
2528 doReturn: /*context->data[lstIVbytePointerInContext] = lstNilObj;*/
2529 context = context->data[lstIVpreviousContextInContext];
2530 doReturn2: if (context == lstNilObj) {
2531 /*aProcess->data[lstIVcontextInProcess] = lstNilObj;*/ /* 'complete' flag */
2532 int rr = doReturn(lstReturnReturned);
2533 if (rr) XRETURN(rr);
2534 if (tmp || retGSwitch) goto doAllAgain;
2535 goto execComplete;
2536 }
2537 doReturn3: aProcess->data[lstIVcontextInProcess] = context;
2538 reloadFromCtx();
2539 PUSHIT(retValue);
2540 break;
2541 case lstBXBlockReturn:
2542 DBG0("DoSpecial: BlockReturn");
2543 /* the very bad thing is that this can be inter-group return */
2544 retValue = POPIT;
2545 /*context->data[lstIVbytePointerInContext] = lstNilObj;*/
2546 /*dprintf("cp=%p\n", aProcess);*/
2547 context = context->data[lstIVcreatingContextInBlock]->data[lstIVpreviousContextInContext];
2548 if (context == lstNilObj) {
2549 if (curGroup->group->prev) {
2550 /* not the last process */
2551 goto doReturn2;
2552 }
2553 /* return from the process of the group */
2554 /* if this is return from the main group, we have to return from executor */
2555 if (curGroup == runGroups) {
2556 aProcess = runGroups->group->process; /* initial process */
2557 aProcess->data[lstIVresultInProcess] = retValue;
2558 aProcess->data[lstIVcontextInProcess] = lstNilObj;
2559 /* clear the current run group */
2560 while (curGroup->group) releaseRunContext();
2561 XRETURN(lstReturnReturned); /* done */
2562 } else {
2563 /* just kill the current run group */
2564 while (curGroup->group) releaseRunContext();
2565 free(removeCurrentGroup());
2566 }
2567 /* the current group is dead, go on with the next */
2568 nextGroup(0);
2569 goto doAllAgain;
2570 }
2571 /* check if we should do unwinding and possibly group switching */
2572 if (context->data[lstIVprocOwnerInContext] != aProcess) {
2573 /* yes, this is inter-process return; do unwinding */
2574 op = context->data[lstIVprocOwnerInContext];
2575 dprintf(" ct=%p\n", context);
2576 dprintf(" op=%p\n", op);
2577 dprintf(" nl=%p\n", lstNilObj);
2578 /* first try our own process group */
2579 if (groupHasProcess(curGroup, op)) {
2580 /* unwinding in current process group */
2581 while (curGroup->group->process != op) releaseRunContext();
2582 goto doReturn3;
2583 }
2584 /* not in the current group; this means that the current group is effectively dead */
2585 /* remove current group */
2586 if (curGroup == runGroups) {
2587 /* main group */
2588 while (curGroup->group->prev) releaseRunContext();
2589 aProcess = runGroups->group->process; /* initial process */
2590 aProcess->data[lstIVresultInProcess] = retValue;
2591 aProcess->data[lstIVcontextInProcess] = lstNilObj;
2592 /* clear the current run group */
2593 while (curGroup->group) releaseRunContext();
2594 XRETURN(lstReturnReturned); /* done */
2595 }
2596 while (curGroup->group) releaseRunContext();
2597 free(removeCurrentGroup());
2598 /* inter-group communications should be done with events, so just shedule to the next process */
2599 nextGroup(0);
2600 goto doAllAgain;
2601 }
2602 goto doReturn2;
2603 case lstBXDuplicate:
2604 DBG0("DoSpecial: Duplicate");
2605 assert(stackTop > 0);
2606 retValue = stack->data[stackTop-1];
2607 PUSHIT(retValue);
2608 break;
2609 case lstBXPopTop:
2610 DBG0("DoSpecial: PopTop");
2611 assert(stackTop > 0);
2612 --stackTop;
2613 break;
2614 case lstBXBranch:
2615 DBG0("DoSpecial: Branch");
2616 low = VAL;
2617 curIP = low;
2618 break;
2619 case lstBXBranchIfTrue:
2620 DBG0("DoSpecial: BranchIfTrue");
2621 low = VAL;
2622 retValue = POPIT;
2623 if (retValue == lstTrueObj) curIP = low; else curIP += VALSIZE;
2624 break;
2625 case lstBXBranchIfFalse:
2626 DBG0("DoSpecial: BranchIfFalse");
2627 low = VAL;
2628 retValue = POPIT;
2629 if (retValue == lstFalseObj) curIP = low; else curIP += VALSIZE;
2630 break;
2631 case lstBXBranchIfNil:
2632 DBG0("DoSpecial: BranchIfNil");
2633 low = VAL;
2634 retValue = POPIT;
2635 if (retValue == lstNilObj) curIP = low; else curIP += VALSIZE;
2636 break;
2637 case lstBXBranchIfNotNil:
2638 DBG0("DoSpecial: BranchIfNotNil");
2639 low = VAL;
2640 retValue = POPIT;
2641 if (retValue != lstNilObj) curIP = low; else curIP += VALSIZE;
2642 break;
2643 case lstBXSendToSuper:
2644 DBG0("DoSpecial: SendToSuper");
2645 /* next byte has literal selector number */
2646 low = bp[curIP++];
2647 messageSelector = literals->data[low];
2648 receiverClass = method->data[lstIVclassInMethod]->data[lstIVparentClassInClass];
2649 arguments = POPIT;
2650 l0 = bp[curIP];
2651 goto checkCache;
2652 case lstBXThisContext:
2653 DBG0("DoSpecial: ThisContext");
2654 PUSHIT(context);
2655 break;
2656 case lstBXBreakpoint:
2657 DBG0("DoSpecial: Breakpoint");
2658 /*fprintf(stderr, "BP\n");*/
2659 /* back up on top of the breaking location */
2660 --curIP;
2661 /* return to our master process */
2662 /*aProcess->data[lstIVresultInProcess] = lstNilObj;*/
2663 retValue = lstNilObj;
2664 if (doReturn(lstReturnBreak)) XRETURN(lstReturnBreak);
2665 if (tmp || retGSwitch) goto doAllAgain;
2666 goto execComplete;
2667 default:
2668 lstFatal("invalid doSpecial", low);
2669 break;
2670 }
2671 break;
2672 default:
2673 if (curGroup == runGroups) {
2674 retValue = lstNilObj;
2675 if (doReturn(lstReturnError)) XRETURN(lstReturnError);
2676 fprintf(stderr, "invalid bytecode: %d\n", high);
2677 if (tmp || retGSwitch) goto doAllAgain;
2678 goto execComplete;
2679 }
2680 lstFatal("invalid bytecode", high);
2681 break;
2682 }
2683 }
2684 }
2685
2686
2687 int lstExecute (lstObject *aProcess, int ticks, int locked) {
2688 lstResetResume();
2689 return lstExecuteInternal(aProcess, ticks, locked);
2690 }
2691
2692
2693 int lstResume (void) {
2694 if (!lstSuspended) return -1; /* very fatal error */
2695 return lstExecuteInternal(NULL, 0, 0);
2696 }
2697
2698
2699 int lstCanResume (void) {
2700 return lstSuspended != 0;
2701 }
2702
2703
2704 void lstResetResume (void) {
2705 if (lstSuspended) {
2706 lstSuspended = 0;
2707 curGroup = runGroups;
2708 while (curGroup->group) releaseRunContext();
2709 }
2710 }
2711
2712
2713 #define RARG (lstRootStack[otop+0])
2714 #define RMETHOD (lstRootStack[otop+1])
2715 #define RPROCESS (lstRootStack[otop+2])
2716 #define RCONTEXT (lstRootStack[otop+3])
2717 int lstRunMethodWithArg (lstObject *method, lstObject *inClass, lstObject *arg, lstObject **result, int locked) {
2718 lstObject *o;
2719 int otop = lstRootTop, x;
2720 if (result) *result = NULL;
2721 /* save method and arguments */
2722 if (!method || method->stclass != lstMethodClass) return lstReturnError;
2723 lstRootStack[LST_RSTACK_NSP()] = arg;
2724 lstRootStack[LST_RSTACK_NSP()] = method;
2725 /* create Process object */
2726 lstRootStack[LST_RSTACK_NSP()] = lstAllocInstance(lstProcessSize, lstProcessClass); /*lstStaticAlloc(lstProcessSize);*/
2727 /* create Context object (must be dynamic) */
2728 lstRootStack[LST_RSTACK_NSP()] = lstAllocInstance(lstContextSize, lstContextClass);
2729 RPROCESS->data[lstIVcontextInProcess] = RCONTEXT;
2730 x = lstIntValue(RMETHOD->data[lstIVstackSizeInMethod]);
2731 o = lstRootStack[LST_RSTACK_NSP()] = RCONTEXT->data[lstIVstackInContext] = lstAllocInstance(x, lstArrayClass);
2732 /*if (x) memset(lstBytePtr(o), 0, x*LST_BYTES_PER_WORD);*/
2733 /* build arguments array */
2734 o = lstAllocInstance(arg ? 2 : 1, lstArrayClass);
2735 /*o->data[0] = RCONTEXT;*/
2736 o->data[0] = inClass ? inClass : lstNilObj->stclass;
2737 if (arg) o->data[1] = arg;
2738 RCONTEXT->data[lstIVprocOwnerInContext] = RPROCESS;
2739 RCONTEXT->data[lstIVargumentsInContext] = o;
2740 RCONTEXT->data[lstIVtemporariesInContext] = lstAllocInstance(lstIntValue(RMETHOD->data[lstIVtemporarySizeInMethod]), lstArrayClass);
2741 RCONTEXT->data[lstIVbytePointerInContext] = lstNewInt(0);
2742 RCONTEXT->data[lstIVstackTopInContext] = lstNewInt(0);
2743 RCONTEXT->data[lstIVpreviousContextInContext] = lstNilObj;
2744 RCONTEXT->data[lstIVmethodInContext] = RMETHOD;
2745 /* now go do it */
2746 int res = lstExecute(RPROCESS, 0, locked>0);
2747 if (res == lstReturnReturned && result) *result = RPROCESS->data[lstIVresultInProcess];
2748 /*printf("OTOP: %d; TOP: %d\n", otop, lstRootTop);*/
2749 switch (res) {
2750 case lstReturnBadMethod:
2751 fprintf(stderr, "can't find method in call\n");
2752 o = RPROCESS->data[lstIVresultInProcess];
2753 fprintf(stderr, "Unknown method: %s\n", lstBytePtr(o));
2754 lstBackTrace(RPROCESS->data[lstIVcontextInProcess]);
2755 break;
2756 case lstReturnAPISuspended:
2757 if (lstExecUserBreak != 666) {
2758 fprintf(stderr, "\nuser break\n");
2759 o = RPROCESS->data[lstIVresultInProcess];
2760 lstBackTrace(RPROCESS->data[lstIVcontextInProcess]);
2761 }
2762 break;
2763 }
2764 if (lstRootTop > otop) lstRootTop = otop;
2765 return res;
2766 }
2767
2768
2769 void lstCompleteFinalizers (void) {
2770 for (;;) {
2771 lstGC();
2772 if (finGroupCount < 1) break;
2773 runOnlyFins = 1;
2774 dprintf("%d finalizers left\n", finGroupCount);
2775 lstExecuteInternal(NULL, 10000, 0);
2776 }
2777 }
Useless fork of Little Smalltalk (advanced and unusable)