'From Squeak3.2gamma of 15 January 2002 [latest update: #4653] on 12 February 2002 at 5:16:57 pm'! "Change Set: BCInterpreter-ajh Date: 12 February 2002 Author: Anthony Hannan (ajh18@cornell.edu) This is part of the New Block Closure Version set of changes. Please refer to http://minnow.cc.gatech.edu/squeak/BlockClosureVersion. This changeset modifies the VM classes so they will run the new block closure image format. See Interpreter class comment enclosed for details."! !Interpreter commentStamp: '' prior: 0! This class is a complete implementation of the Smalltalk-80 virtual machine, derived originally from the Blue Book specification. It has been modernized with 32-bit pointers, stack frame contexts, and attention to variable use that allows the CCodeGenerator (qv) to keep, eg, the instruction pointer and stack pointer in registers. In addition to SmallInteger arithmetic and Floats, it supports logic on 32-bit PositiveLargeIntegers, thus allowing it to simulate itself much more effectively than would otherwise be the case. NOTE: Here follows a list of things to be borne in mind when working on this code, or when making changes for the future. 1. There are a number of things that should be done the next time we plan to release a copletely incompatible image format. These include unifying the instanceSize field of the class format word -- see instantiateClass:indexableSize:. Also, CallStacks should be given a special format code (see next item). 2. There is a fast check for CallStacks (see isStackHeader:) which will fail if the compact class index of CallStack change. This is necessary because the oops may change during a compaction when the oops are being adjusted. It's important to be aware of this when writing a new image using the systemTracer. A better solution would be to reserve one of the format codes for CallStacks only. 3. We have made normal files tolerant to size and positions up to 32 bits. This has not been done for async files, since they are still experimental. The code in size, at: and at:put: should work with sizes and indices up to 31 bits, although I have not tested it (di 12/98); it might or might not work with 32-bit sizes. 4. Note that 0 is used in a couple of places as an impossible oop. This should be changed to a constant that really is impossible (or perhaps there is code somewhere that guarantees it --if so it should be put in this comment). The places include the method cache and the at cache. ---- In January 2002, Anthony Hannan (ajh) added Block Closure support, and in the process eliminated context objects and revamped the bytecodes. This resulted in a 12% speed up in bytecodes and 35% speed up in message sends as measured by 0 tinyBenchmarks (on a i586 533Mhz running Linux, compiled with gcc). This is nice for the Interpreter, but unfortunately makes the current Jitter obsolete. Jitter will have to be rewritten, but hopefully it will be simpler with the new bytecodes and stack layout. Method/block contexts now reside on a stack, not the hardware stack, but a stack object (a CallStack) that can hold many context frames (see defaultStackSize). When a stack overflows a new stack is started with a link to the previous stack (see startNewStack). Frames overlap (like traditional activation records) with the parameter slots of a message send becoming the arg slots of the new context (see MethodContext2 for frame layout, and activateNewMethod). pushThisContext creates an MethodContext2 object that refers to the frame on the stack. The MethodContext2 object is also put in a reserved slot in the frame, so the we can tell if its index still refers to its frame and not another frame that replaced it (making it obsolete/dead). Blocks (BlockClosures) have their own methods separate from their home method and their own local storage for captured temps from the home context. They also have a slot for their home context's ActiveFrame that is filled in only if the block contains a return (^). A method creates a block by issuing a createBlock or createReturnBlock instruction but only after pushing the block method, captured temp values (including 'self' if needed), and home context (if returns). The createBlock instruction pops these and use them to create the BlockClosure. The pushed block method is stored as a literal in the parent method. If a temp can be shared between multiple closures/context and changed, then the temp is wrapped in a SharedTemp holder initially, and the methods will read/write to it indirectly. When executing a block, primitiveValue simply gets the block method from the block and activates the method normally keeping the block as the receiver. The block method accesses closure variables from the receiver the same way a regular method accesses instance variables from a regular object. The bytecodes now reference local variables (receiver, args, and temps) by offset from the stack pointer (localSP) (see pushLocal... and storeLocal...). This makes the Compiler and Decompiler a little more complex because the offsets change with the sp but makes execution faster because sp is held in a machine register. (When registers become more plentiful we can change to referencing locals by framePointer offset which does not change with sp). The bytecodes reference fields of objects (such as receiver instance variables) by first pushing the object then replacing the object with its field value (see getField... and setField...). This same technique is used to get inside SharedTemp holders and global var associatons. This does double the bytecode size for getting/setting instance variables, but since we are accessing the receiver by sp offset we need the two bytecodes. This in addition to separate methods for blocks and a separate byte array for bytecodes adds about 7% to the overal size of a 3.2 default image. (If we eventually put the fp in a register then we could copy the receiver to a fixed offset from the fp (we read the receiver anyway to get its class for method lookup) and have special single bytecodes that access its instance variables. Alternatively, we could copy the receiver to a separate global that we update on every frame change, requiring three more memory accesses per return (read numArgs from method, then read receiver from frame, then store into receiver global). Note, however, having special bytecodes for the receiver means we would have to take away special bytecodes from somewhere else) The active method is held in a separate global and updated on every frame change. This allows us to use special single bytecodes for sends and literal access (see pushLiteralRange and send...). I though this was necessary to avoid bloat since sends are so prolific. (Again, if fp were in a register we wouldn't need the method global, the special bytecodes could access the method from a fixed fp offset). The rest of the bytecodes are pretty standard like before (pop, jump..., return..., etc.), although there are some changes to them. Short jumps are no longer distributed over a range of bytecodes to save space, instead each has a single extended bytecode which makes booleanCheat: faster since it only has to check a single bytecode. And method returns are divided into local or remote returns instead of doing a pseudo remote return even when local. ! ]style[(2574 9 306 14 1056 10 536 8 2336)f1,f1LCallStack Comment;,f1,f1LMethodContext2 Comment;,f1,f1LSharedTemp Comment;,f1,f1LCompiler Comment;,f1! !CCodeGenerator methodsFor: 'inlining' stamp: 'ajh 2/4/2002 22:45'! doInlining: inlineFlag "Inline the bodies of all methods that are suitable for inlining." "Modified slightly for the translator, since the first level of inlining for the interpret loop must be performed in order that the instruction implementations can easily discover their addresses." | pass progress | inlineFlag ifFalse: [ self inlineDispatchesInMethodNamed: #interpret localizingVars: #(). ^ self]. self collectInlineList. pass _ 0. progress _ true. [progress] whileTrue: [ "repeatedly attempt to inline methods until no further progress is made" progress _ false. ('Inlining pass ', (pass _ pass + 1) printString, '...') displayProgressAt: Sensor cursorPoint from: 0 to: methods size during: [:bar | methods doWithIndex: [:m :i | bar value: i. (m tryToInlineMethodsIn: self) ifTrue: [progress _ true]]]]. 'Inlining bytecodes' displayProgressAt: Sensor cursorPoint from: 1 to: 2 during: [:bar | self inlineDispatchesInMethodNamed: #interpret localizingVars: #(currentBytecode localIP localSP localReturnValue localTrue localFalse). bar value: 1. self removeMethodsReferingToGlobals: #(currentBytecode localIP localSP localReturnValue localTrue localFalse) except: #interpret. bar value: 2]. "make receiver on the next line false to generate code for all methods, even those that are inlined or unused" true ifTrue: [ (methods includesKey: #interpret) ifTrue: [ "only prune when generating the interpreter itself" self pruneUnreachableMethods]]. ! ! !CCodeGenerator methodsFor: 'inlining' stamp: 'ajh 1/11/2002 20:06'! pruneUnreachableMethods "Remove any methods that are not reachable. Retain methods needed by the BitBlt operation table, primitives, plug-ins, or interpreter support code." | retain | "Build a set of selectors for methods that should be output even though they have no apparent callers. Some of these are stored in tables for indirect lookup, some are called by the C support code or by primitives." retain _ BitBltSimulation opTable asSet. #(checkedLongAt: fullDisplayUpdate interpret printCallStack printCallStackTop: printAllStacks printFrame: printFrame:stack: longPrint: shortPrint: readImageFromFile:HeapSize:StartingAt: success: "Windows needs the following two for startup and debug" readableFormat: getCurrentBytecode "Jitter reuses all of these" allocateChunk: characterForAscii: findClassOfMethod:forReceiver: findSelectorOfMethod:forReceiver: firstAccessibleObject loadInitialContext noteAsRoot:headerLoc: nullCompilerHook primitiveFloatAdd primitiveFloatDivide primitiveFloatMultiply primitiveFloatSubtract primitiveFlushExternalPrimitives setCompilerInitialized: splObj:) do: [:sel | retain add: sel]. InterpreterProxy organization categories do: [:cat | ((cat ~= 'initialize') and: [cat ~= 'private']) ifTrue: [ retain addAll: (InterpreterProxy organization listAtCategoryNamed: cat)]]. "Remove all the unreachable methods that aren't retained for the reasons above." self unreachableMethods do: [:sel | (retain includes: sel) ifFalse: [ methods removeKey: sel ifAbsent: []]]. ! ! !CCodeGenerator methodsFor: 'inlining' stamp: 'ajh 11/22/2001 11:13'! removeMethodsReferingToGlobals: varList except: methodName "Remove any methods (presumably inlined) that still contain references to the given obsolete global variables." | varListAsStrings removeIt mVars | self flag: #tony. "Need to tell the user if removing a method that was not inlined" varListAsStrings _ varList collect: [ :sym | sym asString ]. methods keys copy do: [ :sel | removeIt _ false. mVars _ (self methodNamed: sel) freeVariableReferences asSet. varListAsStrings do: [ :v | (mVars includes: v) ifTrue: [ removeIt _ true ]. ]. (removeIt and: [sel ~= methodName]) ifTrue: [ methods removeKey: sel ifAbsent: []. ]. ].! ! !FileStream methodsFor: 'editing' stamp: 'ajh 10/18/2001 00:24'! changeCrToLf self changeEvery: Character cr to: Character linefeed! ! !FileStream methodsFor: 'editing' stamp: 'ajh 10/18/2001 00:23'! changeEvery: char1 to: char2 | c | self position: 0. 1 to: self size do: [:i | c _ self next. c = char1 ifTrue: [ self skip: - 1. self nextPut: char2] ]. ! ! !FileStream methodsFor: 'editing' stamp: 'ajh 10/18/2001 00:24'! changeLfToCr self changeEvery: Character linefeed to: Character cr! ! !InterpreterProxy methodsFor: 'initialize' stamp: 'ajh 1/23/2002 16:24'! loadStackFrom: aContext self push: aContext receiver. method _ aContext method. argumentCount _ method numArgs. 1 to: argumentCount do:[:i| self push: (aContext tempAt: i) ].! ! !ObjectMemory methodsFor: 'initialization' stamp: 'ajh 1/20/2002 01:28'! initializeObjectMemory: bytesToShift "Initialize object memory variables at startup time. Assume endOfMemory is initially set (by the image-reading code) to the end of the last object in the image. Initialization redefines endOfMemory to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks." "Assume: image reader initializes the following variables: memory endOfMemory memoryLimit specialObjectsOop lastHash " "di 11/18/2000 fix slow full GC" self inline: false. "set the start of the young object space" youngStart _ endOfMemory. "image may be at a different address; adjust oops for new location" totalObjectCount _ self adjustAllOopsBy: bytesToShift. self initializeMemoryFirstFree: endOfMemory. "initializes endOfMemory, freeBlock" specialObjectsOop _ specialObjectsOop + bytesToShift. "heavily used special objects" nilObj _ self splObj: NilObject. falseObj _ self splObj: FalseObject. trueObj _ self splObj: TrueObject. rootTableCount _ 0. child _ 0. field _ 0. parentField _ 0. defaultStackSize _ 500. "must be > method max numTemps + method max stackSize + FrameContextInfoSize (64 + 60 + 3)" allocationCount _ 0. lowSpaceThreshold _ 0. signalLowSpace _ false. compStart _ 0. compEnd _ 0. fwdTableNext _ 0. fwdTableLast _ 0. remapBufferCount _ 0. allocationsBetweenGCs _ 4000. "do incremental GC after this many allocations" tenuringThreshold _ 2000. "tenure all suriving objects if count is over this threshold" growHeadroom _ 4*1024*1024. "four megabyte of headroom when growing" shrinkThreshold _ 8*1024*1024. "eight megabyte of free space before shrinking" "garbage collection statistics" statFullGCs _ 0. statFullGCMSecs _ 0. statIncrGCs _ 0. statIncrGCMSecs _ 0. statTenures _ 0. statRootTableOverflows _ 0. displayBits _ 0. "support for the Acorn VM; ignored if zero" ! ! !ObjectMemory methodsFor: 'interpreter access' stamp: 'ajh 11/19/2001 01:34'! fetchClassOf: oop | ccIndex | self inline: true. (self isIntegerObject: oop) ifTrue: [^ self splObj: ClassInteger]. ccIndex _ self ccIndexIn: (self baseHeader: oop). ccIndex = 0 ifTrue: [^ (self classHeader: oop) bitAnd: AllButTypeMask ] ifFalse: ["look up compact class" ^ self fetchPointer: ccIndex - 1 ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop) ]. ! ! !ObjectMemory methodsFor: 'interpreter access' stamp: 'ajh 10/3/2001 11:27'! fetchClassOfNonInt: oop | ccIndex | self inline: true. ccIndex _ self ccIndexIn: (self baseHeader: oop). ccIndex = 0 ifTrue: [^ (self classHeader: oop) bitAnd: AllButTypeMask ] ifFalse: ["look up compact class" ^ self fetchPointer: ccIndex - 1 ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop)] ! ! !ObjectMemory methodsFor: 'interpreter access' stamp: 'ajh 10/5/2001 14:22'! instantiateClass: classPointer indexableSize: size fill: bool with: fillValue " NOTE: This method supports the backward-compatible split instSize field of the class format word. The sizeHiBits will go away and other shifts change by 2 when the split fields get merged in an (incompatible) image change. " | hash header1 header2 cClass byteSize format inc binc header3 hdrSize newObj sizeHiBits | self inline: false. DoAssertionChecks ifTrue: [ size < 0 ifTrue: [ self error: 'cannot have a negative indexable field count' ]]. hash _ self newObjectHash. header1 _ self formatOfClass: classPointer. "Low 2 bits are 0" sizeHiBits _ (header1 bitAnd: 16r60000) >> 9. header1 _ (header1 bitAnd: 16r1FFFF) bitOr: ((hash << HashBitsOffset) bitAnd: HashBits). header2 _ classPointer. header3 _ 0. cClass _ header1 bitAnd: CompactClassMask. "compact class field from format word" byteSize _ (header1 bitAnd: SizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0" format _ (header1 >> 8) bitAnd: 16rF. format < 8 ifTrue: [ "Bitmaps and Arrays" inc _ size * 4. ] ifFalse: [ "Strings and Methods" inc _ (size + 3) bitAnd: AllButTypeMask. "round up" binc _ 3 - ((size + 3) bitAnd: 3). "odd bytes" "low bits of byte size go in format field" header1 _ header1 bitOr: (binc << 8). ]. (byteSize + inc) > 255 ifTrue: [ "requires size header word" header3 _ byteSize + inc. header1 _ header1 - (byteSize bitAnd: 16rFF). "Clear qsize field" ] ifFalse: [ header1 _ header1 + inc. ]. byteSize _ byteSize + inc. header3 > 0 ifTrue: [ "requires full header" hdrSize _ 3. ] ifFalse: [ cClass = 0 ifTrue: [ hdrSize _ 2 ] ifFalse: [ hdrSize _ 1 ]. ]. newObj _ self allocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3 doFill: bool with: fillValue. ^ newObj! ! !ObjectMemory methodsFor: 'interpreter access' stamp: 'ajh 10/5/2001 14:33'! instantiateSmallClassNoFill: classPointer sizeInBytes: sizeInBytes "This version of instantiateClass assumes the object will be filled by the sender and that the total object size is under 256 bytes, the limit for objects with only one or two header words. Note that the size is specified in bytes and should include four bytes for the base header word." | hash header1 header2 hdrSize | hash _ self newObjectHash. header1 _ ((hash << HashBitsOffset) bitAnd: HashBits) bitOr: (self formatOfClass: classPointer). header1 _ header1 + (sizeInBytes - (header1 bitAnd: SizeMask)). header2 _ classPointer. (header1 bitAnd: CompactClassMask) = 0 "is compact class field from format word zero?" ifTrue: [ hdrSize _ 2 ] ifFalse: [ hdrSize _ 1 ]. ^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: 0 doFill: false with: 0! ! !ObjectMemory methodsFor: 'header access' stamp: 'ajh 10/3/2001 11:35'! ccIndexIn: baseHeader "Extract the compact class bits from baseHeader" ^ (baseHeader >> 12) bitAnd: 16r1F! ! !ObjectMemory methodsFor: 'header access' stamp: 'ajh 10/3/2001 12:52'! formatIn: baseHeader " 0 no fields 1 fixed fields only (all containing pointers) 2 indexable fields only (all containing pointers) 3 both fixed and indexable fields (all containing pointers) 4 both fixed and indexable weak fields (all containing pointers). 5 unused 6 indexable word fields only (no pointers) 7 unused 8-11 indexable byte fields only (no pointers) (low 2 bits are low 2 bits of size) 12-15 unused (was compiled method but that has changed to format 3 with a pointer to its bytecodes array) " ^ (baseHeader >> 8) bitAnd: 16rF! ! !ObjectMemory methodsFor: 'object enumeration' stamp: 'ajh 11/19/2001 01:33'! lastPointerOf: oop "Return the byte offset of the last pointer field of the given object. Works with CompiledMethods, as well as ordinary objects. Can be used even when the type bits are not correct." | fmt sz header | self inline: true. header _ self baseHeader: oop. fmt _ self formatIn: header. fmt <= 4 ifTrue: [ (fmt = 3 and: [self isStackHeader: header]) ifTrue: [ "stacks end at their top" ^ (StackStart + (self fetchStackPointerOf: oop)) * 4]. sz _ self sizeBitsOfSafe: oop. ^ sz - BaseHeaderSize "all pointers"]. ^ 0 "no pointers"! ! !ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'ajh 10/3/2001 12:27'! markPhase "Mark phase of the mark and sweep garbage collector. Set the mark bits of all reachable objects. Free chunks are untouched by this process." "Assume: All non-free objects are initially unmarked. Root objects were unmarked when they were made roots. (Make sure this stays true!!!!)." | oop | self inline: false. "trace the interpreter's objects, including the active stack and special objects array" self markAndTraceInterpreterOops. "trace the roots" 1 to: rootTableCount do: [ :i | oop _ rootTable at: i. self markAndTrace: oop. ]. ! ! !ObjectMemory methodsFor: 'gc -- compaction' stamp: 'ajh 10/3/2001 12:56'! lastPointerWhileForwarding: oop "The given object may have its header word in a forwarding block. Find the offset of the last pointer in the object in spite of this obstacle." | header fwdBlock fmt size | self inline: true. header _ self longAt: oop. (header bitAnd: MarkBit) ~= 0 ifTrue: [ "oop is forwarded; get its real header from its forwarding table entry" fwdBlock _ (header bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ]. header _ self longAt: fwdBlock + 4. ]. fmt _ self formatIn: header. fmt <= 4 ifTrue: [(fmt = 3 and: [self isStackHeader: header]) ifTrue: ["stacks end at their top index" ^ (StackStart + (self fetchStackPointerOf: oop)) * 4]. "do sizeBitsOf: using the header we obtained" (header bitAnd: TypeMask) = HeaderTypeSizeAndClass ifTrue: [ size _ (self sizeHeader: oop) bitAnd: AllButTypeMask ] ifFalse: [ size _ header bitAnd: SizeMask ]. ^ size - BaseHeaderSize]. fmt < 12 ifTrue: [^ 0]. "no pointers" ^ 0 "no pointers. Was compiled method but its format has changed to 3"! ! !ObjectMemory methodsFor: 'become' stamp: 'ajh 2/6/2002 11:57'! become: array1 with: array2 twoWay: twoWayFlag "All references to each object in array1 are swapped with all references to the corresponding object in array2. That is, all pointers to one object are replaced with with pointers to the other. The arguments must be arrays of the same length. Returns true if the primitive succeeds." "Implementation: Uses forwarding blocks to update references as done in compaction." (self fetchClassOf: array1) = (self splObj: ClassArray) ifFalse: [ ^ false ]. (self fetchClassOf: array2) = (self splObj: ClassArray) ifFalse: [ ^ false ]. (self lastPointerOf: array1) = (self lastPointerOf: array2) ifFalse: [ ^ false ]. (self containOnlyOops: array1 and: array2) ifFalse: [ ^ false ]. (self prepareForwardingTableForBecoming: array1 with: array2 twoWay: twoWayFlag) ifFalse: [^ false]. "fail; not enough space for forwarding table" self saveStackTopFrame. "in case positions change" (self allYoung: array1 and: array2) ifTrue: [ "sweep only the young objects plus the roots" self mapPointersInObjectsFrom: youngStart to: endOfMemory. ] ifFalse: [ "sweep all objects" self mapPointersInObjectsFrom: (self startOfMemory) to: endOfMemory. ]. twoWayFlag ifTrue: [self restoreHeadersAfterBecoming: array1 with: array2] ifFalse: [self restoreHeadersAfterForwardBecome]. self initializeMemoryFirstFree: freeBlock. "re-initialize memory used for forwarding table" self loadStackTopFrame. ^ true "success"! ! !Interpreter methodsFor: 'initialization' stamp: 'ajh 1/7/2002 18:51'! initializeInterpreter: bytesToShift "Initialize Interpreter state before starting execution of a new image." interpreterProxy _ self sqGetInterpreterProxy. self initializeObjectMemory: bytesToShift. self initCompilerHooks. self flushExternalPrimitives. process _ nilObj. callStack _ nilObj. freeStack _ nilObj. messageSelector _ nilObj. newMethod _ nilObj. methodClass _ nilObj. lkupClass _ nilObj. receiverClass _ nilObj. newNativeMethod _ nilObj. self flushMethodCache. self loadInitialContext. interruptCheckCounter _ 0. interruptCheckCounterFeedBackReset _ 1000. interruptChecksEveryNms _ 5. nextPollTick _ 0. nextWakeupTick _ 0. lastTick _ 0. interruptKeycode _ 2094. "cmd-." interruptPending _ false. semaphoresUseBufferA _ true. semaphoresToSignalCountA _ 0. semaphoresToSignalCountB _ 0. deferDisplayUpdates _ false. pendingFinalizationSignals _ 0. ! ! !Interpreter methodsFor: 'initialization' stamp: 'ajh 2/8/2002 14:41'! loadInitialContext | myList priority processLists processList | process _ self fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer. self callStack: (self fetchPointer: StackIndex ofObject: process). self storePointer: StackIndex ofObject: process withValue: (self integerObjectOf: 0). "mark running" self loadStackTopFrame. myList _ self fetchPointer: MyListIndex ofObject: process. myList = nilObj ifTrue: [ "Can not be nil since that indicates suspended. This should never be the case in a correctly converted image, however." priority _ self quickFetchInteger: PriorityIndex ofObject: process. processLists _ self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer. processList _ self fetchPointer: priority - 1 ofObject: processLists. self storePointer: MyListIndex ofObject: process withValue: processList. ]. ! ! !Interpreter methodsFor: 'utilities' stamp: 'ajh 10/3/2001 16:32'! assertClassOf: oop is: classOop "Succeed if the given (non-integer) object is an instance of the given class. Fail if the object is an integer." | ccIndex cl | self inline: true. (self isIntegerObject: oop) ifTrue: [ successFlag _ false. ^ nil ]. ccIndex _ self ccIndexIn: (self baseHeader: oop). ccIndex = 0 ifTrue: [ cl _ ((self classHeader: oop) bitAnd: AllButTypeMask) ] ifFalse: [ "look up compact class" cl _ (self fetchPointer: (ccIndex - 1) ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop))]. self success: cl = classOop. ! ! !Interpreter methodsFor: 'utilities' stamp: 'ajh 10/5/2001 14:36'! makePointwithxValue: xValue yValue: yValue | pointResult | pointResult _ self instantiateSmallClassNoFill: (self splObj: ClassPoint) sizeInBytes: 12. self storePointer: XIndex ofObject: pointResult withValue: (self integerObjectOf: xValue). self storePointer: YIndex ofObject: pointResult withValue: (self integerObjectOf: yValue). ^ pointResult! ! !Interpreter methodsFor: 'object memory support' stamp: 'ajh 2/8/2002 14:10'! mapInterpreterOops "Map all oops in the interpreter's state to their new values during garbage collection or a become: operation." "Assume: All traced variables contain valid oops." "Memory pointers, such as stackPointer, will be updated in postGCAction" | oop offset | nilObj _ self remap: nilObj. falseObj _ self remap: falseObj. trueObj _ self remap: trueObj. specialObjectsOop _ self remap: specialObjectsOop. compilerInitialized ifFalse: [ process _ self remap: process. offset _ endOfStack - callStack. callStack _ self remap: callStack. endOfStack _ callStack + offset. freeStack _ self remap: freeStack. ]. messageSelector _ self remap: messageSelector. newMethod _ self remap: newMethod. methodClass _ self remap: methodClass. lkupClass _ self remap: lkupClass. receiverClass _ self remap: receiverClass. 1 to: remapBufferCount do: [ :i | oop _ remapBuffer at: i. (self isIntegerObject: oop) ifFalse: [ remapBuffer at: i put: (self remap: oop). ]. ].! ! !Interpreter methodsFor: 'object memory support' stamp: 'ajh 1/7/2002 18:50'! markAndTraceInterpreterOops "Mark and trace all oops in the interpreter's state." "Assume: All traced variables contain valid oops." | oop | self compilerMarkHook. self markAndTrace: specialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes" compilerInitialized ifFalse: [ self markAndTrace: process. self markAndTrace: callStack. self markAndTrace: freeStack]. self markAndTrace: messageSelector. self markAndTrace: newMethod. self markAndTrace: methodClass. self markAndTrace: lkupClass. self markAndTrace: receiverClass. 1 to: remapBufferCount do: [ :i | oop _ remapBuffer at: i. (self isIntegerObject: oop) ifFalse: [ self markAndTrace: oop. ]. ].! ! !Interpreter methodsFor: 'object memory support' stamp: 'ajh 2/8/2002 14:11'! postGCAction "Mark the active and home contexts as roots if old. This allows the interpreter to use storePointerUnchecked to store into them." compilerInitialized ifTrue: [ self compilerPostGC ] ifFalse: [ (callStack < youngStart) ifTrue: [self beRootIfOld: callStack]. self loadStackTopFrame. ]. (self sizeOfFree: freeBlock) > shrinkThreshold ifTrue:[ "Attempt to shrink memory after successfully reclaiming lots of memory" self shrinkObjectMemory: (self sizeOfFree: freeBlock) - growHeadroom. ]. ! ! !Interpreter methodsFor: 'object memory support' stamp: 'ajh 2/6/2002 11:55'! preGCAction: fullGCFlag fullGCFlag ifTrue: [freeStack _ nilObj]. compilerInitialized ifTrue: [self compilerPreGC: fullGCFlag] ifFalse: [self saveStackTopFrame].! ! !Interpreter methodsFor: 'compiled methods' stamp: 'ajh 1/28/2002 23:47'! argumentCountOf: methodPointer ^ (self headerOf: methodPointer) >> 27 ! ! !Interpreter methodsFor: 'compiled methods' stamp: 'ajh 10/3/2001 17:39'! argumentCountOfBlock: blockPointer ^ self argumentCountOf: (self fetchPointer: BlockMethodIndex ofObject: blockPointer)! ! !Interpreter methodsFor: 'compiled methods' stamp: 'ajh 10/4/2001 23:09'! bytecodesOf: aMethod ^ self fetchPointer: BytecodesIndex ofObject: aMethod! ! !Interpreter methodsFor: 'compiled methods' stamp: 'ajh 10/22/2001 10:41'! isCompiledMethod: oop ^ (self fetchClassOf: oop) = (self splObj: ClassCompiledMethod)! ! !Interpreter methodsFor: 'compiled methods' stamp: 'ajh 1/20/2002 12:26'! literal: offset ^ self literal: offset ofMethod: method! ! !Interpreter methodsFor: 'compiled methods' stamp: 'ajh 10/3/2001 17:01'! literalCountOf: methodPointer ^ (self fetchWordLengthOf: methodPointer) - LiteralStart! ! !Interpreter methodsFor: 'compiled methods' stamp: 'ajh 10/10/2001 10:34'! methodClassOf: methodPointer "Stored in last literal when super is used" ^ self literal: (self literalCountOf: methodPointer) - 1 ofMethod: methodPointer! ! !Interpreter methodsFor: 'compiled methods' stamp: 'ajh 1/28/2002 23:50'! numExtraTempsIn: methodHeader ^ (methodHeader >> 21) bitAnd: 63! ! !Interpreter methodsFor: 'compiled methods' stamp: 'ajh 10/3/2001 17:07'! primitiveIndexOf: methodPointer ^ ((self headerOf: methodPointer) >> 1) bitAnd: 2047! ! !Interpreter methodsFor: 'compiled methods' stamp: 'ajh 1/28/2002 23:58'! stackSizeIn: methodHeader "return the number of bytes this method needs available in its frame (not including args that are already on the stack). low 4 bits a 0 because method stores stack size in words // 4, so we add 2 bits to multiply by 4 and 2 bits to convert to bytes." ^ (methodHeader >> 11) bitAnd: 16r3F0! ! !Interpreter methodsFor: 'interpreter shell' stamp: 'ajh 2/4/2002 23:05'! interpret "This is the main interpreter loop. It normally loops forever, fetching and executing bytecodes. When running in the context of a browser plugin VM, however, it must return control to the browser periodically. This should done only when the state of the currently running Squeak thread is safely stored in the object heap. Since this is the case at the moment that a check for interrupts is performed, that is when we return to the browser if it is time to do so. Interrupt checks happen quite frequently." "record entry time when running as a browser plug-in" GenerateBrowserPlugin ifTrue: [self plugInSetStartTime]. BaseHeaderSize = 4 ifFalse: [self error: 'getField... setField... assumes BaseHeaderSize of 4. Fix them']. "ASSUME trueObj and falseObj never move (since they are in the very front of object memory; see SystemTracer2>>pvtTraceImage), if they do then we need to move the assignments below to #internalizeIPandSP. localTrue and localFalse are needed so gcc (on Linux) does not over optimize and include a trueObj and falseObj move into registers at the end of every bytecode. It does this to anticipate a jump to jumpForwardIfTrue/False, pushTrue/False, and localReturnTrue/False. This over optimization is really a bug with gcc but I am working around it here since it provides such a significant speed up. - ajh 2/4/2002" localTrue _ trueObj. localFalse _ falseObj. self internalizeIPandSP. self fetchNextBytecode. [true] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable]. localIP _ localIP - 1. "undo the pre-increment of IP before returning" self externalizeIPandSP. ! ! !Interpreter methodsFor: 'primitive support' stamp: 'ajh 10/5/2001 14:36'! positive32BitIntegerFor: integerValue | newLargeInteger | "Note - integerValue is interpreted as POSITIVE, eg, as the result of Bitmap>at:, or integer>bitAnd:." (integerValue >= 0 and: [self isIntegerValue: integerValue]) ifTrue: [^ self integerObjectOf: integerValue]. newLargeInteger _ self instantiateSmallClassNoFill: (self splObj: ClassLargePositiveInteger) sizeInBytes: 8. self storeByte: 3 ofObject: newLargeInteger withValue: ((integerValue >> 24) bitAnd: 16rFF). self storeByte: 2 ofObject: newLargeInteger withValue: ((integerValue >> 16) bitAnd: 16rFF). self storeByte: 1 ofObject: newLargeInteger withValue: ((integerValue >> 8) bitAnd: 16rFF). self storeByte: 0 ofObject: newLargeInteger withValue: (integerValue bitAnd: 16rFF). ^ newLargeInteger! ! !Interpreter methodsFor: 'primitive support' stamp: 'ajh 10/7/2001 20:21'! primitiveResponse "Details: Since primitives can run for a long time, we must check to see if it is time to process a timer interrupt. However, on the Mac, the high-resolution millisecond clock is expensive to poll. Thus, we use a fast, low-resolution (1/60th second) clock to determine if the primitive took enough time to justify polling the high-resolution clock. Seems Byzantine, but Bob Arning showed that the performance of primitive-intensive code decreased substantially if there was another process waiting on a Delay. One other detail: If the primitive fails, we want to postpone the timer interrupt until just after the primitive failure code has been entered. This is accomplished by setting the interrupt check counter to zero, thus triggering a check for interrupts when activating the method containing the primitive." | timerPending startTime delta primIdx nArgs | timerPending _ nextWakeupTick ~= 0. timerPending ifTrue: [startTime _ self ioLowResMSecs]. DoBalanceChecks ifTrue:["check stack balance" nArgs _ argumentCount. primIdx _ primitiveIndex. delta _ stackPointer - framePointer. ]. successFlag _ true. self dispatchOn: primitiveIndex in: PrimitiveTable. DoBalanceChecks ifTrue:[ (self balancedStack: delta afterPrimitive: primIdx withArgs: nArgs) ifFalse:[self printUnbalancedStack: primIdx]. ]. timerPending ifTrue: [ (self ioLowResMSecs ~= startTime) ifTrue: [ "primitive ran for more than a tick; check for possible timer interrupts" ((self ioMSecs bitAnd: MillisecondClockMask) >= nextWakeupTick) ifTrue: [ successFlag ifTrue: ["process the interrupt now" self checkForInterrupts] ifFalse: ["process the interrupt in primtive failure code" interruptCheckCounter _ 0]]]]. ^ successFlag ! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'ajh 10/24/2001 22:03'! install: rcvr inAtCache: cache at: atIx string: stringy "Install the oop of this object in the given cache (at or atPut), along with its size, format and fixedSize" | hdr fmt totalLength fixedFields | self var: #cache declareC: 'int *cache'. hdr _ self baseHeader: rcvr. fmt _ self formatIn: hdr. (fmt = 3 and: [self isStackHeader: hdr]) ifTrue: ["Stacks must not be put in the atCache, since their size is not constant" ^ self primitiveFail]. totalLength _ self lengthOf: rcvr baseHeader: hdr format: fmt. fixedFields _ self fixedFieldsOf: rcvr format: fmt length: totalLength. cache at: atIx+AtCacheOop put: rcvr. stringy ifTrue: [cache at: atIx+AtCacheFmt put: fmt + 16] "special flag for strings" ifFalse: [cache at: atIx+AtCacheFmt put: fmt]. cache at: atIx+AtCacheFixedFields put: fixedFields. cache at: atIx+AtCacheSize put: totalLength - fixedFields. ! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'ajh 12/28/2001 22:11'! primitiveCapacity | rcvr sz | rcvr _ self stackTop. (self isIntegerObject: rcvr) ifTrue: [^ self primitiveFail]. "Integers are not indexable" (self formatOf: rcvr) < 2 ifTrue: [^ self primitiveFail]. "This is not an indexable object" sz _ self stCapacityOf: rcvr. successFlag ifTrue: [self pop: 1 thenPush: (self positive32BitIntegerFor: sz)] ! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'ajh 12/28/2001 22:10'! stCapacityOf: oop "Return the number of indexable fields in the given object. (i.e., what Smalltalk would return for capacity)." "Note: Assume oop is not a SmallInteger!!" | hdr fmt totalLength fixedFields | self inline: true. hdr _ self baseHeader: oop. fmt _ self formatIn: hdr. totalLength _ self lengthOf: oop baseHeader: hdr format: fmt. fixedFields _ self fixedFieldsOf: oop format: fmt length: totalLength. ^ totalLength - fixedFields! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'ajh 2/6/2002 11:54'! stObject: array at: index "Return what ST would return for at: index." | hdr fmt totalLength fixedFields stSize | self inline: false. hdr _ self baseHeader: array. fmt _ self formatIn: hdr. totalLength _ self lengthOf: array baseHeader: hdr format: fmt. fixedFields _ self fixedFieldsOf: array format: fmt length: totalLength. (fmt = 3 and: [self isStackHeader: hdr]) ifTrue: [ callStack = array ifTrue: [self saveStackTopFrame]. stSize _ self fetchStackPointerOf: array. ] ifFalse: [ stSize _ totalLength - fixedFields. ]. ((self cCoerce: index to: 'unsigned ') >= 1 and: [(self cCoerce: index to: 'unsigned ') <= (self cCoerce: stSize to: 'unsigned ')]) ifTrue: [^ self subscript: array with: (index + fixedFields) format: fmt] ifFalse: [successFlag _ false. ^ 0].! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'ajh 2/6/2002 11:55'! stObject: array at: index put: value "Do what ST would return for at: index put: value." | hdr fmt totalLength fixedFields stSize | self inline: false. hdr _ self baseHeader: array. fmt _ self formatIn: hdr. totalLength _ self lengthOf: array baseHeader: hdr format: fmt. fixedFields _ self fixedFieldsOf: array format: fmt length: totalLength. (fmt = 3 and: [self isStackHeader: hdr]) ifTrue: [ callStack = array ifTrue: [self saveStackTopFrame]. stSize _ self fetchStackPointerOf: array. ] ifFalse: [ stSize _ totalLength - fixedFields. ]. ((self cCoerce: index to: 'unsigned ') >= 1 and: [(self cCoerce: index to: 'unsigned ') <= (self cCoerce: stSize to: 'unsigned ')]) ifTrue: [self subscript: array with: (index + fixedFields) storing: value format: fmt] ifFalse: [successFlag _ false]! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'ajh 2/6/2002 11:54'! stSizeOf: oop "Return the number of indexable fields in the given object. (i.e., what Smalltalk would return for size)." "Note: Assume oop is not a SmallInteger!!" | hdr fmt totalLength fixedFields | self inline: true. hdr _ self baseHeader: oop. fmt _ self formatIn: hdr. totalLength _ self lengthOf: oop baseHeader: hdr format: fmt. fixedFields _ self fixedFieldsOf: oop format: fmt length: totalLength. (fmt = 3 and: [self isStackHeader: hdr]) ifTrue: [ callStack = oop ifTrue: [self saveStackTopFrame]. ^ self fetchStackPointerOf: oop ] ifFalse: [ ^ totalLength - fixedFields ]! ! !Interpreter methodsFor: 'object access primitives' stamp: 'ajh 2/6/2002 11:55'! primitiveObjectPointsTo | rcvr thang lastField | thang _ self popStack. rcvr _ self popStack. (self isIntegerObject: rcvr) ifTrue: [^ self pushBool: false]. callStack = rcvr ifTrue: [self saveStackTopFrame]. lastField _ self lastPointerOf: rcvr. BaseHeaderSize to: lastField by: 4 do: [:i | (self longAt: rcvr + i) = thang ifTrue: [^ self pushBool: true]]. self pushBool: false.! ! !Interpreter methodsFor: 'object access primitives' stamp: 'ajh 10/8/2001 11:19'! primitiveStoreStackp "Atomic store into stack topIndex. Also ensures that any newly accessible cells are initialized to nil" | aStack newStackp stackp | aStack _ self stackValue: 1. newStackp _ self stackIntegerValue: 0. self success: (newStackp >= 0). self success: (newStackp <= ((self fetchWordLengthOf: aStack) - StackStart)). successFlag ifFalse: [^ self primitiveFail]. stackp _ self fetchStackPointerOf: aStack. newStackp > stackp ifTrue: ["Nil any newly accessible cells" stackp + 1 to: newStackp do: [:i | self storePointer: i+StackStart-1 ofObject: aStack withValue: nilObj]]. self storeWord: StackTopIndex ofObject: aStack withValue: (self integerObjectOf: newStackp). self pop: 1 ! ! !Interpreter methodsFor: 'control primitives' stamp: 'ajh 2/10/2002 23:30'! primitiveDoPrimitiveWithArgs | argumentArray arraySize index primIdx | argumentArray _ self stackTop. self assertClassOf: argumentArray is: (self splObj: ClassArray). primIdx _ self stackIntegerValue: 1. successFlag ifFalse: [^ self primitiveFail]. "invalid args" arraySize _ self fetchWordLengthOf: argumentArray. (self roomInStack: (arraySize - 2) * 4) ifFalse: [self moveTopFrameToNewStack]. "Pop primIndex and argArray, then push args in place..." self pop: 2. primitiveIndex _ primIdx. argumentCount _ arraySize. index _ 1. [index <= argumentCount] whileTrue: [self push: (self fetchPointer: index - 1 ofObject: argumentArray). index _ index + 1]. "Run the primitive (sets successFlag)" self pushRemappableOop: argumentArray. "prim might alloc/gc" lkupClass _ nilObj. self primitiveResponse. argumentArray _ self popRemappableOop. successFlag ifFalse: ["If primitive failed, then restore state for failure code" self pop: arraySize. self pushInteger: primIdx. self push: argumentArray. argumentCount _ 2. "... caller (execNewMeth) will run failure code"]! ! !Interpreter methodsFor: 'control primitives' stamp: 'ajh 10/7/2001 20:02'! primitivePerform | performSelector newReceiver selectorPtr lookupClass performMethod | performSelector _ messageSelector. performMethod _ newMethod. messageSelector _ self stackValue: argumentCount - 1. newReceiver _ self stackValue: argumentCount. "NOTE: the following lookup may fail and be converted to #doesNotUnderstand:, so we must adjust argumentCount and slide args now, so that would work." "Slide arguments down over selector" argumentCount _ argumentCount - 1. selectorPtr _ stackPointer - (argumentCount * 4). self transfer: argumentCount from: selectorPtr + 4 to: selectorPtr. self pop: 1. lookupClass _ self fetchClassOf: newReceiver. self findNewMethodInClass: lookupClass. self success: ((self argumentCountOf: newMethod) = argumentCount). successFlag ifTrue: [self executeNewMethod. "Recursive xeq affects successFlag" successFlag _ true] ifFalse: ["Slide the args back up (sigh) and re-insert the selector." self unPop: 1. stackPointer to: stackPointer - ((argumentCount - 1) * 4) by: -4 do: [:i | self longAt: i put: (self longAt: i - 4)]. self longAt: stackPointer - (argumentCount * 4) put: messageSelector. argumentCount _ argumentCount + 1. newMethod _ performMethod. messageSelector _ performSelector]! ! !Interpreter methodsFor: 'control primitives' stamp: 'ajh 2/10/2002 23:30'! primitivePerformAt: lookupClass "Common routine used by perform:withArgs: and perform:withArgs:inSuperclass:" "NOTE: The case of doesNotUnderstand: is not a failure to perform. The only failures are arg types and consistency of argumentCount." | performSelector argumentArray arraySize index performMethod performArgCount | argumentArray _ self popStack. self assertClassOf: argumentArray is: (self splObj: ClassArray). successFlag ifFalse: [^ self unPop: 1]. "Check for enough space to push all args" arraySize _ self fetchWordLengthOf: argumentArray. (self roomInStack: arraySize * 4) ifFalse: [self moveTopFrameToNewStack]. performSelector _ messageSelector. performMethod _ newMethod. performArgCount _ argumentCount. messageSelector _ self popStack. "Copy the arguments to the stack, and execute" index _ 1. [index <= arraySize] whileTrue: [self push: (self fetchPointer: index - 1 ofObject: argumentArray). index _ index + 1]. argumentCount _ arraySize. self findNewMethodInClass: lookupClass. self success: (self argumentCountOf: newMethod) = argumentCount. successFlag ifTrue: [self executeNewMethod. "Recursive xeq affects successFlag" successFlag _ true] ifFalse: ["Restore the state and fail" self pop: argumentCount. self push: messageSelector. self push: argumentArray. messageSelector _ performSelector. newMethod _ performMethod. argumentCount _ performArgCount] ! ! !Interpreter methodsFor: 'control primitives' stamp: 'ajh 1/16/2002 18:58'! primitiveValue | block blockMethod | block _ self stackValue: argumentCount. blockMethod _ self fetchPointer: BlockMethodIndex ofObject: block. self success: argumentCount = (self argumentCountOf: blockMethod). successFlag ifTrue: [ newMethod _ blockMethod. self activateNewMethod. ]. ! ! !Interpreter methodsFor: 'control primitives' stamp: 'ajh 1/16/2002 19:01'! primitiveValueWithArgs | argumentArray block blockMethod | argumentArray _ self popStack. block _ self stackTop. blockMethod _ self fetchPointer: BlockMethodIndex ofObject: block. self assertClassOf: argumentArray is: (self splObj: ClassArray). argumentCount _ self fetchWordLengthOf: argumentArray. self success: argumentCount = (self argumentCountOf: blockMethod). successFlag ifTrue: [ newMethod _ blockMethod. self activateNewMethodWithArgs: argumentArray. ] ifFalse: [ self unPop: 1. argumentCount _ 1. ].! ! !Interpreter methodsFor: 'processes' stamp: 'ajh 2/12/2002 05:30'! primitiveResume self resume: self stackTop! ! !Interpreter methodsFor: 'processes' stamp: 'ajh 10/5/2001 17:03'! primitiveSuspend self success: self stackTop = process. successFlag ifTrue: [ self storePointer: MyListIndex ofObject: process withValue: nilObj. self pop: 1. self push: nilObj. self transferTo: self wakeHighestPriority. ].! ! !Interpreter methodsFor: 'processes' stamp: 'ajh 10/5/2001 17:04'! primitiveWait | sema excessSignals | sema _ self stackTop. "rcvr" self assertClassOf: sema is: (self splObj: ClassSemaphore). successFlag ifTrue: [ excessSignals _ self fetchInteger: ExcessSignalsIndex ofObject: sema. excessSignals > 0 ifTrue: [ self storeInteger: ExcessSignalsIndex ofObject: sema withValue: excessSignals - 1. ] ifFalse: [ self addLastLink: process toList: sema. self transferTo: self wakeHighestPriority. ]. ].! ! !Interpreter methodsFor: 'processes' stamp: 'ajh 1/12/2002 22:44'! processFinished self inline: false. self storePointer: StackIndex ofObject: process withValue: nilObj. self storePointer: MyListIndex ofObject: process withValue: nilObj. self resumeHighestProcess. ! ! !Interpreter methodsFor: 'processes' stamp: 'ajh 2/12/2002 05:29'! resume: aProcess | activePriority newPriority | self inline: false. activePriority _ self quickFetchInteger: PriorityIndex ofObject: process. newPriority _ self quickFetchInteger: PriorityIndex ofObject: aProcess. newPriority > activePriority ifTrue: [ self putToSleep: process. self transferTo: aProcess. ] ifFalse: [ self putToSleep: aProcess. ].! ! !Interpreter methodsFor: 'processes' stamp: 'ajh 2/8/2002 14:42'! resumeHighestProcess "Transfer control to highest priority process, forgeting current process, which is presumed finished" process _ self wakeHighestPriority. self storePointer: ActiveProcessIndex ofObject: self schedulerPointer withValue: process. self callStack: (self fetchPointer: StackIndex ofObject: process). self storePointer: StackIndex ofObject: process withValue: (self integerObjectOf: 0). "mark process running" self loadStackTopFrame. ! ! !Interpreter methodsFor: 'processes' stamp: 'ajh 10/5/2001 17:10'! schedulerPointer ^ self fetchPointer: ValueIndex ofObject: (self splObj: SchedulerAssociation)! ! !Interpreter methodsFor: 'processes' stamp: 'ajh 2/12/2002 05:29'! transferTo: newProc "Record a process to be awoken on the next interpreter cycle. ikp 11/24/1999 06:07 -- added hook for external runtime compiler" self storePointer: ActiveProcessIndex ofObject: self schedulerPointer withValue: newProc. compilerInitialized ifTrue: [ self compilerProcessChange: process to: newProc. ] ifFalse: [ self saveStackTopFrame. self storePointer: StackIndex ofObject: process withValue: callStack. process _ newProc. self callStack: (self fetchPointer: StackIndex ofObject: newProc). self storePointer: StackIndex ofObject: newProc withValue: ConstZero. "mark process running" self loadStackTopFrame. ]. ! ! !Interpreter methodsFor: 'processes' stamp: 'ajh 10/5/2001 17:09'! wakeHighestPriority "Return the highest priority process that is ready to run." "Note: It is a fatal VM error if there is no runnable process." | schedLists p processList | schedLists _ self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer. p _ self fetchWordLengthOf: schedLists. p _ p - 1. "index of last indexable field" processList _ self fetchPointer: p ofObject: schedLists. [self isEmptyList: processList] whileTrue: [ p _ p - 1. p < 0 ifTrue: [ self error: 'scheduler could not find a runnable process' ]. processList _ self fetchPointer: p ofObject: schedLists. ]. ^ self removeFirstLinkOfList: processList! ! !Interpreter methodsFor: 'I/O primitives' stamp: 'ajh 11/2/2001 15:06'! displayBitsOf: aForm Left: l Top: t Right: r Bottom: b "Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object." | displayObj dispBits w h dispBitsIndex d left right top bottom surfaceHandle | displayObj _ self splObj: TheDisplay. aForm = displayObj ifFalse: [^ nil]. self success: ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]). successFlag ifTrue: [ dispBits _ self fetchPointer: 0 ofObject: displayObj. w _ self fetchInteger: 1 ofObject: displayObj. h _ self fetchInteger: 2 ofObject: displayObj. d _ self fetchInteger: 3 ofObject: displayObj. l < 0 ifTrue:[left _ 0] ifFalse:[left _ l]. r > w ifTrue:[right _ w] ifFalse:[right _ r]. t < 0 ifTrue:[top _ 0] ifFalse:[top _ t]. b > h ifTrue:[bottom _ h] ifFalse:[bottom _ b]. ((left <= right) and: [top <= bottom]) ifFalse:[^nil]. (self isIntegerObject: dispBits) ifTrue:[ surfaceHandle _ self integerValueOf: dispBits. showSurfaceFn = 0 ifTrue:[ showSurfaceFn _ self ioLoadFunction: 'ioShowSurface' From: 'SurfacePlugin'. showSurfaceFn = 0 ifTrue:[^self success: false]]. self cCode:'((int (*) (int, int, int, int, int))showSurfaceFn)(surfaceHandle, left, top, right-left, bottom-top)'. ] ifFalse:[ dispBitsIndex _ dispBits + BaseHeaderSize. "index in memory byte array" self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, left, right, top, bottom)' inSmalltalk:[self showDisplayBits: dispBitsIndex w: w h: h d: d left: left right: right top: top bottom: bottom] ]. ].! ! !Interpreter methodsFor: 'other primitives' stamp: 'ajh 10/22/2001 09:51'! primitiveExternalCall "Call an external primitive. The external primitive methods contain as first literal an array consisting of: * The module name (String | Symbol) * The function name (String | Symbol) * The session ID (SmallInteger) [OBSOLETE] * The function index (Integer) in the externalPrimitiveTable For fast failures the primitive index of any method where the external prim is not found is rewritten in the method cache with zero. This allows for ultra fast responses as long as the method stays in the cache. The fast failure response relies on lkupClass being properly set. This is done in #addToMethodCacheSel:class:method:primIndex: to compensate for execution of methods that are looked up in a superclass (such as in primitivePerformAt). With the latest modifications (e.g., actually flushing the function addresses from the VM), the session ID is obsolete. But for backward compatibility it is still kept around. Also, a failed lookup is reported specially. If a method has been looked up and not been found, the function address is stored as -1 (e.g., the SmallInteger -1 to distinguish from 16rFFFFFFFF which may be returned from the lookup). It is absolutely okay to remove the rewrite if we run into any problems later on. It has an approximate speed difference of 30% per failed primitive call which may be noticable but if, for any reasons, we run into problems (like with J3) we can always remove the rewrite." | lit addr moduleName functionName moduleLength functionLength index nArgs delta | DoBalanceChecks ifTrue:["check stack balance" nArgs _ argumentCount. delta _ stackPointer - framePointer. ]. "Fetch the first literal of the method" "self success: (self literalCountOf: newMethod) > 0. successFlag ifFalse:[^ nil]. @@: Could this be omitted for speed?!! Yes, if we assume the method is a valid method, which we do in many other places. For instance, popStackBytecode doesn't check if it will pop past the frame bottom. Some day we'll have a method validator to validate imported compiled methods. -ajh 10/7/2001" lit _ self literal: 0 ofMethod: newMethod. "Check if it's an array of length 4 (this could also be assumed correct, but we'll leave it in to help catch subtle version changes)" self success: ((self fetchClassOf: lit) = (self splObj: ClassArray) and:[(self lengthOf: lit) = 4]). successFlag ifFalse:[^ nil]. "Look at the function index in case it has been loaded before" index _ self fetchPointer: 3 ofObject: lit. (self isIntegerObject: index) ifFalse:[^ self success: false]. index _ self integerValueOf: index. "Check if we have already looked up the function and failed." index < 0 ifTrue:[ "Function address was not found in this session, Rewrite the mcache entry with a zero primitive index." self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: 0. ^ self success: false]. "Try to call the function directly" (index > 0 and:[index <= MaxExternalPrimitiveTableSize]) ifTrue:[ addr _ externalPrimitiveTable at: index-1. addr ~= 0 ifTrue:[ self cCode:' ((int (*) (void)) addr) ()' inSmalltalk:[self callExternalPrimitive: addr]. DoBalanceChecks ifTrue:[ (self balancedStack: delta afterPrimitive: primitiveIndex withArgs: nArgs) ifFalse:[self printUnbalancedStackFromNamedPrimitive]]. ^ nil]. "if we come here, then an index to the external prim was kept on the ST side although the underlying prim table was already flushed" ^ self success: false]. "Clean up session id and external primitive index" self storeInteger: 2 ofObject: lit withValue: 0. self storeInteger: 3 ofObject: lit withValue: 0. "The function has not been loaded yet. Fetch module and function name." moduleName _ self fetchPointer: 0 ofObject: lit. moduleName = nilObj ifTrue:[ moduleLength _ 0. ] ifFalse:[ self success: (self isBytes: moduleName). moduleLength _ self lengthOf: moduleName. ]. functionName _ self fetchPointer: 1 ofObject: lit. self success: (self isBytes: functionName). functionLength _ self lengthOf: functionName. successFlag ifFalse:[^nil]. "Backward compatibility: Attempt to map any old-style named primitives into the new ones. The old ones are exclusively bound into the VM so we don't need to check if a module is given." addr _ 0. "Addr ~= 0 indicates we have a compat match later" moduleLength = 0 ifTrue:[ "Search the obsolete named primitive table for a match" index _ self findObsoleteNamedPrimitive: (self cCoerce: (functionName+4) to: 'char *') length: functionLength. "The returned value is the index into the obsolete primitive table. If the index is found, use the 'C-style' version of the lookup." index < 0 ifFalse:[ addr _ self ioLoadFunction: (self cCoerce: ((obsoleteNamedPrimitiveTable at: index) at: 2) to: 'char*') From: (self cCoerce: ((obsoleteNamedPrimitiveTable at: index) at: 1) to:'char*')]]. addr = 0 ifTrue:["Only if no compat version was found" addr _ self ioLoadExternalFunction: functionName + 4 OfLength: functionLength FromModule: moduleName + 4 OfLength: moduleLength. ]. addr = 0 ifTrue:[ index _ -1. "remember we failed" ] ifFalse:[ "add the function to the external primitive table" index _ self addToExternalPrimitiveTable: addr. "if no space, index will be zero so we will look it up again. although slow it makes sure we will find the prim in case it's needed." ]. self success: index >= 0. "Store the index (or -1 if failure) back in the literal" self storePointer: 3 ofObject: lit withValue: (self integerObjectOf: index). "If the function has been successfully loaded process it" (successFlag and:[addr ~= 0]) ifTrue:[self cCode:' ((int (*) (void)) addr) ()' inSmalltalk:[self callExternalPrimitive: addr]. DoBalanceChecks ifTrue:[ (self balancedStack: delta afterPrimitive: primitiveIndex withArgs: nArgs) ifFalse:[self printUnbalancedStackFromNamedPrimitive]]] ifFalse:["Otherwise rewrite the primitive index" self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: 0].! ! !Interpreter methodsFor: 'other primitives' stamp: 'ajh 2/6/2002 11:55'! primitiveSnapshot | dataSize rcvr | "update state of active context" compilerInitialized ifTrue: [self compilerPreSnapshot] ifFalse: [self saveStackTopFrame]. self storePointer: StackIndex ofObject: process withValue: callStack. "compact memory and compute the size of the memory actually in use" self cleanUpCallStacks. self incrementalGC. "maximimize space for forwarding table" self fullGC. dataSize _ freeBlock - (self startOfMemory). "Assume: all objects are below the start of the free block" successFlag ifTrue: [ rcvr _ self popStack. "pop rcvr" self push: trueObj. self writeImageFile: dataSize. self pop: 1. "pop true" ]. successFlag ifTrue: [ self push: falseObj ] ifFalse: [ self push: rcvr ]. compilerInitialized ifTrue: [self compilerPostSnapshot].! ! !Interpreter methodsFor: 'other primitives' stamp: 'ajh 2/6/2002 11:55'! primitiveSnapshotEmbedded | dataSize rcvr | self compilerPreSnapshotHook. "save the state of the current process and save it on the scheduler queue" self saveStackTopFrame. self storePointer: StackIndex ofObject: process withValue: callStack. "compact memory and compute the size of the memory actually in use" self cleanUpCallStacks. self incrementalGC. "maximimize space for forwarding table" self fullGC. dataSize _ freeBlock - (self startOfMemory). "Assume: all objects are below the start of the free block" successFlag ifTrue: [ rcvr _ self popStack. "pop rcvr" self push: trueObj. self writeImageFileEmbedded: dataSize. self pop: 1. "pop true" ]. successFlag ifTrue: [ self push: falseObj ] ifFalse: [ self push: rcvr ]. self compilerPostSnapshotHook.! ! !Interpreter methodsFor: 'debug printing' stamp: 'ajh 1/11/2002 19:09'! longPrint: oop | lastPtr val lastLong hdrType prevVal | (self isIntegerObject: oop) ifTrue: [^ self shortPrint: oop]. "print pointer fields" prevVal _ 0. lastPtr _ 256 min: (self lastPointerOf: oop). hdrType _ self headerType: oop. hdrType = 2 ifTrue: [lastPtr _ 0]. (0 - (self extraHeaderBytes: oop)) to: lastPtr by: 4 do: [:a | val _ self longAt: oop+a. (a > 0 and: [(val = prevVal) & (a ~= lastPtr)]) ifTrue: [ prevVal = (self longAt: oop+a-8) ifFalse: [ self cr. self print: ' ...etc...'] ] ifFalse: [ self cr. self printNum: a. self tab. self printHex: val. self tab. a=-8 ifTrue: [self print: 'size = '. self printNum: val - hdrType]. a=-4 ifTrue: [self print: '<'. self printNameOfClass: val - hdrType count: 5. self print: '>']. a=0 ifTrue: [self printObjectHeader: val]. a>0 ifTrue: [self shortPrintNoCr: val]. ]. prevVal _ val ]. "print non pointer fields" lastLong _ 256 min: (self sizeBitsOf: oop) - 4. hdrType = 2 ifTrue: [ "free" self cr. self printNum: (oop+(self longAt: oop)-2). ] ifFalse: [ (self isBytes: oop) ifTrue: [ lastPtr + 4 to: lastLong by: 4 do: [:a | self cr. self printNum: a. self tab. 0 to: 3 do: [:i | self printNum: (self byteAt: oop+a+i). self print: ' ']. self tab. 0 to: 3 do: [:i | self printChar: (self byteAt: oop+a+i). self print: ' ']. ]. ] ifFalse: [ lastPtr+4 to: lastLong by: 4 do: [:a | self cr. self printNum: a. self tab. self printHex: (self longAt: oop+a). ] ] ]. self cr. ! ! !Interpreter methodsFor: 'debug printing' stamp: 'ajh 1/13/2002 01:52'! printAllStacks "Print all the stacks of all running processes, including those that are currently suspended." | oop | oop _ self firstObject. [oop < endOfMemory] whileTrue:[ (self fetchClassOf: oop) == (self splObj: ClassProcess) ifTrue: [ self cr. oop = process ifTrue: [self print: 'Active ']. self print: 'Process '; printNum: oop; cr. self printCallStackOf: oop]. oop _ self objectAfter: oop. ].! ! !Interpreter methodsFor: 'debug printing' stamp: 'ajh 2/6/2002 11:54'! printCallStack self saveStackTopFrame. self printCallStackOf: process. ! ! !Interpreter methodsFor: 'debug printing' stamp: 'ajh 2/7/2002 18:48'! printCallStackOf: aProcess self printCallStackOf: aProcess top: 10000! ! !Interpreter methodsFor: 'debug printing' stamp: 'ajh 2/7/2002 19:05'! printCallStackOf: aProcess top: n "Print top n methods" | stck stackBits fp meth rcvr home senderOffset i isDNU sel | aProcess = process ifTrue: [stck _ callStack] ifFalse: [stck _ self fetchPointer: StackIndex ofObject: aProcess]. i _ 0. stackBits _ self stackBitsOf: stck. fp _ self stack: stck ptrForIndex: (self fpIndexIn: stackBits). [stck = nilObj or: [(i _ i + 1) > n]] whileFalse: [ self printHex: stck. self print: ' '. self printNum: (self stack: stck indexForPtr: fp). self print: ' '. meth _ self methodOfFp: fp. rcvr _ self longAt: (self firstFrameAddrOfFp: fp). ((self fetchClassOf: rcvr) = (self splObj: ClassBlockClosure) and: [(self fetchPointer: BlockMethodIndex ofObject: rcvr) = meth]) ifFalse: [ isDNU _ self printClassAndSelectorOfMethod: meth forReceiverClass: (self fetchClassOf: rcvr). isDNU ifTrue: [ "print selector of doesNotUnderstand message (last arg)" sel _ self fetchPointer: 0 ofObject: (self longAt: fp + (FrameLastArgOffset * 4)). self print: ' '. self printStringOf: sel. ]. ] ifTrue: [ "is block context" self print: '[]'. home _ self fetchPointer: BlockHomeIndex ofObject: rcvr. home ~~ nilObj ifTrue: [ self print: ' in '. self printNum: (self fetchPointer: ContextStackIndex ofObject: home). self print: ' '. self printNum: (self quickFetchInteger: ContextFrameIndex ofObject: home)]. ]. self cr. senderOffset _ self senderOffsetIn: (self frameBitsOfFp: fp). senderOffset = 0 ifTrue: [ stck _ self fetchPointer: PreviousStackIndex ofObject: stck. stck = nilObj ifFalse: [ stackBits _ self stackBitsOf: stck. fp _ self stack: stck ptrForIndex: (self fpIndexIn: stackBits). ]. ] ifFalse: [ fp _ fp - senderOffset. ]. ]. stck = nilObj ifFalse: [self print: '...'. self cr]. ! ! !Interpreter methodsFor: 'debug printing' stamp: 'ajh 2/6/2002 11:55'! printCallStackTop: n "Print to n methods" self saveStackTopFrame. self printCallStackOf: process top: n. ! ! !Interpreter methodsFor: 'debug printing' stamp: 'ajh 1/11/2002 02:09'! printClassAndSelectorOfMethod: meth forReceiverClass: rcvrClass | currClass classDict classDictSize methodArray i found isDoesNotUnderstand selector | self printNameOfClass: rcvrClass count: 5. currClass _ rcvrClass. found _ false. isDoesNotUnderstand _ false. [found or: [currClass = nilObj]] whileFalse: [ classDict _ self fetchPointer: MessageDictionaryIndex ofObject: currClass. classDictSize _ self fetchWordLengthOf: classDict. methodArray _ self fetchPointer: MethodArrayIndex ofObject: classDict. i _ 0. [i < (classDictSize - SelectorStart) and: [found not]] whileTrue: [ meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [ rcvrClass = currClass ifFalse: [ self print: '('. self printNameOfClass: currClass count: 5. self print: ')']. self print: '>>'. selector _ self fetchPointer: i + SelectorStart ofObject: classDict. self printStringOf: selector. selector = (self splObj: SelectorDoesNotUnderstand) ifTrue: [ isDoesNotUnderstand _ true]. found _ true]. i _ i + 1. ]. found ifFalse: [currClass _ self fetchPointer: SuperclassIndex ofObject: currClass]. ]. found ifFalse: [ "Method not found in superclass chain" self print: '>> a '. self printNameOfClass: (self fetchClassOf: meth) count: 5. ]. ^ isDoesNotUnderstand! ! !Interpreter methodsFor: 'debug printing' stamp: 'ajh 2/6/2002 23:58'! printFrame: n "print nth frame from top" | val s fp sp senderOffset meth rcvr stackBits | s _ callStack. fp _ framePointer. sp _ stackPointer. 1 to: n do: [:i | senderOffset _ self senderOffsetIn: (self frameBitsOfFp: fp). senderOffset = 0 ifTrue: [ "sender is on previous stack" s _ self previousStackOf: s. s = nilObj ifTrue: [^ self print: 'not that many frames']. sp _ self stack: s ptrForIndex: (self fetchStackPointerOf: s). stackBits _ self stackBitsOf: s. fp _ self stack: s ptrForIndex: (self fpIndexIn: stackBits). ] ifFalse: [ "sender is right before me on current stack" sp _ self firstFrameAddrOfFp: fp. fp _ fp - senderOffset]. ]. meth _ self longAt: fp + (FrameMethodOffset * 4). rcvr _ self longAt: (self firstFrameAddrOfFp: fp). ((self fetchClassOf: rcvr) = (self splObj: ClassBlockClosure) and: [(self fetchPointer: BlockMethodIndex ofObject: rcvr) = meth]) ifTrue: [self print: '[]'] ifFalse: [self printClassAndSelectorOfMethod: meth forReceiverClass: (self fetchClassOf: rcvr)]. sp to: (self firstFrameAddrOfFp: fp) by: -4 do: [:addr | self cr. addr = fp ifTrue: [self print: 'fp -> '] ifFalse: [self printHex: addr]. self tab. val _ self longAt: addr. self printHex: val. self tab. self shortPrintNoCr: val. ]. self cr. ! ! !Interpreter methodsFor: 'debug printing' stamp: 'ajh 2/6/2002 12:05'! printFrame: fi stack: stk "print frame under frame at fi in stack stk" | val s fp sp meth rcvr | s _ stk. fp _ self stack: s ptrForIndex: fi. sp _ fp - (self receiverOffsetIn: (self frameBitsOfFp: fp)). fp _ fp - (self senderOffsetIn: (self frameBitsOfFp: fp)). meth _ self longAt: fp + (FrameMethodOffset * 4). rcvr _ self longAt: (self firstFrameAddrOfFp: fp). ((self fetchClassOf: rcvr) = (self splObj: ClassBlockClosure) and: [(self fetchPointer: BlockMethodIndex ofObject: rcvr) = meth]) ifTrue: [self print: '[]'] ifFalse: [self printClassAndSelectorOfMethod: meth forReceiverClass: (self fetchClassOf: rcvr)]. sp to: (self firstFrameAddrOfFp: fp) by: -4 do: [:addr | self cr. self printHex: addr. self print: ' '. val _ self longAt: addr. self printHex: val. self print: ' '. self shortPrintNoCr: val]. self cr. ! ! !Interpreter methodsFor: 'debug printing' stamp: 'ajh 1/11/2002 18:21'! printHex: n "For testing in Smalltalk, this method should be overridden in a subclass." self cCode: 'printf("%X", (long) n)'.! ! !Interpreter methodsFor: 'debug printing' stamp: 'ajh 1/11/2002 19:48'! printObjectHeader: hdr | cc | cc _ (hdr bitAnd: CompactClassMask) >> 12. self print: ' 0 ifTrue: [ self print: ':'. self printNameOfClass: (self fetchPointer: cc - 1 ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop)) count: 5. ]. self print: '>'. self print: ''. self print: ''. self print: ''. ! ! !Interpreter methodsFor: 'debug printing' stamp: 'ajh 1/11/2002 19:08'! shortPrint: oop self shortPrintNoCr: oop. self cr.! ! !Interpreter methodsFor: 'debug printing' stamp: 'ajh 1/11/2002 19:08'! shortPrintNoCr: oop | classOop | (self isIntegerObject: oop) ifTrue: [ self print: '='. ^ self printNum: (self integerValueOf: oop)]. classOop _ self fetchClassOf: oop. (self sizeBitsOf: classOop) = ("Metaclass instSize" 6 +1*4) ifTrue: [ self print: 'class '. ^ self printNameOfClass: oop count: 5]. oop = nilObj ifTrue: [^ self print: 'nil']. oop = falseObj ifTrue: [^ self print: 'false']. oop = trueObj ifTrue: [^ self print: 'true']. self print: 'a '. self printNameOfClass: classOop count: 5. (self isBytes: oop) ifTrue: [ self print: ' '. self printStringOf: oop. "may be garbage but who cares" ]. ! ! !Interpreter methodsFor: 'debug printing' stamp: 'ajh 1/11/2002 18:25'! tab "For testing in Smalltalk, this method should be overridden in a subclass." self printf: '\t'.! ! !Interpreter methodsFor: 'debug support' stamp: 'ajh 10/7/2001 19:52'! balancedStack: delta afterPrimitive: primIdx withArgs: nArgs "Return true if the stack is still balanced after executing primitive primIndex with nArgs args. Delta is 'stackPointer - activeContext' which is a relative measure for the stack pointer (so we don't have to relocate it during the primitive)" (primIdx >= 81 and:[primIdx <= 88]) ifTrue:[^true]. "81-88 are control primitives after which the stack may look unbalanced" successFlag ifTrue:[ "Successful prim, stack must have exactly nArgs arguments popped off" ^(stackPointer - framePointer + (nArgs * 4)) = delta ]. "Failed prim must leave stack intact" ^(stackPointer - framePointer) = delta ! ! !Interpreter methodsFor: 'debug support' stamp: 'ajh 10/7/2001 18:36'! okayActiveProcessStack | s | s _ callStack. [s = nilObj] whileFalse: [ self okayFields: s. s _ self fetchPointer: PreviousStackIndex ofObject: s. ].! ! !Interpreter methodsFor: 'debug support' stamp: 'ajh 10/7/2001 18:41'! okayFields: oop "If this is a pointers object, check that its fields are all okay oops." | i fieldOop | (oop = nil or: [oop = 0]) ifTrue: [ ^true ]. (self isIntegerObject: oop) ifTrue: [ ^true ]. self okayOop: oop. self oopHasOkayClass: oop. (self isPointers: oop) ifFalse: [ ^true ]. (self isStackHeader: (self baseHeader: oop)) ifTrue: [i _ StackStart + (self fetchStackPointerOf: oop) - 1] ifFalse: [i _ (self lengthOf: oop) - 1]. [i >= 0] whileTrue: [ fieldOop _ self fetchPointer: i ofObject: oop. (self isIntegerObject: fieldOop) ifFalse: [ self okayOop: fieldOop. self oopHasOkayClass: fieldOop. ]. i _ i - 1. ].! ! !Interpreter methodsFor: 'debug support' stamp: 'ajh 1/7/2002 18:43'! okayInterpreterObjects | oopOrZero oop | self okayFields: nilObj. self okayFields: falseObj. self okayFields: trueObj. self okayFields: specialObjectsOop. self okayFields: process. self okayFields: callStack. self okayFields: freeStack. self okayFields: messageSelector. self okayFields: newMethod. self okayFields: lkupClass. 0 to: MethodCacheEntries - 1 by: MethodCacheEntrySize do: [ :i | oopOrZero _ methodCache at: i + MethodCacheSelector. oopOrZero = 0 ifFalse: [ self okayFields: (methodCache at: i + MethodCacheSelector). self okayFields: (methodCache at: i + MethodCacheClass). self okayFields: (methodCache at: i + MethodCacheMethod). ]. ]. 1 to: remapBufferCount do: [ :i | oop _ remapBuffer at: i. (self isIntegerObject: oop) ifFalse: [ self okayFields: oop. ]. ]. self okayActiveProcessStack.! ! !Interpreter methodsFor: 'image save/restore' stamp: 'ajh 10/22/2001 10:39'! byteSwapByteObjectsFrom: startOop to: stopAddr "Byte-swap the words of all bytes objects in a range of the image, including Strings, ByteArrays, and CompiledMethods. This returns these objects to their original byte ordering after blindly byte-swapping the entire image. For compiled methods, byte-swap only their bytecodes part." | oop fmt wordAddr | oop _ startOop. [oop < stopAddr] whileTrue: [ (self isFreeObject: oop) ifFalse: [ fmt _ self formatOf: oop. fmt >= 8 ifTrue: [ "oop contains bytes" wordAddr _ oop + BaseHeaderSize. self reverseBytesFrom: wordAddr to: oop + (self sizeBitsOf: oop). ]. ]. oop _ self objectAfter: oop. ]. ! ! !Interpreter methodsFor: 'image save/restore' stamp: 'ar 7/16/1999 22:48'! checkImageVersionFrom: f startingAt: imageOffset "Read and verify the image file version number and return true if the the given image file needs to be byte-swapped. As a side effect, position the file stream just after the version number of the image header. This code prints a warning and does a hard-exit if it cannot find a valid version number." "This code is based on C code by Ian Piumarta." | version firstVersion | self var: #f declareC: 'sqImageFile f'. "check the version number" self sqImageFile: f Seek: imageOffset. version _ firstVersion _ self getLongFromFile: f swap: false. (self readableFormat: version) ifTrue: [^ false]. "try with bytes reversed" self sqImageFile: f Seek: imageOffset. version _ self getLongFromFile: f swap: true. (self readableFormat: version) ifTrue: [^ true]. "Note: The following is only meaningful if not reading an embedded image" imageOffset = 0 ifTrue:[ "try skipping the first 512 bytes (prepended by certain Mac file transfer utilities)" self sqImageFile: f Seek: 512. version _ self getLongFromFile: f swap: false. (self readableFormat: version) ifTrue: [^ false]. "try skipping the first 512 bytes with bytes reversed" self sqImageFile: f Seek: 512. version _ self getLongFromFile: f swap: true. (self readableFormat: version) ifTrue: [^ true]]. "hard failure; abort" self print: 'This interpreter (vers. '. self printNum: self imageFormatVersion. self print: ' cannot read image file (vers. '. self printNum: firstVersion. self cr. self print: 'Hit CR to quit'. self getchar. self ioExit. ! ! !Interpreter methodsFor: 'image save/restore' stamp: 'ajh 10/24/2001 22:29'! cleanUpCallStacks "Sweep memory, nilling out all fields of stacks above their tops." | oop header fmt sz | oop _ self firstObject. [oop < endOfMemory] whileTrue: [ (self isFreeObject: oop) ifFalse: [ header _ self baseHeader: oop. fmt _ self formatIn: header. (fmt = 3 and: [self isStackHeader: header]) ifTrue: [sz _ self sizeBitsOf: oop. (self lastPointerOf: oop) + 4 to: sz - BaseHeaderSize by: 4 do: [:i | self longAt: oop+i put: nilObj]]]. oop _ self objectAfter: oop. ]. ! ! !Interpreter methodsFor: 'image save/restore' stamp: 'ajh 2/12/2002 06:48'! imageFormatVersion "Return a magic constant that changes when the image format changes. Since the image reading code uses this to detect byte ordering, one must avoid version numbers that are invariant under byte reversal." ^ 6603 "$B asciiValue * 100 + 3" "Stacks and block closures. ajh 2/12/2002" " 6502 ($A asciiValue * 100 + 2) Contexts and no block closures. Squeak 3.3 and earlier"! ! !Interpreter methodsFor: 'image save/restore' stamp: 'jm 5/30/2000 08:44'! readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory." "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command." "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!" | swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift heapSize | self var: #f declareC: 'sqImageFile f'. swapBytes _ self checkImageVersionFrom: f startingAt: imageOffset. headerStart _ (self sqImageFilePosition: f) - 4. "record header start position" headerSize _ self getLongFromFile: f swap: swapBytes. dataSize _ self getLongFromFile: f swap: swapBytes. oldBaseAddr _ self getLongFromFile: f swap: swapBytes. specialObjectsOop _ self getLongFromFile: f swap: swapBytes. lastHash _ self getLongFromFile: f swap: swapBytes. savedWindowSize _ self getLongFromFile: f swap: swapBytes. fullScreenFlag _ self getLongFromFile: f swap: swapBytes. extraVMMemory _ self getLongFromFile: f swap: swapBytes. lastHash = 0 ifTrue: [ "lastHash wasn't stored (e.g. by the cloner); use 999 as the seed" lastHash _ 999]. "decrease Squeak object heap to leave extra memory for the VM" heapSize _ self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'. "compare memory requirements with availability". minimumMemory _ dataSize + 100000. "need at least 100K of breathing room" heapSize < minimumMemory ifTrue: [ GenerateBrowserPlugin ifTrue: [ self plugInNotifyUser: 'The amount of memory specified by the ''memory'' EMBED tag is not enough for the installed Squeak image file.'. ^ nil] ifFalse: [self error: 'Insufficient memory for this image']]. "allocate a contiguous block of memory for the Squeak heap" memory _ self cCode: '(unsigned char *) sqAllocateMemory(minimumMemory, heapSize)'. memory = nil ifTrue: [ GenerateBrowserPlugin ifTrue: [ self plugInNotifyUser: 'There is not enough memory to give Squeak the amount specified by the ''memory'' EMBED tag.'. ^ nil] ifFalse: [self error: 'Failed to allocate memory for the heap']]. memStart _ self startOfMemory. memoryLimit _ (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety" endOfMemory _ memStart + dataSize. "position file after the header" self sqImageFile: f Seek: headerStart + headerSize. "read in the image in bulk, then swap the bytes if necessary" bytesRead _ self cCode: 'sqImageFileRead(memory, sizeof(unsigned char), dataSize, f)'. bytesRead ~= dataSize ifTrue: [ GenerateBrowserPlugin ifTrue: [ self plugInNotifyUser: 'Squeak had problems reading its image file.'. self plugInShutdown. ^ nil] ifFalse: [self error: 'Read failed or premature end of image file']]. swapBytes ifTrue: [self reverseBytesInImage]. "compute difference between old and new memory base addresses" bytesToShift _ memStart - oldBaseAddr. self initializeInterpreter: bytesToShift. "adjusts all oops to new location" ^ dataSize ! ! !Interpreter methodsFor: 'image save/restore' stamp: 'ar 2/5/2001 19:21'! writeImageFileIO: imageBytes | headerStart headerSize f bytesWritten | self var: #f declareC: 'sqImageFile f'. self ioCanWriteImage ifFalse:[^self primitiveFail]. "local constants" headerStart _ 0. headerSize _ 64. "header size in bytes; do not change!!" f _ self cCode: 'sqImageFileOpen(imageName, "wb")'. f = nil ifTrue: [ "could not open the image file for writing" self success: false. ^ nil]. headerStart _ self cCode: 'sqImageFileStartLocation(f,imageName,headerSize+imageBytes)'. self cCode: '/* Note: on Unix systems one could put an exec command here, padded to 512 bytes */'. "position file to start of header" self sqImageFile: f Seek: headerStart. self putLong: (self imageFormatVersion) toFile: f. self putLong: headerSize toFile: f. self putLong: imageBytes toFile: f. self putLong: (self startOfMemory) toFile: f. self putLong: specialObjectsOop toFile: f. self putLong: lastHash toFile: f. self putLong: (self ioScreenSize) toFile: f. self putLong: fullScreenFlag toFile: f. self putLong: extraVMMemory toFile: f. 1 to: 7 do: [:i | self putLong: 0 toFile: f]. "fill remaining header words with zeros" successFlag ifFalse: [ "file write or seek failure" self cCode: 'sqImageFileClose(f)'. ^ nil]. "position file after the header" self sqImageFile: f Seek: headerStart + headerSize. "write the image data" bytesWritten _ self cCode: 'sqImageFileWrite(memory, sizeof(unsigned char), imageBytes, f)'. self success: bytesWritten = imageBytes. self cCode: 'sqImageFileClose(f)'. ! ! !Interpreter methodsFor: 'plugin support' stamp: 'ajh 10/5/2001 14:34'! floatObjectOf: aFloat | newFloatObj | self var: #aFloat declareC: 'double aFloat'. newFloatObj _ self instantiateSmallClassNoFill: (self splObj: ClassFloat) sizeInBytes: 12. self storeFloatAt: newFloatObj + BaseHeaderSize from: aFloat. ^ newFloatObj. ! ! !Interpreter methodsFor: 'plugin support' stamp: 'ajh 10/22/2001 10:43'! flushExternalPrimitives "Flush the references to external functions from plugin primitives. This will force a reload of those primitives when accessed next. Note: We must flush the method cache here so that any failed primitives are looked up again." | oop primIdx | oop _ self firstObject. [oop < endOfMemory] whileTrue:[ (self isFreeObject: oop) ifFalse: [ (self isCompiledMethod: oop) ifTrue: [ primIdx _ self primitiveIndexOf: oop. primIdx = PrimitiveExternalCallIndex ifTrue: [ self flushExternalPrimitiveOf: oop. ]. ]. ]. oop _ self objectAfter: oop. ]. self flushMethodCache. self flushObsoleteIndexedPrimitives. self flushExternalPrimitiveTable.! ! !Interpreter methodsFor: 'image segment in/out' stamp: 'ajh 10/8/2001 11:52'! primitiveStoreImageSegment "This primitive is called from Squeak as... storeSegmentFor: arrayOfRoots into: aWordArray outPointers: anArray." "This primitive will store a binary image segment (in the same format as the Squeak image file) of the receiver and every object in its proper tree of subParts (ie, that is not refered to from anywhere else outside the tree). All pointers from within the tree to objects outside the tree will be copied into the array of outpointers. In their place in the image segment will be an oop equal to the offset in the outPointer array (the first would be 4). but with the high bit set." "The primitive expects the array and wordArray to be more than adequately long. In this case it returns normally, and truncates the two arrays to exactly the right size. To simplify truncation, both incoming arrays are required to be 256 bytes or more long (ie with 3-word headers). If either array is too small, the primitive will fail, but in no other case. During operation of the primitive, it is necessary to convert from both internal and external oops to their mapped values. To make this fast, the headers of the original objects in question are replaced by the mapped values (and this is noted by adding the forbidden XX header type). Tables are kept of both kinds of oops, as well as of the original headers for restoration. To be specific, there are two similar two-part tables, the outpointer array, and one in the upper fifth of the segmentWordArray. Each grows oops from the bottom up, and preserved headers from halfway up. In case of either success or failure, the headers must be restored. In the event of primitive failure, the table of outpointers must also be nilled out (since the garbage in the high half will not have been discarded." | outPointerArray segmentWordArray savedYoungStart lastOut lastIn firstIn lastSeg endSeg segOop fieldPtr fieldOop mapOop doingClass lastPtr extraSize hdrTypeBits arrayOfRoots hdrBaseIn hdrBaseOut header firstOut versionOffset | outPointerArray _ self stackValue: 0. segmentWordArray _ self stackValue: 1. arrayOfRoots _ self stackValue: 2. "Essential type checks" ((self formatOf: arrayOfRoots) = 2 "Must be indexable pointers" and: [(self formatOf: outPointerArray) = 2 "Must be indexable pointers" and: [(self formatOf: segmentWordArray) = 6]]) "Must be indexable words" ifFalse: [^ self primitiveFail]. ((self headerType: outPointerArray) = HeaderTypeSizeAndClass "Must be 3-word header" and: [(self headerType: segmentWordArray) = HeaderTypeSizeAndClass]) "Must be 3-word header" ifFalse: [^ self primitiveFail]. DoAssertionChecks ifTrue: [self verifyCleanHeaders]. "Use the top half of outPointers for saved headers." firstOut _ outPointerArray + BaseHeaderSize. lastOut _ firstOut - 4. hdrBaseOut _ outPointerArray + ((self lastPointerOf: outPointerArray) // 8 * 4). "top half" lastSeg _ segmentWordArray. endSeg _ segmentWordArray + (self sizeBitsOf: segmentWordArray) - 4. "Write a version number for byte order and version check" versionOffset _ 4. lastSeg _ lastSeg + versionOffset. lastSeg > endSeg ifTrue: [^ self primitiveFail]. self longAt: lastSeg put: self imageSegmentVersion. "Allocate top 1/8 of segment for table of internal oops and saved headers" firstIn _ endSeg - ((self sizeBitsOf: segmentWordArray) // 32 * 4). "Take 1/8 of seg" lastIn _ firstIn - 4. hdrBaseIn _ firstIn + ((self sizeBitsOf: segmentWordArray) // 64 * 4). "top half" "First mark the rootArray and all root objects." self longAt: arrayOfRoots put: ((self longAt: arrayOfRoots) bitOr: MarkBit). lastPtr _ arrayOfRoots + (self lastPointerOf: arrayOfRoots). fieldPtr _ arrayOfRoots + BaseHeaderSize. [fieldPtr <= lastPtr] whileTrue: [fieldOop _ self longAt: fieldPtr. (self isIntegerObject: fieldOop) ifFalse: [self longAt: fieldOop put: ((self longAt: fieldOop) bitOr: MarkBit)]. fieldPtr _ fieldPtr + 4]. "Then do a mark pass over all objects. This will stop at our marked roots, thus leaving our segment unmarked in their shadow." savedYoungStart _ youngStart. youngStart _ self startOfMemory. "process all of memory" self markAndTraceInterpreterOops. "and special objects array" youngStart _ savedYoungStart. "Finally unmark the rootArray and all root objects." self longAt: arrayOfRoots put: ((self longAt: arrayOfRoots) bitAnd: AllButMarkBit). fieldPtr _ arrayOfRoots + BaseHeaderSize. [fieldPtr <= lastPtr] whileTrue: [fieldOop _ self longAt: fieldPtr. (self isIntegerObject: fieldOop) ifFalse: [self longAt: fieldOop put: ((self longAt: fieldOop) bitAnd: AllButMarkBit)]. fieldPtr _ fieldPtr + 4]. "All external objects, and only they, are now marked. Copy the array of roots into the segment, and forward its oop." lastIn _ lastIn + 4. lastIn >= hdrBaseIn ifTrue: [successFlag _ false]. lastSeg _ self copyObj: arrayOfRoots toSegment: segmentWordArray addr: lastSeg stopAt: firstIn saveOopAt: lastIn headerAt: hdrBaseIn + (lastIn - firstIn). successFlag ifFalse: [lastIn _ lastIn - 4. self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut. ^ self primitiveFailAfterCleanup: outPointerArray]. "Now run through the segment fixing up all the pointers. Note that more objects will be added to the segment as we make our way along." segOop _ self oopFromChunk: segmentWordArray + versionOffset + BaseHeaderSize. [segOop <= lastSeg] whileTrue: [(self headerType: segOop) <= 1 ifTrue: ["This object has a class field (type=0 or 1) -- start with that." fieldPtr _ segOop - 4. doingClass _ true] ifFalse: ["No class field -- start with first data field" fieldPtr _ segOop + BaseHeaderSize. doingClass _ false]. lastPtr _ segOop + (self lastPointerOf: segOop). "last field" "Go through all oops, remapping them..." [fieldPtr > lastPtr] whileFalse: ["Examine each pointer field" fieldOop _ self longAt: fieldPtr. doingClass ifTrue: [hdrTypeBits _ fieldOop bitAnd: TypeMask. fieldOop _ fieldOop - hdrTypeBits]. (self isIntegerObject: fieldOop) ifTrue: ["Just an integer -- nothing to do" fieldPtr _ fieldPtr + 4] ifFalse: [header _ self longAt: fieldOop. (header bitAnd: TypeMask) = HeaderTypeFree ifTrue: ["Has already been forwarded -- this is the link" mapOop _ header bitAnd: AllButTypeMask] ifFalse: [((self longAt: fieldOop) bitAnd: MarkBit) = 0 ifTrue: ["Points to an unmarked obj -- an internal pointer. Copy the object into the segment, and forward its oop." lastIn _ lastIn + 4. lastIn >= hdrBaseIn ifTrue: [successFlag _ false]. lastSeg _ self copyObj: fieldOop toSegment: segmentWordArray addr: lastSeg stopAt: firstIn saveOopAt: lastIn headerAt: hdrBaseIn + (lastIn - firstIn). successFlag ifFalse: ["Out of space in segment" lastIn _ lastIn - 4. self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut. ^ self primitiveFailAfterCleanup: outPointerArray]. mapOop _ (self longAt: fieldOop) bitAnd: AllButTypeMask] ifFalse: ["Points to a marked obj -- an external pointer. Map it as a tagged index in outPointers, and forward its oop." lastOut _ lastOut + 4. lastOut >= hdrBaseOut ifTrue: ["Out of space in outPointerArray" lastOut _ lastOut - 4. self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut. ^ self primitiveFailAfterCleanup: outPointerArray]. . mapOop _ lastOut - outPointerArray bitOr: 16r80000000. self forward: fieldOop to: mapOop savingOopAt: lastOut andHeaderAt: hdrBaseOut + (lastOut - firstOut)]]. "Replace the oop by its mapped value" doingClass ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits. fieldPtr _ fieldPtr + 8. doingClass _ false] ifFalse: [self longAt: fieldPtr put: mapOop. fieldPtr _ fieldPtr + 4]. ]]. segOop _ self objectAfter: segOop]. self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut. "Truncate the outPointerArray..." ((outPointerArray + (self lastPointerOf: outPointerArray) - lastOut) < 12 or: [(endSeg - lastSeg) < 12]) ifTrue: ["Not enough room to insert simple 3-word headers" ^ self primitiveFailAfterCleanup: outPointerArray]. extraSize _ self extraHeaderBytes: segmentWordArray. hdrTypeBits _ self headerType: segmentWordArray. "Copy the 3-word wordArray header to establish a free chunk." self transfer: 3 from: segmentWordArray - extraSize to: lastOut+4. "Adjust the size of the original as well as the free chunk." self longAt: lastOut+4 put: outPointerArray + (self lastPointerOf: outPointerArray) - lastOut - extraSize + hdrTypeBits. self longAt: outPointerArray-extraSize put: lastOut - firstOut + 8 + hdrTypeBits. "Note that pointers have been stored into roots table" self beRootIfOld: outPointerArray. "Truncate the image segment..." "Copy the 3-word wordArray header to establish a free chunk." self transfer: 3 from: segmentWordArray - extraSize to: lastSeg+4. "Adjust the size of the original as well as the free chunk." self longAt: segmentWordArray-extraSize put: lastSeg - segmentWordArray + BaseHeaderSize + hdrTypeBits. self longAt: lastSeg+4 put: endSeg - lastSeg - extraSize + hdrTypeBits. DoAssertionChecks ifTrue: [self verifyCleanHeaders]. self pop: 3. "...leaving the reciever on the stack as return value" ! ! !Interpreter methodsFor: 'registers' stamp: 'ajh 1/20/2002 12:01'! externalizeIPandSP "Copy the local instruction and stack pointer to global variables for use in primitives and other functions outside the interpret loop." instructionPointer _ self cCoerce: localIP to: 'int'. stackPointer _ self cCoerce: localSP to: 'int'. ! ! !Interpreter methodsFor: 'registers' stamp: 'ajh 2/11/2002 01:05'! internalLoadPreviousFrame: frameBits senderOffset: senderOffset "Internal to dispatch loop only." | fp | self inline: true. fp _ framePointer. localSP _ self cCoerce: fp - (self receiverOffsetIn: frameBits) to: 'char *'. fp _ fp - senderOffset. framePointer _ fp. method _ self methodOfFp: fp. localIP _ self cCoerce: (self ipIn: frameBits method: method) to: 'char *'. ! ! !Interpreter methodsFor: 'registers' stamp: 'ajh 2/10/2002 22:55'! internalLoadStackTopFrame "load sp, fp, method and ip of top frame from callStack" | stackBits | self inline: true. localSP _ self cCoerce: (self stack: callStack ptrForIndex: (self quickFetchInteger: StackTopIndex ofObject: callStack)) to: 'char *'. stackBits _ self stackBitsOf: callStack. framePointer _ self stack: callStack ptrForIndex: (self fpIndexIn: stackBits). method _ self methodOfFp: framePointer. localIP _ self cCoerce: (self ipIn: stackBits method: method) to: 'char *'. ! ! !Interpreter methodsFor: 'registers' stamp: 'ajh 1/20/2002 12:09'! internalizeIPandSP "Copy the local instruction and stack pointer to local variables for rapid access within the interpret loop." localIP _ self cCoerce: instructionPointer to: 'char *'. localSP _ self cCoerce: stackPointer to: 'char *'. ! ! !Interpreter methodsFor: 'registers' stamp: 'ajh 2/10/2002 22:46'! loadPreviousFrame: frameBits senderOffset: senderOffset | fp | self inline: true. fp _ framePointer. stackPointer _ fp - (self receiverOffsetIn: frameBits). fp _ fp - senderOffset. method _ self methodOfFp: fp. framePointer _ fp. instructionPointer _ self ipIn: frameBits method: method. ! ! !Interpreter methodsFor: 'registers' stamp: 'ajh 2/10/2002 21:52'! loadStackTopFrame "load sp, fp, method and ip of top frame from callStack" | stackBits stack | self inline: true. stack _ callStack. stackPointer _ self stack: stack ptrForIndex: (self quickFetchInteger: StackTopIndex ofObject: stack). stackBits _ self stackBitsOf: stack. framePointer _ self stack: stack ptrForIndex: (self fpIndexIn: stackBits). method _ self methodOfFp: framePointer. instructionPointer _ self ipIn: stackBits method: method. ! ! !Interpreter methodsFor: 'registers' stamp: 'ajh 2/10/2002 21:46'! saveStackTopFrame "save top frame info (sp, ip, fp) to callStack" | stack | self inline: true. stack _ callStack. self storeWord: StackTopIndex ofObject: stack withValue: (self integerObjectOf: (self stack: stack indexForPtr: stackPointer)). self storeWord: TopFrameIpFpIndex ofObject: stack withValue: ( ((self cCoerce: instructionPointer - (self bytecodesOf: method) - BaseHeaderSize + 2 to: 'unsigned int') << IpShift) + ((self stack: stack indexForPtr: framePointer) << 1) + 1 "+ 1 for integer bit" ). "instructionPointer is a pointer variable equal to: bytecode oop + ip + BaseHeaderSize -1 (for 0-based addressing of fetchByte) -1 (because it gets incremented BEFORE fetching currentByte)" ! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 1/7/2002 15:17'! activeFrameOfFp: fp "Return the ActiveFrame refering to the frame at fp, may be nilObj" ^ self longAt: fp + (FrameActiveOffset * 4)! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 1/28/2002 20:56'! arg: reverseOffset "This is for args only. For other temps use temporary:" ^ self longAt: framePointer + (FrameLastArgOffset * 4) - (reverseOffset * 4)! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 1/28/2002 21:06'! arg: reverseOffset put: value "This is for args only. For other temps use temporary:put:" self longAt: framePointer + (FrameLastArgOffset * 4) - (reverseOffset * 4) put: value! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 2/6/2002 13:47'! firstFrameAddrOfFp: fp ^ fp - (self receiverOffsetIn: (self frameBitsOfFp: fp))! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 2/5/2002 12:08'! frameBitsOfFp: fp "Return the small int encoding: unwindTag, ip, numArgs, & senderFpOffset" ^ self longAt: fp + (FrameBitsOffset * 4)! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 2/6/2002 11:43'! frameReceiver "Return the receiver in the current frame (stored right before first arg)" ^ self longAt: framePointer - (self receiverOffsetIn: (self frameBitsOfFp: framePointer))! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 2/10/2002 22:29'! internalActiveFrameObj "Internal to dispatch loop only. Retrieve or create the ActiveFrame refering to the current frame" | frameObj | self inline: true. frameObj _ self activeFrameOfFp: framePointer. frameObj = ConstZero ifFalse: [^ frameObj]. self externalizeIPandSP. frameObj _ self instantiateSmallClassNoFill: (self splObj: ClassActiveFrame) sizeInBytes: 12. self internalizeIPandSP. self storePointerUnchecked: ContextStackIndex ofObject: frameObj withValue: callStack. self storePointerUnchecked: ContextFrameIndex ofObject: frameObj withValue: (self integerObjectOf: (self stack: callStack indexForPtr: framePointer)). self longAt: framePointer + (FrameActiveOffset * 4) put: frameObj. ^ frameObj ! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 2/5/2002 19:04'! internalPush0Sp0 "Push 0 for ip, sp, and 0 for fp offset. 0 means caller is on previous stack" self inline: true. localSP _ localSP + 4. self longAt: localSP put: ( (argumentCount - FrameLastArgOffset << (ReceiverShift+2)) + 1 "+ 1 for integer bit" ). ! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 2/7/2002 17:45'! internalPushIpSpFp "Push ip, sp, and fp of caller so we can return to it" self inline: true. localSP _ localSP + 4. self longAt: localSP put: ( ((self cCoerce: localIP - (self bytecodesOf: method) - BaseHeaderSize + 2 to: 'unsigned int') << IpShift) + (argumentCount - FrameLastArgOffset << (ReceiverShift+2)) + ((self cCoerce: localSP - framePointer to: 'unsigned int') << SenderShift) + 1 "+ 1 for integer bit" ). "instructionPointer is a pointer variable equal to: bytecode oop + ip + BaseHeaderSize -1 (for 0-based addressing of fetchByte) -1 (because it gets incremented BEFORE fetching currentByte)" ! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 2/11/2002 00:55'! ipIn: bits method: meth "Return a pointer to the meth bytecode encoded in bits" self inline: true. ^ (self bytecodesOf: meth) + ((self cCoerce: bits to: 'unsigned int') >> IpShift) + BaseHeaderSize - 2 "instruction pointer is a pointer variable equal to bytecodes oop + ip + BaseHeaderSize -1 for 0-based addressing of fetchByte -1 because it gets incremented BEFORE fetching currentByte" ! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 2/12/2002 03:15'! isValidFrame: frameObj stack: stack "Is frameObj in my process stack. stack must be equal to (self stackOf: frameObj) and is given so we don't have to get it ourselves so this can be inlined into if tests directly" self inline: true. ^ (self processOf: stack) = process and: [(self activeFrameOfFp: (self stack: stack ptrForIndex: (self quickFetchInteger: ContextFrameIndex ofObject: frameObj))) = frameObj]! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 1/7/2002 18:41'! methodOfFp: fp "Return the method of the frame at fp" ^ self longAt: fp + (FrameMethodOffset * 4)! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 2/10/2002 21:26'! push0Sp0 "Push 0 for ip, sp, and 0 for fp offset. 0 means caller is on previous stack" | sp | self inline: true. sp _ stackPointer + 4. self longAt: sp put: ( (argumentCount - FrameLastArgOffset << (ReceiverShift+2)) + 1 "+ 1 for integer bit" ). stackPointer _ sp.! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 2/10/2002 21:26'! pushIpSpFp "Push ip, sp, and fp of caller so we can return to it" | sp | self inline: true. sp _ stackPointer + 4. self longAt: sp put: ( ((self cCoerce: instructionPointer - (self bytecodesOf: method) - BaseHeaderSize + 2 to: 'unsigned int') << IpShift) + (argumentCount - FrameLastArgOffset << (ReceiverShift+2)) + (sp - framePointer << SenderShift) + 1 "+ 1 for integer bit" ). stackPointer _ sp. "instructionPointer is a pointer variable equal to: bytecode oop + ip + BaseHeaderSize -1 (for 0-based addressing of fetchByte) -1 (because it gets incremented BEFORE fetching currentByte)" ! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 2/6/2002 12:58'! receiverOffsetIn: bits "Return the byte offset of the callers sp" ^ (bits >> ReceiverShift) bitAnd: ReceiverMask! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 2/6/2002 13:17'! senderOffsetIn: bits "Return the byte offset of the callers fp, zero means sender is on the previous stack" ^ (bits >> SenderShift) bitAnd: SenderMask! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 10/4/2001 11:31'! stackOf: activationRecord ^ self fetchPointer: ContextStackIndex ofObject: activationRecord! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 12/20/2001 23:09'! temporary: offset "Internal to dispatch loop only. This is for extra temps only. For args use arg:" ^ self longAt: localSP - (offset * 4)! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 12/20/2001 23:10'! temporary: offset put: value "Internal to dispatch loop only. This is for extra temps only. For args use arg:put:" self longAt: localSP - (offset * 4) put: value! ! !Interpreter methodsFor: 'frame' stamp: 'ajh 2/11/2002 10:40'! unwindFlagIn: frameBits "Return 1 if the frame with frameBits contains an unwind block (ensure:/ifCurtailed: method) that needs to be exectued. otherwsie return 0" ^ (frameBits >> UnwindFlagShift) bitAnd: UnwindFlagMask! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 2/8/2002 14:16'! callStack: stack self inline: true. callStack _ stack. (stack < youngStart) ifTrue: [self beRootIfOld: stack]. endOfStack _ self lastStackPointerOf: stack. ! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 10/22/2001 11:54'! fetchStackPointerOf: aCallStack "Return the top index of aCallStack" | sp | self inline: true. sp _ self fetchPointer: StackTopIndex ofObject: aCallStack. (self isIntegerObject: sp) ifFalse: [^ 0]. ^ self integerValueOf: sp! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 2/6/2002 23:38'! fpIndexIn: stackBits "Return the fp index encoded in stackBits" ^ stackBits >> 1 bitAnd: StackFpMask! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 10/4/2001 11:45'! internalReplaceTop: obj ^ self longAt: localSP put: obj! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 2/10/2002 23:11'! internalRoomInStack: additionalNumberOfBytes ^ ((self cCoerce: localSP to: 'int') + additionalNumberOfBytes) < endOfStack "lastStackSlot" "always leave the last slot available so internalResumeUnwind:thenReturn:from:, which uses one more arg then the frame it replaces, doesn't have to do a stack overflow check"! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 10/4/2001 23:08'! isStackHeader: baseHeader ^ (self ccIndexIn: baseHeader) = StackCCIndex! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 10/24/2001 20:57'! lastStackPointerOf: aStack "Return the address of the last usable slot in aStack (its capacity)" ^ aStack + (self sizeBitsOf: aStack) - BaseHeaderSize! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 12/27/2001 13:46'! moveTopFrameToNewStack self error: 'moveTopFrameToNewStack not implemented yet'. ! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 2/10/2002 23:43'! newStack | aNewStack | freeStack ~= nilObj ifTrue: [ aNewStack _ freeStack. freeStack _ self fetchPointer: PreviousStackIndex ofObject: freeStack. ] ifFalse: [ "Need to create a new stack" aNewStack _ self instantiateClass: (self splObj: ClassCallStack) indexableSize: defaultStackSize fill: false with: 0. self storePointerUnchecked: StackTopIndex ofObject: aNewStack withValue: ConstZero. self storePointerUnchecked: TopFrameIpFpIndex ofObject: aNewStack withValue: ConstZero. self storePointerUnchecked: StackProcessIndex ofObject: aNewStack withValue: nilObj. ]. self storePointerUnchecked: PreviousStackIndex ofObject: aNewStack withValue: nilObj. "unchecked since nil is always marked" ^ aNewStack! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 2/7/2002 16:26'! popCallStack "Pop entire stack (presumably its empty) and make its previous stack the current callStack. framePointer, stackPointer, and InstructionPointer have to be updated by the caller. top frame pointer is returned" | newFreeStack | self inline: false. self storeWord: TopFrameIpFpIndex ofObject: callStack withValue: ConstZero. self storeWord: StackTopIndex ofObject: callStack withValue: ConstZero. self storePointerUnchecked: StackProcessIndex ofObject: callStack withValue: nilObj. newFreeStack _ callStack. callStack _ self previousStackOf: callStack. self storePointerUnchecked: PreviousStackIndex ofObject: newFreeStack withValue: freeStack. "unchecked because newFreeStack (callStack) is always a root or young" freeStack _ newFreeStack. callStack = nilObj ifTrue: [^ nil]. (callStack < youngStart) ifTrue: [self beRootIfOld: callStack]. endOfStack _ self lastStackPointerOf: callStack. ! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 10/4/2001 13:02'! previousStackOf: aCallStack ^ self fetchPointer: PreviousStackIndex ofObject: aCallStack! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 12/28/2001 20:01'! primitiveNewStack self popStack. "class CallStack" self push: self newStack. ! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 10/16/2001 15:40'! processOf: aCallStack ^ self fetchPointer: StackProcessIndex ofObject: aCallStack! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 2/10/2002 22:10'! pushNils: n "Push n nils on the stack" | nilOop sp first | self inline: true. sp _ stackPointer. first _ sp + 4. nilOop _ nilObj. sp _ sp + (n * 4). first to: sp by: 4 do: [:addr | self longAt: addr put: nilOop]. stackPointer _ sp. ! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 10/16/2001 00:22'! replaceStackValue: offset with: obj self longAt: stackPointer - (offset*4) put: obj! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 10/8/2001 10:21'! replaceTop: obj self longAt: stackPointer put: obj! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 2/10/2002 23:19'! roomInStack: additionalNumberOfBytes ^ (stackPointer + additionalNumberOfBytes) < endOfStack "lastStackSlot" "always leave the last slot available so internalResumeUnwind:thenReturn:from:, which uses one more arg then the frame it replaces, doesn't have to do a stack overflow check"! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 2/6/2002 13:41'! stack: stack indexForPtr: addr "Return the Smalltalk index of addr in theStack" ^ ((addr - stack - BaseHeaderSize) >> 2) - StackStart + 1! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 10/16/2001 18:58'! stack: stack ptrForIndex: index "Return a pointer to the element in stack at index" ^ stack + BaseHeaderSize + ((StackStart + index - 1) * 4)! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 2/6/2002 23:46'! stackBitsOf: stack ^ self fetchPointer: TopFrameIpFpIndex ofObject: stack! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 2/10/2002 23:47'! startNewStack "Start a new stack (because the current one is full) by reusing the top one from the freeStack list, if its empty create a brand new one. Copy the receiver and args to the new stack, and pop args off previous stack. The caller will finish filling in the stack (with senderOffset = 0 indicating previous frame is in previous stack)." | aNewStack | self inline: false. freeStack ~= nilObj ifTrue: [ aNewStack _ freeStack. freeStack _ self fetchPointer: PreviousStackIndex ofObject: freeStack. aNewStack < youngStart ifTrue: [self beRootIfOld: aNewStack] ] ifFalse: [ "Need to create a new stack" aNewStack _ self instantiateClass: (self splObj: ClassCallStack) indexableSize: defaultStackSize fill: false with: 0. self storePointerUnchecked: StackTopIndex ofObject: aNewStack withValue: ConstZero. self storePointerUnchecked: TopFrameIpFpIndex ofObject: aNewStack withValue: ConstZero. ]. self storePointerUnchecked: PreviousStackIndex ofObject: aNewStack withValue: callStack. self storePointerUnchecked: StackProcessIndex ofObject: aNewStack withValue: process. self pop: argumentCount. self saveStackTopFrame. self transfer: argumentCount + 1 from: stackPointer to: aNewStack + BaseHeaderSize + (StackStart * 4). callStack _ aNewStack. endOfStack _ self lastStackPointerOf: aNewStack. stackPointer _ self stack: aNewStack ptrForIndex: argumentCount + 1. ! ! !Interpreter methodsFor: 'stack' stamp: 'ajh 2/10/2002 23:48'! startNewStackWithArgs: argsArray "Start a new stack (because the current one is full) by reusing the empty one in process or creating a new one. Copy the receiver from top of existing stack and push args given" | aNewStack args | self inline: true. freeStack ~= nilObj ifTrue: [ aNewStack _ freeStack. freeStack _ self fetchPointer: PreviousStackIndex ofObject: freeStack. args _ argsArray. aNewStack < youngStart ifTrue: [self beRootIfOld: aNewStack] ] ifFalse: [ "Need to create a new stack" self pushRemappableOop: argsArray. aNewStack _ self instantiateClass: (self splObj: ClassCallStack) indexableSize: defaultStackSize fill: false with: 0. args _ self popRemappableOop. self storePointerUnchecked: StackTopIndex ofObject: aNewStack withValue: ConstZero. self storePointerUnchecked: TopFrameIpFpIndex ofObject: aNewStack withValue: ConstZero. ]. self storePointerUnchecked: PreviousStackIndex ofObject: aNewStack withValue: callStack. self storePointerUnchecked: StackProcessIndex ofObject: aNewStack withValue: process. self saveStackTopFrame. self storePointerUnchecked: StackStart ofObject: aNewStack withValue: self stackTop. self transfer: argumentCount from: args + BaseHeaderSize to: aNewStack + BaseHeaderSize + (StackStart + 1 * 4). callStack _ aNewStack. endOfStack _ self lastStackPointerOf: aNewStack. stackPointer _ self stack: aNewStack ptrForIndex: argumentCount + 1. ! ! !Interpreter methodsFor: 'sending' stamp: 'ajh 2/10/2002 23:20'! activateNewMethod "Push a new frame on the stack for newMethod. Receiver and args are already on top of the stack. See ActiveFrame class comment for frame layout. #internalActiveNewMethod should mirror this method" | newMethodHeader | newMethodHeader _ self headerOf: newMethod. (self roomInStack: (self stackSizeIn: newMethodHeader)) ifTrue: [ self push: newMethod. self pushIpSpFp. ] ifFalse: [ self startNewStack. "will save ip, sp, & fp to previous stack" self push: newMethod. self push0Sp0. "0 indicates caller is on previous stack" ]. framePointer _ stackPointer. "points at IpSpFp bits" self push: ConstZero. "slot for active frame object, zero means no object" self pushNils: (self numExtraTempsIn: newMethodHeader). method _ newMethod. "must come after pushIpSpFp above" instructionPointer _ (self bytecodesOf: newMethod) + BaseHeaderSize - 1. "point before first byte" ! ! !Interpreter methodsFor: 'sending' stamp: 'ajh 2/10/2002 23:21'! activateNewMethodWithArgs: argsArray "Push a new frame on the stack for newMethod, like activateNewMethod, except only the receiver is on top of the callStack while args are given separately. argumentCount must be equal to argsArray size" | newMethodHeader | newMethodHeader _ self headerOf: newMethod. (self roomInStack: (argumentCount * 4) + (self stackSizeIn: newMethodHeader)) ifTrue: [ self transfer: argumentCount from: argsArray + BaseHeaderSize to: stackPointer + 4. self unPop: argumentCount. self push: newMethod. self pushIpSpFp. ] ifFalse: [ self startNewStackWithArgs: argsArray. self push: newMethod. self push0Sp0. "0 indicates caller is on previous stack" ]. framePointer _ stackPointer. "points at IpSpFp bits" self push: ConstZero. "slot for active frame object, zero means no object" self pushNils: (self numExtraTempsIn: newMethodHeader). method _ newMethod. "must come after pushIpSpFp above" instructionPointer _ (self bytecodesOf: newMethod) + BaseHeaderSize - 1. "point before first byte" ! ! !Interpreter methodsFor: 'sending' stamp: 'ikp 1/3/1999 17:29'! executeNewMethod primitiveIndex > 0 ifTrue: [ self primitiveResponse. successFlag ifTrue: [^ nil]]. "if not primitive, or primitive failed, activate the method" self activateNewMethod. "check for possible interrupts at each real send" self quickCheckForInterrupts. ! ! !Interpreter methodsFor: 'sending' stamp: 'ajh 2/10/2002 23:12'! internalActivateNewMethod "Mirrors activateNewMethod except stackPointer and instructionPointer are replaced by localSP and localIP, respectively. This method is expected to be inlined into the bytecode dispatch loop" | newMethodHeader | newMethodHeader _ self headerOf: newMethod. (self internalRoomInStack: (self stackSizeIn: newMethodHeader)) ifTrue: [ self internalPush: newMethod. self internalPushIpSpFp. ] ifFalse: [ self externalizeIPandSP. self startNewStack. "will save ip, sp, & fp to previous stack" localSP _ self cCoerce: stackPointer to: 'char *'. "internalize, ip set below" self internalPush: newMethod. self internalPush0Sp0. "0 indicates caller is on previous stack" ]. framePointer _ self cCoerce: localSP to: 'int'. "points at IpSpFp bits" self internalPush: ConstZero. "slot for active frame object, 0 means no object" 1 to: (self numExtraTempsIn: newMethodHeader) do: [:i | self internalPush: nilObj]. method _ newMethod. "must come after internalPushIpSpFp above" localIP _ self cCoerce: (self bytecodesOf: newMethod) + BaseHeaderSize - 1 to: 'char *'. "point before first byte" ! ! !Interpreter methodsFor: 'sending' stamp: 'ajh 2/12/2002 13:35'! internalFindNewMethod "Find the compiled method to be run when the current messageSelector is sent to the class 'lkupClass', setting the values of 'newMethod' and 'primitiveIndex'." | ok | self inline: true. self sharedCodeNamed: 'commonLookup' inCase: 0. "send" ok _ self lookupInMethodCacheSel: messageSelector class: lkupClass. ok ifFalse: [ "entry was not found in the cache; look it up the hard way" self externalizeIPandSP. self lookupMethodInClass: lkupClass. self internalizeIPandSP. self addNewMethodToCache]. ! ! !Interpreter methodsFor: 'sending' stamp: 'ajh 2/12/2002 13:35'! normalSend "Send a message, starting lookup with the receiver's class." "Assume: messageSelector and argumentCount have been set, and that the receiver and arguments have been pushed onto the stack," "Note: This method is inlined into the interpreter dispatch loop." | rcvr | self inline: true. self sharedCodeNamed: 'commonSend' inCase: 0. "send" rcvr _ self internalStackValue: argumentCount. lkupClass _ self fetchClassOf: rcvr. receiverClass _ lkupClass. self internalFindNewMethod. self internalExecuteNewMethod. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'sending' stamp: 'ajh 1/20/2002 12:27'! superclassSend "Send a message to self, starting lookup with the superclass of the class containing the currently executing method." "Assume: messageSelector and argumentCount have been set, and that the receiver and arguments have been pushed onto the stack," "Note: This method is inlined into the interpreter dispatch loop." | rcvr | self inline: true. lkupClass _ self superclassOf: (self methodClassOf: method). rcvr _ self internalStackValue: argumentCount. receiverClass _ self fetchClassOf: rcvr. self internalFindNewMethod. self internalExecuteNewMethod. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/9/2002 19:39'! createBlock "Create a new BlockClosure and fill it will the top n vars from stack. It will have no receiver and no remote return" self internalReplaceTop: self createBasicBlock. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/16/2002 20:10'! createReturnBlock "Create a new BlockClosure and fill it will the top n vars from stack, also fill in home context for remote return" | block | block _ self createBasicBlock. self internalPop: 1. "pop method" self storePointer: BlockHomeIndex ofObject: block withValue: self internalStackTop. "return home context" self internalReplaceTop: block. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/10/2002 13:26'! getField "get fieldIndex from next byte and replace top object with its field value at fieldIndex. fieldIndex starts at 1 for the first field and all slot are in the same index space, ie. no distinction between fixed fields and indexable fields. To fetch the first indexable field add the number of fixed fields to the index first. This bytecodes assumes BaseHeaderSize = 4" self longAt: localSP put: (self longAt: (self longAt: localSP) + (self fetchByte * 4)). self fetchNextBytecode. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/12/2002 13:29'! getFieldRange "Replace top object with its n-th field value. n is encoded in bytecode and ranges from 1 to 24. This bytecodes assumes BaseHeaderSize = 4" self fetchNextBytecode. "assumes currentBytecode below will turn constant when inlined" self longAt: localSP put: (self longAt: (self longAt: localSP) + (currentBytecode-101 * 4)). ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/8/2002 03:10'! jumpBack localIP _ 1 - self fetchByte + localIP. "increment ip before accessing it" currentBytecode _ self byteAt: localIP. "No check for interupts on backwards jump here, assuming there is at least one normal send in the loop, which checks for interrupts. If the compiler detects a small loop with no normal sends, it should generate #jumpBackInterrupt instead"! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/8/2002 03:10'! jumpBackInterrupt "for backward jumps in small loops with no sends that would check for interrupts; so check for interrupts here" localIP _ 0 - self fetchByte + localIP. "increment ip before accessing it" self internalQuickCheckForInterrupts. self fetchNextBytecode.! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/30/2002 13:19'! jumpForward self jump: self fetchByte! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/11/2002 00:04'! jumpForwardIfFalse | boolean | boolean _ self internalStackTop. boolean = localFalse ifTrue: [ self jump: self fetchByte. ] ifFalse: [ boolean = trueObj ifFalse: [ localIP _ localIP - 1. "retry this jump after return from mustBeBoolean" messageSelector _ self splObj: SelectorMustBeBoolean. argumentCount _ 0. ^ self normalSend ]. "skip offset byte and fetch next byte" localIP _ localIP + 2. currentBytecode _ self byteAt: localIP. ]. self internalPop: 1. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/4/2002 23:02'! jumpForwardIfTrue | boolean | boolean _ self internalStackTop. boolean = localTrue ifTrue: [ self jump: self fetchByte. ] ifFalse: [ boolean = falseObj ifFalse: [ localIP _ localIP - 1. "retry this jump after return from mustBeBoolean" messageSelector _ self splObj: SelectorMustBeBoolean. argumentCount _ 0. ^ self normalSend ]. "skip offset byte and fetch next byte" localIP _ localIP + 2. currentBytecode _ self byteAt: localIP. ]. self internalPop: 1. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/4/2002 23:03'! localReturnFalse localReturnValue _ localFalse. self localReturn. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/30/2002 19:37'! localReturnNil localReturnValue _ nilObj. self localReturn. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/11/2002 00:05'! localReturnSelf "Return to previous frame, keep self on top. Same as #localReturn except we do not replace the top with localReturnValue." | senderOffset frameBits | self inline: true. "Pop top frame" frameBits _ self frameBitsOfFp: framePointer. senderOffset _ self senderOffsetIn: frameBits. senderOffset ~= 0 ifTrue: [ "sender is right before me on current stack" self internalLoadPreviousFrame: frameBits senderOffset: senderOffset. ] ifFalse: [ self popCallStack. callStack = nilObj ifTrue: [ "Just popped last frame, transfer to the highest priority process" self processFinished. self internalizeIPandSP. ^ self fetchNextBytecode ]. "sender is on previous stack" self internalLoadStackTopFrame. ]. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/30/2002 19:37'! localReturnTop localReturnValue _ self internalStackTop. self localReturn. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/4/2002 22:59'! localReturnTrue localReturnValue _ localTrue. self localReturn. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/11/2002 01:17'! longJump self jump: (self fetchByte-128 * 256) + self fetchByte! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/4/2002 23:03'! longJumpIfFalse | boolean | boolean _ self internalStackTop. boolean = localFalse ifTrue: [ self jump: (self fetchByte-128 * 256) + self fetchByte. ] ifFalse: [ boolean = trueObj ifFalse: [ localIP _ localIP - 1. "retry this jump after return from mustBeBoolean" messageSelector _ self splObj: SelectorMustBeBoolean. argumentCount _ 0. ^ self normalSend ]. localIP _ localIP + 2. "skip offset bytes" self fetchNextBytecode. ]. self internalPop: 1. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/4/2002 23:03'! longJumpIfTrue | boolean | boolean _ self internalStackTop. boolean = localTrue ifTrue: [ self jump: (self fetchByte-128 * 256) + self fetchByte. ] ifFalse: [ boolean = falseObj ifFalse: [ localIP _ localIP - 1. "retry this jump after return from mustBeBoolean" messageSelector _ self splObj: SelectorMustBeBoolean. argumentCount _ 0. ^ self normalSend ]. localIP _ localIP + 2. "skip offset bytes" self fetchNextBytecode. ]. self internalPop: 1. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/5/2002 01:33'! popTop self fetchNextBytecode. localSP _ localSP - 4. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/10/2002 13:40'! pushByte self longAt: (localSP _ localSP + 4) put: self fetchByte << 1 + 1. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/5/2002 01:34'! pushFalse self fetchNextBytecode. self longAt: (localSP _ localSP + 4) put: localFalse. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/12/2002 13:32'! pushLiteralRange "push literal stored in method at litOffset encoded in my bytecode" self fetchNextBytecode. "assumes currentBytecode below will turn constant when inlined" self internalPush: (self literal: currentBytecode-158). ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/10/2002 13:45'! pushLocal "push frame value at spOffset from new sp. spOffset is in next byte." localSP _ localSP + 4. self longAt: localSP put: (self longAt: localSP - (self fetchByte * 4)). self fetchNextBytecode. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/12/2002 13:28'! pushLocalRange "push frame value at spOffset from new sp. spOffset is encoded in bytecode and ranges from 1 to 24. spOffset of 1 is equivalent to duplicate" self fetchNextBytecode. "assumes currentBytecode below will turn constant when inlined" localSP _ localSP + 4. self longAt: localSP put: (self longAt: localSP - (currentBytecode-52 * 4)). ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/5/2002 01:35'! pushMinusOne self fetchNextBytecode. self longAt: (localSP _ localSP + 4) put: ConstMinusOne. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/5/2002 01:36'! pushNil self fetchNextBytecode. self longAt: (localSP _ localSP + 4) put: nilObj. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/5/2002 01:36'! pushOne self fetchNextBytecode. self longAt: (localSP _ localSP + 4) put: ConstOne. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/11/2002 00:36'! pushThisContext self internalPush: self internalActiveFrameObj. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/5/2002 01:36'! pushTrue self fetchNextBytecode. self longAt: (localSP _ localSP + 4) put: localTrue. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/5/2002 01:36'! pushTwo self fetchNextBytecode. self longAt: (localSP _ localSP + 4) put: ConstTwo. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/5/2002 01:37'! pushZero self fetchNextBytecode. self longAt: (localSP _ localSP + 4) put: ConstZero. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/9/2002 17:01'! remoteReturnTop self remoteReturn: self internalStackTop! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/3/2002 15:05'! send "selector is on top and numArgs is in next byte" messageSelector _ self longAt: localSP. localSP _ localSP - 4. argumentCount _ self fetchByte. self normalSend. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/12/2002 13:27'! send0Range "0 args and selector is in method at litOffset encoded in my bytecode" argumentCount _ 0. messageSelector _ self literal: currentBytecode - 1. self normalSend. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/12/2002 13:27'! send1Range "1 arg and selector is in method at litOffset encoded in my bytecode" argumentCount _ 1. messageSelector _ self literal: currentBytecode - 21. self normalSend. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/12/2002 13:27'! send2Range "2 args and selector is in method at litOffset encoded in my bytecode" argumentCount _ 2. messageSelector _ self literal: currentBytecode - 41. self normalSend. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/4/2002 12:16'! send3Range "2 args and selector is in method at litOffset encoded in my bytecode" messageSelector _ self literal: 0. argumentCount _ 3. self normalSend. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/12/2002 13:28'! sendRange "selector is on top and numArgs is encoded in current bytecode (0-5)" messageSelector _ self longAt: localSP. argumentCount _ currentBytecode - 46. localSP _ localSP - 4. self normalSend. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/11/2002 00:45'! setField "get fieldIndex in next byte then pop object and set its field at fieldIndex to the remaining top value. fieldIndex starts at 1 for the first field and all slot are in the same index space, ie. no distinction between fixed fields and indexable fields. To fetch the first indexable field add the number of fixed fields to the index first. This bytecodes assumes BaseHeaderSize = 4" | object | object _ self longAt: localSP. localSP _ localSP - 4. self longAt: object + (self fetchByte * 4) put: (self longAt: localSP). (object < youngStart) ifTrue: [ self possibleRootStoreInto: object value: (self longAt: localSP)]. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/11/2002 00:47'! setFieldPop "same as setField except pop final value" | object | object _ self longAt: localSP. localSP _ localSP - 4. self longAt: object + (self fetchByte * 4) put: (self longAt: localSP). (object < youngStart) ifTrue: [ self possibleRootStoreInto: object value: (self longAt: localSP)]. localSP _ localSP - 4. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/12/2002 13:30'! setFieldPopRange "pop object and set its field at fieldIndex to remaining top value then pop it. fieldIndex is encoded in my bytecode. This bytecodes assumes BaseHeaderSize = 4" | object | object _ self longAt: localSP. localSP _ localSP - 4. self longAt: object + (currentBytecode-125 * 4) put: (self longAt: localSP). (object < youngStart) ifTrue: [ self possibleRootStoreInto: object value: (self longAt: localSP)]. localSP _ localSP - 4. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/12/2002 13:30'! setFieldRange "pop object and set its field fieldIndex to remaining top value. fieldIndex is encoded in my bytecode. This bytecodes assumes BaseHeaderSize = 4" | object | object _ self longAt: localSP. localSP _ localSP - 4. self longAt: object + (currentBytecode-142 * 4) put: (self longAt: localSP). (object < youngStart) ifTrue: [ self possibleRootStoreInto: object value: (self longAt: localSP)]. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/10/2002 14:25'! storeLocal "get spOffset from next byte and copy top object to frame slot at spOffset from sp" self longAt: localSP - (self fetchByte * 4) put: (self longAt: localSP). self fetchNextBytecode. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/10/2002 14:26'! storeLocalInVar "get spOffset from next byte and copy top object to frame slot at spOffset from sp wrapped in a Var holder. Assumes BaseHeaderSize = 4" | var | self externalizeIPandSP. var _ self instantiateSmallClassNoFill: (self splObj: ClassVar) sizeInBytes: 8. self internalizeIPandSP. self longAt: var + 4 put: (self longAt: localSP). self longAt: localSP - (self fetchByte * 4) put: var. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/10/2002 14:27'! storeLocalInVarPop "get spOffset from next byte and pop top object into frame slot at spOffset from original sp wrapped in a Var holder. Assumes BaseHeaderSize = 4" | var | self externalizeIPandSP. var _ self instantiateSmallClassNoFill: (self splObj: ClassVar) sizeInBytes: 8. self internalizeIPandSP. self longAt: var + 4 put: (self longAt: localSP). self longAt: localSP - (self fetchByte * 4) put: var. localSP _ localSP - 4. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/10/2002 14:28'! storeLocalPop "get spOffset from next byte and pop top object into frame slot at spOffset from original sp" self longAt: localSP - (self fetchByte * 4) put: (self longAt: localSP). localSP _ localSP - 4. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/12/2002 13:29'! storeLocalPopRange "pop top object into frame slot at spOffset from original sp. spOffset is encoded in my bytecode" self fetchNextBytecode. "assumes currentBytecode below will turn constant when inlined" self longAt: localSP - (currentBytecode-78 * 4) put: (self longAt: localSP). localSP _ localSP - 4. ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 2/12/2002 13:29'! storeLocalRange "copy top object to frame slot at spOffset from sp. spOffset is encoded in my bytecode" self fetchNextBytecode. "assumes currentBytecode below will turn constant when inlined" self longAt: localSP - (currentBytecode-91 * 4) put: (self longAt: localSP). ! ! !Interpreter methodsFor: 'bytecodes' stamp: 'ajh 1/30/2002 15:25'! superSend "selector is on top and numArgs is in next byte" argumentCount _ self fetchByte. messageSelector _ self longAt: localSP. localSP _ localSP - 4. self superclassSend. ! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:05'! sendAdd | rcvr arg result | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [result _ (self integerValueOf: rcvr) + (self integerValueOf: arg). (self isIntegerValue: result) ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: result). ^ self fetchNextBytecode "success"]] ifFalse: [successFlag _ true. self externalizeIPandSP. self primitiveFloatAdd: rcvr toArg: arg. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]]. messageSelector _ self specialSelector: 0. argumentCount _ 1. self normalSend! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:05'! sendAt "BytecodePrimAt will only succeed if the receiver is in the atCache. Otherwise it will fail so that the more general primitiveAt will put it in the cache after validating that message lookup results in a primitive response." | index rcvr result atIx | index _ self internalStackTop. rcvr _ self internalStackValue: 1. successFlag _ (self isIntegerObject: rcvr) not and: [self isIntegerObject: index]. successFlag ifTrue: [atIx _ rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7" (atCache at: atIx+AtCacheOop) = rcvr ifTrue: [result _ self commonVariableInternal: rcvr at: (self integerValueOf: index) cacheIndex: atIx. successFlag ifTrue: [self fetchNextBytecode. ^ self internalPop: 2 thenPush: result]]]. messageSelector _ self specialSelector: 16. argumentCount _ 1. self normalSend. ! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:05'! sendAtEnd messageSelector _ self specialSelector: 21. argumentCount _ 0. self normalSend.! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:06'! sendAtPut "BytecodePrimAtPut will only succeed if the receiver is in the atCache. Otherwise it will fail so that the more general primitiveAtPut will put it in the cache after validating that message lookup results in a primitive response." | index rcvr atIx value | value _ self internalStackTop. index _ self internalStackValue: 1. rcvr _ self internalStackValue: 2. successFlag _ (self isIntegerObject: rcvr) not and: [self isIntegerObject: index]. successFlag ifTrue: [atIx _ (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache" (atCache at: atIx+AtCacheOop) = rcvr ifTrue: [self commonVariable: rcvr at: (self integerValueOf: index) put: value cacheIndex: atIx. successFlag ifTrue: [self fetchNextBytecode. ^ self internalPop: 3 thenPush: value]]]. messageSelector _ self specialSelector: 17. argumentCount _ 2. self normalSend! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:06'! sendBitAnd successFlag _ true. self externalizeIPandSP. self primitiveBitAnd. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]. messageSelector _ self specialSelector: 14. argumentCount _ 1. self normalSend! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:06'! sendBitOr successFlag _ true. self externalizeIPandSP. self primitiveBitOr. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]. messageSelector _ self specialSelector: 15. argumentCount _ 1. self normalSend! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:06'! sendBitShift successFlag _ true. self externalizeIPandSP. self primitiveBitShift. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]. messageSelector _ self specialSelector: 12. argumentCount _ 1. self normalSend! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:06'! sendClass | rcvr | rcvr _ self internalStackTop. self internalPop: 1 thenPush: (self fetchClassOf: rcvr). self fetchNextBytecode. ! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:07'! sendDiv | quotient | successFlag _ true. quotient _ self doPrimitiveDiv: (self internalStackValue: 1) by: (self internalStackValue: 0). successFlag ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: quotient). ^ self fetchNextBytecode "success"]. messageSelector _ self specialSelector: 13. argumentCount _ 1. self normalSend! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:07'! sendDivide | rcvr arg result | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [rcvr _ self integerValueOf: rcvr. arg _ self integerValueOf: arg. ((arg ~= 0) and: [(rcvr \\ arg) = 0]) ifTrue: [result _ rcvr // arg. "generates C / operation" (self isIntegerValue: result) ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: result). ^ self fetchNextBytecode "success"]]] ifFalse: [successFlag _ true. self externalizeIPandSP. self primitiveFloatDivide: rcvr byArg: arg. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]]. messageSelector _ self specialSelector: 9. argumentCount _ 1. self normalSend. ! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/13/2002 02:02'! sendDo messageSelector _ self specialSelector: 26. argumentCount _ 1. self normalSend. ! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:07'! sendEqual | rcvr arg bool | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [^ self booleanCheat: rcvr = arg]. successFlag _ true. bool _ self primitiveFloatEqual: rcvr toArg: arg. successFlag ifTrue: [^ self booleanCheat: bool]. messageSelector _ self specialSelector: 6. argumentCount _ 1. self normalSend ! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:07'! sendEquivalent | rcvr arg | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. self booleanCheat: rcvr = arg.! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:07'! sendGreaterOrEqual | rcvr arg bool | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [self cCode: '' inSmalltalk: [^ self booleanCheat: (self integerValueOf: rcvr) >= (self integerValueOf: arg)]. ^ self booleanCheat: rcvr >= arg]. successFlag _ true. bool _ self primitiveFloatLess: rcvr thanArg: arg. successFlag ifTrue: [^ self booleanCheat: bool not]. messageSelector _ self specialSelector: 5. argumentCount _ 1. self normalSend ! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:07'! sendGreaterThan | rcvr arg bool | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [self cCode: '' inSmalltalk: [^ self booleanCheat: (self integerValueOf: rcvr) > (self integerValueOf: arg)]. ^ self booleanCheat: rcvr > arg]. successFlag _ true. bool _ self primitiveFloatGreater: rcvr thanArg: arg. successFlag ifTrue: [^ self booleanCheat: bool]. messageSelector _ self specialSelector: 3. argumentCount _ 1. self normalSend ! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:08'! sendLessOrEqual | rcvr arg bool | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [self cCode: '' inSmalltalk: [^ self booleanCheat: (self integerValueOf: rcvr) <= (self integerValueOf: arg)]. ^ self booleanCheat: rcvr <= arg]. successFlag _ true. bool _ self primitiveFloatGreater: rcvr thanArg: arg. successFlag ifTrue: [^ self booleanCheat: bool not]. messageSelector _ self specialSelector: 4. argumentCount _ 1. self normalSend ! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:08'! sendLessThan | rcvr arg bool | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [self cCode: '' inSmalltalk: [^ self booleanCheat: (self integerValueOf: rcvr) < (self integerValueOf: arg)]. ^ self booleanCheat: rcvr < arg]. successFlag _ true. bool _ self primitiveFloatLess: rcvr thanArg: arg. successFlag ifTrue: [^ self booleanCheat: bool]. messageSelector _ self specialSelector: 2. argumentCount _ 1. self normalSend ! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:08'! sendMakePoint successFlag _ true. self externalizeIPandSP. self primitiveMakePoint. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]. messageSelector _ self specialSelector: 11. argumentCount _ 1. self normalSend! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:08'! sendMod | mod | successFlag _ true. mod _ self doPrimitiveMod: (self internalStackValue: 1) by: (self internalStackValue: 0). successFlag ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: mod). ^ self fetchNextBytecode "success"]. messageSelector _ self specialSelector: 10. argumentCount _ 1. self normalSend! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:08'! sendMultiply | rcvr arg result | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [rcvr _ self integerValueOf: rcvr. arg _ self integerValueOf: arg. result _ rcvr * arg. ((arg = 0 or: [(result // arg) = rcvr]) and: [self isIntegerValue: result]) ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: result). ^ self fetchNextBytecode "success"]] ifFalse: [successFlag _ true. self externalizeIPandSP. self primitiveFloatMultiply: rcvr byArg: arg. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]]. messageSelector _ self specialSelector: 8. argumentCount _ 1. self normalSend. ! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/13/2002 02:03'! sendNew messageSelector _ self specialSelector: 27. argumentCount _ 0. self normalSend. ! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/13/2002 02:03'! sendNewWithArg messageSelector _ self specialSelector: 28. argumentCount _ 1. self normalSend. ! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:09'! sendNext messageSelector _ self specialSelector: 19. argumentCount _ 0. self normalSend.! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:09'! sendNextPut messageSelector _ self specialSelector: 20. argumentCount _ 1. self normalSend.! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:09'! sendNotEqual | rcvr arg bool | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [^ self booleanCheat: rcvr ~= arg]. successFlag _ true. bool _ self primitiveFloatEqual: rcvr toArg: arg. successFlag ifTrue: [^ self booleanCheat: bool not]. messageSelector _ self specialSelector: 7. argumentCount _ 1. self normalSend ! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:10'! sendSize messageSelector _ self specialSelector: 18. argumentCount _ 0. self normalSend! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/9/2002 15:10'! sendSubtract | rcvr arg result | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [result _ (self integerValueOf: rcvr) - (self integerValueOf: arg). (self isIntegerValue: result) ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: result). ^ self fetchNextBytecode "success"]] ifFalse: [successFlag _ true. self externalizeIPandSP. self primitiveFloatSubtract: rcvr fromArg: arg. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]]. messageSelector _ self specialSelector: 1. argumentCount _ 1. self normalSend! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/13/2002 02:02'! sendValue | block | block _ self internalStackTop. successFlag _ true. argumentCount _ 0. self assertClassOf: block is: (self splObj: ClassBlockClosure). successFlag ifTrue: [ self externalizeIPandSP. self primitiveValue. self internalizeIPandSP. ]. successFlag ifFalse: [ messageSelector _ self specialSelector: 24. argumentCount _ 0. ^ self normalSend ]. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/13/2002 02:02'! sendValueWithArg | block | block _ self internalStackValue: 1. successFlag _ true. argumentCount _ 1. self assertClassOf: block is: (self splObj: ClassBlockClosure). successFlag ifTrue: [ self externalizeIPandSP. self primitiveValue. self internalizeIPandSP. ]. successFlag ifFalse: [ messageSelector _ self specialSelector: 25. argumentCount _ 1. ^ self normalSend ]. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/13/2002 02:03'! sendX successFlag _ true. self externalizeIPandSP. self primitivePointX. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]. messageSelector _ self specialSelector: 29. argumentCount _ 0. self normalSend! ! !Interpreter methodsFor: 'common send bytecodes' stamp: 'ajh 1/13/2002 02:03'! sendY successFlag _ true. self externalizeIPandSP. self primitivePointY. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]. messageSelector _ self specialSelector: 30. argumentCount _ 0. self normalSend! ! !Interpreter methodsFor: 'bytecode support' stamp: 'ajh 2/12/2002 13:32'! booleanCheat: cond | nextBytecode | self inline: true. self internalPop: 2. nextBytecode _ self fetchByte. nextBytecode = 156 "jumpForwardIfFalse" ifTrue: [ cond ifTrue: [ "skip jump offset and fetch next byte" localIP _ localIP + 2. currentBytecode _ self byteAt: localIP. ^ self ] ifFalse: [ ^ self jump: self fetchByte ]. ]. "next bytecode is not jumpForwardIfFalse, so just push bool object and execute the bytecode normally" cond ifTrue: [self internalPush: trueObj] ifFalse: [self internalPush: falseObj]. currentBytecode _ nextBytecode. ! ! !Interpreter methodsFor: 'bytecode support' stamp: 'ajh 1/25/2002 03:54'! createBasicBlock "Create a new BlockClosure and fill it will the top n vars from stack. n is the next bytecode." | closureSize block | self inline: true. closureSize _ self fetchByte. "Create block" self externalizeIPandSP. block _ self instantiateClass: (self splObj: ClassBlockClosure) indexableSize: closureSize fill: false with: 0. self internalizeIPandSP. "Fill block with closure vars that are on top of stack" self internalPop: closureSize. self transfer: closureSize from: (self cCoerce: localSP + 4 to: 'int') to: block + BaseHeaderSize + (ClosureStart * 4). "Fill in method" self storePointerUnchecked: BlockMethodIndex ofObject: block withValue: self internalStackTop. "No return home context (yet)" self storePointerUnchecked: BlockHomeIndex ofObject: block withValue: nilObj. ^ block! ! !Interpreter methodsFor: 'returning' stamp: 'ajh 2/6/2002 14:27'! cannotReturn: resultObj from: homeContext | lookupClass | self inline: false. self push: process. self push: resultObj. self push: homeContext. messageSelector _ self splObj: SelectorCannotReturnFrom. argumentCount _ 2. lookupClass _ self fetchClassOf: process. self findNewMethodInClass: lookupClass. self executeNewMethod. ! ! !Interpreter methodsFor: 'returning' stamp: 'ajh 2/6/2002 14:27'! couldNotReturn: resultObj from: homeContext | lookupClass | self inline: false. self push: process. self push: resultObj. self push: homeContext. messageSelector _ self splObj: SelectorCouldNotReturnFrom. argumentCount _ 2. lookupClass _ self fetchClassOf: process. self findNewMethodInClass: lookupClass. self executeNewMethod. ! ! !Interpreter methodsFor: 'returning' stamp: 'ajh 2/11/2002 10:36'! internalReturn: resultObj from: homeContext "Internal to dispatch loop only. Return from homeContext with resultObj on top. Assumes homeContext is valid. Mirrors return:from:." | frameBits unwindFlag senderOffset unwindBlock stackBits | self inline: true. [(self activeFrameOfFp: framePointer) ~= homeContext] whileTrue: [ frameBits _ self frameBitsOfFp: framePointer. unwindFlag _ self unwindFlagIn: frameBits. senderOffset _ self senderOffsetIn: frameBits. senderOffset ~= 0 ifTrue: [ "partial internalLoadPreviousFrame:senderOffset:" framePointer _ framePointer - senderOffset. ] ifFalse: [ unwindBlock _ self arg: 0. self popCallStack. callStack = nilObj ifTrue: [ "supposedly can't happen since homeContext is valid and not reached yet. But isValidFrame: can be fooled if by chance another frame taking the place of homeContext holds the dead homeContext in exactly the same stack slot where it used to reside." self processFinished. "start next highest process" self couldNotReturn: resultObj from: homeContext. self internalizeIPandSP. ^ self fetchNextBytecode ]. "partial internalLoadStackTopFrame" stackBits _ self stackBitsOf: callStack. framePointer _ self stack: callStack ptrForIndex: (self fpIndexIn: stackBits). ]. unwindFlag = 1 ifTrue: [ "Popped ensure:/ifCurtailed:, execute unwind block that was first arg" senderOffset ~= 0 ifTrue: [ "rest of internalLoadPreviousFrame:senderOffset:" localSP _ self cCoerce: framePointer + senderOffset - (self receiverOffsetIn: frameBits) to: 'char *'. method _ self methodOfFp: framePointer. localIP _ self cCoerce: (self ipIn: frameBits method: method) to: 'char *'. unwindBlock _ self longAt: localSP + 4. ] ifFalse: [ "rest of internalLoadStackFrame" localSP _ self cCoerce: (self stack: callStack ptrForIndex: (self quickFetchInteger: StackTopIndex ofObject: callStack)) to: 'char *'. method _ self methodOfFp: framePointer. localIP _ self cCoerce: (self ipIn: stackBits method: method) to: 'char *'. ]. ^ self internalUnwind: unwindBlock thenReturn: resultObj from: homeContext. ]. ]. frameBits _ self frameBitsOfFp: framePointer. senderOffset _ self senderOffsetIn: frameBits. senderOffset ~= 0 ifTrue: [ self internalLoadPreviousFrame: frameBits senderOffset: senderOffset. ] ifFalse: [ self popCallStack. callStack = nilObj ifTrue: [ "homeContext was bottom frame, resume next highest process" self processFinished. self internalizeIPandSP. ^ self fetchNextBytecode ]. self internalLoadStackTopFrame. ]. self fetchNextBytecode. self internalReplaceTop: resultObj. ! ! !Interpreter methodsFor: 'returning' stamp: 'ajh 2/6/2002 10:56'! internalUnwind: block thenReturn: value from: context "Internal to dispatch loop only. Resume with #executeThenReturn:from: replacing ensure:/ifCurtailed: frame" self inline: true. self internalReplaceTop: block. self internalPush: value. self internalPush: context. messageSelector _ self splObj: SelectorExecuteThenReturnFrom. argumentCount _ 2. ^ self normalSend! ! !Interpreter methodsFor: 'returning' stamp: 'ajh 2/12/2002 13:35'! localReturn "Return to the previous frame with the value of localReturnValue on top, which should have been set before calling this. We use localReturnValue, which will be local to the interpret function (see CCodeGenerator>>doInlining:), instead of passing it in as an argument because we want to share this code when inlined. We cannot have args in methods that have shared code that is going to be jumped to (see sharedCodeNamed:inCase:)" "localReturnSelf mirrors this method" | frameBits senderOffset | self inline: true. self sharedCodeNamed: 'commonLocalReturn' inCase: 217. "localReturnTop" "Pop top frame" frameBits _ self frameBitsOfFp: framePointer. senderOffset _ self senderOffsetIn: frameBits. senderOffset ~= 0 ifTrue: [ "sender is right before me on current stack" self internalLoadPreviousFrame: frameBits senderOffset: senderOffset. ] ifFalse: [ self popCallStack. callStack = nilObj ifTrue: [ "Just popped last frame, transfer to the highest priority process" self processFinished. self internalizeIPandSP. ^ self fetchNextBytecode ]. "sender is on previous stack" self internalLoadStackTopFrame. ]. self fetchNextBytecode. self internalReplaceTop: localReturnValue. ! ! !Interpreter methodsFor: 'returning' stamp: 'ajh 2/12/2002 03:14'! primitiveReturnFrom "Unwind to homeContext and return to its sender with resultObj on top." | homeContext resultObj proc stack | homeContext _ self popStack. resultObj _ self popStack. proc _ self stackTop. proc = process ifFalse: [self unPop: 2. ^ self primitiveFail]. homeContext ~= nilObj ifFalse: [self unPop: 2. ^ self primitiveFail]. stack _ self stackOf: homeContext. (self isValidFrame: homeContext stack: stack) ifFalse: [self unPop: 2. ^ self primitiveFail]. self return: resultObj from: homeContext. ! ! !Interpreter methodsFor: 'returning' stamp: 'ajh 2/12/2002 03:14'! remoteReturn: value "Do a remote return only if the frame has a block closure and it has a home, otherwise do a immediate return" | home stack | self inline: true. home _ self fetchPointer: BlockHomeIndex ofObject: self frameReceiver. home ~= nilObj ifFalse: [ self externalizeIPandSP. self cannotReturn: value from: home. self internalizeIPandSP. ^ self fetchNextBytecode ]. stack _ self stackOf: home. (self isValidFrame: home stack: stack) ifFalse: [ self externalizeIPandSP. self cannotReturn: value from: home. self internalizeIPandSP. ^ self fetchNextBytecode ]. self internalReturn: value from: home. ! ! !Interpreter methodsFor: 'returning' stamp: 'ajh 2/11/2002 10:36'! return: resultObj from: homeContext "Return from homeContext with resultObj on top. Assumes homeContext is valid (in process stack). internalReturn:from: mirrors this" | frameBits unwindFlag senderOffset unwindBlock stackBits | self inline: true. [(self activeFrameOfFp: framePointer) ~= homeContext] whileTrue: [ frameBits _ self frameBitsOfFp: framePointer. unwindFlag _ self unwindFlagIn: frameBits. senderOffset _ self senderOffsetIn: frameBits. senderOffset ~= 0 ifTrue: [ "partial loadPreviousFrame:senderOffset:" framePointer _ framePointer - senderOffset. ] ifFalse: [ unwindBlock _ self arg: 0. self popCallStack. callStack = nilObj ifTrue: [ "supposedly can't happen since homeContext is valid and not reached yet. But isValidFrame: can be fooled if by chance another frame taking the place of homeContext holds the dead homeContext in exactly the same stack slot where it used to reside." self processFinished. "start next highest process" ^ self couldNotReturn: resultObj from: homeContext. ]. "partial loadStackTopFrame" stackBits _ self stackBitsOf: callStack. framePointer _ self stack: callStack ptrForIndex: (self fpIndexIn: stackBits). ]. unwindFlag = 1 ifTrue: [ "Popped ensure:/ifCurtailed:, execute unwind block that was first arg" senderOffset ~= 0 ifTrue: [ "rest of internalLoadPreviousFrame:senderOffset:" stackPointer _ framePointer + senderOffset - (self receiverOffsetIn: frameBits). method _ self methodOfFp: framePointer. instructionPointer _ self ipIn: frameBits method: method. unwindBlock _ self longAt: stackPointer + 4. ] ifFalse: [ "rest of internalLoadStackFrame" stackPointer _ self stack: callStack ptrForIndex: (self quickFetchInteger: StackTopIndex ofObject: callStack). method _ self methodOfFp: framePointer. instructionPointer _ self ipIn: stackBits method: method. ]. ^ self unwind: unwindBlock thenReturn: resultObj from: homeContext. ]. ]. frameBits _ self frameBitsOfFp: framePointer. senderOffset _ self senderOffsetIn: frameBits. senderOffset ~= 0 ifTrue: [ self loadPreviousFrame: frameBits senderOffset: senderOffset. ] ifFalse: [ self popCallStack. callStack = nilObj ifTrue: [ "homeContext was bottom frame, resume next highest process" ^ self processFinished. ]. self loadStackTopFrame. ]. self replaceTop: resultObj. ! ! !Interpreter methodsFor: 'returning' stamp: 'ajh 2/6/2002 10:55'! unwind: block thenReturn: value from: homeContext "Resume with #executeThenReturn:from: replacing ensure:/ifCurtailed: frame" | lookupClass | self inline: true. self replaceTop: block. self push: value. self push: homeContext. messageSelector _ self splObj: SelectorExecuteThenReturnFrom. argumentCount _ 2. lookupClass _ self fetchClassOf: block. self findNewMethodInClass: lookupClass. self executeNewMethod. ! ! !InterpreterSimulator methodsFor: 'initialization' stamp: 'ajh 10/10/2001 19:12'! initialize "Initialize the InterpreterSimulator when running the interpreter inside Smalltalk. The primary responsibility of this method is to allocate Smalltalk Arrays for variables that will be declared as statically-allocated global arrays in the translated code." "initialize class variables" ObjectMemory initialize. Interpreter initialize. methodCache _ Array new: MethodCacheSize. atCache _ Array new: AtCacheTotalSize. self flushMethodCache. rootTable _ Array new: RootTableSize. remapBuffer _ Array new: RemapBufferSize. semaphoresUseBufferA _ true. semaphoresToSignalA _ Array new: SemaphoresToSignalSize. semaphoresToSignalB _ Array new: SemaphoresToSignalSize. externalPrimitiveTable _ CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize). obsoleteNamedPrimitiveTable _ CArrayAccessor on: self class obsoleteNamedPrimitiveTable. obsoleteIndexedPrimitiveTable _ CArrayAccessor on: (self class obsoleteIndexedPrimitiveTable collect:[:spec| CArrayAccessor on: (spec ifNil:[Array new: 3] ifNotNil:[Array with: spec first with: spec second with: nil])]). pluginList _ #(). mappedPluginEntries _ #(). "initialize InterpreterSimulator variables used for debugging" byteCount _ 0. sendCount _ 0. traceOn _ true. myBitBlt _ BitBltSimulator new setInterpreter: self. displayForm _ Form extent: 640@480 depth: 8. "displayForm is created in response to primitiveBeDisplay, but one is need for showDisplayBits:w:h:d:left:right:top:bottom: during DoAssertionChecks" filesOpen _ OrderedCollection new. ! ! !InterpreterSimulator methodsFor: 'initialization' stamp: 'ajh 10/10/2001 14:21'! openOn: fileName "(InterpreterSimulator new openOn: 'clonex.image') test" self openOn: fileName extraMemory: 3000000.! ! !InterpreterSimulator methodsFor: 'initialization' stamp: 'ajh 10/9/2001 19:00'! openOn: fileName extraMemory: extraBytes "InterpreterSimulator new openOn: 'clone.im' extraMemory: 100000" | f version headerSize count oldBaseAddr bytesToShift swapBytes | "open image file and read the header" f _ FileStream readOnlyFileNamed: fileName. imageName _ f fullName. f binary. version _ self nextLongFrom: f. "current version: 16r1966 (=6502)" (self readableFormat: version) ifTrue: [swapBytes _ false] ifFalse: [(version _ self byteSwapped: version) = self imageFormatVersion ifTrue: [swapBytes _ true] ifFalse: [self error: 'incomaptible image format']]. headerSize _ self nextLongFrom: f swap: swapBytes. endOfMemory _ self nextLongFrom: f swap: swapBytes. "first unused location in heap" oldBaseAddr _ self nextLongFrom: f swap: swapBytes. "object memory base address of image" specialObjectsOop _ self nextLongFrom: f swap: swapBytes. lastHash _ self nextLongFrom: f swap: swapBytes. "Should be loaded from, and saved to the image header" lastHash = 0 ifTrue: [lastHash _ 999]. savedWindowSize _ self nextLongFrom: f swap: swapBytes. fullScreenFlag _ self nextLongFrom: f swap: swapBytes. extraVMMemory _ self nextLongFrom: f swap: swapBytes. "allocate interpreter memory" memoryLimit _ endOfMemory + extraBytes. "read in the image in bulk, then swap the bytes if necessary" f position: headerSize. memory _ Bitmap new: memoryLimit // 4. count _ f readInto: memory startingAt: 1 count: endOfMemory // 4. count ~= (endOfMemory // 4) ifTrue: [self halt]. f close. swapBytes ifTrue: [Utilities informUser: 'Swapping bytes of foreign image...' during: [self reverseBytesInImage]]. self initialize. bytesToShift _ 0 - oldBaseAddr. "adjust pointers for zero base address" endOfMemory _ endOfMemory. Utilities informUser: 'Relocating object pointers...' during: [self initializeInterpreter: bytesToShift]. ! ! !InterpreterSimulator methodsFor: 'testing' stamp: 'ajh 2/4/2002 23:27'! test Transcript clear. byteCount _ 0. localTrue _ trueObj. localFalse _ falseObj. self internalizeIPandSP. self fetchNextBytecode. [true] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable. byteCount _ byteCount + 1]. self externalizeIPandSP. ! ! !InterpreterSimulator methodsFor: 'debug printing' stamp: 'ajh 12/20/2001 14:51'! classAndSelectorOfMethod: meth forReceiverClass: rcvrClass | currClass classDict classDictSize methodArray i found str | str _ '' writeStream. str nextPutAll: (self nameOfClass: rcvrClass count: 5). currClass _ rcvrClass. found _ false. [found or: [currClass = nilObj]] whileFalse: [ classDict _ self fetchPointer: MessageDictionaryIndex ofObject: currClass. classDictSize _ self fetchWordLengthOf: classDict. methodArray _ self fetchPointer: MethodArrayIndex ofObject: classDict. i _ 0. [i < (classDictSize - SelectorStart) and: [found not]] whileTrue: [ meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [ rcvrClass = currClass ifFalse: [ str nextPutAll: '('. str nextPutAll: (self nameOfClass: currClass count: 5). str nextPutAll: ')']. str nextPutAll: '>>'. str nextPutAll: (self stringOf: (self fetchPointer: i + SelectorStart ofObject: classDict)). found _ true]. i _ i + 1. ]. found ifFalse: [currClass _ self fetchPointer: SuperclassIndex ofObject: currClass]. ]. found ifFalse: [ "Method not found in superclass chain" str nextPutAll: '>> a '. str nextPutAll: (self nameOfClass: (self fetchClassOf: meth) count: 5). ]. ^ str contents! ! !InterpreterSimulator methodsFor: 'debug printing' stamp: 'ajh 12/20/2001 14:46'! nameOfClass: classOop count: cnt "Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object." cnt <= 0 ifTrue: [^ 'bad class']. ^ (self sizeBitsOf: classOop) = 16r1C "(Metaclass instSize+1 * 4)" ifTrue: [(self nameOfClass: (self fetchPointer: 5 "thisClass" ofObject: classOop) count: cnt - 1), ' class'] ifFalse: [self stringOf: (self fetchPointer: 6 "name" ofObject: classOop)]! ! !InterpreterSimulator methodsFor: 'debug printing' stamp: 'ajh 1/11/2002 18:20'! printHex: anInteger traceOn ifTrue: [Transcript show: anInteger hex].! ! !InterpreterSimulator methodsFor: 'debug printing' stamp: 'ajh 1/11/2002 19:12'! shortString: oop | name classOop | (self isIntegerObject: oop) ifTrue: [^ '=' , (self integerValueOf: oop) printString , ' (' , (self integerValueOf: oop) hex , ')']. classOop _ self fetchClassOf: oop. (self sizeBitsOf: classOop) = (Metaclass instSize +1*4) ifTrue: [ ^ 'class ' , (self nameOfClass: oop)]. name _ self nameOfClass: classOop. name size = 0 ifTrue: [name _ '??']. name = 'String' ifTrue: [^ (self stringOf: oop) printString]. name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)]. name = 'Character' ifTrue: [^ '=' , (Character value: (self integerValueOf: (self fetchPointer: 0 ofObject: oop))) printString]. name = 'UndefinedObject' ifTrue: [^ 'nil']. name = 'False' ifTrue: [^ 'false']. name = 'True' ifTrue: [^ 'true']. name = 'Float' ifTrue: [^ '=' , (self floatValueOf: oop) printString]. name = 'Association' ifTrue: [^ '(' , (self shortString: (self longAt: oop + BaseHeaderSize)) , ' -> ' , (self longAt: oop + BaseHeaderSize + 4) hex8 , ')']. ('AEIOU' includes: name first) ifTrue: [^ 'an ' , name] ifFalse: [^ 'a ' , name]! ! !InterpreterSimulator methodsFor: 'debug printing' stamp: 'ajh 1/11/2002 18:25'! tab traceOn ifTrue: [ Transcript tab; endEntry ].! ! !InterpreterSimulator methodsFor: 'debug support' stamp: 'ajh 10/8/2001 12:28'! dumpMethodHeader: hdr ^ String streamContents: [:strm | strm nextPutAll: '> 28 bitAnd: 16rF) printString , '>'. strm nextPutAll: '> 22 bitAnd: 16r3F) printString , '>'. strm nextPutAll: '> 16 bitAnd: 16r3F) printString , '>'. strm nextPutAll: '> 12 bitAnd: 16rF) * 4) printString , '>'. strm nextPutAll: '> 1 bitAnd: 16r7FF) printString , '>'. ]! ! !InterpreterSimulator methodsFor: 'debug support' stamp: 'ajh 1/11/2002 19:11'! hexDump: oop | byteSize val | (self isIntegerObject: oop) ifTrue: [^ self shortString: oop]. ^ String streamContents: [:strm | byteSize _ 256 min: (self sizeBitsOf: oop)-4. (self headerStart: oop) to: byteSize by: 4 do: [:a | val _ self longAt: oop+a. strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); space; space; space; nextPutAll: val hex8; space; space. a=0 ifTrue: [strm nextPutAll: (self dumpHeader: val)] ifFalse: [strm nextPutAll: (self charsOfLong: val)]]]! ! !InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'ajh 2/12/2002 13:29'! getFieldRange "Replace top object with its n-th field value. n is encoded in bytecode and ranges from 1 to 24. This bytecodes assumes BaseHeaderSize = 4" self longAt: localSP put: (self longAt: (self longAt: localSP) + (currentBytecode-101 * 4)). self fetchNextBytecode. "out of order in super" ! ! !InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'ajh 2/12/2002 13:32'! pushLiteralRange "push literal stored in method at litOffset encoded in my bytecode" self internalPush: (self literal: currentBytecode-158). self fetchNextBytecode. "out of order in super" ! ! !InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'ajh 2/12/2002 13:28'! pushLocalRange "push frame value at spOffset from new sp. spOffset is encoded in bytecode and ranges from 1 to 24. spOffset of 1 is equivalent to duplicate" localSP _ localSP + 4. self longAt: localSP put: (self longAt: localSP - (currentBytecode-52 * 4)). self fetchNextBytecode. "out of order in super" ! ! !InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'ajh 2/12/2002 13:29'! storeLocalPopRange "pop top object into frame slot at spOffset from original sp. spOffset is encoded in my bytecode" self longAt: localSP - (currentBytecode-78 * 4) put: (self longAt: localSP). localSP _ localSP - 4. self fetchNextBytecode. "out of order in super" ! ! !InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'ajh 2/12/2002 13:29'! storeLocalRange "copy top object to frame slot at spOffset from sp. spOffset is encoded in my bytecode" self longAt: localSP - (currentBytecode-91 * 4) put: (self longAt: localSP). self fetchNextBytecode. "out of order in super" ! ! !InterpreterSimulator methodsFor: 'stepping' stamp: 'ajh 10/16/2001 16:00'! readyForStepping byteCount _ 0. localTrue _ trueObj. localFalse _ falseObj. self internalizeIPandSP. self fetchNextBytecode. self externalizeIPandSP. ! ! !InterpreterSimulator methodsFor: 'stepping' stamp: 'ajh 10/18/2001 23:22'! step self internalizeIPandSP. self dispatchOn: currentBytecode in: BytecodeTable. byteCount _ byteCount + 1. self externalizeIPandSP. ! ! !InterpreterSimulator methodsFor: 'stepping' stamp: 'ajh 10/16/2001 14:08'! stepUntilByteCount: n Transcript clear. self internalizeIPandSP. [byteCount < n] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable. byteCount _ byteCount + 1]. self externalizeIPandSP. ! ! !InterpreterSimulator methodsFor: 'stepping' stamp: 'ajh 1/20/2002 12:25'! stepUntilFrameChange | fp | Transcript clear. self internalizeIPandSP. fp _ framePointer. [framePointer = fp] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable. byteCount _ byteCount + 1]. self externalizeIPandSP. ! ! !InterpreterSimulator methodsFor: 'stepping' stamp: 'ajh 1/29/2002 03:12'! stepUntilReturn "Step until return or stack change" | fp s | Transcript clear. self internalizeIPandSP. s _ callStack. fp _ framePointer. [framePointer >= fp and: [callStack = s]] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable. byteCount _ byteCount + 1]. self externalizeIPandSP. ! ! !ObjectMemory class methodsFor: 'initialization' stamp: 'ajh 11/21/2001 13:35'! initialize "ObjectMemory initialize" "Translation flags (booleans that control code generation via conditional translation):" DoAssertionChecks _ false. "generate assertion checks" DoBalanceChecks _ false. "generate stack balance checks" self initializeSpecialObjectIndices. self initializeObjectHeaderConstants. RemapBufferSize _ 25. RootTableSize _ 2500. "number of root table entries (4 bytes/entry)" "tracer actions" StartField _ 1. StartObj _ 2. Upward _ 3. Done _ 4.! ! !ObjectMemory class methodsFor: 'initialization' stamp: 'ajh 2/7/2002 14:18'! initializeSpecialObjectIndices "Initialize indices into specialObjects array." NilObject _ 0. FalseObject _ 1. TrueObject _ 2. SchedulerAssociation _ 3. ClassBitmap _ 4. ClassInteger _ 5. ClassString _ 6. ClassArray _ 7. "SmalltalkDictionary _ 8." "Do not delete!!" ClassFloat _ 9. ClassActiveFrame _ 10. ClassBlockClosure _ 11. ClassPoint _ 12. ClassLargePositiveInteger _ 13. TheDisplay _ 14. ClassMessage _ 15. ClassCompiledMethod _ 16. TheLowSpaceSemaphore _ 17. ClassSemaphore _ 18. ClassCharacter _ 19. SelectorDoesNotUnderstand _ 20. SelectorCannotReturnFrom _ 21. TheInputSemaphore _ 22. SpecialSelectors _ 23. CharacterTable _ 24. SelectorMustBeBoolean _ 25. ClassByteArray _ 26. ClassProcess _ 27. CompactClasses _ 28. TheTimerSemaphore _ 29. TheInterruptSemaphore _ 30. FloatProto _ 31. SelectorCannotInterpret _ 34. SelectorCouldNotReturnFrom _ 35. ClassCallStack _ 36. ClassVar _ 37. ExternalObjectsArray _ 38. ClassTranslatedMethod _ 40. TheFinalizationSemaphore _ 41. ClassLargeNegativeInteger _ 42. ClassExternalAddress _ 43. ClassExternalStructure _ 44. ClassExternalData _ 45. ClassExternalFunction _ 46. ClassExternalLibrary _ 47. SelectorExecuteThenReturnFrom _ 48. ! ! !Interpreter class methodsFor: 'initialization' stamp: 'ajh 10/3/2001 13:01'! initialize "Interpreter initialize" super initialize. "initialize ObjectMemory constants" self initializeAssociationIndex. self initializeBytecodeTable. self initializeCaches. self initializeCharacterIndex. self initializeClassIndices. self initializeCompilerHooks. self initializeStackIndices. self initializeContextIndices. self initializeDirectoryLookupResultCodes. self initializeMessageIndices. self initializeMethodIndices. self initializePointIndices. self initializePrimitiveTable. self initializeSchedulerIndices. self initializeSmallIntegers. self initializeStreamIndices. SemaphoresToSignalSize _ 500. PrimitiveExternalCallIndex _ 117. "Primitive index for #primitiveExternalCall" GenerateBrowserPlugin _ false. MillisecondClockMask _ 16r1FFFFFFF. "Note: The external primitive table should actually be dynamically sized but for the sake of inferior platforms (e.g., Mac :-) who cannot allocate memory in any reasonable way, we keep it static (and cross our fingers...)" MaxExternalPrimitiveTableSize _ 4096. "entries" ! ! !Interpreter class methodsFor: 'initialization' stamp: 'ajh 10/5/2001 14:03'! initializeAssociationIndex "Class Association" ValueIndex _ 1. "Class Var" VarValueIndex _ 0. "Do not change this index unless you also change the Smalltalk compiler. It hard codes 0 in shortcut bytecodes such as pushFrameVariableSlotBytecode"! ! !Interpreter class methodsFor: 'initialization' stamp: 'ajh 2/12/2002 13:26'! initializeBytecodeTable "Interpreter initializeBytecodeTable" "This table will be used to generate a C switch statement. Note: BytecodeDecoder>>#createBytecodeTable should mirror this" BytecodeTable _ Array new: 256. self table: BytecodeTable from: #( "General send bytecode, selector on top of stack (extended - uses next byte)" (0 send) ":numArgs" "Quick send bytecodes (single - does not use next byte)" ( 1 20 send0Range) "literals 1-20, 0 args" (21 40 send1Range) "literals 1-20, 1 arg" (41 44 send2Range) "literals 1-4, 2 args" (45 send3Range) "literals 1, 3 args" (46 51 sendRange) "args 0-5, selector on top of stack" "starting ranges are hard coded in respective bytecode methods" "OrderedLiterals>> #categorySizes and #categoryForSelector: hard codes 'send#Range' sizes" "General superSend bytecode, selector on top of stack (extended)" (52 superSend) ":numArgs" "Quick push/store bytecodes (single), chosen based on bytecodeFrequency of shrunken 3.2 image" ( 53 78 pushLocalRange) "locals 1-26" ( 79 91 storeLocalPopRange) "locals 1-13" ( 92 101 storeLocalRange) "locals 1-10" (102 125 getFieldRange) "fields 1-24" (126 142 setFieldPopRange) "fields 1-17" (143 144 setFieldRange) "fields 1-2" "starting ranges are hard coded in respective bytecode methods" "Common pop and push constant bytecodes (single)" (145 popTop) (146 pushTrue) (147 pushFalse) (148 pushNil) (149 pushMinusOne) (150 pushZero) (151 pushOne) (152 pushTwo) "Jump bytecodes (extended)" (153 jumpBack) ":offset" (154 jumpForward) ":offset" (155 jumpForwardIfTrue) ":offset" (156 jumpForwardIfFalse) ":offset" (157 jumpBackInterrupt) ":offset" "#booleanCheat: hard codes 'jumpForwardIfFalse' bytecode" "Quick literal bytecodes (single)" (158 203 pushLiteralRange) "literals 1-46" "starting range is hard coded in respective bytecode method" "General push/store bytecodes (extended)" (204 pushByte) ":byte" "push SmallInteger from 0 to 255" (205 pushLocal) ":spOffset" (206 storeLocal) ":spOffset" (207 storeLocalPop) ":spOffset" (208 storeLocalInVar) ":spOffset" (209 storeLocalInVarPop) ":spOffset" (210 getField) ":fieldIndex" (211 setField) ":fieldIndex" (212 setFieldPop) ":fieldIndex" "Local return bytecodes (single)" (213 localReturnSelf) (214 localReturnTrue) (215 localReturnFalse) (216 localReturnNil) (217 localReturnTop) "Create block bytecodes (extended)" (218 createBlock) ":closureSize" (219 createReturnBlock) ":closureSize" "thisContext and remoteReturn bytecodes (single)" (220 pushThisContext) (221 remoteReturnTop) "Long jump bytecodes (double extended - uses next two bytes)" (222 longJump) ":highOffset :lowOffset" (223 longJumpIfTrue) ":highOffset :lowOffset" (224 longJumpIfFalse) ":highOffset :lowOffset" "Common send bytecodes (single)" (225 sendAdd) (226 sendSubtract) (227 sendLessThan) (228 sendGreaterThan) (229 sendLessOrEqual) (230 sendGreaterOrEqual) (231 sendEqual) (232 sendNotEqual) (233 sendMultiply) (234 sendDivide) (235 sendMod) (236 sendMakePoint) (237 sendBitShift) (238 sendDiv) (239 sendBitAnd) (240 sendBitOr) (241 sendAt) (242 sendAtPut) (243 sendSize) (244 sendNext) (245 sendNextPut) (246 sendAtEnd) (247 sendEquivalent) (248 sendClass) (249 sendValue) (250 sendValueWithArg) (251 sendDo) (252 sendNew) (253 sendNewWithArg) (254 sendX) (255 sendY) "#willSend expects all send bytecodes and only send bytecodes to be from 0 to 52 and 225 to 255" "#bytecodeLengthOf: hard codes which bytecodes have extensions and which don't" "senders of #sharedCodeNamed:inCase: hard code certain bytecodes like send and localReturnTop" ). ! ! !Interpreter class methodsFor: 'initialization' stamp: 'ajh 2/11/2002 10:33'! initializeContextIndices "Class BlockClosure" BlockMethodIndex _ 0. BlockHomeIndex _ 1. ClosureStart _ 2. "Class ActivationRecord" ContextStackIndex _ 0. ContextFrameIndex _ 1. "Context info stored on each stack frame. Offset is from framePointer, which points at ip/top slot" FrameLastArgOffset _ -2. FrameMethodOffset _ -1. FrameBitsOffset _ 0. FrameActiveOffset _ 1. "The FrameBits is a SmallInteger encoding the following:" "Bit-range Parameter" "31-17 senderIp (0-32767 bytes)" IpShift _ 17. IpMask _ 16r7FFF. "16-12 rcvrOffset (0-31 words)" ReceiverShift _ 10. ReceiverMask _ 16r7C. "11 handlerFlag (0-1)" HandlerFlagShift _ 11. HandlerFlagMask _ 1. "10-2 senderOffset (0-511 words)" SenderShift _ 0. SenderMask _ 16r7FC. "1 unwindFlag (0-1)" UnwindFlagShift _ 1. UnwindFlagMask _ 1. "0 integer bit, always 1" "SenderMask >> 2 > (maxArgs + maxFrameStackInWords + 3)" "ReceiverMask >> 2 > (maxArgs - FrameLastArgOffset)" "IpMask > largest method bytecodes size" "IpShift and IpMask are also used by the CallStack, see initializeStackIndices"! ! !Interpreter class methodsFor: 'initialization' stamp: 'ajh 10/3/2001 13:14'! initializeMethodIndices "Class CompiledMethod" HeaderIndex _ 0. BytecodesIndex _ 1. TrailerIndex _ 2. LiteralStart _ 3. ! ! !Interpreter class methodsFor: 'initialization' stamp: 'ajh 2/7/2002 14:13'! initializePrimitiveTable "This table generates a C switch statement for primitive dispatching." "NOTE: The real limit here is 2047, but our C compiler currently barfs over 700" MaxPrimitiveIndex _ 700. PrimitiveTable _ Array new: MaxPrimitiveIndex + 1. self table: PrimitiveTable from: #( "Integer Primitives (0-19)" (0 primitiveFail) (1 primitiveAdd) (2 primitiveSubtract) (3 primitiveLessThan) (4 primitiveGreaterThan) (5 primitiveLessOrEqual) (6 primitiveGreaterOrEqual) (7 primitiveEqual) (8 primitiveNotEqual) (9 primitiveMultiply) (10 primitiveDivide) (11 primitiveMod) (12 primitiveDiv) (13 primitiveQuo) (14 primitiveBitAnd) (15 primitiveBitOr) (16 primitiveBitXor) (17 primitiveBitShift) (18 primitiveMakePoint) (19 primitiveFail) "Guard primitive for simulation -- *must* fail" "LargeInteger Primitives (20-39)" "32-bit logic is aliased to Integer prims above" (20 39 primitiveFail) "Float Primitives (40-59)" (40 primitiveAsFloat) (41 primitiveFloatAdd) (42 primitiveFloatSubtract) (43 primitiveFloatLessThan) (44 primitiveFloatGreaterThan) (45 primitiveFloatLessOrEqual) (46 primitiveFloatGreaterOrEqual) (47 primitiveFloatEqual) (48 primitiveFloatNotEqual) (49 primitiveFloatMultiply) (50 primitiveFloatDivide) (51 primitiveTruncated) (52 primitiveFractionalPart) (53 primitiveExponent) (54 primitiveTimesTwoPower) (55 primitiveSquareRoot) (56 primitiveSine) (57 primitiveArctan) (58 primitiveLogN) (59 primitiveExp) "Subscript and Stream Primitives (60-67)" (60 primitiveAt) (61 primitiveAtPut) (62 primitiveSize) (63 primitiveStringAt) (64 primitiveStringAtPut) (65 primitiveNext) (66 primitiveNextPut) (67 primitiveAtEnd) "StorageManagement Primitives (68-79)" (68 primitiveObjectAt) (69 primitiveObjectAtPut) (70 primitiveNew) (71 primitiveNewWithArg) (72 primitiveArrayBecomeOneWay) "Blue Book: primitiveBecome" (73 primitiveInstVarAt) (74 primitiveInstVarAtPut) (75 primitiveAsOop) (76 primitiveStoreStackp) "Blue Book: primitiveAsObject" (77 primitiveSomeInstance) (78 primitiveNextInstance) (79 primitiveCapacity) "was primitiveNewMethod" "Control Primitives (80-89)" (80 primitiveNewStack) "was primitiveBlockCopy" (81 primitiveValue) (82 primitiveValueWithArgs) (83 primitivePerform) (84 primitivePerformWithArgs) (85 primitiveSignal) (86 primitiveWait) (87 primitiveResume) (88 primitiveSuspend) (89 primitiveFlushCache) "Input/Output Primitives (90-109)" (90 primitiveMousePoint) (91 primitiveTestDisplayDepth) "Blue Book: primitiveCursorLocPut" (92 primitiveSetDisplayMode) "Blue Book: primitiveCursorLink" (93 primitiveInputSemaphore) (94 primitiveGetNextEvent) "Blue Book: primitiveSampleInterval" (95 primitiveInputWord) (96 primitiveObsoleteIndexedPrimitive) "primitiveCopyBits" (97 primitiveSnapshot) (98 primitiveStoreImageSegment) (99 primitiveLoadImageSegment) (100 primitivePerformInSuperclass) "Blue Book: primitiveSignalAtTick" (101 primitiveBeCursor) (102 primitiveBeDisplay) (103 primitiveScanCharacters) (104 primitiveObsoleteIndexedPrimitive) "primitiveDrawLoop" (105 primitiveStringReplace) (106 primitiveScreenSize) (107 primitiveMouseButtons) (108 primitiveKbdNext) (109 primitiveKbdPeek) "System Primitives (110-119)" (110 primitiveEquivalent) (111 primitiveClass) (112 primitiveBytesLeft) (113 primitiveQuit) (114 primitiveExitToDebugger) (115 primitiveChangeClass) "Blue Book: primitiveOopsLeft" (116 primitiveFlushCacheByMethod) (117 primitiveExternalCall) (118 primitiveDoPrimitiveWithArgs) (119 primitiveFlushCacheSelective) "Squeak 2.2 and earlier use 119. Squeak 2.3 and later use 116. Both are supported for backward compatibility." "Miscellaneous Primitives (120-127)" (120 primitiveCalloutToFFI) (121 primitiveImageName) (122 primitiveNoop) "Blue Book: primitiveImageVolume" (123 primitiveFail) "was primitiveValueUninterruptably @@@: Remove this when all VMs have support" (124 primitiveLowSpaceSemaphore) (125 primitiveSignalAtBytesLeft) "Squeak Primitives Start Here" "Squeak Miscellaneous Primitives (128-149)" (126 primitiveDeferDisplayUpdates) (127 primitiveShowDisplayRect) (128 primitiveArrayBecome) (129 primitiveSpecialObjectsOop) (130 primitiveFullGC) (131 primitiveIncrementalGC) (132 primitiveObjectPointsTo) (133 primitiveSetInterruptKey) (134 primitiveInterruptSemaphore) (135 primitiveMillisecondClock) (136 primitiveSignalAtMilliseconds) (137 primitiveSecondsClock) (138 primitiveSomeObject) (139 primitiveNextObject) (140 primitiveBeep) (141 primitiveClipboardText) (142 primitiveVMPath) (143 primitiveShortAt) (144 primitiveShortAtPut) (145 primitiveConstantFill) "NOTE: When removing the obsolete indexed primitives, the following two should go become #primitiveIntegerAt / atPut" (146 primitiveObsoleteIndexedPrimitive) "primitiveReadJoystick" (147 primitiveObsoleteIndexedPrimitive) "primitiveWarpBits" (148 primitiveClone) (149 primitiveGetAttribute) "File Primitives (150-169) - NO LONGER INDEXED" (150 164 primitiveObsoleteIndexedPrimitive) (165 primitiveIntegerAt) "hacked in here for now" (166 primitiveIntegerAtPut) (167 168 primitiveFail) (169 primitiveObsoleteIndexedPrimitive) "Sound Primitives (170-199) - NO LONGER INDEXED" (170 185 primitiveObsoleteIndexedPrimitive) (186 188 primitiveFail) (189 194 primitiveObsoleteIndexedPrimitive) "Unwind primitives" (195 primitiveFail) "was primitiveFindNextUnwindContext" (196 primitiveReturnFrom) "was primitiveTerminateTo" (197 primitiveFail) "was primitiveFindHandlerContext" (198 primitiveFail) "was primitiveMarkUnwindMethod" (199 primitiveFail) "was primitiveMarkHandlerMethod" "Networking Primitives (200-229) - NO LONGER INDEXED" (200 225 primitiveObsoleteIndexedPrimitive) (226 229 primitiveFail) "Other Primitives (230-249)" (230 primitiveRelinquishProcessor) (231 primitiveForceDisplayUpdate) (232 primitiveFormPrint) (233 primitiveSetFullScreen) (234 primitiveObsoleteIndexedPrimitive) "primBitmapdecompressfromByteArrayat" (235 primitiveObsoleteIndexedPrimitive) "primStringcomparewithcollated" (236 primitiveObsoleteIndexedPrimitive) "primSampledSoundconvert8bitSignedFromto16Bit" (237 primitiveObsoleteIndexedPrimitive) "primBitmapcompresstoByteArray" (238 241 primitiveObsoleteIndexedPrimitive) "serial port primitives" (242 primitiveFail) (243 primitiveObsoleteIndexedPrimitive) "primStringtranslatefromtotable" (244 primitiveObsoleteIndexedPrimitive) "primStringfindFirstInStringinSetstartingAt" (245 primitiveObsoleteIndexedPrimitive) "primStringindexOfAsciiinStringstartingAt" (246 primitiveObsoleteIndexedPrimitive) "primStringfindSubstringinstartingAtmatchTable" (247 primitiveSnapshotEmbedded) (248 249 primitiveFail) "VM Implementor Primitives (250-255)" (250 clearProfile) (251 dumpProfile) (252 startProfiling) (253 stopProfiling) (254 primitiveVMParameter) (255 primitiveInstVarsPutFromStack) "Never used except in Disney tests. Remove after 2.3 release." "Quick Push Const Methods" (256 primitivePushSelf) (257 primitivePushTrue) (258 primitivePushFalse) (259 primitivePushNil) (260 primitivePushMinusOne) (261 primitivePushZero) (262 primitivePushOne) (263 primitivePushTwo) "Quick Push Const Methods" (264 519 primitiveLoadInstVar) "MIDI Primitives (520-539) - NO LONGER INDEXED" (520 529 primitiveObsoleteIndexedPrimitive) (530 539 primitiveFail) "reserved for extended MIDI primitives" "Experimental Asynchrous File Primitives - NO LONGER INDEXED" (540 545 primitiveObsoleteIndexedPrimitive) (546 547 primitiveFail) "Pen Tablet Primitives - NO LONGER INDEXED" (548 primitiveObsoleteIndexedPrimitive) (549 primitiveObsoleteIndexedPrimitive) "Sound Codec Primitives - NO LONGER INDEXED" (550 553 primitiveObsoleteIndexedPrimitive) (554 569 primitiveFail) "External primitive support primitives" (570 primitiveFlushExternalPrimitives) (571 primitiveUnloadModule) (572 primitiveListBuiltinModule) (573 primitiveListExternalModule) (574 primitiveFail) "reserved for addl. external support prims" "Unassigned Primitives" (575 700 primitiveFail)). ! ! !Interpreter class methodsFor: 'initialization' stamp: 'ajh 1/7/2002 18:52'! initializeSchedulerIndices "Class ProcessorScheduler" ProcessListsIndex _ 0. ActiveProcessIndex _ 1. "Class LinkedList" FirstLinkIndex _ 0. LastLinkIndex _ 1. "Class Semaphore" ExcessSignalsIndex _ 2. "Class Link" NextLinkIndex _ 0. "Class Process" StackIndex _ 1. PriorityIndex _ 2. MyListIndex _ 3. ! ! !Interpreter class methodsFor: 'initialization' stamp: 'ajh 2/7/2002 00:09'! initializeStackIndices "Class CallStack" StackCCIndex _ 4. "compact class index" "The following class vars are stored in super (ObjectMemory)" StackTopIndex _ 0. TopFrameIpFpIndex _ 1. PreviousStackIndex _ 2. StackProcessIndex _ 3. StackStart _ 4. "TopFrameIpFpIndex holds a SmallInteger encoding the following: Bit-range Parameter" "31-17 ip (0-32767 bytes) IpShift/IpMask initialized in initializeContextIndices" "16-1 fpIndex (0-65535 words)" StackFpMask _ 16rFFFF. "0 integer bit, always 1" ! ! !Interpreter class methodsFor: 'translation' stamp: 'ajh 2/12/2002 06:38'! declareCVarsIn: aCCodeGenerator aCCodeGenerator var: #interpreterProxy type: #'struct VirtualMachine*'. aCCodeGenerator var: #methodCache declareC: 'int methodCache[', (MethodCacheSize + 1) printString, ']'. aCCodeGenerator var: #atCache declareC: 'int atCache[', (AtCacheTotalSize + 1) printString, ']'. aCCodeGenerator var: #localIP type: #'char*'. aCCodeGenerator var: #localSP type: #'char*'. aCCodeGenerator var: 'semaphoresToSignalA' declareC: 'int semaphoresToSignalA[', (SemaphoresToSignalSize + 1) printString, ']'. aCCodeGenerator var: 'semaphoresToSignalB' declareC: 'int semaphoresToSignalB[', (SemaphoresToSignalSize + 1) printString, ']'. aCCodeGenerator var: #compilerHooks declareC: 'int (*compilerHooks[', (CompilerHooksSize + 1) printString, '])()'. aCCodeGenerator var: #interpreterVersion declareC: 'const char *interpreterVersion = "', Smalltalk datedVersion, '[BC] [', Smalltalk lastUpdateString,']"'. aCCodeGenerator var: #obsoleteIndexedPrimitiveTable declareC: 'char* obsoleteIndexedPrimitiveTable[][3] = ', self obsoleteIndexedPrimitiveTableString. aCCodeGenerator var: #obsoleteNamedPrimitiveTable declareC: 'const char* obsoleteNamedPrimitiveTable[][3] = ', self obsoleteNamedPrimitiveTableString. aCCodeGenerator var: #externalPrimitiveTable declareC: 'int externalPrimitiveTable[', (MaxExternalPrimitiveTableSize + 1) printString, ']'. ! ! !Interpreter class methodsFor: 'translation' stamp: 'tpr 10/17/2000 14:23'! translateInDirectory: directory doInlining: inlineFlag forBrowserPlugin: pluginFlag "Translate the Smalltalk description of the virtual machine into C. If inlineFlag is true, small method bodies are inlined to reduce procedure call overhead. On the PPC, this results in a factor of three speedup with only 30% increase in code size. If pluginFlag is true, generate code for an interpreter that runs as a browser plugin (Netscape or IE)." "Note: The pluginFlag is meaningless on Windows and Unix. On these platforms Squeak runs as it's own process and doesn't need any special attention from the VMs point of view. Meaning that NONE of the required additional functions will be supported. In other words, the pluginFlag is not needed and not supported." "Return the list of exports for this module" | doInlining cg exports fileName| doInlining _ inlineFlag. pluginFlag ifTrue: [doInlining _ true]. "must inline when generating browser plugin" Interpreter initialize. ObjectMemory initialize. GenerateBrowserPlugin _ pluginFlag. cg _ CCodeGenerator new initialize. cg addClass: Interpreter. cg addClass: ObjectMemory. Interpreter declareCVarsIn: cg. ObjectMemory declareCVarsIn: cg. "Get all the named prims from the VM. Note: the format of exports is: pluginName -> Array of: primitiveName. so we can generate a nice table from it." exports _ '' -> cg exportedPrimitiveNames asArray. fileName _ directory fullNameFor: 'interp.c'. cg storeCodeOnFile: fileName doInlining: doInlining. ^exports! ! Interpreter initialize! ObjectMemory initialize! InterpreterSimulator removeSelector: #longPrint:! InterpreterSimulator removeSelector: #printCallStackVarsOf:! InterpreterSimulator removeSelector: #printStack! InterpreterSimulator removeSelector: #pushLiteralConstantBytecode! InterpreterSimulator removeSelector: #pushLiteralVariableBytecode! InterpreterSimulator removeSelector: #pushReceiverVariableBytecode! InterpreterSimulator removeSelector: #pushTemporaryVariableBytecode! InterpreterSimulator removeSelector: #shortPrint:! InterpreterSimulator removeSelector: #stackDepth! InterpreterSimulator removeSelector: #storeAndPopReceiverVariableBytecode! InterpreterSimulator removeSelector: #storeAndPopTemporaryVariableBytecode! InterpreterSimulator removeSelector: #validateActiveContext! Interpreter removeSelector: #activeFrameObj! Interpreter removeSelector: #bytecodePrimAdd! Interpreter removeSelector: #bytecodePrimAt! Interpreter removeSelector: #bytecodePrimAtEnd! Interpreter removeSelector: #bytecodePrimAtPut! Interpreter removeSelector: #bytecodePrimBitAnd! Interpreter removeSelector: #bytecodePrimBitOr! Interpreter removeSelector: #bytecodePrimBitShift! Interpreter removeSelector: #bytecodePrimBlockCopy! Interpreter removeSelector: #bytecodePrimClass! Interpreter removeSelector: #bytecodePrimDiv! Interpreter removeSelector: #bytecodePrimDivide! Interpreter removeSelector: #bytecodePrimDo! Interpreter removeSelector: #bytecodePrimEqual! Interpreter removeSelector: #bytecodePrimEquivalent! Interpreter removeSelector: #bytecodePrimGreaterOrEqual! Interpreter removeSelector: #bytecodePrimGreaterThan! Interpreter removeSelector: #bytecodePrimLessOrEqual! Interpreter removeSelector: #bytecodePrimLessThan! Interpreter removeSelector: #bytecodePrimMakePoint! Interpreter removeSelector: #bytecodePrimMod! Interpreter removeSelector: #bytecodePrimMultiply! Interpreter removeSelector: #bytecodePrimNew! Interpreter removeSelector: #bytecodePrimNewWithArg! Interpreter removeSelector: #bytecodePrimNext! Interpreter removeSelector: #bytecodePrimNextPut! Interpreter removeSelector: #bytecodePrimNotEqual! Interpreter removeSelector: #bytecodePrimPointX! Interpreter removeSelector: #bytecodePrimPointY! Interpreter removeSelector: #bytecodePrimSize! Interpreter removeSelector: #bytecodePrimSubtract! Interpreter removeSelector: #bytecodePrimValue! Interpreter removeSelector: #bytecodePrimValueWithArg! Interpreter removeSelector: #caller! Interpreter removeSelector: #cannotReturn:! Interpreter removeSelector: #cleanUpContexts! Interpreter removeSelector: #context:hasSender:! Interpreter removeSelector: #doubleExtendedDoAnythingBytecode! Interpreter removeSelector: #duplicateTopBytecode! Interpreter removeSelector: #errorPoppedAllTryingToReturn:from:! Interpreter removeSelector: #experimentalBytecode! Interpreter removeSelector: #extendedPushBytecode! Interpreter removeSelector: #extendedStoreAndPopBytecode! Interpreter removeSelector: #extendedStoreBytecode! Interpreter removeSelector: #fetchContextRegisters:! Interpreter removeSelector: #fpOffsetIn:! Interpreter removeSelector: #headerOfFp:! Interpreter removeSelector: #internalAboutToReturn:through:! Interpreter removeSelector: #internalCannotReturn:! Interpreter removeSelector: #internalFetchContextRegisters:! Interpreter removeSelector: #internalLoadFrameResumePosition! Interpreter removeSelector: #internalLoadPreviousFrameFrom:senderOffset:! Interpreter removeSelector: #internalNewActiveContext:! Interpreter removeSelector: #internalPopStack! Interpreter removeSelector: #internalPrimitiveValue! Interpreter removeSelector: #internalPushNils:! Interpreter removeSelector: #internalResumeUnwind:thenReturn:from:! Interpreter removeSelector: #internalSaveFrameResumePosition! Interpreter removeSelector: #internalStoreContextRegisters:! Interpreter removeSelector: #internalWouldStackOverflow:! Interpreter removeSelector: #ipAndTopOfFp:! Interpreter removeSelector: #ipOfHeader:method:! Interpreter removeSelector: #isContext:header:! Interpreter removeSelector: #isContextHeader:! Interpreter removeSelector: #isHandlerMarked:! Interpreter removeSelector: #isMethodContextHeader:! Interpreter removeSelector: #isUnwindMarked:! Interpreter removeSelector: #isValidFrame:! Interpreter removeSelector: #jump! Interpreter removeSelector: #jumpBackAndCheckInterrupt! Interpreter removeSelector: #jumpIfFalse! Interpreter removeSelector: #jumpIfTrue! Interpreter removeSelector: #jumplfFalseBy:! Interpreter removeSelector: #jumplfTrueBy:! Interpreter removeSelector: #literalCountOfHeader:! Interpreter removeSelector: #loadFrameResumePosition! Interpreter removeSelector: #loadStackResumePosition! Interpreter removeSelector: #loadStackTopPosition! Interpreter removeSelector: #localReturn:! Interpreter removeSelector: #longUnconditionalJump! Interpreter removeSelector: #newActiveContext:! Interpreter removeSelector: #newFrameHeader:! Interpreter removeSelector: #newSenderAndUnwindBits:! Interpreter removeSelector: #popStackBytecode! Interpreter removeSelector: #popTopFrame:! Interpreter removeSelector: #positive64BitIntegerFor:! Interpreter removeSelector: #positive64BitValueOf:! Interpreter removeSelector: #primitiveBlockCopy! Interpreter removeSelector: #primitiveFindHandlerContext! Interpreter removeSelector: #primitiveFindNextUnwindContext! Interpreter removeSelector: #primitiveMarkHandlerMethod! Interpreter removeSelector: #primitiveMarkUnwindMethod! Interpreter removeSelector: #primitiveNewMethod! Interpreter removeSelector: #primitiveReturnTo! Interpreter removeSelector: #primitiveTerminateProcess! Interpreter removeSelector: #primitiveTerminateTo! Interpreter removeSelector: #primitiveValueUninterruptably! Interpreter removeSelector: #pushActiveContextBytecode! Interpreter removeSelector: #pushConstantFalseBytecode! Interpreter removeSelector: #pushConstantMinusOneBytecode! Interpreter removeSelector: #pushConstantNilBytecode! Interpreter removeSelector: #pushConstantOneBytecode! Interpreter removeSelector: #pushConstantTrueBytecode! Interpreter removeSelector: #pushConstantTwoBytecode! Interpreter removeSelector: #pushConstantZeroBytecode! Interpreter removeSelector: #pushLiteralConstant:! Interpreter removeSelector: #pushLiteralConstantBytecode! Interpreter removeSelector: #pushLiteralVariable:! Interpreter removeSelector: #pushLiteralVariableBytecode! Interpreter removeSelector: #pushReceiverBytecode! Interpreter removeSelector: #pushReceiverVariable:! Interpreter removeSelector: #pushReceiverVariableBytecode! Interpreter removeSelector: #pushTemporaryVariable:! Interpreter removeSelector: #pushTemporaryVariableBytecode! Interpreter removeSelector: #restoreProcessStacks! Interpreter removeSelector: #resumeUnwind:thenReturn:from:! Interpreter removeSelector: #resumeUnwind:thenReturn:to:! Interpreter removeSelector: #return:to:! Interpreter removeSelector: #returnFalse! Interpreter removeSelector: #returnNil! Interpreter removeSelector: #returnReceiver! Interpreter removeSelector: #returnTopFromBlock! Interpreter removeSelector: #returnTopFromMethod! Interpreter removeSelector: #returnTrue! Interpreter removeSelector: #returnValue:to:! Interpreter removeSelector: #saveFrameResumePosition:! Interpreter removeSelector: #saveStackResumePosition! Interpreter removeSelector: #saveStackTopPosition! Interpreter removeSelector: #secondExtendedSendBytecode! Interpreter removeSelector: #sendLiteralSelectorBytecode! Interpreter removeSelector: #sender! Interpreter removeSelector: #senderAndUnwindOfFp:! Interpreter removeSelector: #shortConditionalJump! Interpreter removeSelector: #shortUnconditionalJump! Interpreter removeSelector: #signed64BitIntegerFor:! Interpreter removeSelector: #signed64BitValueOf:! Interpreter removeSelector: #singleExtendedSendBytecode! Interpreter removeSelector: #singleExtendedSuperBytecode! Interpreter removeSelector: #stackIndexForPtr:! Interpreter removeSelector: #stackPointerIndex! Interpreter removeSelector: #stackPtrForIndex:! Interpreter removeSelector: #storeAndPopReceiverVariableBytecode! Interpreter removeSelector: #storeAndPopTemporaryVariableBytecode! Interpreter removeSelector: #storeContextRegisters:! Interpreter removeSelector: #storeInstructionPointerValue:inContext:! Interpreter removeSelector: #storeIp:andSp:ofFp:andMethod:! Interpreter removeSelector: #storeStackPointerValue:inContext:! Interpreter removeSelector: #terminateProcess! Interpreter removeSelector: #topFpOffsetIn:! Interpreter removeSelector: #topOffsetIn:! Interpreter removeSelector: #unwindTagIn:! Interpreter removeSelector: #unwindThenTerminate:! Interpreter removeSelector: #wouldStackOverflow:! ObjectMemory subclass: #Interpreter instanceVariableNames: 'process callStack endOfStack framePointer instructionPointer stackPointer method localIP localSP messageSelector argumentCount newMethod currentBytecode successFlag primitiveIndex methodCache atCache lkupClass nextPollTick nextWakeupTick lastTick interruptKeycode interruptPending semaphoresToSignalA semaphoresUseBufferA semaphoresToSignalCountA semaphoresToSignalB semaphoresToSignalCountB savedWindowSize fullScreenFlag deferDisplayUpdates pendingFinalizationSignals compilerInitialized compilerHooks extraVMMemory newNativeMethod methodClass receiverClass interpreterVersion obsoleteIndexedPrimitiveTable obsoleteNamedPrimitiveTable interpreterProxy showSurfaceFn interruptCheckCounterFeedBackReset interruptChecksEveryNms externalPrimitiveTable freeStack localReturnValue localTrue localFalse ' classVariableNames: 'ActiveProcessIndex AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase BlockHomeIndex BlockMethodIndex BytecodeTable BytecodesIndex CacheProbeMax CharacterValueIndex ClosureStart CompilerHooksSize ContextFrameIndex ContextStackIndex CrossedX DirBadPath DirEntryFound DirNoMoreEntries EndOfRun ExcessSignalsIndex FirstLinkIndex FrameActiveOffset FrameBitsOffset FrameLastArgOffset FrameMethodOffset GenerateBrowserPlugin HandlerFlagMask HandlerFlagShift HeaderIndex InstanceSpecificationIndex IpMask IpShift JitterTable LastLinkIndex LiteralStart MaxExternalPrimitiveTableSize MaxPrimitiveIndex MessageArgumentsIndex MessageDictionaryIndex MessageLookupClassIndex MessageSelectorIndex MethodArrayIndex MethodCacheClass MethodCacheEntries MethodCacheEntrySize MethodCacheMask MethodCacheMethod MethodCacheNative MethodCachePrim MethodCacheSelector MethodCacheSize MillisecondClockMask MyListIndex NextLinkIndex PrimitiveExternalCallIndex PrimitiveTable PriorityIndex ProcessListsIndex ReceiverMask ReceiverShift SelectorStart SemaphoresToSignalSize SenderMask SenderShift StackCCIndex StackFpMask StackIndex StackProcessIndex StreamArrayIndex StreamIndexIndex StreamReadLimitIndex StreamWriteLimitIndex SuperclassIndex TopFrameIpFpIndex TrailerIndex UnwindFlagMask UnwindFlagShift ValueIndex VarValueIndex XIndex YIndex ' poolDictionaries: '' category: 'VMConstruction-Interpreter'! ObjectMemory removeSelector: #allocateOrRecycleContext:! ObjectMemory removeSelector: #instantiateContext:sizeInBytes:! ObjectMemory removeSelector: #instantiateSmallClass:sizeInBytes:fill:! ObjectMemory removeSelector: #recycleContextIfPossible:! Object subclass: #ObjectMemory instanceVariableNames: 'memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop rootTable rootTableCount child field parentField freeBlock lastHash allocationCount lowSpaceThreshold signalLowSpace compStart compEnd fwdTableNext fwdTableLast remapBuffer remapBufferCount allocationsBetweenGCs tenuringThreshold statFullGCs statFullGCMSecs statIncrGCs statIncrGCMSecs statTenures statRootTableOverflows interruptCheckCounter displayBits totalObjectCount shrinkThreshold growHeadroom defaultStackSize ' classVariableNames: 'AllButHashBits AllButMarkBit AllButMarkBitAndTypeMask AllButRootBit AllButTypeMask BaseHeaderSize CharacterTable ClassActiveFrame ClassArray ClassBitmap ClassBlockClosure ClassByteArray ClassCallStack ClassCharacter ClassCompiledMethod ClassExternalAddress ClassExternalData ClassExternalFunction ClassExternalLibrary ClassExternalStructure ClassFloat ClassInteger ClassLargeNegativeInteger ClassLargePositiveInteger ClassMessage ClassPoint ClassProcess ClassSemaphore ClassString ClassTranslatedMethod ClassVar CompactClassMask CompactClasses ConstMinusOne ConstOne ConstTwo ConstZero DoAssertionChecks DoBalanceChecks Done ExternalObjectsArray FalseObject FloatProto GCTopMarker HashBits HashBitsOffset HeaderTypeClass HeaderTypeFree HeaderTypeGC HeaderTypeShort HeaderTypeSizeAndClass MarkBit NilObject PreviousStackIndex RemapBufferSize RootBit RootTableSize SchedulerAssociation SelectorCannotInterpret SelectorCannotReturnFrom SelectorCouldNotReturnFrom SelectorDoesNotUnderstand SelectorExecuteThenReturnFrom SelectorMustBeBoolean SizeMask SpecialSelectors StackStart StackTopIndex StartField StartObj TheDisplay TheFinalizationSemaphore TheInputSemaphore TheInterruptSemaphore TheLowSpaceSemaphore TheTimerSemaphore TrueObject TypeMask Upward ' poolDictionaries: '' category: 'VMConstruction-Interpreter'!