'From Squeak3.4alpha of ''11 November 2002'' [latest update: #5109] on 29 December 2002 at 11:48:06 pm'! "Change Set: voidIsVoidNotInt Date: 24 November 2002 Author: johnmci@smalltalkconsulting.com Fix various parts of the interpreter, plus SLANG to extrude C code that ensures there are no extra variables that are not needed in methods, and that the return type of void matchs the return type of the method. This removes hundreds of warning messages from a compile"! Object subclass: #TMethod instanceVariableNames: 'selector returnType args locals declarations primitive parseTree labels possibleSideEffectsCache complete export static comment definingClass globalStructureBuildMethodHasFoo ' classVariableNames: 'CaseStatements ' poolDictionaries: '' category: 'VMConstruction-Translation to C'! !BalloonEngineBase methodsFor: 'displaying' stamp: 'JMM 11/23/2002 22:39'! fillColorSpan: pixelValue32 from: leftX to: rightX "Fill the span buffer between leftEdge and rightEdge with the given pixel value." | x0 x1 | self inline: true. "Use a unrolled version for anti-aliased fills..." self aaLevelGet = 1 ifFalse:[self fillColorSpanAA: pixelValue32 x0: leftX x1: rightX. self cCode: 'return' inSmalltalk: [^self]]. x0 _ leftX. x1 _ rightX. "Unroll the inner loop four times, since we're only storing data." [x0 + 4 < x1] whileTrue:[ spanBuffer at: x0 put: pixelValue32. spanBuffer at: x0+1 put: pixelValue32. spanBuffer at: x0+2 put: pixelValue32. spanBuffer at: x0+3 put: pixelValue32. x0 _ x0+4. ]. [x0 < x1] whileTrue:[ spanBuffer at: x0 put: pixelValue32. x0 _ x0 + 1. ].! ! !BalloonEnginePlugin methodsFor: 'lines-wide' stamp: 'JMM 11/23/2002 22:42'! stepToFirstWideLine "Initialize the current entry in the GET by stepping to the current scan line" self inline: true. self stepToFirstWideLineIn: (getBuffer at: self getStartGet) at: self currentYGet! ! !BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'JMM 11/23/2002 22:41'! stepToFirstWideBezier "Initialize the current entry in the GET by stepping to the current scan line" self inline: true. self stepToFirstWideBezierIn: (getBuffer at: self getStartGet) at: self currentYGet! ! !BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'JMM 11/23/2002 22:40'! fillLinearGradient self inline: true. self fillLinearGradient: self lastExportedFillGet from: self lastExportedLeftXGet to: self lastExportedRightXGet at: self currentYGet! ! !BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'JMM 11/23/2002 22:41'! fillRadialGradient self inline: true. self fillRadialGradient: self lastExportedFillGet from: self lastExportedLeftXGet to: self lastExportedRightXGet at: self currentYGet! ! !CCodeGenerator methodsFor: 'C code generator' stamp: 'JMM 11/21/2002 15:28'! emitCHeaderOn: aStream "Write a C file header onto the given stream." aStream nextPutAll: '/* Automatically generated from Squeak on '. aStream nextPutAll: Time dateAndTimeNow printString. aStream nextPutAll: ' */'; cr; cr. aStream nextPutAll: '#include "sq.h"'; cr. "Additional header files" headerFiles do:[:hdr| aStream nextPutAll:'#include '; nextPutAll: hdr; cr]. aStream nextPutAll: ' /* memory access macros */ #define byteAt(i) (*((unsigned char *) (i))) #define byteAtput(i, val) (*((unsigned char *) (i)) = val) #define longAt(i) (*((int *) (i))) #define longAtput(i, val) (*((int *) (i)) = val) void printCallStack(void); void error(char *s); void error(char *s) { /* Print an error message and exit. */ static int printingStack = false; printf("\n%s\n\n", s); if (!!printingStack) { /* flag prevents recursive error when trying to print a broken stack */ printingStack = true; printCallStack(); } exit(-1); } '. aStream cr.! ! !LargeIntegersPlugin methodsFor: 'debugging' stamp: 'JMM 11/21/2002 14:49'! think "Flag for marking methods for later thinking." self msg: '#think should not be called'! ! !ObjectMemory methodsFor: 'garbage collection' stamp: 'JMM 11/24/2002 23:17'! incrementalGC "Do a mark/sweep garbage collection of just the young object area of object memory (i.e., objects above youngStart), using the root table to identify objects containing pointers to young objects from the old object area." | survivorCount startTime | self inline: false. rootTableCount >= RootTableSize ifTrue: [ "root table overflow; cannot do an incremental GC (this should be very rare)" statRootTableOverflows _ statRootTableOverflows + 1. self fullGC. self cCode: 'return' inSmalltalk: [^self]]. DoAssertionChecks ifTrue: [self reverseDisplayFrom: 8 to: 15]. DoAssertionChecks ifTrue: [self validateRoots]. self preGCAction: false. "incremental GC and compaction" startTime _ self ioMicroMSecs. self markPhase. survivorCount _ self sweepPhase. self incrementalCompaction. allocationCount _ 0. statIncrGCs _ statIncrGCs + 1. statIncrGCMSecs _ statIncrGCMSecs + (self ioMicroMSecs - startTime). survivorCount > tenuringThreshold ifTrue: [ "move up the young space boundary if there are too many survivors; this limits the number of objects that must be processed on future incremental GC's" statTenures _ statTenures + 1. self clearRootsTable. youngStart _ freeBlock. "reset the young object boundary" ]. self postGCAction. DoAssertionChecks ifTrue: [self reverseDisplayFrom: 8 to: 15]. ! ! !ObjectMemory methodsFor: 'garbage collection' stamp: 'JMM 11/26/2002 13:28'! lowestFreeAfter: chunk "Return the first free block after the given chunk in memory." | oop oopHeader oopHeaderType oopSize | self inline: false. oop _ self oopFromChunk: chunk. [oop < endOfMemory] whileTrue: [ oopHeader _ self baseHeader: oop. oopHeaderType _ oopHeader bitAnd: TypeMask. (oopHeaderType = HeaderTypeFree) ifTrue: [ ^ oop ] ifFalse: [ oopHeaderType = HeaderTypeSizeAndClass ifTrue: [ oopSize _ (self sizeHeader: oop) bitAnd: AllButTypeMask ] ifFalse: [ oopSize _ oopHeader bitAnd: SizeMask ]. ]. oop _ self oopFromChunk: (oop + oopSize). ]. self error: 'expected to find at least one free object'. ^0 ! ! !ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'JMM 11/26/2002 13:30'! markAndTrace: oop "Mark all objects reachable from the given one. Trace from the given object even if it is old. Do not trace if it is already marked. Mark it only if it is a young object." "Tracer state variables: child object being examined field next field of child to examine parentField field where child was stored in its referencing object" | header lastFieldOffset action | header _ self longAt: oop. (header bitAnd: MarkBit) = 0 ifFalse: [self cCode: 'return' inSmalltalk: [^self] "already marked"]. "record tracing status in object's header" header _ (header bitAnd: AllButTypeMask) bitOr: HeaderTypeGC. oop >= youngStart ifTrue: [ header _ header bitOr: MarkBit ]. "mark only if young" self longAt: oop put: header. "initialize the tracer state machine" parentField _ GCTopMarker. child _ oop. lastFieldOffset _ self lastPointerOf: oop. field _ oop + lastFieldOffset. action _ StartField. "run the tracer state machine until all objects reachable from oop are marked" [action = Done] whileFalse: [ action = StartField ifTrue: [ action _ self startField ]. action = StartObj ifTrue: [ action _ self startObj ]. action = Upward ifTrue: [ action _ self upward ]. ].! ! !ObjectMemory methodsFor: 'finalization' stamp: 'JMM 11/26/2002 13:25'! firstAccessibleObject "Return the first accessible object in the heap." | obj | obj _ self firstObject. [obj < endOfMemory] whileTrue: [ (self isFreeObject: obj) ifFalse: [ ^obj ]. obj _ self objectAfter: obj. ]. self error: 'heap is empty'. ^0! ! !Interpreter methodsFor: 'utilities' stamp: 'JMM 11/26/2002 13:16'! arrayValueOf: arrayOop "Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object." "Note: May be called by translated primitive code." self returnTypeC: 'void *'. ((self isIntegerObject: arrayOop) not and: [self isWordsOrBytes: arrayOop]) ifTrue: [^ self cCode: '(void *) (arrayOop + 4)']. self primitiveFail. ^0.! ! !Interpreter methodsFor: 'utilities' stamp: 'JMM 11/26/2002 22:09'! loadFloatOrIntFrom: floatOrInt "If floatOrInt is an integer, then convert it to a C double float and return it. If it is a Float, then load its value and return it. Otherwise fail -- ie return with successFlag set to false." self inline: true. self returnTypeC: 'double'. (self isIntegerObject: floatOrInt) ifTrue: [^ self cCode: '((double) (floatOrInt >> 1))' inSmalltalk: [(self integerValueOf: floatOrInt) asFloat]]. (self fetchClassOfNonInt: floatOrInt) = (self splObj: ClassFloat) ifTrue: [^ self floatValueOf: floatOrInt]. successFlag _ false. ^0.0! ! !Interpreter methodsFor: 'method lookup cache' stamp: 'JMM 11/24/2002 23:16'! addNewMethodToCache "Add the given entry to the method cache. The policy is as follows: Look for an empty entry anywhere in the reprobe chain. If found, install the new entry there. If not found, then install the new entry at the first probe position and delete the entries in the rest of the reprobe chain. This has two useful purposes: If there is active contention over the first slot, the second or third will likely be free for reentry after ejection. Also, flushing is good when reprobe chains are getting full." | probe hash | self inline: false. self compilerTranslateMethodHook. "newMethod x lkupClass -> newNativeMethod (may cause GC !!)" hash _ messageSelector bitXor: lkupClass. "drop low-order zeros from addresses" 0 to: CacheProbeMax-1 do: [:p | probe _ (hash >> p) bitAnd: MethodCacheMask. (methodCache at: probe + MethodCacheSelector) = 0 ifTrue: ["Found an empty entry -- use it" methodCache at: probe + MethodCacheSelector put: messageSelector. methodCache at: probe + MethodCacheClass put: lkupClass. methodCache at: probe + MethodCacheMethod put: newMethod. methodCache at: probe + MethodCachePrim put: primitiveIndex. methodCache at: probe + MethodCacheNative put: newNativeMethod. self cCode: 'return' inSmalltalk: [^self]]]. "OK, we failed to find an entry -- install at the first slot..." probe _ hash bitAnd: MethodCacheMask. "first probe" methodCache at: probe + MethodCacheSelector put: messageSelector. methodCache at: probe + MethodCacheClass put: lkupClass. methodCache at: probe + MethodCacheMethod put: newMethod. methodCache at: probe + MethodCachePrim put: primitiveIndex. methodCache at: probe + MethodCacheNative put: newNativeMethod. "...and zap the following entries" 1 to: CacheProbeMax-1 do: [:p | probe _ (hash >> p) bitAnd: MethodCacheMask. methodCache at: probe + MethodCacheSelector put: 0]. ! ! !Interpreter methodsFor: 'method lookup cache' stamp: 'JMM 11/26/2002 14:29'! rewriteMethodCacheSel: selector class: class primIndex: localPrimIndex "Rewrite an existing entry in the method cache with a new primitive index." | probe hash | self inline: false. hash _ selector bitXor: class. 0 to: CacheProbeMax - 1 do: [:p | probe _ hash >> p bitAnd: MethodCacheMask. ((methodCache at: probe + MethodCacheSelector) = selector and: [(methodCache at: probe + MethodCacheClass) = class]) ifTrue: [methodCache at: probe + MethodCachePrim put: localPrimIndex. self cCode: 'return' inSmalltalk: [^self]]]! ! !Interpreter methodsFor: 'primitive support' stamp: 'JMM 11/26/2002 13:33'! positive32BitValueOf: oop "Convert the given object into an integer value. The object may be either a positive ST integer or a four-byte LargePositiveInteger." | sz value | (self isIntegerObject: oop) ifTrue: [ value _ self integerValueOf: oop. value < 0 ifTrue: [^ self primitiveFail]. ^ value]. self assertClassOf: oop is: (self splObj: ClassLargePositiveInteger). successFlag ifTrue: [ sz _ self lengthOf: oop. sz = 4 ifFalse: [^ self primitiveFail]]. successFlag ifTrue: [ ^ (self fetchByte: 0 ofObject: oop) + ((self fetchByte: 1 ofObject: oop) << 8) + ((self fetchByte: 2 ofObject: oop) << 16) + ((self fetchByte: 3 ofObject: oop) << 24) ]. ^nil.! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'JMM 11/26/2002 14:15'! primitiveMakePoint | rcvr argument pt | argument _ self stackValue: 0. rcvr _ self stackValue: 1. (self isIntegerObject: rcvr) ifTrue:[ (self isIntegerObject: argument) ifTrue:[pt _ self makePointwithxValue: (self integerValueOf: rcvr) yValue: (self integerValueOf: argument)] ifFalse:[pt _ self makePointwithxValue: (self integerValueOf: rcvr) yValue: 0. "Above may cause GC!!" self storePointer: 1 ofObject: pt withValue: (self stackValue: 0)]. ] ifFalse:[ (self isFloatObject: rcvr) ifFalse:[self success: false. self cCode: 'return' inSmalltalk: [^self]]. pt _ self makePointwithxValue: 0 yValue: 0. "Above may cause GC!!" self storePointer: 0 ofObject: pt withValue: (self stackValue: 1). self storePointer: 1 ofObject: pt withValue: (self stackValue: 0). ]. self pop: 2. self push: pt. ! ! !Interpreter methodsFor: 'float primitives' stamp: 'JMM 11/21/2002 15:01'! primitiveFloatAdd self primitiveFloatAdd: (self stackValue: 1) toArg: self stackTop! ! !Interpreter methodsFor: 'float primitives' stamp: 'JMM 11/21/2002 15:01'! primitiveFloatDivide self primitiveFloatDivide: (self stackValue: 1) byArg: self stackTop! ! !Interpreter methodsFor: 'float primitives' stamp: 'JMM 11/26/2002 14:02'! primitiveFloatEqual: rcvrOop toArg: argOop | rcvr arg | self var: #rcvr declareC: 'double rcvr'. self var: #arg declareC: 'double arg'. rcvr _ self loadFloatOrIntFrom: rcvrOop. arg _ self loadFloatOrIntFrom: argOop. successFlag ifTrue: [^ rcvr = arg]. ^nil.! ! !Interpreter methodsFor: 'float primitives' stamp: 'JMM 11/26/2002 14:03'! primitiveFloatGreater: rcvrOop thanArg: argOop | rcvr arg | self var: #rcvr declareC: 'double rcvr'. self var: #arg declareC: 'double arg'. rcvr _ self loadFloatOrIntFrom: rcvrOop. arg _ self loadFloatOrIntFrom: argOop. successFlag ifTrue: [^ rcvr > arg]. ^nil ! ! !Interpreter methodsFor: 'float primitives' stamp: 'JMM 11/26/2002 14:03'! primitiveFloatLess: rcvrOop thanArg: argOop | rcvr arg | self var: #rcvr declareC: 'double rcvr'. self var: #arg declareC: 'double arg'. rcvr _ self loadFloatOrIntFrom: rcvrOop. arg _ self loadFloatOrIntFrom: argOop. successFlag ifTrue: [^ rcvr < arg]. ^nil ! ! !Interpreter methodsFor: 'float primitives' stamp: 'JMM 11/21/2002 15:01'! primitiveFloatMultiply self primitiveFloatMultiply: (self stackValue: 1) byArg: self stackTop! ! !Interpreter methodsFor: 'float primitives' stamp: 'JMM 11/21/2002 15:01'! primitiveFloatSubtract self primitiveFloatSubtract: (self stackValue: 1) fromArg: self stackTop! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'JMM 11/26/2002 13:20'! commonAt: stringy "This code is called if the receiver responds primitively to at:. If this is so, it will be installed in the atCache so that subsequent calls of at: or next may be handled immediately in bytecode primitive routines." | index rcvr atIx result | index _ self positive32BitValueOf: (self stackValue: 0). "Sets successFlag" rcvr _ self stackValue: 1. successFlag & (self isIntegerObject: rcvr) not ifFalse: [^ self primitiveFail]. "NOTE: The at-cache, since it is specific to the non-super response to #at:. Therefore we must determine that the message is #at: (not, eg, #basicAt:), and that the send is not a super-send, before using the at-cache." (messageSelector = (self specialSelector: 16) and: [lkupClass = (self fetchClassOfNonInt: rcvr)]) ifTrue: ["OK -- look in the at-cache" atIx _ rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7" (atCache at: atIx+AtCacheOop) = rcvr ifFalse: ["Rcvr not in cache. Install it..." self install: rcvr inAtCache: atCache at: atIx string: stringy]. successFlag ifTrue: [result _ self commonVariable: rcvr at: index cacheIndex: atIx]. successFlag ifTrue: [^ self pop: 2 thenPush: result]]. "The slow but sure way..." successFlag _ true. result _ self stObject: rcvr at: index. successFlag ifTrue: [stringy ifTrue: [result _ self characterForAscii: (self integerValueOf: result)]. ^ self pop: 2 thenPush: result]. ^nil! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'JMM 11/26/2002 22:44'! commonAtPut: stringy "This code is called if the receiver responds primitively to at:Put:. If this is so, it will be installed in the atPutCache so that subsequent calls of at: or next may be handled immediately in bytecode primitive routines." | value index rcvr atIx | value _ self stackValue: 0. index _ self positive32BitValueOf: (self stackValue: 1). "Sets successFlag" rcvr _ self stackValue: 2. successFlag & (self isIntegerObject: rcvr) not ifFalse: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. "NOTE: The atPut-cache, since it is specific to the non-super response to #at:Put:. Therefore we must determine that the message is #at:Put: (not, eg, #basicAt:Put:), and that the send is not a super-send, before using the at-cache." (messageSelector = (self specialSelector: 17) and: [lkupClass = (self fetchClassOfNonInt: rcvr)]) ifTrue: ["OK -- look in the at-cache" atIx _ (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache" (atCache at: atIx+AtCacheOop) = rcvr ifFalse: ["Rcvr not in cache. Install it..." self install: rcvr inAtCache: atCache at: atIx string: stringy]. successFlag ifTrue: [self commonVariable: rcvr at: index put: value cacheIndex: atIx]. successFlag ifTrue: [self pop: 3 thenPush: value. self cCode: 'return' inSmalltalk: [^self]]]. "The slow but sure way..." successFlag _ true. stringy ifTrue: [self stObject: rcvr at: index put: (self asciiOfCharacter: value)] ifFalse: [self stObject: rcvr at: index put: value]. successFlag ifTrue: [self pop: 3 thenPush: value. self cCode: 'return' inSmalltalk: [^self]]. ! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'JMM 11/26/2002 13:20'! commonVariable: rcvr at: index cacheIndex: atIx "This code assumes the reciever has been identified at location atIx in the atCache." | stSize fmt fixedFields result | stSize _ atCache at: atIx+AtCacheSize. ((self cCoerce: index to: 'unsigned ') >= 1 and: [(self cCoerce: index to: 'unsigned ') <= (self cCoerce: stSize to: 'unsigned ')]) ifTrue: [fmt _ atCache at: atIx+AtCacheFmt. fmt <= 4 ifTrue: [fixedFields _ atCache at: atIx+AtCacheFixedFields. ^ self fetchPointer: index + fixedFields - 1 ofObject: rcvr]. fmt < 8 ifTrue: "Bitmap" [result _ self fetchWord: index - 1 ofObject: rcvr. result _ self positive32BitIntegerFor: result. ^ result]. fmt >= 16 "Note fmt >= 16 is an artificial flag for strings" ifTrue: "String" [^ self characterForAscii: (self fetchByte: index - 1 ofObject: rcvr)] ifFalse: "ByteArray" [^ self integerObjectOf: (self fetchByte: index - 1 ofObject: rcvr)]]. self primitiveFail. ^nil! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'JMM 11/26/2002 13:24'! 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 _ (hdr >> 8) bitAnd: 16rF. (fmt = 3 and: [self isContextHeader: hdr]) ifTrue: ["Contexts must not be put in the atCache, since their size is not constant" self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. 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: 'JMM 11/26/2002 14:16'! primitiveNext "PrimitiveNext will succeed only if the stream's array is in the atCache. Otherwise failure will lead to proper message lookup of at: and subsequent installation in the cache if appropriate." | stream array index limit result atIx | stream _ self stackTop. ((self isPointers: stream) and: [(self lengthOf: stream) >= (StreamReadLimitIndex + 1)]) ifFalse: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. array _ self fetchPointer: StreamArrayIndex ofObject: stream. index _ self fetchInteger: StreamIndexIndex ofObject: stream. limit _ self fetchInteger: StreamReadLimitIndex ofObject: stream. atIx _ array bitAnd: AtCacheMask. (index < limit and: [(atCache at: atIx+AtCacheOop) = array]) ifFalse: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. "OK -- its not at end, and the array is in the cache" index _ index + 1. result _ self commonVariable: array at: index cacheIndex: atIx. "Above may cause GC, so can't use stream, array etc. below it" successFlag ifTrue: [stream _ self stackTop. self storeInteger: StreamIndexIndex ofObject: stream withValue: index. self pop: 1 thenPush: result. self cCode: 'return' inSmalltalk: [^self]]. ! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'JMM 11/26/2002 14:16'! primitiveNextPut "PrimitiveNextPut will succeed only if the stream's array is in the atPutCache. Otherwise failure will lead to proper message lookup of at:put: and subsequent installation in the cache if appropriate." | value stream index limit array atIx | value _ self stackTop. stream _ self stackValue: 1. ((self isPointers: stream) and: [(self lengthOf: stream) >= (StreamReadLimitIndex + 1)]) ifFalse: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. array _ self fetchPointer: StreamArrayIndex ofObject: stream. index _ self fetchInteger: StreamIndexIndex ofObject: stream. limit _ self fetchInteger: StreamReadLimitIndex ofObject: stream. atIx _ (array bitAnd: AtCacheMask) + AtPutBase. (index < limit and: [(atCache at: atIx+AtCacheOop) = array]) ifFalse: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. "OK -- its not at end, and the array is in the cache" index _ index + 1. self commonVariable: array at: index put: value cacheIndex: atIx. successFlag ifTrue: [self storeInteger: StreamIndexIndex ofObject: stream withValue: index. self pop: 2 thenPush: value. self cCode: 'return' inSmalltalk: [^self]]. ! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'JMM 11/26/2002 14:23'! primitiveSize | rcvr sz | rcvr _ self stackTop. (self isIntegerObject: rcvr) ifTrue: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. "Integers are not indexable" (self formatOf: rcvr) < 2 ifTrue: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. "This is not an indexable object" sz _ self stSizeOf: rcvr. successFlag ifTrue: [self pop: 1 thenPush: (self positive32BitIntegerFor: sz)] ! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'JMM 11/26/2002 14:26'! primitiveStringReplace " primReplaceFrom: start to: stop with: replacement startingAt: repStart " | array start stop repl replStart hdr arrayFmt totalLength arrayInstSize replFmt replInstSize srcIndex | array _ self stackValue: 4. start _ self stackIntegerValue: 3. stop _ self stackIntegerValue: 2. repl _ self stackValue: 1. replStart _ self stackIntegerValue: 0. successFlag ifFalse: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. (self isIntegerObject: repl) "can happen in LgInt copy" ifTrue: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. hdr _ self baseHeader: array. arrayFmt _ (hdr >> 8) bitAnd: 16rF. totalLength _ self lengthOf: array baseHeader: hdr format: arrayFmt. arrayInstSize _ self fixedFieldsOf: array format: arrayFmt length: totalLength. ((start >= 1) and: [(start <= stop) and: [stop + arrayInstSize <= totalLength]]) ifFalse: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. hdr _ self baseHeader: repl. replFmt _ (hdr >> 8) bitAnd: 16rF. totalLength _ self lengthOf: repl baseHeader: hdr format: replFmt. replInstSize _ self fixedFieldsOf: repl format: replFmt length: totalLength. ((replStart >= 1) and: [stop - start + replStart + replInstSize <= totalLength]) ifFalse: [ self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. "Array formats (without byteSize bits, if bytes array) must be same" arrayFmt < 8 ifTrue: [arrayFmt = replFmt ifFalse: [ self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]] ifFalse: [(arrayFmt bitAnd: 16rC) = (replFmt bitAnd: 16rC) ifFalse: [ self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]]. srcIndex _ replStart + replInstSize - 1. " - 1 for 0-based access" arrayFmt < 4 ifTrue: [ "pointer type objects" start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i | self storePointer: i ofObject: array withValue: (self fetchPointer: srcIndex ofObject: repl). srcIndex _ srcIndex + 1. ] ] ifFalse: [ arrayFmt < 8 ifTrue: [ "long-word type objects" start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i | self storeWord: i ofObject: array withValue: (self fetchWord: srcIndex ofObject: repl). srcIndex _ srcIndex + 1 ] ] ifFalse: [ "byte-type objects" start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i | self storeByte: i ofObject: array withValue: (self fetchByte: srcIndex ofObject: repl). srcIndex _ srcIndex + 1. ] ]. ]. self pop: 4. "leave rcvr on stack"! ! !Interpreter methodsFor: 'object access primitives' stamp: 'JMM 11/26/2002 13:58'! primitiveChangeClass "Primitive. Change the class of the receiver into the class of the argument given that the format of the receiver matches the format of the argument's class. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have." | arg rcvr argClass classHdr sizeHiBits byteSize argFormat rcvrFormat ccIndex | arg _ self stackObjectValue: 0. rcvr _ self stackObjectValue: 1. successFlag ifFalse:[self cCode: 'return' inSmalltalk: [^self]]. "Get the class we want to convert the receiver into" argClass _ self fetchClassOf: arg. "Check what the format of the class says" classHdr _ self formatOfClass: argClass. "Low 2 bits are 0" "Compute the size of instances of the class (used for fixed field classes only)" sizeHiBits _ (classHdr bitAnd: 16r60000) >> 9. classHdr _ classHdr bitAnd: 16r1FFFF. byteSize _ (classHdr bitAnd: SizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0" "Check the receiver's format against that of the class" argFormat _ (classHdr >> 8) bitAnd: 16rF. rcvrFormat _ self formatOf: rcvr. argFormat = rcvrFormat ifFalse:[self success: false. self cCode: 'return' inSmalltalk: [^self]]. "no way" "For fixed field classes, the sizes must match. Note: byteSize-4 because base header is included in class size." argFormat < 2 ifTrue:[(byteSize - 4) = (self byteSizeOf: rcvr) ifFalse:[self success: false.self cCode: 'return' inSmalltalk: [^self]]]. (self headerType: rcvr) = HeaderTypeShort ifTrue:[ "Compact classes. Check if the arg's class is compact and exchange ccIndex" ccIndex _ classHdr bitAnd: CompactClassMask. ccIndex = 0 ifTrue:[self success: false.self cCode: 'return' inSmalltalk: [^self]]. "class is not compact" self longAt: rcvr put: (((self longAt: rcvr) bitAnd: CompactClassMask bitInvert32) bitOr: ccIndex) ] ifFalse:[ "Exchange the class pointer, which could make rcvr a root for argClass" self longAt: rcvr-4 put: (argClass bitOr: (self headerType: rcvr)). (rcvr < youngStart) ifTrue: [ self possibleRootStoreInto: rcvr value: argClass. ]. ]. "Flush cache because rcvr's class has changed" self flushMethodCache. successFlag ifTrue: [ self pop: 1 ].! ! !Interpreter methodsFor: 'object access primitives' stamp: 'JMM 11/26/2002 14:17'! primitiveObjectPointsTo | rcvr thang lastField | thang _ self popStack. rcvr _ self popStack. (self isIntegerObject: rcvr) ifTrue: [self pushBool: false. self cCode: 'return' inSmalltalk: [^self]]. lastField _ self lastPointerOf: rcvr. BaseHeaderSize to: lastField by: 4 do: [:i | (self longAt: rcvr + i) = thang ifTrue: [self pushBool: true. self cCode: 'return' inSmalltalk: [^self]]]. self pushBool: false.! ! !Interpreter methodsFor: 'object access primitives' stamp: 'JMM 11/26/2002 14:25'! primitiveStoreStackp "Atomic store into context stackPointer. Also ensures that any newly accessible cells are initialized to nil" | ctxt newStackp stackp | ctxt _ self stackValue: 1. newStackp _ self stackIntegerValue: 0. self success: (newStackp >= 0). self success: (newStackp <= (LargeContextSize-BaseHeaderSize // 4 - CtxtTempFrameStart)). successFlag ifFalse: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. stackp _ self fetchStackPointerOf: ctxt. newStackp > stackp ifTrue: ["Nil any newly accessible cells" stackp + 1 to: newStackp do: [:i | self storePointer: i+CtxtTempFrameStart-1 ofObject: ctxt withValue: nilObj]]. self storeStackPointerValue: newStackp inContext: ctxt. self pop: 1 ! ! !Interpreter methodsFor: 'control primitives' stamp: 'JMM 11/26/2002 14:01'! primitiveDoPrimitiveWithArgs | argumentArray arraySize index cntxSize primIdx | argumentArray _ self stackTop. arraySize _ self fetchWordLengthOf: argumentArray. cntxSize _ self fetchWordLengthOf: activeContext. self success: (self stackPointerIndex + arraySize) < cntxSize. self assertClassOf: argumentArray is: (self splObj: ClassArray). primIdx _ self stackIntegerValue: 1. successFlag ifFalse: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. "invalid args" "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: 'JMM 11/26/2002 14:18'! 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 cntxSize performMethod performArgCount | argumentArray _ self popStack. self assertClassOf: argumentArray is: (self splObj: ClassArray). successFlag ifTrue: ["Check for enough space to push all args" arraySize _ self fetchWordLengthOf: argumentArray. cntxSize _ self fetchWordLengthOf: activeContext. self success: (self stackPointerIndex + arraySize) < cntxSize]. successFlag ifFalse: [self unPop: 1. self cCode: 'return' inSmalltalk: [^self]]. 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: 'JMM 11/26/2002 14:18'! primitivePerformInSuperclass | lookupClass rcvr currentClass | lookupClass _ self stackTop. rcvr _ self stackValue: argumentCount. currentClass _ self fetchClassOf: rcvr. [currentClass ~= lookupClass] whileTrue: [currentClass _ self superclassOf: currentClass. currentClass = nilObj ifTrue: [self primitiveFail.. self cCode: 'return' inSmalltalk: [^self]]]. self popStack. self primitivePerformAt: lookupClass. successFlag ifFalse: [self push: lookupClass]! ! !Interpreter methodsFor: 'processes' stamp: 'JMM 11/26/2002 14:31'! signalSemaphoreWithIndex: index "Record the given semaphore index in the double buffer semaphores array to be signaled at the next convenient moment. Set the interruptCheckCounter to zero to force a real interrupt check as soon as possible." index <= 0 ifTrue: [self cCode: 'return' inSmalltalk: [^self]]. "bad index; ignore it" semaphoresUseBufferA ifTrue: [semaphoresToSignalCountA < SemaphoresToSignalSize ifTrue: [ semaphoresToSignalCountA _ semaphoresToSignalCountA + 1. semaphoresToSignalA at: semaphoresToSignalCountA put: index]] ifFalse: [semaphoresToSignalCountB < SemaphoresToSignalSize ifTrue: [ semaphoresToSignalCountB _ semaphoresToSignalCountB + 1. semaphoresToSignalB at: semaphoresToSignalCountB put: index]]. interruptCheckCounter _ 0. ! ! !Interpreter methodsFor: 'I/O primitives' stamp: 'JMM 11/26/2002 13:23'! 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: [self cCode: 'return' inSmalltalk: [^self]]. 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:[self cCode: 'return' inSmalltalk: [^self]]. successFlag ifTrue: [ (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: 'return' inSmalltalk: [^self]]]. 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: 'I/O primitives' stamp: 'JMM 11/26/2002 14:04'! primitiveGetNextEvent "Primitive. Return the next input event from the OS event queue." | evtBuf arg value | self var: #evtBuf declareC:'int evtBuf[8] = { 0, 0, 0, 0, 0, 0, 0, 0 }'. self cCode:'' inSmalltalk:[evtBuf _ CArrayAccessor on: (IntegerArray new: 8)]. arg _ self stackValue: 0. ((self fetchClassOf: arg) = self classArray and:[(self slotSizeOf: arg) = 8]) ifFalse: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. self ioGetNextEvent: (self cCoerce: evtBuf to: 'sqInputEvent*'). successFlag ifFalse:[self cCode: 'return' inSmalltalk: [^self]]. "Event type" self storeInteger: 0 ofObject: arg withValue: (evtBuf at: 0). successFlag ifFalse:[self cCode: 'return' inSmalltalk: [^self]]. "Event time stamp" self storeInteger: 1 ofObject: arg withValue: ((evtBuf at: 1) bitAnd: MillisecondClockMask). successFlag ifFalse:[self cCode: 'return' inSmalltalk: [^self]]. "Event arguments" 2 to: 7 do:[:i| value _ evtBuf at: i. (self isIntegerValue: value) ifTrue:[self storeInteger: i ofObject: arg withValue: value] ifFalse:["Need to remap because allocation may cause GC" self pushRemappableOop: arg. value _ self positive32BitIntegerFor: value. arg _ self popRemappableOop. self storePointer: i ofObject: arg withValue: value. ]. ]. successFlag ifFalse:[self cCode: 'return' inSmalltalk: [^self]]. self pop: 1. self cCode: 'return' inSmalltalk: [^self].! ! !Interpreter methodsFor: 'I/O primitives' stamp: 'JMM 11/26/2002 14:07'! primitiveInputSemaphore "Register the input semaphore. If the argument is not a Semaphore, unregister the current input semaphore." | arg | arg _ self stackValue: 0. (self isIntegerObject: arg) ifTrue:[ "If arg is integer, then use it as an index into the external objects array and install it as the new event semaphore" self ioSetInputSemaphore: (self integerValueOf: arg). successFlag ifTrue:[self pop: 1]. self cCode: 'return' inSmalltalk: [^self] ]. "old code for compatibility" arg _ self popStack. ((self fetchClassOf: arg) = (self splObj: ClassSemaphore)) ifTrue: [ self storePointer: TheInputSemaphore ofObject: specialObjectsOop withValue: arg. ] ifFalse: [ self storePointer: TheInputSemaphore ofObject: specialObjectsOop withValue: nilObj. ].! ! !Interpreter methodsFor: 'I/O primitives' stamp: 'JMM 11/26/2002 22:12'! primitiveScreenDepth "Return a SmallInteger indicating the current depth of the OS screen" | depth | self export: true. depth _ self ioScreenDepth. (self failed or:[depth <= 0]) ifTrue:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. self pop: 1. self pushInteger: depth.! ! !Interpreter methodsFor: 'I/O primitives' stamp: 'JMM 11/26/2002 14:29'! reverseDisplayFrom: startIndex to: endIndex "Reverse the given range of Display words (at different bit depths, this will reverse different numbers of pixels). Used to give feedback during VM activities such as garbage collection when debugging. It is assumed that the given word range falls entirely within the first line of the Display." | displayObj dispBitsPtr w reversed | displayObj _ self splObj: TheDisplay. ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifFalse: [self cCode: 'return' inSmalltalk: [^self]]. w _ self fetchInteger: 1 ofObject: displayObj. dispBitsPtr _ (self fetchPointer: 0 ofObject: displayObj). (self isIntegerObject: dispBitsPtr) ifTrue:[self cCode: 'return' inSmalltalk: [^self]]. dispBitsPtr _ dispBitsPtr + BaseHeaderSize. dispBitsPtr + (startIndex * 4) to: dispBitsPtr + (endIndex * 4) by: 4 do: [:ptr | reversed _ (self longAt: ptr) bitXor: 16rFFFFFFFF. self longAt: ptr put: reversed]. self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: 1. self ioForceDisplayUpdate. ! ! !Interpreter methodsFor: 'I/O primitives' stamp: 'JMM 11/26/2002 14:30'! showDisplayBits: 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." deferDisplayUpdates ifTrue: [self cCode: 'return' inSmalltalk: [^self]]. self displayBitsOf: aForm Left: l Top: t Right: r Bottom: b! ! !Interpreter methodsFor: 'sound primitives' stamp: 'JMM 11/26/2002 14:10'! primitiveIntegerAt "Return the 32bit signed integer contents of a words receiver" | index rcvr sz addr value | index _ self stackIntegerValue: 0. rcvr _ self stackValue: 1. (self isIntegerObject: rcvr) ifTrue:[self success: false. self cCode: 'return' inSmalltalk: [^self]]. (self isWords: rcvr) ifFalse:[self success: false. self cCode: 'return' inSmalltalk: [^self]]. sz _ self lengthOf: rcvr. "number of fields" self success: ((index >= 1) and: [index <= sz]). successFlag ifTrue: [ addr _ rcvr + BaseHeaderSize - 4 "for zero indexing" + (index * 4). value _ self cCode:'*((int *) addr)' inSmalltalk:[self integerAt: addr]. self pop: 2. "pop rcvr, index" "push element value" (self isIntegerValue: value) ifTrue:[self pushInteger: value] ifFalse:[self push: (self signed32BitIntegerFor: value)]. ].! ! !Interpreter methodsFor: 'sound primitives' stamp: 'JMM 11/26/2002 14:11'! primitiveIntegerAtPut "Return the 32bit signed integer contents of a words receiver" | index rcvr sz addr value valueOop | valueOop _ self stackValue: 0. index _ self stackIntegerValue: 1. rcvr _ self stackValue: 2. (self isIntegerObject: rcvr) ifTrue:[self success: false. self cCode: 'return' inSmalltalk: [^self]]. (self isWords: rcvr) ifFalse:[self success: false. self cCode: 'return' inSmalltalk: [^self]]. sz _ self lengthOf: rcvr. "number of fields" ((index >= 1) and: [index <= sz]) ifFalse:[self success: false. self cCode: 'return' inSmalltalk: [^self]]. (self isIntegerObject: valueOop) ifTrue:[value _ self integerValueOf: valueOop] ifFalse:[value _ self signed32BitValueOf: valueOop]. successFlag ifTrue:[ addr _ rcvr + BaseHeaderSize - 4 "for zero indexing" + (index * 4). value _ self cCode:'*((int *) addr) = value' inSmalltalk:[self integerAt: addr put: value]. self pop: 3 thenPush: valueOop. "pop all; return value" ]. ! ! !Interpreter methodsFor: 'sound primitives' stamp: 'JMM 11/26/2002 14:21'! primitiveShortAt "Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Return the contents of the given index. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word." | index rcvr sz addr value | index _ self stackIntegerValue: 0. rcvr _ self stackValue: 1. self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]). successFlag ifFalse: [self cCode: 'return' inSmalltalk: [^self]]. sz _ ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2. "number of 16-bit fields" self success: ((index >= 1) and: [index <= sz]). successFlag ifTrue: [ addr _ rcvr + BaseHeaderSize + (2 * (index - 1)). value _ self cCode: '*((short int *) addr)' inSmalltalk: [self halfWordAt: addr]. self pop: 2. "pop rcvr, index" self pushInteger: value. "push element value" ].! ! !Interpreter methodsFor: 'sound primitives' stamp: 'JMM 11/26/2002 14:22'! primitiveShortAtPut "Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Set the contents of the given index to the given value. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word." | index rcvr sz addr value | value _ self stackIntegerValue: 0. index _ self stackIntegerValue: 1. rcvr _ self stackValue: 2. self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]). successFlag ifFalse: [self cCode: 'return' inSmalltalk: [^self]]. sz _ ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2. "number of 16-bit fields" self success: ((index >= 1) and: [index <= sz]). self success: ((value >= -32768) and: [value <= 32767]). successFlag ifTrue: [ addr _ rcvr + BaseHeaderSize + (2 * (index - 1)). self cCode: '*((short int *) addr) = value'. self pop: 2. "pop index and value; leave rcvr on stack" ].! ! !Interpreter methodsFor: 'other primitives' stamp: 'JMM 11/26/2002 22:11'! 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 - activeContext. ]. "Fetch the first literal of the method" self success: (self literalCountOf: newMethod) > 0."@@: Could this be omitted for speed?!!" successFlag ifFalse:[self cCode: 'return' inSmalltalk: [^self]]. lit _ self literal: 0 ofMethod: newMethod. "Check if it's an array of length 4" self success: ((self fetchClassOf: lit) = (self splObj: ClassArray) and:[(self lengthOf: lit) = 4]). successFlag ifFalse:[self cCode: 'return' inSmalltalk: [^self]]. "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. self cCode: 'return' inSmalltalk: [^self]]. 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. self cCode: 'return' inSmalltalk: [^self]]. "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]]. self cCode: 'return' inSmalltalk: [^self]]. "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. self cCode: 'return' inSmalltalk: [^self]]. "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:[self cCode: 'return' inSmalltalk: [^self]]. "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: 'JMM 11/21/2002 15:00'! primitiveFlushExternalPrimitives "Primitive. Flush all the existing external primitives in the image thus forcing a reload on next invokation." self flushExternalPrimitives! ! !Interpreter methodsFor: 'other primitives' stamp: 'JMM 11/26/2002 14:06'! primitiveImageName "When called with a single string argument, record the string as the current image file name. When called with zero arguments, return a string containing the current image file name." | s sz sCRIfn okToRename| argumentCount = 1 ifTrue: [ "If the security plugin can be loaded, use it to check for rename permission. If not, assume it's ok" sCRIfn _ self ioLoadFunction: 'secCanRenameImage' From: 'SecurityPlugin'. sCRIfn ~= 0 ifTrue:[okToRename _ self cCode:' ((int (*) (void)) sCRIfn)()'. okToRename ifFalse:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]]. s _ self stackTop. self assertClassOf: s is: (self splObj: ClassString). successFlag ifTrue: [ sz _ self stSizeOf: s. self imageNamePut: (s + BaseHeaderSize) Length: sz. self pop: 1. "pop s, leave rcvr on stack" ]. ] ifFalse: [ sz _ self imageNameSize. s _ self instantiateClass: (self splObj: ClassString) indexableSize: sz. self imageNameGet: (s + BaseHeaderSize) Length: sz. self pop: 1. "rcvr" self push: s. ]. ! ! !Interpreter methodsFor: 'other primitives' stamp: 'JMM 11/26/2002 14:13'! primitiveListBuiltinModule "Primitive. Return the n-th builtin module name." | moduleName index length nameOop | self var: #moduleName type: 'char *'. self methodArgumentCount = 1 ifFalse:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. index _ self stackIntegerValue: 0. index <= 0 ifTrue:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. moduleName _ self ioListBuiltinModule: index. moduleName == nil ifTrue:[ self pop: 2. "arg+rcvr" self push: self nilObject. self cCode: 'return' inSmalltalk: [^self]]. length _ self strlen: moduleName. nameOop _ self instantiateClass: self classString indexableSize: length. 0 to: length-1 do:[:i| self storeByte: i ofObject: nameOop withValue: (moduleName at: i)]. self pop: 2. "arg+rcvr" self push: nameOop.! ! !Interpreter methodsFor: 'other primitives' stamp: 'JMM 11/26/2002 14:13'! primitiveListExternalModule "Primitive. Return the n-th loaded external module name." | moduleName index length nameOop | self var: #moduleName type: 'char *'. self methodArgumentCount = 1 ifFalse:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. index _ self stackIntegerValue: 0. index <= 0 ifTrue:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. moduleName _ self ioListLoadedModule: index. moduleName == nil ifTrue:[ self pop: 2. "arg+rcvr" self push: self nilObject. self cCode: 'return' inSmalltalk: [^self]]. length _ self strlen: moduleName. nameOop _ self instantiateClass: self classString indexableSize: length. 0 to: length-1 do:[:i| self storeByte: i ofObject: nameOop withValue: (moduleName at: i)]. self pop: 2. "arg+rcvr" self push: nameOop.! ! !Interpreter methodsFor: 'other primitives' stamp: 'JMM 11/26/2002 14:21'! primitiveScanCharacters "Invoke the character scanner primitive." | kernDelta stops sourceString scanStopIndex scanStartIndex rcvr scanDestX scanLastIndex scanXTable scanMap maxGlyph ascii stopReason glyphIndex sourceX sourceX2 nextDestX scanRightX nilOop | self methodArgumentCount = 6 ifFalse:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. "Load the arguments" kernDelta _ self stackIntegerValue: 0. stops _ self stackObjectValue: 1. (self fetchClassOf: stops) = self classArray ifFalse:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. (self slotSizeOf: stops) >= 258 ifFalse:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. scanRightX _ self stackIntegerValue: 2. sourceString _ self stackObjectValue: 3. (self isBytes: sourceString) ifFalse:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. scanStopIndex _ self stackIntegerValue: 4. scanStartIndex _ self stackIntegerValue: 5. (scanStartIndex > 0 and:[scanStopIndex > 0 and:[ scanStopIndex <= (self byteSizeOf: sourceString)]]) ifFalse:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. "Load receiver and required instVars" rcvr _ self stackObjectValue: 6. ((self isPointers: rcvr) and:[(self slotSizeOf: rcvr) >= 4]) ifFalse:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. scanDestX _ self fetchInteger: 0 ofObject: rcvr. scanLastIndex _ self fetchInteger: 1 ofObject: rcvr. scanXTable _ self fetchPointer: 2 ofObject: rcvr. scanMap _ self fetchPointer: 3 ofObject: rcvr. ((self fetchClassOf: scanXTable) = self classArray and:[ (self fetchClassOf: scanMap) = self classArray]) ifFalse:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. (self slotSizeOf: scanMap) = 256 ifFalse:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. self failed ifTrue:[self cCode: 'return' inSmalltalk: [^self]]. maxGlyph _ (self slotSizeOf: scanXTable) - 2. "Okay, here we go. We have eliminated nearly all failure conditions, to optimize the inner fetches." scanLastIndex _ scanStartIndex. nilOop _ self nilObject. [scanLastIndex <= scanStopIndex] whileTrue:[ "Known to be okay since scanStartIndex > 0 and scanStopIndex <= sourceString size" ascii _ self fetchByte: scanLastIndex-1 ofObject: sourceString. "Known to be okay since stops size >= 258" (stopReason _ self fetchPointer: ascii ofObject: stops) = nilOop ifFalse:[ "Store everything back and get out of here" (self isIntegerValue: scanDestX) ifFalse:[self primitiveFail.. self cCode: 'return' inSmalltalk: [^self]]. self storeInteger: 0 ofObject: rcvr withValue: scanDestX. self storeInteger: 1 ofObject: rcvr withValue: scanLastIndex. self pop: 7. "args+rcvr" self push: stopReason. self cCode: 'return' inSmalltalk: [^self]]. "Known to be okay since scanMap size = 256" glyphIndex _ self fetchInteger: ascii ofObject: scanMap. (self failed or:[glyphIndex < 0 or:[glyphIndex > maxGlyph]]) ifTrue:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. sourceX _ self fetchInteger: glyphIndex ofObject: scanXTable. sourceX2 _ self fetchInteger: glyphIndex+1 ofObject: scanXTable. "Above may fail if non-integer entries in scanXTable" self failed ifTrue:[self cCode: 'return' inSmalltalk: [^self]]. nextDestX _ scanDestX + sourceX2 - sourceX. nextDestX > scanRightX ifTrue:[ "Store everything back and get out of here" (self isIntegerValue: scanDestX) ifFalse:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. self storeInteger: 0 ofObject: rcvr withValue: scanDestX. self storeInteger: 1 ofObject: rcvr withValue: scanLastIndex. self pop: 7. "args+rcvr" self push: (self fetchPointer: CrossedX-1 ofObject: stops). self cCode: 'return' inSmalltalk: [^self]]. scanDestX _ nextDestX + kernDelta. scanLastIndex _ scanLastIndex + 1]. (self isIntegerValue: scanDestX) ifFalse:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. self storeInteger: 0 ofObject: rcvr withValue: scanDestX. self storeInteger: 1 ofObject: rcvr withValue: scanStopIndex. self pop: 7. "args+rcvr" self push: (self fetchPointer: EndOfRun-1 ofObject: stops). self cCode: 'return' inSmalltalk: [^self]! ! !Interpreter methodsFor: 'other primitives' stamp: 'JMM 11/26/2002 14:27'! primitiveUnloadModule "Primitive. Unload the module with the given name." "Reloading of the module will happen *later* automatically, when a function from it is called. This is ensured by invalidating current sessionID." | moduleName | self methodArgumentCount = 1 ifFalse:[self success: false. self cCode: 'return' inSmalltalk: [^self]]. moduleName _ self stackValue: 0. (self isIntegerObject: moduleName) ifTrue:[self success: false. self cCode: 'return' inSmalltalk: [^self]]. (self isBytes: moduleName) ifFalse:[self success: false. self cCode: 'return' inSmalltalk: [^self]]. (self ioUnloadModule: (self cCoerce: (self firstIndexableField: moduleName) to: 'int') OfLength: (self byteSizeOf: moduleName)) ifFalse:[self success: false. self cCode: 'return' inSmalltalk: [^self]]. self flushExternalPrimitives. self pop: 1 "pop moduleName; return receiver"! ! !Interpreter methodsFor: 'other primitives' stamp: 'JMM 11/26/2002 14:28'! primitiveVMParameter "Behaviour depends on argument count: 0 args: return an Array of VM parameter values; 1 arg: return the indicated VM parameter; 2 args: set the VM indicated parameter. VM parameters are numbered as follows: 1 end of old-space (0-based, read-only) 2 end of young-space (read-only) 3 end of memory (read-only) 4 allocationCount (read-only) 5 allocations between GCs (read-write) 6 survivor count tenuring threshold (read-write) 7 full GCs since startup (read-only) 8 total milliseconds in full GCs since startup (read-only) 9 incremental GCs since startup (read-only) 10 total milliseconds in incremental GCs since startup (read-only) 11 tenures of surving objects since startup (read-only) 12-20 specific to the translating VM 21 root table size (read-only) 22 root table overflows since startup (read-only) 23 bytes of extra memory to reserve for VM buffers, plugins, etc. 24 memory headroom when growing object memory (rw) 25 memory threshold above which shrinking object memory (rw) Note: Thanks to Ian Piumarta for this primitive." | mem paramsArraySize result arg index | mem _ self cCoerce: memory to: 'int'. self cCode: '' inSmalltalk: [mem _ 0]. argumentCount = 0 ifTrue: [ paramsArraySize _ 25. result _ self instantiateClass: (self splObj: ClassArray) indexableSize: paramsArraySize. 0 to: paramsArraySize - 1 do: [:i | self storeWord: i ofObject: result withValue: (self integerObjectOf: 0)]. self storeWord: 0 ofObject: result withValue: (self integerObjectOf: youngStart - mem). self storeWord: 1 ofObject: result withValue: (self integerObjectOf: freeBlock - mem). self storeWord: 2 ofObject: result withValue: (self integerObjectOf: endOfMemory - mem). self storeWord: 3 ofObject: result withValue: (self integerObjectOf: allocationCount). self storeWord: 4 ofObject: result withValue: (self integerObjectOf: allocationsBetweenGCs). self storeWord: 5 ofObject: result withValue: (self integerObjectOf: tenuringThreshold). self storeWord: 6 ofObject: result withValue: (self integerObjectOf: statFullGCs). self storeWord: 7 ofObject: result withValue: (self integerObjectOf: statFullGCMSecs). self storeWord: 8 ofObject: result withValue: (self integerObjectOf: statIncrGCs). self storeWord: 9 ofObject: result withValue: (self integerObjectOf: statIncrGCMSecs). self storeWord: 10 ofObject: result withValue: (self integerObjectOf: statTenures). self storeWord: 20 ofObject: result withValue: (self integerObjectOf: rootTableCount). self storeWord: 21 ofObject: result withValue: (self integerObjectOf: statRootTableOverflows). self storeWord: 22 ofObject: result withValue: (self integerObjectOf: extraVMMemory). self storeWord: 23 ofObject: result withValue: (self integerObjectOf: shrinkThreshold). self storeWord: 24 ofObject: result withValue: (self integerObjectOf: growHeadroom). self pop: 1 thenPush: result. self cCode: 'return' inSmalltalk: [^self]]. arg _ self stackTop. (self isIntegerObject: arg) ifFalse: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. arg _ self integerValueOf: arg. argumentCount = 1 ifTrue: [ "read VM parameter" (arg < 1 or: [arg > 23]) ifTrue: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. arg = 1 ifTrue: [result _ youngStart - mem]. arg = 2 ifTrue: [result _ freeBlock - mem]. arg = 3 ifTrue: [result _ endOfMemory - mem]. arg = 4 ifTrue: [result _ allocationCount]. arg = 5 ifTrue: [result _ allocationsBetweenGCs]. arg = 6 ifTrue: [result _ tenuringThreshold]. arg = 7 ifTrue: [result _ statFullGCs]. arg = 8 ifTrue: [result _ statFullGCMSecs]. arg = 9 ifTrue: [result _ statIncrGCs]. arg = 10 ifTrue: [result _ statIncrGCMSecs]. arg = 11 ifTrue: [result _ statTenures]. ((arg >= 12) and: [arg <= 20]) ifTrue: [result _ 0]. arg = 21 ifTrue: [result _ rootTableCount]. arg = 22 ifTrue: [result _ statRootTableOverflows]. arg = 23 ifTrue: [result _ extraVMMemory]. arg = 24 ifTrue: [result _ shrinkThreshold]. arg = 25 ifTrue: [result _ growHeadroom]. self pop: 2 thenPush: (self integerObjectOf: result). self cCode: 'return' inSmalltalk: [^self]]. "write a VM parameter" argumentCount = 2 ifFalse: [self primitiveFail.. self cCode: 'return' inSmalltalk: [^self]]. index _ self stackValue: 1. (self isIntegerObject: index) ifFalse: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. index _ self integerValueOf: index. index <= 0 ifTrue: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. successFlag _ false. index = 5 ifTrue: [ result _ allocationsBetweenGCs. allocationsBetweenGCs _ arg. successFlag _ true]. index = 6 ifTrue: [ result _ tenuringThreshold. tenuringThreshold _ arg. successFlag _ true]. index = 23 ifTrue: [ result _ extraVMMemory. extraVMMemory _ arg. successFlag _ true]. index = 24 ifTrue: [ result _ shrinkThreshold. arg > 0 ifTrue:[ shrinkThreshold _ arg. successFlag _ true]]. index = 25 ifTrue: [ result _ growHeadroom. arg > 0 ifTrue:[ growHeadroom _ arg. successFlag _ true]]. successFlag ifTrue: [ self pop: 3 thenPush: (self integerObjectOf: result). "return old value" self cCode: 'return' inSmalltalk: [^self]]. self primitiveFail. "attempting to write a read-only parameter" ! ! !Interpreter methodsFor: 'debug support' stamp: 'JMM 11/26/2002 21:56'! okayFields: oop "If this is a pointers object, check that its fields are all okay oops." | i fieldOop c | (oop = nil or: [oop = 0]) ifTrue: [ ^true ]. (self isIntegerObject: oop) ifTrue: [ ^true ]. self okayOop: oop. self oopHasOkayClass: oop. (self isPointers: oop) ifFalse: [ ^true ]. c _ self fetchClassOf: oop. (c = (self splObj: ClassMethodContext) or: [c = (self splObj: ClassBlockContext)]) ifTrue: [i _ CtxtTempFrameStart + (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. ]. ^true! ! !Interpreter methodsFor: 'debug support' stamp: 'JMM 11/21/2002 14:59'! printCallStack self printCallStackOf: activeContext! ! !Interpreter methodsFor: 'debug support' stamp: 'JMM 11/24/2002 23:17'! printNameOfClass: classOop count: cnt "Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object." cnt <= 0 ifTrue: [self print: 'bad class'. self cCode: 'return' inSmalltalk: [^self]]. (self sizeBitsOf: classOop) = 16r1C "(Metaclass instSize+1 * 4)" ifTrue: [self printNameOfClass: (self fetchPointer: 5 "thisClass" ofObject: classOop) count: cnt - 1. self print: ' class'] ifFalse: [self printStringOf: (self fetchPointer: 6 "name" ofObject: classOop)]! ! !Interpreter methodsFor: 'debug support' stamp: 'JMM 11/26/2002 14:28'! printStringOf: oop | fmt cnt i | (self isIntegerObject: oop) ifTrue:[self cCode: 'return' inSmalltalk: [^self]]. fmt _ self formatOf: oop. fmt < 8 ifTrue: [self cCode: 'return' inSmalltalk: [^self]]. cnt _ 100 min: (self lengthOf: oop). i _ 0. [i < cnt] whileTrue: [ self printChar: (self fetchByte: i ofObject: oop). i _ i + 1. ].! ! !Interpreter methodsFor: 'image save/restore' stamp: 'JMM 11/26/2002 22:05'! 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'. self var: #imageOffset declareC: 'squeakFileOffsetType imageOffset'. "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. ^false ! ! !Interpreter methodsFor: 'image save/restore' stamp: 'JMM 11/26/2002 14:32'! writeImageFileIO: imageBytes | headerStart headerSize f bytesWritten sCWIfn okToWrite | self var: #f declareC: 'sqImageFile f'. self var: #headerStart declareC: 'squeakFileOffsetType headerStart'. "If the security plugin can be loaded, use it to check for write permission. If not, assume it's ok" sCWIfn _ self ioLoadFunction: 'secCanWriteImage' From: 'SecurityPlugin'. sCWIfn ~= 0 ifTrue:[okToWrite _ self cCode:' ((int (*) (void)) sCWIfn)()'. okToWrite ifFalse:[self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]]. "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. self cCode: 'return' inSmalltalk: [^self]]. 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)'. self cCode: 'return' inSmalltalk: [^self]]. "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: 'image segment in/out' stamp: 'JMM 11/26/2002 14:14'! primitiveLoadImageSegment "This primitive is called from Squeak as... loadSegmentFrom: aWordArray outPointers: anArray." "This primitive will load a binary image segment created by primitiveStoreImageSegment. It expects the outPointer array to be of the proper size, and the wordArray to be well formed. It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of zero. If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble. But what more could you have done with it anyway?" | outPointerArray segmentWordArray endSeg segOop fieldPtr fieldOop doingClass lastPtr extraSize mapOop lastOut outPtr hdrTypeBits header data | DoAssertionChecks ifTrue: [self verifyCleanHeaders]. outPointerArray _ self stackValue: 0. lastOut _ outPointerArray + (self lastPointerOf: outPointerArray). segmentWordArray _ self stackValue: 1. endSeg _ segmentWordArray + (self sizeBitsOf: segmentWordArray) - BaseHeaderSize. "Essential type checks" ((self formatOf: outPointerArray) = 2 "Must be indexable pointers" and: [(self formatOf: segmentWordArray) = 6]) "Must be indexable words" ifFalse: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. "Version check. Byte order of the WordArray now" data _ self longAt: segmentWordArray + BaseHeaderSize. (self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [ "Not readable -- try again with reversed bytes..." self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + 4. data _ self longAt: segmentWordArray + BaseHeaderSize. (self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [ "Still NG -- put things back and fail" self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + 4. DoAssertionChecks ifTrue: [self verifyCleanHeaders]. self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]]. "Reverse the Byte type objects if the data from opposite endian machine" "Test top byte. $d on the Mac or $s on the PC. Rest of word is equal" data = self imageSegmentVersion ifFalse: [ "Reverse the byte-type objects once" segOop _ self oopFromChunk: segmentWordArray + BaseHeaderSize + 4. "Oop of first embedded object" self byteSwapByteObjectsFrom: segOop to: endSeg + 4]. "Proceed through the segment, remapping pointers..." segOop _ self oopFromChunk: segmentWordArray + BaseHeaderSize + 4. [segOop <= endSeg] 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" lastPtr > endSeg ifTrue: [ DoAssertionChecks ifTrue: [self verifyCleanHeaders]. self primitiveFail "out of bounds". self cCode: 'return' inSmalltalk: [^self]]. "Go through all oops, remapping them..." [fieldPtr > lastPtr] whileFalse: ["Examine each pointer field" fieldOop _ self longAt: fieldPtr. doingClass ifTrue: [hdrTypeBits _ self headerType: fieldPtr. fieldOop _ fieldOop - hdrTypeBits]. (self isIntegerObject: fieldOop) ifTrue: ["Integer -- nothing to do" fieldPtr _ fieldPtr + 4] ifFalse: [(fieldOop bitAnd: 3) = 0 ifFalse: [self primitiveFail "bad oop". self cCode: 'return' inSmalltalk: [^self]]. (fieldOop bitAnd: 16r80000000) = 0 ifTrue: ["Internal pointer -- add segment offset" mapOop _ fieldOop + segmentWordArray] ifFalse: ["External pointer -- look it up in outPointers" outPtr _ outPointerArray + (fieldOop bitAnd: 16r7FFFFFFF). outPtr > lastOut ifTrue: [self primitiveFail "out of bounds". self cCode: 'return' inSmalltalk: [^self]]. mapOop _ self longAt: outPtr]. doingClass ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits. fieldPtr _ fieldPtr + 8. doingClass _ false] ifFalse: [self longAt: fieldPtr put: mapOop. fieldPtr _ fieldPtr + 4]. segOop < youngStart ifTrue: [self possibleRootStoreInto: segOop value: mapOop]. ]]. segOop _ self objectAfter: segOop]. "Again, proceed through the segment checking consistency..." segOop _ self oopFromChunk: segmentWordArray + BaseHeaderSize + 4. [segOop <= endSeg] whileTrue: [(self oopHasOKclass: segOop) ifFalse: [self primitiveFail "inconsistency". self cCode: 'return' inSmalltalk: [^self]]. fieldPtr _ segOop + BaseHeaderSize. "first field" lastPtr _ segOop + (self lastPointerOf: segOop). "last field" "Go through all oops, remapping them..." [fieldPtr > lastPtr] whileFalse: ["Examine each pointer field" fieldOop _ self longAt: fieldPtr. (self oopHasOKclass: fieldOop) ifFalse: [self primitiveFail "inconsistency". self cCode: 'return' inSmalltalk: [^self]]. fieldPtr _ fieldPtr + 4]. segOop _ self objectAfter: segOop]. "Truncate the segment word array to size = 4 (vers stamp only)" extraSize _ self extraHeaderBytes: segmentWordArray. hdrTypeBits _ self headerType: segmentWordArray. extraSize = 8 ifTrue: [self longAt: segmentWordArray-extraSize put: BaseHeaderSize + 4 + hdrTypeBits] ifFalse: [header _ self longAt: segmentWordArray. self longAt: segmentWordArray put: header - (header bitAnd: SizeMask) + BaseHeaderSize + 4]. "and return the roots array which was first in the segment" DoAssertionChecks ifTrue: [self verifyCleanHeaders]. self pop: 3 thenPush: (self oopFromChunk: segmentWordArray + BaseHeaderSize + 4). ! ! !Interpreter methodsFor: 'image segment in/out' stamp: 'JMM 11/26/2002 14:25'! 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 cCode: 'return' inSmalltalk: [^self]]. ((self headerType: outPointerArray) = HeaderTypeSizeAndClass "Must be 3-word header" and: [(self headerType: segmentWordArray) = HeaderTypeSizeAndClass]) "Must be 3-word header" ifFalse: [self primitiveFail. self cCode: 'return' inSmalltalk: [^self]]. 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 cCode: 'return' inSmalltalk: [^self]]. 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" "clear the recycled context lists" freeContexts _ NilContext. freeLargeContexts _ NilContext. 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. self cCode: 'return' inSmalltalk: [^self]]. "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. self cCode: 'return' inSmalltalk: [^self]]. 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. self cCode: 'return' inSmalltalk: [^self]]. . 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. self cCode: 'return' inSmalltalk: [^self]]. 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" ! ! !TMethod methodsFor: 'inlining support' stamp: 'JMM 11/26/2002 12:57'! hasReturnButNotSelf "Answer true if this method contains a return statement." parseTree nodesDo: [ :n | (n isReturn and: [n name ~= '^self']) ifTrue: [^ true ]]. ^ false! ! !TMethod methodsFor: 'C code generation' stamp: 'hg 8/14/2000 15:41'! emitCCodeOn: aStream generator: aCodeGen "Emit C code for this method onto the given stream. All calls to inlined methods should already have been expanded." self emitCCommentOn: aStream. "place method comment before function" self emitCHeaderOn: aStream generator: aCodeGen. parseTree emitCCodeOn: aStream level: 1 generator: aCodeGen. aStream nextPutAll: '}'; cr.! ! !TMethod methodsFor: 'C code generation' stamp: 'JMM 11/26/2002 12:58'! emitCFunctionPrototype: aStream generator: aCodeGen "Emit a C function header for this method onto the given stream." | arg realReturnType | realReturnType _ (self parseTree statements isEmpty not and: [self hasReturnButNotSelf]) ifTrue: [returnType] ifFalse: ['void']. export ifTrue:[aStream nextPutAll:'EXPORT('; nextPutAll: realReturnType; nextPutAll:') '] ifFalse:[(aCodeGen isGeneratingPluginCode and:[self isStatic]) ifTrue:[aStream nextPutAll:'static ']. aStream nextPutAll: realReturnType; space]. aStream nextPutAll: (aCodeGen cFunctionNameFor: selector), '('. args isEmpty ifTrue: [ aStream nextPutAll: 'void' ]. 1 to: args size do: [ :i | arg _ args at: i. (declarations includesKey: arg) ifTrue: [ aStream nextPutAll: (declarations at: arg). ] ifFalse: [ aStream nextPutAll: 'int ', (args at: i). ]. i < args size ifTrue: [ aStream nextPutAll: ', ' ]. ]. aStream nextPutAll: ')'.! !