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