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