'From Squeak3.1alpha of 4 February 2001 [latest update: #3681] on 20 February 2001 at 9:52:48 pm'! "Change Set: BBStack-ar Date: 20 February 2001 Author: Andreas Raab Fixes unbalanced stacks after BB prims invoked with arguments. Also adds the ability to check for stack balance when DoBalanceChecks is enabled during translation."! 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 freeContexts freeLargeContexts interruptCheckCounter displayBits totalObjectFoundAtStartup ' classVariableNames: 'AllButHashBits AllButMarkBit AllButMarkBitAndTypeMask AllButRootBit AllButTypeMask BaseHeaderSize BlockContextProto CharacterTable ClassArray ClassBitmap ClassBlockContext ClassByteArray ClassCharacter ClassCompiledMethod ClassExternalAddress ClassExternalData ClassExternalFunction ClassExternalLibrary ClassExternalStructure ClassFloat ClassInteger ClassLargeNegativeInteger ClassLargePositiveInteger ClassMessage ClassMethodContext ClassPoint ClassProcess ClassPseudoContext ClassSemaphore ClassString ClassTranslatedMethod CompactClassMask CompactClasses ConstMinusOne ConstOne ConstTwo ConstZero CtxtTempFrameStart DoAssertionChecks DoBalanceChecks Done ExternalObjectsArray FalseObject FloatProto GCTopMarker HashBits HashBitsOffset HeaderTypeClass HeaderTypeFree HeaderTypeGC HeaderTypeShort HeaderTypeSizeAndClass LargeContextBit LargeContextSize MarkBit MethodContextProto NilContext NilObject RemapBufferSize RootBit RootTableSize SchedulerAssociation SelectorCannotInterpret SelectorCannotReturn SelectorDoesNotUnderstand SelectorMustBeBoolean SizeMask SmallContextSize SpecialSelectors StackStart StartField StartObj TheDisplay TheFinalizationSemaphore TheInputSemaphore TheInterruptSemaphore TheLowSpaceSemaphore TheTimerSemaphore TrueObject TypeMask Upward ' poolDictionaries: '' category: 'VMConstruction-Interpreter'! !BitBltSimulation methodsFor: 'setup' stamp: 'ar 2/20/2001 21:11'! copyBitsLockedAndClipped "Perform the actual copyBits operation. Assume: Surfaces have been locked and clipping was performed." | done | self inline: true. "Try a shortcut for stuff that should be run as quickly as possible" done _ self tryCopyingBitsQuickly. done ifTrue:[^nil]. (combinationRule = 30) | (combinationRule = 31) ifTrue: ["Check and fetch source alpha parameter for alpha blend" interpreterProxy methodArgumentCount = 1 ifTrue: [sourceAlpha _ interpreterProxy stackIntegerValue: 0. (interpreterProxy failed not and: [(sourceAlpha >= 0) & (sourceAlpha <= 255)]) ifFalse: [^ interpreterProxy primitiveFail]] ifFalse: [^ interpreterProxy primitiveFail]]. bitCount _ 0. "Choose and perform the actual copy loop." self performCopyLoop. (combinationRule = 22) | (combinationRule = 32) ifTrue: ["zero width and height; return the count" affectedL _ affectedR _ affectedT _ affectedB _ 0]. hDir > 0 ifTrue: [affectedL _ dx. affectedR _ dx + bbW] ifFalse: [affectedL _ dx - bbW + 1. affectedR _ dx + 1]. vDir > 0 ifTrue: [affectedT _ dy. affectedB _ dy + bbH] ifFalse: [affectedT _ dy - bbH + 1. affectedB _ dy + 1]! ! !BitBltSimulation methodsFor: 'primitives' stamp: 'ar 2/20/2001 21:12'! primitiveCopyBits "Invoke the copyBits primitive. If the destination is the display, then copy it to the screen." | rcvr | self export: true. rcvr _ interpreterProxy stackValue: interpreterProxy methodArgumentCount. (self loadBitBltFrom: rcvr) ifFalse:[^interpreterProxy primitiveFail]. self copyBits. interpreterProxy failed ifTrue:[^nil]. self showDisplayBits. interpreterProxy failed ifTrue:[^nil]. interpreterProxy pop: interpreterProxy methodArgumentCount. (combinationRule = 22) | (combinationRule = 32) ifTrue:[ interpreterProxy pop: 1. ^ interpreterProxy pushInteger: bitCount].! ! !BitBltSimulation methodsFor: 'primitives' stamp: 'ar 2/20/2001 21:10'! primitiveWarpBits "Invoke the warpBits primitive. If the destination is the display, then copy it to the screen." | rcvr | self export: true. rcvr _ interpreterProxy stackValue: interpreterProxy methodArgumentCount. (self loadWarpBltFrom: rcvr) ifFalse:[^interpreterProxy primitiveFail]. self warpBits. interpreterProxy failed ifTrue:[^nil]. self showDisplayBits. interpreterProxy failed ifTrue:[^nil]. interpreterProxy pop: interpreterProxy methodArgumentCount.! ! !Interpreter methodsFor: 'primitive support' stamp: 'ar 2/20/2001 00:59'! 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 - activeContext. ]. 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: 'other primitives' stamp: 'ar 2/20/2001 00:57'! 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:[^nil]. 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:[^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: 'debug support' stamp: 'ar 2/20/2001 21:42'! 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 - activeContext + (nArgs * 4)) = delta ]. "Failed prim must leave stack intact" ^(stackPointer - activeContext) = delta ! ! !Interpreter methodsFor: 'debug support' stamp: 'ar 2/20/2001 21:39'! printStringOf: oop | fmt cnt i | (self isIntegerObject: oop) ifTrue:[^nil]. fmt _ self formatOf: oop. fmt < 8 ifTrue: [ ^nil ]. cnt _ 100 min: (self lengthOf: oop). i _ 0. [i < cnt] whileTrue: [ self printChar: (self fetchByte: i ofObject: oop). i _ i + 1. ].! ! !Interpreter methodsFor: 'debug support' stamp: 'ar 2/20/2001 01:00'! printUnbalancedStack: primIdx self inline: false. self print: 'Stack unbalanced after '. successFlag ifTrue:[self print:'successful primitive '] ifFalse:[self print: 'failed primitive ']. self printNum: primIdx. self cr. ! ! !Interpreter methodsFor: 'debug support' stamp: 'ar 2/20/2001 21:39'! printUnbalancedStackFromNamedPrimitive | lit | self inline: false. self print: 'Stack unbalanced after '. successFlag ifTrue:[self print:'successful '] ifFalse:[self print: 'failed ']. lit _ self literal: 0 ofMethod: newMethod. self printStringOf: (self fetchPointer: 1 ofObject: lit). self print:' in '. self printStringOf: (self fetchPointer: 0 ofObject: lit). self cr. ! ! !ObjectMemory class methodsFor: 'initialization' stamp: 'ar 2/20/2001 21:52'! 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. SmallContextSize _ 92. "16 indexable fields" LargeContextSize _ 252. "56 indexable fileds. Max with single header word." LargeContextBit _ 16r40000. "This bit set in method headers if large context is needed." CtxtTempFrameStart _ 6. "Copy of TempFrameStart in Interp" NilContext _ 1. "the oop for the integer 0; used to mark the end of context lists" RemapBufferSize _ 25. RootTableSize _ 2500. "number of root table entries (4 bytes/entry)" "tracer actions" StartField _ 1. StartObj _ 2. Upward _ 3. Done _ 4.! ! ObjectMemory initialize!