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