VM Maker: VMMaker-oscog-EstebanLorenzano
Locked
 
|
Esteban Lorenzano uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker-oscog-EstebanLorenzano.138.mcz ==================== Summary ==================== Name: VMMaker-oscog-EstebanLorenzano.138 Author: EstebanLorenzano Time: 11 November 2011, 2:06:05 pm UUID: 11b27e15-98a3-4d17-8e9a-c718e641c0de Ancestors: VMMaker-oscog-EstebanLorenzano.124, VMMaker.oscog-eem.137 attempt to integrate Eliot changes (not sure it works) -removed generation of __buildInfo in header files (it was causing compile errors... maybe my problem, but I don't know how to solve it other way) -fix on LargeIntegersPlugin... already not sure about it, but now seems to work. =============== Diff against VMMaker-oscog-EstebanLorenzano.124 =============== Item was changed: ----- Method: CCodeGenerator>>builtin: (in category 'utilities') ----- builtin: sel "Answer true if the given selector is one of the builtin selectors." + ^(self kernel: sel) or: [translationDict includesKey: sel]! - ^(#(error: - byteAt: byteAt:put: byteAtPointer: byteAtPointer:put: - intAt: intAt:put: intAtPointer: intAtPointer:put: - longAt: longAt:put: longAtPointer: longAtPointer:put: - shortAt: shortAt:put: shortAtPointer: shortAtPointer:put: - fetchFloatAt:into: storeFloatAt:from: - fetchFloatAtPointer:into: storeFloatAtPointer:from: - fetchSingleFloatAt:into: storeSingleFloatAt:from: - fetchSingleFloatAtPointer:into: storeSingleFloatAtPointer:from:) - includes: sel) - or: [translationDict includesKey: sel]! Item was changed: ----- Method: CCodeGenerator>>fileHeaderVersionStampForSourceClass: (in category 'C code generator') ----- fileHeaderVersionStampForSourceClass: sourceClass "Answer a suitable versiomn stamp to include in the header." | exportBuildInfo slangDescription sourceDescription | + [exportBuildInfo := sourceClass isInterpreterClass ifTrue: ['char *__interpBuildInfo = __buildInfo;'] ifFalse: [sourceClass isCogitClass ifTrue: ['char *__cogitBuildInfo = __buildInfo;']]] on: MessageNotUnderstood do: [:ex| ex resume: false]. [slangDescription := self monticelloDescriptionFor: self class. sourceClass ifNotNil: [sourceDescription := self monticelloDescriptionFor: sourceClass]] on: Error do: [:ex| | now | now := Time dateAndTimeNow printString. + ^String streamContents: [:s| s nextPutAll: '/* Automatically generated from Squeak on '. s nextPutAll: now. s nextPutAll: ' */'; cr; cr. s nextPutAll: 'static char __buildInfo[] = "Generated on '. s nextPutAll: now. s nextPutAll: '. Compiled on "'. s nextPutAll: '__DATE__ ;'; cr. exportBuildInfo ifNotNil: [s nextPutAll: exportBuildInfo; cr]. s cr]]. + ^String streamContents: [:s| s nextPutAll: '/* Automatically generated by'. s crtab. s nextPutAll: slangDescription. sourceDescription ifNotNil: [s cr; nextPutAll: ' from'; crtab; nextPutAll: sourceDescription]. s cr; nextPutAll: ' */'; cr. sourceDescription ifNotNil: [s nextPutAll: 'static char __buildInfo[] = "'. s nextPutAll: sourceDescription. s nextPutAll: ' " __DATE__ ;'; cr. exportBuildInfo ifNotNil: [s nextPutAll: exportBuildInfo; cr]. s cr]]! Item was added: + ----- Method: CCodeGenerator>>kernel: (in category 'utilities') ----- + kernel: sel + "Answer true if the given selector is one of the kernel selectors that are implemented as macros." + + ^(#(error: + byteAt: byteAt:put: byteAtPointer: byteAtPointer:put: + intAt: intAt:put: intAtPointer: intAtPointer:put: + longAt: longAt:put: longAtPointer: longAtPointer:put: + shortAt: shortAt:put: shortAtPointer: shortAtPointer:put: + fetchFloatAt:into: storeFloatAt:from: + fetchFloatAtPointer:into: storeFloatAtPointer:from: + fetchSingleFloatAt:into: storeSingleFloatAt:from: + fetchSingleFloatAtPointer:into: storeSingleFloatAtPointer:from:) + includes: sel)! Item was changed: ----- Method: CCodeGenerator>>messageReceiverIsInterpreterProxy: (in category 'utilities') ----- messageReceiverIsInterpreterProxy: sendNode ^self isGeneratingPluginCode and: [sendNode receiver isVariable and: ['interpreterProxy' = sendNode receiver name + and: [(self kernel: sendNode selector) not]]]! - and: [(self builtin: sendNode selector) not]]]! Item was changed: ----- Method: CCodeGenerator>>prepareMethods (in category 'utilities') ----- prepareMethods | globals | globals := Set new: 200. globals addAll: variables. methods do: [:m | m locals, m args do: [:var | (globals includes: var) ifTrue: [self error: 'Local variable name may mask global when inlining: ' , var]. ((methods at: var ifAbsent: [nil]) ifNil: [false] ifNotNil: [:m1| m1 isStructAccessor not]) ifTrue: [logger ensureCr; nextPutAll: 'Local variable name ', var, ' in '; nextPutAll: m selector; nextPutAll: ' may mask method when inlining: ' , var]]. m bindClassVariablesIn: constants. m prepareMethodIn: self]! Item was changed: ----- Method: CCodeGenerator>>storeAPIExportHeader:OnFile: (in category 'public') ----- storeAPIExportHeader: headerName OnFile: fullHeaderPath "Store C header code on the given file. Evaluate aBlock with the stream to generate its contents." | header | header := String streamContents: [:s| + "s nextPutAll: (self fileHeaderVersionStampForSourceClass: nil); cr." - s nextPutAll: (self fileHeaderVersionStampForSourceClass: nil); cr. self emitCAPIExportHeaderOn: s]. (self needToGenerateHeader: headerName file: fullHeaderPath contents: header) ifTrue: [self storeHeaderOnFile: fullHeaderPath contents: header]! Item was changed: ----- Method: CCodeGenerator>>storeHeaderOnFile:contents: (in category 'public') ----- storeHeaderOnFile: fileName contents: contents "Store C header code on the given file. Evaluate aBlock with the stream to generate its contents." | aStream | aStream := VMMaker forceNewFileNamed: fileName. + aStream ifNil: [Error signal: 'Could not open C header file: ', fileName]. + ["(contents beginsWith: '/* Automatic') ifFalse: + [aStream nextPutAll: (self fileHeaderVersionStampForSourceClass: nil); cr]." - [(contents beginsWith: '/* Automatic') ifFalse: - [aStream nextPutAll: (self fileHeaderVersionStampForSourceClass: nil); cr]. aStream nextPutAll: contents] ensure: [aStream close]! Item was added: + ----- Method: CObjectAccessor class>>alignedByteSizeOf:forClient: (in category 'accessing') ----- + alignedByteSizeOf: aCObjectAccessor forClient: aVMClass + "Hack; this only works if the object is actually bytes." + ^aCObjectAccessor object size! Item was changed: ----- Method: CoInterpreter>>ceContext:instVar: (in category 'trampolines') ----- ceContext: maybeContext instVar: slotIndex <api> | result | + (objectMemory isContextNonInt: maybeContext) - (self isContextNonInt: maybeContext) ifTrue: [instructionPointer := self popStack. result := self externalInstVar: slotIndex ofContext: maybeContext. self push: instructionPointer] ifFalse: [result := objectMemory fetchPointer: slotIndex ofObject: maybeContext]. ^result! Item was changed: ----- Method: CoInterpreter>>ceContext:instVar:value: (in category 'trampolines') ----- ceContext: maybeMarriedContext instVar: slotIndex value: anOop <api> "genStorePop:MaybeContextReceiverVariable: filters out unmarried contexts but not arbitrary objects in subclasses. It answers maybeMarriedContext so that the StackToRegisterMappingCogit can keep ReceiverResultReg live." + (objectMemory isContextNonInt: maybeMarriedContext) - (self isContextNonInt: maybeMarriedContext) ifTrue: [self assert: (self isMarriedOrWidowedContext: maybeMarriedContext). instructionPointer := self popStack. self externalInstVar: slotIndex ofContext: maybeMarriedContext put: anOop. self push: instructionPointer] ifFalse: [objectMemory storePointer: slotIndex ofObject: maybeMarriedContext withValue: anOop]. ^maybeMarriedContext! Item was changed: ----- Method: CoInterpreter>>ceTraceBlockActivation (in category 'debug support') ----- ceTraceBlockActivation <api> <var: #cogMethod type: #'CogMethod *'> + cogit recordBlockTrace ifTrue: - cogit recordSendTrace ifTrue: [self recordTrace: TraceBlockActivation thing: (self mframeHomeMethod: framePointer) methodObject + source: TraceIsFromMachineCode. + cogit printOnTrace ifTrue: + [self printActivationNameFor: (self mframeHomeMethod: framePointer) methodObject + receiver: (self frameReceiver: framePointer) + isBlock: true + firstTemporary: nil. + self cr]]! - source: TraceIsFromMachineCode]. - cogit printOnTrace ifTrue: - [self printActivationNameFor: (self mframeHomeMethod: framePointer) methodObject - receiver: (self frameReceiver: framePointer) - isBlock: true - firstTemporary: nil. - self cr]! Item was changed: ----- Method: CoInterpreter>>ceTraceLinkedSend: (in category 'debug support') ----- ceTraceLinkedSend: theReceiver | cogMethod | <api> <var: #cogMethod type: #'CogMethod *'> cogMethod := self cCoerceSimple: (self stackTop - cogit traceLinkedSendOffset) to: #'CogMethod *'. + "cogit recordSendTrace ifTrue: is implicit; wouldn't compile the call otherwise." + self recordTrace: (objectMemory fetchClassOf: theReceiver) + thing: cogMethod selector + source: TraceIsFromMachineCode. - cogit recordSendTrace ifTrue: - [self recordTrace: (objectMemory fetchClassOf: theReceiver) thing: cogMethod selector source: TraceIsFromMachineCode]. cogit printOnTrace ifTrue: [self printActivationNameFor: cogMethod methodObject receiver: theReceiver isBlock: false firstTemporary: nil; cr]. self sendBreak: cogMethod selector + BaseHeaderSize point: (objectMemory lengthOf: cogMethod selector) receiver: theReceiver! Item was changed: ----- Method: CoInterpreter>>commonSend (in category 'message sending') ----- commonSend "Send a message, starting lookup with the receiver's class." "Assume: messageSelector and argumentCount have been set, and that the receiver and arguments have been pushed onto the stack," "Note: This method is inlined into the interpreter dispatch loop." <sharedCodeNamed: 'commonSend' inCase: 131> self sendBreak: messageSelector + BaseHeaderSize point: (objectMemory lengthOf: messageSelector) receiver: (self internalStackValue: argumentCount). cogit recordSendTrace ifTrue: + [self recordTrace: lkupClass thing: messageSelector source: TraceIsFromInterpreter. + cogit printOnTrace ifTrue: + [self printActivationNameForSelector: messageSelector startClass: lkupClass; cr]]. - [self recordTrace: lkupClass thing: messageSelector source: TraceIsFromInterpreter]. self internalFindNewMethod. self internalExecuteNewMethod. self fetchNextBytecode! Item was changed: ----- Method: CoInterpreter>>ensureAllContextsHaveBytecodePCsOrAreBereaved (in category 'frame access') ----- ensureAllContextsHaveBytecodePCsOrAreBereaved "Enumerate all contexts preparing them for a snapshot. Map all native pcs to bytecoded pcs. Convert widowed contexts to single contexts so that the snapshot contains only single contexts. This allows the being married test to avoid checking for a context's frame pointer being in bounds since all frame pointers must have been created in the current system and so be in bounds. Thanks to Greg Nuyens for this idea." | oop decodedIP | oop := objectMemory firstObject. [oop < objectMemory freeStart] whileTrue: [((objectMemory isFreeObject: oop) not + and: [objectMemory isContextNonInt: oop]) ifTrue: - and: [self isContextNonInt: oop]) ifTrue: [(self isMarriedOrWidowedContext: oop) ifTrue: "The stack pages have already been discarded. Any remaining married contexts are actually widows." [self markContextAsDead: oop] ifFalse: [decodedIP := objectMemory fetchPointer: InstructionPointerIndex ofObject: oop. ((objectMemory isIntegerObject: decodedIP) and: [decodedIP signedIntFromLong < 0]) ifTrue: [decodedIP := self mustMapMachineCodePC: (objectMemory integerValueOf: decodedIP) context: oop. objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: oop withValue: decodedIP]]]. oop := objectMemory objectAfter: oop]! Item was added: + ----- Method: CoInterpreter>>interpretAddress (in category 'trampoline support') ----- + interpretAddress + "This is used for asserts that check that inline cache editing results in valid addresses. + In the C VM interpret is presumed to come before any primitives and so it constitutes + the lowest address in C code that machine code should be linked. In the simulator + we just answer something not low." + <api> + <returnTypeC: #usqInt> + ^self cCode: [(self addressOf: #interpret asSymbol) asUnsignedInteger] + inSmalltalk: [heapBase]! Item was added: + ----- Method: CoInterpreter>>primitiveFailAddress (in category 'trampoline support') ----- + primitiveFailAddress + "This is used for asserts that check that inline cache editing results in valid addresses. + In the C VM interpret is presumed to come before any primitives and so it constitutes + the lowest address in C code that machine code should be linked, but optimizing + compilers change things around. In the simulator we just answer something not low." + <api> + <returnTypeC: #usqInt> + ^self cCode: [(self addressOf: #primitiveFail asSymbol) asUnsignedInteger] + inSmalltalk: [heapBase]! Item was added: + ----- Method: CoInterpreter>>printSends (in category 'debug printing') ----- + printSends + <inline: true> + ^cogit printOnTrace! Item was changed: ----- Method: CoInterpreterMT>>threadSwitchIfNecessary:from: (in category 'process primitive support') ----- threadSwitchIfNecessary: newProc from: sourceCode "Invoked from transferTo:from: to switch threads if the new process is bound or affined to some other thread." | newProcThreadId vmThread activeContext tlti vmo | <var: #vmThread type: #'CogVMThread *'> self cCode: [] inSmalltalk: [vmo := cogThreadManager getVMOwner. tlti := cogThreadManager ioGetThreadLocalThreadIndex. self assert: vmo = tlti]. deferThreadSwitch ifTrue: [^self]. newProcThreadId := self ownerIndexOfProcess: newProc. ((activeProcessAffined := newProcThreadId ~= 0) and: [newProcThreadId ~= cogThreadManager getVMOwner]) ifTrue: [self cCode: '' inSmalltalk: [self transcript ensureCr; nextPutAll: #threadSwitchIfNecessary:from:; space; print: newProc; space; print: vmo; nextPutAll: '->'; print: newProcThreadId; cr; flush]. "If primitiveProcessBindToThreadId has bound a process and indicated a thread switch is necessary we'll come in here but the activeProcess won't have a context yet, and it needs one from which the new thread can resume execution." (objectMemory fetchPointer: SuspendedContextIndex ofObject: newProc) = objectMemory nilObject ifTrue: [self assert: newProc = self activeProcess. self push: instructionPointer. self externalWriteBackHeadFramePointers. activeContext := self ensureFrameIsMarried: framePointer SP: stackPointer. objectMemory storePointer: SuspendedContextIndex ofObject: newProc withValue: activeContext]. vmThread := cogThreadManager vmThreadAt: newProcThreadId. vmThread priority: (self quickFetchInteger: PriorityIndex ofObject: newProc). + vmThread state = CTMUnavailable ifTrue: + [vmThread state: CTMWantingOwnership]. self returnToSchedulingLoopAndReleaseVMOrWakeThread: vmThread source: CSSwitchIfNeccessary]. (self quickFetchInteger: PriorityIndex ofObject: newProc) < maxWaitingPriority ifTrue: [checkThreadActivation := true. self forceInterruptCheck]! Item was removed: - ----- Method: CogBlockMethod class>>alignedByteSizeForClient: (in category 'accessing') ----- - alignedByteSizeForClient: aVMClass - ^aVMClass cogit cogBlockMethodSurrogateClass alignedByteSize! Item was added: + ----- Method: CogBlockMethod class>>alignedByteSizeOf:forClient: (in category 'accessing') ----- + alignedByteSizeOf: anObject forClient: aVMClass + ^aVMClass cogit cogBlockMethodSurrogateClass alignedByteSize! Item was added: + VMClass subclass: #CogGenerationScavenger + instanceVariableNames: 'coInterpreter manager memory futureSpace pastSpace rememberedSet rememberedSetSize' + classVariableNames: '' + poolDictionaries: '' + category: 'VMMaker-MemoryManager'! Item was added: + ----- Method: CogGenerationScavenger>>copyAndForward: (in category 'api') ----- + copyAndForward: survivor + "copyAndForward: survivor copies a survivor object either to + futureSurvivorSpace or, if it is to be promoted, to oldSpace. + It leaves a forwarding pointer behind." + <var: #survivor type: #'object *'> + | newLocation | + newLocation := (self shouldBeTenured: survivor) + ifTrue: [self copyToOldSpace: survivor] + ifFalse: [self copyToFutureSpace: survivor]. + manager forward: survivor to: newLocation + ! Item was added: + ----- Method: CogGenerationScavenger>>scavenge (in category 'api') ----- + scavenge + "The main routine, scavenge, scavenges young objects reachable from the roots (the stack zone + and the rememberedTable). It first scavenges the new objects immediately reachable from the + stack zone, then those directly from old ones (all in the remembered table). Then it scavenges + those that are transitively reachable. If this results in a promotion, the promotee gets remembered, + and it first scavenges objects adjacent to the promotee, then scavenges the ones reachable from + the promoted. This loop continues until no more reachable objects are left. At that point, + pastSurvivorSpace is exchanged with futureSurvivorSpace. + + Notice that each pointer in a live object is inspected once and only once. The previousRememberedSetSize + and previousFutureSurvivorSpaceSize variables ensure that no object is scanned twice, as well as + detecting closure. If this were not true, some pointers might get forwarded twice." + + coInterpreter scavengeStacks. + self scavengeLoop. + self exchange: pastSpace with: futureSpace! Item was added: + ----- Method: CogGenerationScavenger>>scavengeFutureSurvivorSpaceStartingAt: (in category 'api') ----- + scavengeFutureSurvivorSpaceStartingAt: initialAddress + "scavengeFutureSurvivorSpaceStartingAt: does a depth-first traversal of the + new objects starting at the one at the nth word of futureSurvivorSpace." + | ptr | + <var: #ptr type: #'char *'> + ptr := initialAddress. + [ptr < futureSpace limit] whileTrue: + [| obj | + obj := manager objectAt: ptr. + ptr := ptr + (manager byteLengthOf: obj). + self cCoerceSimple: (self scavengeReferentsOf: obj) + to: #void]! Item was added: + ----- Method: CogGenerationScavenger>>scavengeLoop (in category 'api') ----- + scavengeLoop + "This is the inner loop of the main routine, scavenge. It first scavenges the new objects immediately + reachable from old ones. Then it scavenges those that are transitively reachable. If this results in a + promotion, the promotee gets remembered, and it first scavenges objects adjacent to the promotee, + then scavenges the ones reachable from the promoted. This loop continues until no more reachable + objects are left. At that point, pastSurvivorSpace is exchanged with futureSurvivorSpace. + + Notice that each pointer in a live object is inspected once and only once. The previousRememberedSetSize + and previousFutureSurvivorSpaceLimit variables ensure that no object is scanned twice, as well as + detecting closure. If this were not true, some pointers might get forwarded twice." + + | previousRememberedSetSize previousFutureSurvivorSpaceLimit | + previousRememberedSetSize := 0. + previousFutureSurvivorSpaceLimit := futureSpace limit. + self assert: futureSpace limit = futureSpace start. + [self scavengeRememberedSetStartingAt: previousRememberedSetSize. + previousFutureSurvivorSpaceLimit = futureSpace limit ifTrue: + [^self]. + + previousRememberedSetSize := rememberedSetSize. + self scavengeFutureSurvivorSpaceStartingAt: previousFutureSurvivorSpaceLimit. + previousFutureSurvivorSpaceLimit = rememberedSetSize ifTrue: + [^self]. + + previousFutureSurvivorSpaceLimit := futureSpace size] repeat! Item was added: + ----- Method: CogGenerationScavenger>>scavengeReferentsOf: (in category 'api') ----- + scavengeReferentsOf: referrer + "scavengeReferentsOf: referrer inspects all the pointers in referrer. + If any are new objects, it has them moved to FutureSurvivorSpace, + and returns truth. If there are no new referents, it returns falsity." + <var: #referrer type: #'object *'> + | foundNewReferent referent | + referrer isPointers ifFalse: + [^self]. + foundNewReferent := false. + 0 to: (manager lengthOf: referrer) do: + [:i| + referent := manager fetchPointer: i ofObject: referrer. + (manager isYoung: referent) ifTrue: + [foundNewReferent := true. + referent isForwarded ifFalse: + [self copyAndForward: referent]. + manager + storePointerUnchecked: i + ofObject: referrer + withValue: (manager forwardingPointerOf: referent)]]. + ^foundNewReferent! Item was added: + ----- Method: CogGenerationScavenger>>scavengeRememberedSetStartingAt: (in category 'api') ----- + scavengeRememberedSetStartingAt: n + "scavengeRememberedSetStartingAt: n traverses objects in the remembered + set starting at the nth one. If the object does not refer to any new objects, it + is removed from the set. Otherwise, its new referents are scavenged." + | destIndex sourceIndex | + sourceIndex := destIndex := n. + [sourceIndex < rememberedSetSize] whileTrue: + [| referree | + referree := rememberedSet at: sourceIndex. + (self scavengeReferentsOf: referree) + ifTrue: + [rememberedSet at: destIndex put: referree. + destIndex := destIndex + 1] + ifFalse: + [referree isRemembered: false]. + sourceIndex := sourceIndex + 1]. + rememberedSetSize := destIndex! Item was changed: ----- Method: CogIA32Compiler>>relocateCallBeforeReturnPC:by: (in category 'inline cacheing') ----- relocateCallBeforeReturnPC: retpc by: delta | distance | delta ~= 0 ifTrue: + [distance := ((objectMemory byteAt: retpc - 1) << 24) - [distance := ((objectMemory byteAt: retpc - 1) << 24) + ((objectMemory byteAt: retpc - 2) << 16) + ((objectMemory byteAt: retpc - 3) << 8) + (objectMemory byteAt: retpc - 4). distance := distance + delta. objectMemory byteAt: retpc - 1 put: (distance >> 24 bitAnd: 16rFF); byteAt: retpc - 2 put: (distance >> 16 bitAnd: 16rFF); byteAt: retpc - 3 put: (distance >> 8 bitAnd: 16rFF); + byteAt: retpc - 4 put: (distance bitAnd: 16rFF). + false + ifTrue: [self assert: (self callTargetFromReturnAddress: retpc) signedIntToLong >= cogit minCallAddress] + ifFalse: [(self callTargetFromReturnAddress: retpc) signedIntToLong >= cogit minCallAddress ifFalse: + [self error: 'relocating call to invalid address']]]! - byteAt: retpc - 4 put: (distance bitAnd: 16rFF)]! Item was changed: ----- Method: CogIA32Compiler>>rewriteCallAt:target: (in category 'inline cacheing') ----- rewriteCallAt: callSiteReturnAddress target: callTargetAddress "Rewrite a call instruction to call a different target. This variant is used to link PICs in ceSendMiss et al, and to rewrite cached primitive calls. Answer the extent of the code change which is used to compute the range of the icache to flush." + <var: #callSiteReturnAddress type: #usqInt> + <var: #callTargetAddress type: #usqInt> | callDistance | "self cCode: '' inSmalltalk: [cogit disassembleFrom: callSiteReturnAddress - 10 to: callSiteReturnAddress - 1]." + false + ifTrue: [self assert: callTargetAddress >= cogit minCallAddress] + ifFalse: [callTargetAddress >= cogit minCallAddress ifFalse: + [self error: 'linking callsite to invalid address']]. callDistance := (callTargetAddress - callSiteReturnAddress) signedIntToLong. objectMemory byteAt: callSiteReturnAddress - 1 put: (callDistance >> 24 bitAnd: 16rFF); byteAt: callSiteReturnAddress - 2 put: (callDistance >> 16 bitAnd: 16rFF); byteAt: callSiteReturnAddress - 3 put: (callDistance >> 8 bitAnd: 16rFF); byteAt: callSiteReturnAddress - 4 put: (callDistance bitAnd: 16rFF). + self assert: (self callTargetFromReturnAddress: callSiteReturnAddress) signedIntToLong = callTargetAddress. "self cCode: '' inSmalltalk: [cogit disassembleFrom: callSiteReturnAddress - 10 to: callSiteReturnAddress - 1]." ^5! Item was changed: ----- Method: CogIA32Compiler>>rewriteInlineCacheAt:tag:target: (in category 'inline cacheing') ----- rewriteInlineCacheAt: callSiteReturnAddress tag: cacheTag target: callTargetAddress "Rewrite an inline cache to call a different target for a new tag. This variant is used to link unlinked sends in ceSend:to:numArgs: et al. Answer the extent of the code change which is used to compute the range of the icache to flush." + <var: #callSiteReturnAddress type: #usqInt> + <var: #callTargetAddress type: #usqInt> | callDistance | + "self cCode: '' + inSmalltalk: [cogit disassembleFrom: callSiteReturnAddress - 10 to: callSiteReturnAddress - 1]." + false + ifTrue: [self assert: callTargetAddress >= cogit minCallAddress] + ifFalse: [callTargetAddress >= cogit minCallAddress ifFalse: + [self error: 'linking callsite to invalid address']]. - self cCode: '' - inSmalltalk: [false ifTrue: [cogit disassembleFrom: callSiteReturnAddress - 10 to: callSiteReturnAddress - 1]]. callDistance := (callTargetAddress - callSiteReturnAddress) signedIntToLong. objectMemory byteAt: callSiteReturnAddress - 1 put: (callDistance >> 24 bitAnd: 16rFF); byteAt: callSiteReturnAddress - 2 put: (callDistance >> 16 bitAnd: 16rFF); byteAt: callSiteReturnAddress - 3 put: (callDistance >> 8 bitAnd: 16rFF); byteAt: callSiteReturnAddress - 4 put: (callDistance bitAnd: 16rFF); byteAt: callSiteReturnAddress - 6 put: (cacheTag >> 24 bitAnd: 16rFF); byteAt: callSiteReturnAddress - 7 put: (cacheTag >> 16 bitAnd: 16rFF); byteAt: callSiteReturnAddress - 8 put: (cacheTag >> 8 bitAnd: 16rFF); byteAt: callSiteReturnAddress - 9 put: (cacheTag bitAnd: 16rFF). + self assert: (self callTargetFromReturnAddress: callSiteReturnAddress) signedIntToLong = callTargetAddress. + "self cCode: '' + inSmalltalk: [cogit disassembleFrom: callSiteReturnAddress - 10 to: callSiteReturnAddress - 1]." - self cCode: '' - inSmalltalk: [false ifTrue: [cogit disassembleFrom: callSiteReturnAddress - 10 to: callSiteReturnAddress - 1]]. ^10! Item was changed: VMClass subclass: #CogMemoryManager (excessive size, no diff calculated) Item was removed: - ----- Method: CogMethod class>>alignedByteSizeForClient: (in category 'accessing') ----- - alignedByteSizeForClient: aVMClass - ^aVMClass cogit cogMethodSurrogateClass alignedByteSize! Item was added: + ----- Method: CogMethod class>>alignedByteSizeOf:forClient: (in category 'accessing') ----- + alignedByteSizeOf: anObject forClient: aVMClass + ^aVMClass cogit cogMethodSurrogateClass alignedByteSize! Item was removed: - ----- Method: CogMethodSurrogate class>>alignedByteSizeForClient: (in category 'accessing') ----- - alignedByteSizeForClient: aVMClass - ^self alignedByteSize! Item was added: + ----- Method: CogMethodSurrogate class>>alignedByteSizeOf:forClient: (in category 'accessing') ----- + alignedByteSizeOf: anObject forClient: aVMClass + ^self alignedByteSize! Item was changed: VMStructType subclass: #CogObjectHeader + instanceVariableNames: 'classIndex unused0 isPinned isImmutable format isMarked isGrey isRemembered objHash slotSize' - instanceVariableNames: 'classIndex unused0 format isWeak isEphemeron isPointers isPinned isMarked isGrey isRemembered isImmutable objHash objSize' classVariableNames: '' poolDictionaries: '' category: 'VMMaker-MemoryManager'! Item was changed: ----- Method: CogObjectHeader class>>instVarNamesAndTypesForTranslationDo: (in category 'translation') ----- instVarNamesAndTypesForTranslationDo: aBinaryBlock "enumerate aBinaryBlock with the names and C type strings for the inst vars to include in a BytecodeDescriptor struct." + "self typedef" self instVarNames do: [:ivn| aBinaryBlock value: ivn value: (ivn caseOf: { + ['classIndex'] -> [#'unsigned short']. "for speed; can extend to 22 bits by absorbing unused0" + ['unused0'] -> [#(unsigned ' : 6')]. + ['format'] -> [#(unsigned ' : 5')]. - ['classIndex'] -> [#'unsigned short']. "for speed; can extend to 20 bits by absorbing unused0" - ['unused0'] -> [#(unsigned ' : 4')]. - ['format'] -> [#(unsigned ' : 4')]. ['objHash'] -> [#(unsigned ' : 24')]. + ['slotSize'] -> [#'unsigned char'] } - ['objSize'] -> [#'unsigned char'] } otherwise: [#(#unsigned #Boolean ' : 1')])]! Item was added: + ----- Method: CogObjectHeader>>isForwarded (in category 'accessing') ----- + isForwarded + ^self classIndex = 0! Item was added: + ----- Method: CogObjectHeader>>setIsForwarded (in category 'accessing') ----- + setIsForwarded + self classIndex: 0! Item was changed: ----- Method: CogObjectHeaderSurrogate>>format (in category 'accessing') ----- format + ^(memory unsignedByteAt: address + 4) bitAnd: 16r1F! - ^((memory unsignedByteAt: address + 3) bitShift: -4) bitAnd: 16rF! Item was changed: ----- Method: CogObjectHeaderSurrogate>>format: (in category 'accessing') ----- format: aValue + self assert: (aValue between: 0 and: 16r1F). - self assert: (aValue between: 0 and: 16rF). memory + unsignedByteAt: address + 4 + put: ((memory unsignedByteAt: address + 4) bitAnd: 16rE0) + aValue. - unsignedByteAt: address + 3 - put: ((memory unsignedByteAt: address + 3) bitAnd: 16rF) + (aValue bitShift: 4). ^aValue! Item was removed: - ----- Method: CogObjectHeaderSurrogate>>isEphemeron (in category 'accessing') ----- - isEphemeron - ^(((memory unsignedByteAt: address + 4) bitShift: -1) bitAnd: 16r1) ~= 0! Item was removed: - ----- Method: CogObjectHeaderSurrogate>>isEphemeron: (in category 'accessing') ----- - isEphemeron: aValue - memory - unsignedByteAt: address + 4 - put: (((memory unsignedByteAt: address + 4) bitAnd: 16rFD) + ((aValue ifTrue: [1] ifFalse: [0]) bitShift: 1)). - ^aValue! Item was changed: ----- Method: CogObjectHeaderSurrogate>>isGrey (in category 'accessing') ----- isGrey + ^(((memory unsignedByteAt: address + 4) bitShift: -6) bitAnd: 16r1) ~= 0! - ^(((memory unsignedByteAt: address + 4) bitShift: -5) bitAnd: 16r1) ~= 0! Item was changed: ----- Method: CogObjectHeaderSurrogate>>isGrey: (in category 'accessing') ----- isGrey: aValue memory unsignedByteAt: address + 4 + put: (((memory unsignedByteAt: address + 4) bitAnd: 16rBF) + ((aValue ifTrue: [1] ifFalse: [0]) bitShift: 6)). - put: (((memory unsignedByteAt: address + 4) bitAnd: 16rDF) + ((aValue ifTrue: [1] ifFalse: [0]) bitShift: 5)). ^aValue! Item was changed: ----- Method: CogObjectHeaderSurrogate>>isImmutable (in category 'accessing') ----- isImmutable + ^(((memory unsignedByteAt: address + 3) bitShift: -7) bitAnd: 16r1) ~= 0! - ^(((memory unsignedByteAt: address + 4) bitShift: -7) bitAnd: 16r1) ~= 0! Item was changed: ----- Method: CogObjectHeaderSurrogate>>isImmutable: (in category 'accessing') ----- isImmutable: aValue memory + unsignedByteAt: address + 3 + put: (((memory unsignedByteAt: address + 3) bitAnd: 16r7F) + ((aValue ifTrue: [1] ifFalse: [0]) bitShift: 7)). - unsignedByteAt: address + 4 - put: (((memory unsignedByteAt: address + 4) bitAnd: 16r7F) + ((aValue ifTrue: [1] ifFalse: [0]) bitShift: 7)). ^aValue! Item was changed: ----- Method: CogObjectHeaderSurrogate>>isMarked (in category 'accessing') ----- isMarked + ^(((memory unsignedByteAt: address + 4) bitShift: -5) bitAnd: 16r1) ~= 0! - ^(((memory unsignedByteAt: address + 4) bitShift: -4) bitAnd: 16r1) ~= 0! Item was changed: ----- Method: CogObjectHeaderSurrogate>>isMarked: (in category 'accessing') ----- isMarked: aValue memory unsignedByteAt: address + 4 + put: (((memory unsignedByteAt: address + 4) bitAnd: 16rDF) + ((aValue ifTrue: [1] ifFalse: [0]) bitShift: 5)). - put: (((memory unsignedByteAt: address + 4) bitAnd: 16rEF) + ((aValue ifTrue: [1] ifFalse: [0]) bitShift: 4)). ^aValue! Item was changed: ----- Method: CogObjectHeaderSurrogate>>isPinned (in category 'accessing') ----- isPinned + ^(((memory unsignedByteAt: address + 3) bitShift: -6) bitAnd: 16r1) ~= 0! - ^(((memory unsignedByteAt: address + 4) bitShift: -3) bitAnd: 16r1) ~= 0! Item was changed: ----- Method: CogObjectHeaderSurrogate>>isPinned: (in category 'accessing') ----- isPinned: aValue memory + unsignedByteAt: address + 3 + put: (((memory unsignedByteAt: address + 3) bitAnd: 16rBF) + ((aValue ifTrue: [1] ifFalse: [0]) bitShift: 6)). - unsignedByteAt: address + 4 - put: (((memory unsignedByteAt: address + 4) bitAnd: 16rF7) + ((aValue ifTrue: [1] ifFalse: [0]) bitShift: 3)). ^aValue! Item was removed: - ----- Method: CogObjectHeaderSurrogate>>isPointers (in category 'accessing') ----- - isPointers - ^(((memory unsignedByteAt: address + 4) bitShift: -2) bitAnd: 16r1) ~= 0! Item was removed: - ----- Method: CogObjectHeaderSurrogate>>isPointers: (in category 'accessing') ----- - isPointers: aValue - memory - unsignedByteAt: address + 4 - put: (((memory unsignedByteAt: address + 4) bitAnd: 16rFB) + ((aValue ifTrue: [1] ifFalse: [0]) bitShift: 2)). - ^aValue! Item was changed: ----- Method: CogObjectHeaderSurrogate>>isRemembered (in category 'accessing') ----- isRemembered + ^(((memory unsignedByteAt: address + 4) bitShift: -7) bitAnd: 16r1) ~= 0! - ^(((memory unsignedByteAt: address + 4) bitShift: -6) bitAnd: 16r1) ~= 0! Item was changed: ----- Method: CogObjectHeaderSurrogate>>isRemembered: (in category 'accessing') ----- isRemembered: aValue memory unsignedByteAt: address + 4 + put: (((memory unsignedByteAt: address + 4) bitAnd: 16r7F) + ((aValue ifTrue: [1] ifFalse: [0]) bitShift: 7)). - put: (((memory unsignedByteAt: address + 4) bitAnd: 16rBF) + ((aValue ifTrue: [1] ifFalse: [0]) bitShift: 6)). ^aValue! Item was removed: - ----- Method: CogObjectHeaderSurrogate>>isWeak (in category 'accessing') ----- - isWeak - ^((memory unsignedByteAt: address + 4) bitAnd: 16r1) ~= 0! Item was removed: - ----- Method: CogObjectHeaderSurrogate>>isWeak: (in category 'accessing') ----- - isWeak: aValue - memory - unsignedByteAt: address + 4 - put: (((memory unsignedByteAt: address + 4) bitAnd: 16rFE) + (aValue ifTrue: [1] ifFalse: [0])). - ^aValue! Item was changed: ----- Method: CogObjectHeaderSurrogate>>objHash (in category 'accessing') ----- objHash ^(memory unsignedLongAt: address + 5) bitAnd: 16rFFFFFF! Item was changed: ----- Method: CogObjectHeaderSurrogate>>objHash: (in category 'accessing') ----- objHash: aValue self assert: (aValue between: 0 and: 16rFFFFFF). memory unsignedLongAt: address + 5 put: ((memory unsignedLongAt: address + 5) bitAnd: 16rFF000000) + aValue. ^aValue! Item was removed: - ----- Method: CogObjectHeaderSurrogate>>objSize (in category 'accessing') ----- - objSize - ^memory unsignedByteAt: address + 8! Item was removed: - ----- Method: CogObjectHeaderSurrogate>>objSize: (in category 'accessing') ----- - objSize: aValue - ^memory - unsignedByteAt: address + 8 - put: aValue! Item was added: + ----- Method: CogObjectHeaderSurrogate>>slotSize (in category 'accessing') ----- + slotSize + ^memory unsignedByteAt: address + 8! Item was added: + ----- Method: CogObjectHeaderSurrogate>>slotSize: (in category 'accessing') ----- + slotSize: aValue + ^memory + unsignedByteAt: address + 8 + put: aValue! Item was removed: - ----- Method: CogStackPage class>>alignedByteSizeForClient: (in category 'translation') ----- - alignedByteSizeForClient: aVMClass - ^self surrogateClass alignedByteSize! Item was added: + ----- Method: CogStackPage class>>alignedByteSizeOf:forClient: (in category 'translation') ----- + alignedByteSizeOf: anObject forClient: aVMClass + ^self surrogateClass alignedByteSize! Item was changed: ----- Method: CogThreadManager>>willingVMThread (in category 'thread set') ----- willingVMThread "Answer a pointer to a live CogVMThread in any of the ``will do VM work'' states (other than the current owner if the VM is owned), or nil if none. Preferentially answer threads wanting ownership." <returnTypeC: #'CogVMThread *'> + | thread threadWantingVM threadWilling | - | vmThreadA vmThreadB | <inline: false> + <var: #thread type: #'CogVMThread *'> + <var: #threadWantingVM type: #'CogVMThread *'> + <var: #threadWilling type: #'CogVMThread *'> + threadWantingVM := threadWilling := nil. - <var: #vmThreadA type: #'CogVMThread *'> - <var: #vmThreadB type: #'CogVMThread *'> 1 to: numThreads do: [:i| + i ~= vmOwner ifTrue: + [thread := threads at: i. + thread state = CTMWantingOwnership ifTrue: + [(threadWantingVM isNil + or: [threadWantingVM priority < thread priority]) ifTrue: + [threadWantingVM := thread]]. + thread state = CTMAssignableOrInVM ifTrue: + [(threadWilling isNil + or: [threadWilling priority < thread priority]) ifTrue: + [threadWilling := thread]]]]. + threadWantingVM ifNotNil: + [^threadWantingVM]. + threadWilling ifNotNil: + [^threadWilling]. - vmThreadA := threads at: i. - vmThreadA state = CTMWantingOwnership ifTrue: - [^vmThreadA]. - (i ~= vmOwner - and: [vmThreadA state = CTMAssignableOrInVM]) ifTrue: - [i + 1 to: numThreads do: - [:j| - vmThreadB := threads at: i. - vmThreadB state = CTMWantingOwnership ifTrue: - [^vmThreadB]]. - ^vmThreadA]]. ^nil! Item was changed: ----- Method: CogVMSimulator>>sendBreak:point:receiver: (in category 'debugging traps') ----- sendBreak: selectorString point: selectorLength receiver: receiverOrNil "self shortPrintFrameAndCallers: localFP" | i | - cogit printOnTrace ifTrue: - [0 to: selectorLength - 1 do: - [:si| transcript nextPut: (objectMemory byteAt: selectorString + si) asCharacter]. - transcript cr; flush]. breakSelectorLength = selectorLength ifTrue: [i := breakSelectorLength. [i > 0] whileTrue: [(objectMemory byteAt: selectorString + i - 1) = (breakSelector at: i) asInteger ifTrue: [(i := i - 1) = 0 ifTrue: [self changed: #byteCountText. self halt: 'Send of ' , breakSelector, (receiverOrNil ifNotNil: [' to ', (self shortPrint: receiverOrNil)] ifNil: [''])]] ifFalse: [i := 0]]]! Item was changed: CogClass subclass: #Cogit + instanceVariableNames: 'coInterpreter objectMemory objectRepresentation processor threadManager methodZone methodZoneBase codeBase minValidCallAddress lastNInstructions simulatedAddresses simulatedTrampolines simulatedVariableGetters simulatedVariableSetters printRegisters printInstructions compilationTrace clickConfirm breakPC breakBlock singleStep guardPageSize traceLinkedSends traceStores breakMethod methodObj initialPC endPC methodOrBlockNumArgs inBlock needsFrame hasYoungReferent primitiveIndex backEnd postCompileHook primInvokeLabel methodLabel stackCheckLabel blockEntryLabel blockEntryNoContextSwitch blockNoContextSwitchOffset stackOverflowCall sendMissCall missOffset entryPointMask checkedEntryAlignment cmEntryOffset entry cmNoCheckEntryOffset noCheckEntry dynSuperEntry dynSuperEntryAlignment cmDynSuperEntryOffset mnuCall interpretCall endCPICCase0 endCPICCase1 numPICCases firstCPICCaseOffset cPICCaseSize cPICEndSize closedPICSize openPICSize fixups abstractOpcodes annotations generatorTable primitiveGeneratorTable byte0 byte1 byte2 byte3 bytecodePointer opcodeIndex numAbstractOpcodes annotationIndex blockStarts blockCount labelCounter cStackAlignment expectedSPAlignment expectedFPAlignment codeModified maxMethodBefore ceMethodAbortTrampoline cePICAbortTrampoline ceCheckForInterruptTrampoline ceCPICMissTrampoline ceStoreCheckTrampoline ceReturnToInterpreterTrampoline ceBaseFrameReturnTrampoline ceSendMustBeBooleanAddTrueTrampoline ceSendMustBeBooleanAddFalseTrampoline ceCannotResumeTrampoline ceClosureCopyTrampoline ceCreateNewArrayTrampoline ceEnterCogCodePopReceiverReg ceEnterCogCodePopReceiverAndClassRegs cePrimReturnEnterCogCode cePrimReturnEnterCogCodeProfiling ceNonLocalReturnTrampoline ceActiveContextTrampoline ceFetchContextInstVarTrampoline ceStoreContextInstVarTrampoline cePositive32BitIntegerTrampoline ceImplicitReceiverTrampoline ceExplicitReceiverTrampoline ceCaptureCStackPointers ceFlushICache ceCheckFeaturesFunction ceTraceLinkedSendTrampoline ceTraceBlockActivationTrampoline ceTraceStoreTrampoline ceGetSP sendTrampolines superSendTrampolines dynamicSuperSendTrampolines firstSend lastSend realCEEnterCogCodePopReceiverReg realCEEnterCogCodePopReceiverAndClassRegs trampolineTableIndex trampolineAddresses objectReferencesInRuntime runtimeObjectRefIndex cFramePointerInUse debugPrimCallStackOffset ceTryLockVMOwner ceUnlockVMOwner cogMethodSurrogateClass cogBlockMethodSurrogateClass' + classVariableNames: 'AnnotationConstantNames AnnotationShift BlockCreationBytecodeSize Debug DisplacementMask DisplacementX2N EagerInstructionDecoration EncounteredUnknownBytecode FirstAnnotation HasBytecodePC InsufficientCodeSpace IsAbsPCReference IsDisplacement IsDisplacementX2N IsNSSendCall IsObjectReference IsRelativeCall IsSendCall MapEnd MaxCompiledPrimitiveIndex MaxNegativeErrorCode MaxUnitDisplacement MaxUnreportableError MaxX2NDisplacement NotFullyInitialized NumObjRefsInRuntime NumSendTrampolines NumTrampolines ProcessorClass YoungSelectorInPIC' - instanceVariableNames: 'coInterpreter objectMemory objectRepresentation processor threadManager methodZone methodZoneBase codeBase lastNInstructions simulatedAddresses simulatedTrampolines simulatedVariableGetters simulatedVariableSetters printRegisters printInstructions compilationTrace clickConfirm breakPC breakBlock singleStep guardPageSize traceLinkedSends traceStores breakMethod methodObj initialPC endPC methodOrBlockNumArgs inBlock needsFrame hasYoungReferent primitiveIndex backEnd postCompileHook primInvokeLabel methodLabel stackCheckLabel blockEntryLabel blockEntryNoContextSwitch blockNoContextSwitchOffset stackOverflowCall sendMissCall missOffset entryPointMask checkedEntryAlignment cmEntryOffset entry cmNoCheckEntryOffset noCheckEntry dynSuperEntry dynSuperEntryAlignment cmDynSuperEntryOffset mnuCall interpretCall endCPICCase0 endCPICCase1 numPICCases firstCPICCaseOffset cPICCaseSize cPICEndSize closedPICSize openPICSize fixups abstractOpcodes annotations generatorTable primitiveGeneratorTable byte0 byte1 byte2 byte3 bytecodePointer opcodeIndex numAbstractOpcodes annotationIndex blockStarts blockCount labelCounter cStackAlignment expectedSPAlignment expectedFPAlignment codeModified maxMethodBefore ceMethodAbortTrampoline cePICAbortTrampoline ceCheckForInterruptTrampoline ceCPICMissTrampoline ceStoreCheckTrampoline ceReturnToInterpreterTrampoline ceBaseFrameReturnTrampoline ceSendMustBeBooleanAddTrueTrampoline ceSendMustBeBooleanAddFalseTrampoline ceCannotResumeTrampoline ceClosureCopyTrampoline ceCreateNewArrayTrampoline ceEnterCogCodePopReceiverReg ceEnterCogCodePopReceiverAndClassRegs cePrimReturnEnterCogCode cePrimReturnEnterCogCodeProfiling ceNonLocalReturnTrampoline ceActiveContextTrampoline ceFetchContextInstVarTrampoline ceStoreContextInstVarTrampoline cePositive32BitIntegerTrampoline ceImplicitReceiverTrampoline ceExplicitReceiverTrampoline ceCaptureCStackPointers ceFlushICache ceCheckFeaturesFunction ceTraceLinkedSendTrampoline ceTraceBlockActivationTrampoline ceTraceStoreTrampoline ceGetSP sendTrampolines superSendTrampolines dynamicSuperSendTrampolines firstSend lastSend realCEEnterCogCodePopReceiverReg realCEEnterCogCodePopReceiverAndClassRegs trampolineTableIndex trampolineAddresses objectReferencesInRuntime runtimeObjectRefIndex cFramePointerInUse debugPrimCallStackOffset ceTryLockVMOwner ceUnlockVMOwner cogMethodSurrogateClass cogBlockMethodSurrogateClass' - classVariableNames: 'AnnotationConstantNames AnnotationShift BlockCreationBytecodeSize Debug DisplacementMask DisplacementX2N EagerInstructionDecoration EncounteredUnknownBytecode FirstAnnotation HasBytecodePC InsufficientCodeSpace IsAbsPCReference IsDisplacement IsDisplacementX2N IsNSSendCall IsObjectReference IsRelativeCall IsSendCall MapEnd MaxCompiledPrimitiveIndex MaxNegativeErrorCode MaxUnitDisplacement MaxUnreportableError MaxX2NDisplacement NotFullyInitialized NumObjRefsInRuntime NumSendTrampolines NumTrampolines ProcessorClass' poolDictionaries: 'CogMethodConstants CogRTLOpcodes VMBasicConstants VMObjectIndices VMStackFrameOffsets' category: 'VMMaker-JIT'! Cogit class instanceVariableNames: 'generatorTable primitiveTable'! !Cogit commentStamp: '<historical>' prior: 0! I am the code generator for the Cog VM. My job is to produce machine code versions of methods for faster execution and to manage inline caches for faster send performance. coInterpreter <CoInterpreterSimulator> the VM's interpreter with which I cooperate methodZoneManager <CogMethodZoneManager> the manager of the machine code zone objectRepresentation <CogObjectRepresentation> the object used to generate object accesses processor <BochsIA32Alien|?> the simulator that executes the IA32/x86 machine code I generate when simulating execution in Smalltalk simulatedTrampolines <Dictionary of Integer -> MessageSend> the dictionary mapping trap jump addresses to run-time routines used to warp from simulated machine code in to the Smalltalk run-time. simulatedVariableGetters <Dictionary of Integer -> MessageSend> the dictionary mapping trap read addresses to variables in run-time objects used to allow simulated machine code to read variables in the Smalltalk run-time. simulatedVariableSetters <Dictionary of Integer -> MessageSend> the dictionary mapping trap write addresses to variables in run-time objects used to allow simulated machine code to write variables in the Smalltalk run-time. printRegisters printInstructions clickConfirm <Boolean> flags controlling debug printing and code simulation breakPC <Integer> machine code pc breakpoint cFramePointer cStackPointer <Integer> the variables representing the C stack & frame pointers, which must change on FFI callback and return selectorOop <sqInt> the oop of the methodObj being compiled methodObj <sqInt> the bytecode method being compiled initialPC endPC <Integer> the start and end pcs of the methodObj being compiled methodOrBlockNumArgs <Integer> argument count of current method or block being compiled needsFrame <Boolean> whether methodObj or block needs a frame to execute primitiveIndex <Integer> primitive index of current method being compiled methodLabel <CogAbstractOpcode> label for the method header blockEntryLabel <CogAbstractOpcode> label for the start of the block dispatch code stackOverflowCall <CogAbstractOpcode> label for the call of ceStackOverflow in the method prolog sendMissCall <CogAbstractOpcode> label for the call of ceSICMiss in the method prolog entryOffset <Integer> offset of method entry code from start (header) of method entry <CogAbstractOpcode> label for the first instruction of the method entry code noCheckEntryOffset <Integer> offset of the start of a method proper (after the method entry code) from start (header) of method noCheckEntry <CogAbstractOpcode> label for the first instruction of start of a method proper fixups <Array of <AbstractOpcode Label | nil>> the labels for forward jumps that will be fixed up when reaching the relevant bytecode. fixup shas one element per byte in methodObj's bytecode abstractOpcodes <Array of <AbstractOpcode>> the code generated when compiling methodObj byte0 byte1 byte2 byte3 <Integer> individual bytes of current bytecode being compiled in methodObj bytecodePointer <Integer> bytecode pc (same as Smalltalk) of the current bytecode being compiled opcodeIndex <Integer> the index of the next free entry in abstractOpcodes (this code is translated into C where OrderedCollection et al do not exist) numAbstractOpcodes <Integer> the number of elements in abstractOpcocdes blockStarts <Array of <BlockStart>> the starts of blocks in the current method blockCount the index into blockStarts as they are being noted, and hence eventuakly teh total number of blocks in the current method labelCounter <Integer> a nicety for numbering labels not needed in the production system but probably not expensive enough to worry about ceStackOverflowTrampoline <Integer> ceSend0ArgsTrampoline <Integer> ceSend1ArgsTrampoline <Integer> ceSend2ArgsTrampoline <Integer> ceSendNArgsTrampoline <Integer> ceSendSuper0ArgsTrampoline <Integer> ceSendSuper1ArgsTrampoline <Integer> ceSendSuper2ArgsTrampoline <Integer> ceSendSuperNArgsTrampoline <Integer> ceSICMissTrampoline <Integer> ceCPICMissTrampoline <Integer> ceStoreCheckTrampoline <Integer> ceReturnToInterpreterTrampoline <Integer> ceBaseFrameReturnTrampoline <Integer> ceSendMustBeBooleanTrampoline <Integer> ceClosureCopyTrampoline <Integer> the various trampolines (system-call-like jumps from machine code to the run-time). See Cogit>>generateTrampolines for the mapping from trampoline to run-time routine and then read the run-time routine for a funcitonal description. ceEnterCogCodePopReceiverReg <Integer> the enilopmart (jump from run-time to machine-code) methodZoneBase <Integer> ! Cogit class instanceVariableNames: 'generatorTable primitiveTable'! Item was changed: ----- Method: Cogit class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator #( 'coInterpreter' 'objectMemory' 'methodZone' 'objectRepresentation' 'cogBlockMethodSurrogateClass' 'cogMethodSurrogateClass' 'threadManager' 'processor' 'lastNInstructions' 'simulatedAddresses' 'simulatedTrampolines' 'simulatedVariableGetters' 'simulatedVariableSetters' 'printRegisters' 'printInstructions' 'clickConfirm' 'singleStep') do: [:simulationVariableNotNeededForRealVM| aCCodeGenerator removeVariable: simulationVariableNotNeededForRealVM]. NewspeakVM ifFalse: [#( 'dynSuperEntry' 'dynSuperEntryAlignment' 'dynamicSuperSendTrampolines' 'ceImplicitReceiverTrampoline' 'ceExplicitReceiverTrampoline' 'cmDynSuperEntryOffset') do: [:variableNotNeededInNormalVM| aCCodeGenerator removeVariable: variableNotNeededInNormalVM]]. aCCodeGenerator addHeaderFile:'<stddef.h>'; "for e.g. offsetof" addHeaderFile:'"sqCogStackAlignment.h"'; addHeaderFile:'"cogmethod.h"'; addHeaderFile:'#if COGMTVM'; addHeaderFile:'"cointerpmt.h"'; addHeaderFile:'#else'; addHeaderFile:'"cointerp.h"'; addHeaderFile:'#endif'; addHeaderFile:'"cogit.h"'; addHeaderFile:'"dispdbg.h"'. aCCodeGenerator var: #ceGetSP declareC: 'unsigned long (*ceGetSP)(void)'; var: #ceCaptureCStackPointers declareC: 'void (*ceCaptureCStackPointers)(void)'; var: #ceEnterCogCodePopReceiverReg declareC: 'void (*ceEnterCogCodePopReceiverReg)(void)'; var: #realCEEnterCogCodePopReceiverReg declareC: 'void (*realCEEnterCogCodePopReceiverReg)(void)'; var: #ceEnterCogCodePopReceiverAndClassRegs declareC: 'void (*ceEnterCogCodePopReceiverAndClassRegs)(void)'; var: #realCEEnterCogCodePopReceiverAndClassRegs declareC: 'void (*realCEEnterCogCodePopReceiverAndClassRegs)(void)'; var: #ceFlushICache declareC: 'static void (*ceFlushICache)(unsigned long from, unsigned long to)'; var: #ceCheckFeaturesFunction declareC: 'static unsigned long (*ceCheckFeaturesFunction)(void)'; var: #ceTryLockVMOwner declareC: 'unsigned long (*ceTryLockVMOwner)(void)'; var: #ceUnlockVMOwner declareC: 'void (*ceUnlockVMOwner)(void)'; var: #postCompileHook declareC: 'void (*postCompileHook)(CogMethod *, void *)'; var: #openPICList declareC: 'CogMethod *openPICList = 0'; var: #maxMethodBefore type: #'CogBlockMethod *'. aCCodeGenerator declareVar: 'aMethodLabel' type: #'AbstractInstruction'; "Has to come lexicographically before backEnd & methodLabel" var: #backEnd declareC: 'AbstractInstruction *backEnd = &aMethodLabel'; var: #methodLabel declareC: 'AbstractInstruction *methodLabel = &aMethodLabel'; var: #primInvokeLabel type: #'AbstractInstruction *'. self declareC: #(abstractOpcodes stackCheckLabel blockEntryLabel blockEntryNoContextSwitch stackOverflowCall sendMissCall entry noCheckEntry dynSuperEntry mnuCall interpretCall endCPICCase0 endCPICCase1) as: #'AbstractInstruction *' in: aCCodeGenerator. aCCodeGenerator declareVar: #annotations type: #'InstructionAnnotation *'; declareVar: #blockStarts type: #'BlockStart *'; declareVar: #fixups type: #'BytecodeFixup *'. aCCodeGenerator var: #sendTrampolines declareC: 'sqInt sendTrampolines[NumSendTrampolines]'; var: #superSendTrampolines declareC: 'sqInt superSendTrampolines[NumSendTrampolines]'; var: #dynamicSuperSendTrampolines declareC: 'sqInt dynamicSuperSendTrampolines[NumSendTrampolines]'; var: #trampolineAddresses declareC: 'static char *trampolineAddresses[NumTrampolines*2]'; var: #objectReferencesInRuntime declareC: 'static sqInt objectReferencesInRuntime[NumObjRefsInRuntime]'; var: #cePositive32BitIntegerTrampoline declareC: 'static sqInt cePositive32BitIntegerTrampoline'; var: #labelCounter declareC: 'static int labelCounter'; var: #traceLinkedSends + declareC: 'int traceLinkedSends = 8 /* prim trace log on by default */'; - declareC: 'int traceLinkedSends = 2 /* prim trace log on by default */'; var: #cStackAlignment declareC: 'const int cStackAlignment = STACK_ALIGN_BYTES'. aCCodeGenerator declareVar: #CFramePointer type: #'void *'; declareVar: #CStackPointer type: #'void *'; + declareVar: #minValidCallAddress type: #'unsigned long'; declareVar: #debugPrimCallStackOffset type: #'unsigned long'. aCCodeGenerator var: #generatorTable declareC: 'BytecodeDescriptor generatorTable[256]' , (self tableInitializerFor: aCCodeGenerator vmClass generatorTable in: aCCodeGenerator); var: #primitiveGeneratorTable declareC: 'PrimitiveDescriptor primitiveGeneratorTable[MaxCompiledPrimitiveIndex+1]' , (self tableInitializerFor: aCCodeGenerator vmClass primitiveTable in: aCCodeGenerator). "In C the abstract opcode names clash with the Smalltak generator syntactic sugar. Most of the syntactic sugar is inlined, but alas some remains. Rename the syntactic sugar to avoid the clash." (self organization listAtCategoryNamed: #'abstract instructions') do: [:s| aCCodeGenerator addSelectorTranslation: s to: 'g', (aCCodeGenerator cFunctionNameFor: s)]. aCCodeGenerator addSelectorTranslation: #halt: to: 'haltmsg'! Item was changed: ----- Method: Cogit class>>initializeErrorCodes (in category 'class initialization') ----- initializeErrorCodes + self flag: 'these should be positive quantities and the check for error code should be a comparison against minCogMethodAddress/methodZoneBase'. NotFullyInitialized := -1. InsufficientCodeSpace := -2. + YoungSelectorInPIC := -3. + MaxUnreportableError := YoungSelectorInPIC. + EncounteredUnknownBytecode := -4. - MaxUnreportableError := InsufficientCodeSpace. - EncounteredUnknownBytecode := -3. MaxNegativeErrorCode := EncounteredUnknownBytecode! Item was changed: ----- Method: Cogit>>breakOnImplicitReceiver (in category 'debugging') ----- breakOnImplicitReceiver <api> + <cmacro: '() (traceLinkedSends & 32)'> + ^(traceLinkedSends bitAnd: 32) ~= 0! - <cmacro: '() (traceLinkedSends & 16)'> - ^(traceLinkedSends bitAnd: 16) ~= 0! Item was changed: ----- Method: Cogit>>cogMNUPICSelector:methodOperand:numArgs: (in category 'in-line cacheing') ----- cogMNUPICSelector: selector methodOperand: methodOperand numArgs: numArgs <api> "Attempt to create a one-case PIC for an MNU. The tag for the case is at the send site and so doesn't need to be generated." <returnTypeC: #'CogMethod *'> | startAddress headerSize size end | + (objectMemory isYoung: selector) ifTrue: + [^0]. coInterpreter compilationBreak: selector point: (objectMemory lengthOf: selector). + self assert: endCPICCase0 notNil. - endCPICCase0 isNil ifTrue: - [^self cCoerceSimple: NotFullyInitialized to: #'CogMethod *']. startAddress := methodZone allocate: closedPICSize. startAddress = 0 ifTrue: + [coInterpreter callForCogCompiledCodeCompaction. + ^0]. - [^self cCoerceSimple: InsufficientCodeSpace to: #'CogMethod *']. methodLabel address: startAddress; dependent: nil. "stack allocate the various collections so that they are effectively garbage collected on return." self allocateOpcodes: numPICCases * 7 bytecodes: 0. self compileMNUCPIC: (self cCoerceSimple: startAddress to: #'CogMethod *') methodOperand: methodOperand numArgs: numArgs. self computeMaximumSizes. headerSize := self sizeof: CogMethod. size := self generateInstructionsAt: startAddress + headerSize. end := self outputInstructionsAt: startAddress + headerSize. "The missOffset is the same as the interpretOffset." self assert: missOffset = (interpretCall address + interpretCall machineCodeSize - startAddress). self assert: startAddress + cmEntryOffset = entry address. ^self fillInCPICHeader: (self cCoerceSimple: startAddress to: #'CogMethod *') size: closedPICSize numArgs: numArgs numCases: 1 hasMNUCase: true selector: selector ! Item was changed: ----- Method: Cogit>>cogPICSelector:numArgs:Case0Method:Case1Method:tag:isMNUCase: (in category 'in-line cacheing') ----- cogPICSelector: selector numArgs: numArgs Case0Method: case0CogMethod Case1Method: case1MethodOrNil tag: case1Tag isMNUCase: isMNUCase "Attempt to create a two-case PIC for case0CogMethod and case1Method,case1Tag. The tag for case0CogMethod is at the send site and so doesn't need to be generated. case1Method may be any of - a Cog method; link to its unchecked entry-point - a CompiledMethod; link to ceInterpretMethodFromPIC: - a CompiledMethod; link to ceMNUFromPICMNUMethod:receiver:" <var: #case0CogMethod type: #'CogMethod *'> <returnTypeC: #'CogMethod *'> | startAddress headerSize size end | + (objectMemory isYoung: selector) ifTrue: + [^self cCoerceSimple: YoungSelectorInPIC to: #'CogMethod *']. coInterpreter compilationBreak: selector point: (objectMemory lengthOf: selector). startAddress := methodZone allocate: closedPICSize. startAddress = 0 ifTrue: [^self cCoerceSimple: InsufficientCodeSpace to: #'CogMethod *']. methodLabel address: startAddress; dependent: nil. "stack allocate the various collections so that they are effectively garbage collected on return." self allocateOpcodes: numPICCases * 7 bytecodes: 0. self compileCPIC: (self cCoerceSimple: startAddress to: #'CogMethod *') Case0: case0CogMethod Case1Method: case1MethodOrNil tag: case1Tag isMNUCase: isMNUCase numArgs: numArgs. self computeMaximumSizes. headerSize := self sizeof: CogMethod. size := self generateInstructionsAt: startAddress + headerSize. end := self outputInstructionsAt: startAddress + headerSize. "The missOffset is th same as the interpretOffset." self assert: missOffset = (interpretCall address + interpretCall machineCodeSize - startAddress). self assert: startAddress + cmEntryOffset = entry address. self assert: endCPICCase0 address = (startAddress + firstCPICCaseOffset). self assert: endCPICCase1 address = (startAddress + firstCPICCaseOffset + cPICCaseSize). ^self fillInCPICHeader: (self cCoerceSimple: startAddress to: #'CogMethod *') size: closedPICSize numArgs: numArgs numCases: 2 hasMNUCase: isMNUCase selector: selector ! Item was changed: ----- Method: Cogit>>compileBlockEntry: (in category 'compile abstract instructions') ----- compileBlockEntry: blockStart "Compile a block's entry. This looks like a dummy CogBlockMethod header (for frame parsing) followed by either a frame build, if a frame is required, or nothing. The CogMethodHeader's objectHeader field is a back pointer to the method, but this can't be filled in until code generation." <var: #blockStart type: #'BlockStart *'> self AlignmentNops: (self sizeof: CogBlockMethod). self assert: (self sizeof: CogBlockMethod) = (2 * BytesPerWord). blockStart fakeHeader: self Label. self Fill32: 0. "gets filled in later with the homeOffset and startpc" self Fill32: 0. "gets filled in later with numArgs et al" blockStart entryLabel: self Label. needsFrame ifTrue: [self compileBlockFrameBuild: blockStart. + self recordBlockTrace ifTrue: - self recordSendTrace ifTrue: [self CallRT: ceTraceBlockActivationTrampoline]] ifFalse: [self compileBlockFramelessEntry: blockStart]! Item was changed: ----- Method: Cogit>>compilePrimitive (in category 'compile abstract instructions') ----- compilePrimitive "Compile a primitive. If possible, performance-critical primtiives will be generated by their own routines (primitiveGenerator). Otherwise, if there is a primitive at all, we call the C routine with the usual stack-switching dance, test the primFailCode and then either return on success or continue to the method body." <inline: false> | primitiveDescriptor primitiveRoutine | <var: #primitiveDescriptor type: #'PrimitiveDescriptor *'> <var: #primitiveRoutine declareC: 'void (*primitiveRoutine)(void)'> primitiveIndex = 0 ifTrue: [^0]. ((primitiveDescriptor := self primitiveGeneratorOrNil) notNil and: [primitiveDescriptor primitiveGenerator notNil]) ifTrue: ["If a descriptor specifies an argument count (by numArgs >= 0) then it must match for the generated code to be correct. For example for speed many primitives use ResultReceiverReg instead of accessing the stack, so the receiver better be at numArgs down the stack. Use the interpreter version if not." (primitiveDescriptor primNumArgs < 0 "means don't care" or: [primitiveDescriptor primNumArgs = (coInterpreter argumentCountOf: methodObj)]) ifTrue: [^self perform: primitiveDescriptor primitiveGenerator]]. ((primitiveRoutine := coInterpreter functionPointerForCompiledMethod: methodObj primitiveIndex: primitiveIndex) isNil "no primitive" or: [primitiveRoutine = (coInterpreter functionPointerFor: 0 inClass: nil) "routine = primitiveFail"]) ifTrue: [^self genFastPrimFail]. + minValidCallAddress := minValidCallAddress min: primitiveRoutine asUnsignedInteger. ^self compileInterpreterPrimitive: primitiveRoutine! Item was changed: ----- Method: Cogit>>generateClosedPICPrototype (in category 'initialization') ----- generateClosedPICPrototype "Generate the prototype ClosedPIC to determine how much space as full PIC takes. When we first allocate a closed PIC it only has one or two cases and we want to grow it. So we have to determine how big a full one is before hand." | headerSize | numPICCases := 6. "stack allocate the various collections so that they are effectively garbage collected on return." self allocateOpcodes: numPICCases * 7 bytecodes: 0. self compileClosedPICPrototype. self computeMaximumSizes. headerSize := self sizeof: CogMethod. + closedPICSize := headerSize + (self generateInstructionsAt: methodZoneBase + headerSize). - closedPICSize := methodZone roundUpLength: headerSize + (self generateInstructionsAt: methodZoneBase + headerSize). firstCPICCaseOffset := endCPICCase0 address - methodZoneBase. cPICCaseSize := endCPICCase1 address - endCPICCase0 address. + cPICEndSize := closedPICSize - (numPICCases - 1 * cPICCaseSize + firstCPICCaseOffset). + closedPICSize := methodZone roundUpLength: closedPICSize - cPICEndSize := closedPICSize - (numPICCases - 1 * cPICCaseSize + firstCPICCaseOffset) "self cCode: '' inSmalltalk: [| end | end := self outputInstructionsAt: methodZoneBase + headerSize. self disassembleFrom: methodZoneBase + headerSize to: end - 1. self halt]"! Item was changed: ----- Method: Cogit>>halt: (in category 'translation support') ----- halt: aString + <cmacro: '(msg) warning("halt: " msg)'> - <cmacro: '(msg) error("halt: " msg)'> Halt new signal: aString! Item was changed: ----- Method: Cogit>>initializeCodeZoneFrom:upTo: (in category 'initialization') ----- initializeCodeZoneFrom: startAddress upTo: endAddress <api> self cCode: [self sqMakeMemoryExecutableFrom: startAddress To: endAddress] inSmalltalk: [self initializeProcessor]. codeBase := methodZoneBase := (self cCode: [startAddress] inSmalltalk: [startAddress + guardPageSize]). + minValidCallAddress := (codeBase min: coInterpreter interpretAddress) + min: coInterpreter primitiveFailAddress. self initializeBackend. self maybeGenerateCheckFeatures. self maybeGenerateICacheFlush. self generateVMOwnerLockFunctions. ceGetSP := self cCoerceSimple: self genGetLeafCallStackPointer to: #'unsigned long (*)(void)'. self generateStackPointerCapture. self generateTrampolines. self checkPrimitiveTableEnablers. methodZone manageFrom: methodZoneBase to: endAddress. self computeEntryOffsets. self generateClosedPICPrototype. "N.B. this is assumed to be the last thing done in initialization; see Cogit>>initialized" self generateOpenPICPrototype! Item was changed: ----- Method: Cogit>>lookup:for:methodAndErrorSelectorInto: (in category 'in-line cacheing') ----- lookup: selector for: receiver methodAndErrorSelectorInto: binaryBlock + "Lookup selector in the class of receiver. If found, evaluate binaryBlock with the + method, cogged if appropriate.. If not found, due to MNU, lookup the DNU selector + and evaluate binaryBlock with the MNU method, cogged if appropriate.. If not found + due to cannot interpret, evaluate binaryBlock with a nil method and the error selector." - "Lookup selector in the class of receiver. If found, evaluate binaryBlock with - the method, cogged if appopriate.. If not found, due to MNU, lookup the DNU - selector and evaluate binaryBlock with the MNU method, cogged if appopriate.. - If not found due to cannot interpret, evaluate binaryBlock with the error selector - and a nil method." | methodOrSelectorIndex | <inline: true> methodOrSelectorIndex := coInterpreter lookup: selector receiver: receiver. methodOrSelectorIndex asUnsignedInteger > objectMemory startOfMemory ifTrue: + [(objectMemory isOopCompiledMethod: methodOrSelectorIndex) ifFalse: + [^binaryBlock value: methodOrSelectorIndex value: SelectorCannotInterpret]. - [self assert: (objectMemory isOopCompiledMethod: methodOrSelectorIndex). ((coInterpreter methodHasCogMethod: methodOrSelectorIndex) not and: [coInterpreter methodShouldBeCogged: methodOrSelectorIndex]) ifTrue: ["We assume cog:selector: will *not* reclaim the method zone" self cog: methodOrSelectorIndex selector: selector]. + ^binaryBlock value: methodOrSelectorIndex value: nil]. - ^binaryBlock value: methodOrSelectorIndex value: 0]. methodOrSelectorIndex = SelectorDoesNotUnderstand ifTrue: [methodOrSelectorIndex := coInterpreter lookup: (objectMemory splObj: SelectorDoesNotUnderstand) receiver: receiver. methodOrSelectorIndex asUnsignedInteger > objectMemory startOfMemory ifTrue: [self assert: (objectMemory isOopCompiledMethod: methodOrSelectorIndex). ((coInterpreter methodHasCogMethod: methodOrSelectorIndex) not and: [coInterpreter methodShouldBeCogged: methodOrSelectorIndex]) ifTrue: ["We assume cog:selector: will *not* reclaim the method zone" self cog: methodOrSelectorIndex selector: selector]. + ^binaryBlock value: methodOrSelectorIndex value: SelectorDoesNotUnderstand]. + ^binaryBlock value: nil value: SelectorDoesNotUnderstand]. + ^binaryBlock value: nil value: methodOrSelectorIndex! - ^binaryBlock value: methodOrSelectorIndex value: SelectorDoesNotUnderstand]]. - ^binaryBlock value: methodOrSelectorIndex value: nil! Item was added: + ----- Method: Cogit>>minCallAddress (in category 'accessing') ----- + minCallAddress + <cmacro: '() minValidCallAddress'> + ^minValidCallAddress! Item was changed: ----- Method: Cogit>>printOnTrace (in category 'debugging') ----- printOnTrace <api> + <cmacro: '() (traceLinkedSends & 1)'> + ^(traceLinkedSends bitAnd: 1) ~= 0! - <cmacro: '() (traceLinkedSends & 8)'> - ^(traceLinkedSends bitAnd: 8) ~= 0! Item was added: + ----- Method: Cogit>>recordBlockTrace (in category 'debugging') ----- + recordBlockTrace + <api> + <cmacro: '() (traceLinkedSends & 4)'> + ^(traceLinkedSends bitAnd: 4) ~= 0! Item was changed: ----- Method: Cogit>>recordEventTrace (in category 'debugging') ----- recordEventTrace <api> + <cmacro: '() (traceLinkedSends & 16)'> + ^(traceLinkedSends bitAnd: 16) ~= 0! - <cmacro: '() (traceLinkedSends & 4)'> - ^(traceLinkedSends bitAnd: 4) ~= 0! Item was changed: ----- Method: Cogit>>recordPrimTrace (in category 'debugging') ----- recordPrimTrace <api> + <cmacro: '() (traceLinkedSends & 8)'> + ^(traceLinkedSends bitAnd: 8) ~= 0! - <cmacro: '() (traceLinkedSends & 2)'> - ^(traceLinkedSends bitAnd: 2) ~= 0! Item was changed: ----- Method: Cogit>>recordSendTrace (in category 'debugging') ----- recordSendTrace <api> + <cmacro: '() (traceLinkedSends & 2)'> + ^(traceLinkedSends bitAnd: 2) ~= 0! - <cmacro: '() (traceLinkedSends & 1)'> - ^(traceLinkedSends bitAnd: 1) ~= 0! Item was changed: ----- Method: Cogit>>sendTrace: (in category 'debugging') ----- sendTrace: aBooleanOrInteger <doNotGenerate> "traceLinkedSends is a set of flags. + 1 => print trace (if somethign below is selected) + 2 => trace sends + 4 => trace block activations + 8 => trace interpreter primitives + 16 => trace events (context switches, GCs, etc) + 32 => send breakpoint on implicit receiver (Newspeak VM only)" - 1 => trace sends & block activations - 2 => trace interpreter primitives - 4 => trace events (context switches, GCs, etc) - 8 => print trace" traceLinkedSends := aBooleanOrInteger isInteger ifTrue: [aBooleanOrInteger] ifFalse: [aBooleanOrInteger ifTrue: [1] ifFalse: [0]]! Item was changed: ----- Method: Cogit>>setInterpreter: (in category 'initialization') ----- setInterpreter: aCoInterpreter "Initialization of the code generator in the simulator. These objects already exist in the generated C VM or are used only in the simulation." <doNotGenerate> coInterpreter := aCoInterpreter. objectMemory := aCoInterpreter objectMemory. threadManager := aCoInterpreter threadManager. "N.B. may be nil" objectRepresentation := objectMemory objectRepresentationClass for: self. methodZone := CogMethodZone new. methodZone setInterpreter: aCoInterpreter objectRepresentation: objectRepresentation cogit: self. generatorTable := self class generatorTable. primitiveGeneratorTable := self class primitiveTable. processor := ProcessorClass new. simulatedAddresses := Dictionary new. simulatedTrampolines := Dictionary new. simulatedVariableGetters := Dictionary new. simulatedVariableSetters := Dictionary new. traceStores := 0. + traceLinkedSends := 8. "record prim trace on by default (see Cogit class>>decareCVarsIn:)" - traceLinkedSends := 2. "record prim trace on by default (see Cogit class>>decareCVarsIn:)" debugPrimCallStackOffset := 0. singleStep := printRegisters := printInstructions := clickConfirm := false. breakBlock ifNil: [self breakPC: breakPC]. (backEnd := processor abstractInstructionCompilerClass new) cogit: self. (methodLabel := processor abstractInstructionCompilerClass new) cogit: self. sendTrampolines := CArrayAccessor on: (Array new: NumSendTrampolines). superSendTrampolines := CArrayAccessor on: (Array new: NumSendTrampolines). NewspeakVM ifTrue: [dynamicSuperSendTrampolines := CArrayAccessor on: (Array new: NumSendTrampolines)]. "debug metadata" objectReferencesInRuntime := CArrayAccessor on: (Array new: NumObjRefsInRuntime). runtimeObjectRefIndex := 0. "debug metadata" trampolineAddresses := CArrayAccessor on: (Array new: NumTrampolines * 2). trampolineTableIndex := 0. compilationTrace ifNil: [compilationTrace := 0]! Item was changed: ----- Method: GeniePlugin>>cSquaredDistanceFrom:to: (in category 'computation') ----- cSquaredDistanceFrom: aPoint to: bPoint "arguments are pointer to ints paired as x,y coordinates of points" | aPointX aPointY bPointX bPointY xDiff yDiff | + <var: #aPoint type: #'int *'> + <var: #bPoint type: #'int *'> - self var: #aPoint type: 'int * '. - self var: #bPoint type: 'int * '. aPointX := aPoint at: 0. aPointY := aPoint at: 1. bPointX := bPoint at: 0. bPointY := bPoint at: 1. xDiff := bPointX - aPointX. yDiff := bPointY - aPointY. ^ xDiff * xDiff + (yDiff * yDiff)! Item was changed: ----- Method: GeniePlugin>>primSameClassAbsoluteStrokeDistanceMyPoints:otherPoints:myVectors:otherVectors:mySquaredLengths:otherSquaredLengths:myAngles:otherAngles:maxSizeAndReferenceFlag:rowBase:rowInsertRemove:rowInsertRemoveCount: (in category 'computation') ----- primSameClassAbsoluteStrokeDistanceMyPoints: myPointsOop otherPoints: otherPointsOop myVectors: myVectorsOop otherVectors: otherVectorsOop mySquaredLengths: mySquaredLengthsOop otherSquaredLengths: otherSquaredLengthsOop myAngles: myAnglesOop otherAngles: otherAnglesOop maxSizeAndReferenceFlag: maxSizeAndRefFlag rowBase: rowBaseOop rowInsertRemove: rowInsertRemoveOop rowInsertRemoveCount: rowInsertRemoveCountOop | base insertRemove jLimiT substBase insert remove subst removeBase insertBase insertRemoveCount additionalMultiInsertRemoveCost myPoints otherPoints myVectors otherVectors rowInsertRemoveCount mySquaredLengths otherSquaredLengths myAngles otherAngles rowBase rowInsertRemove otherPointsSize myVectorsSize otherVectorsSize otherSquaredLengthsSize rowBaseSize maxDist maxSize forReference jM1 iM1 iM1T2 jM1T2 | + <var: #myPoints type: #'int *'> + <var: #otherPoints type: #'int *'> + <var: #myVectors type: #'int *'> + <var: #otherVectors type: #'int *'> + <var: #mySquaredLengths type: #'int *'> + <var: #otherSquaredLengths type: #'int *'> + <var: #myAngles type: #'int *'> + <var: #otherAngles type: #'int *'> + <var: #rowBase type: #'int *'> + <var: #rowInsertRemove type: #'int *'> + <var: #rowInsertRemoveCount type: #'int *'> - self var: #myPoints type: 'int * '. - self var: #otherPoints type: 'int * '. - self var: #myVectors type: 'int * '. - self var: #otherVectors type: 'int * '. - self var: #mySquaredLengths type: 'int * '. - self var: #otherSquaredLengths type: 'int * '. - self var: #myAngles type: 'int * '. - self var: #otherAngles type: 'int * '. - self var: #rowBase type: 'int * '. - self var: #rowInsertRemove type: 'int * '. - self var: #rowInsertRemoveCount type: 'int * '. self primitive: 'primSameClassAbsoluteStrokeDistanceMyPoints_otherPoints_myVectors_otherVectors_mySquaredLengths_otherSquaredLengths_myAngles_otherAngles_maxSizeAndReferenceFlag_rowBase_rowInsertRemove_rowInsertRemoveCount' parameters: #(#Oop #Oop #Oop #Oop #Oop #Oop #Oop #Oop #SmallInteger #Oop #Oop #Oop) receiver: #Oop. interpreterProxy failed ifTrue: [self msg: 'failed 1'. ^ nil]. interpreterProxy success: (interpreterProxy isWords: myPointsOop) & (interpreterProxy isWords: otherPointsOop) & (interpreterProxy isWords: myVectorsOop) & (interpreterProxy isWords: otherVectorsOop) & (interpreterProxy isWords: mySquaredLengthsOop) & (interpreterProxy isWords: otherSquaredLengthsOop) & (interpreterProxy isWords: myAnglesOop) & (interpreterProxy isWords: otherAnglesOop) & (interpreterProxy isWords: rowBaseOop) & (interpreterProxy isWords: rowInsertRemoveOop) & (interpreterProxy isWords: rowInsertRemoveCountOop). interpreterProxy failed ifTrue: [self msg: 'failed 2'. ^ nil]. interpreterProxy success: (interpreterProxy is: myPointsOop MemberOf: 'PointArray') & (interpreterProxy is: otherPointsOop MemberOf: 'PointArray'). interpreterProxy failed ifTrue: [self msg: 'failed 3'. ^ nil]. myPoints := interpreterProxy firstIndexableField: myPointsOop. otherPoints := interpreterProxy firstIndexableField: otherPointsOop. myVectors := interpreterProxy firstIndexableField: myVectorsOop. otherVectors := interpreterProxy firstIndexableField: otherVectorsOop. mySquaredLengths := interpreterProxy firstIndexableField: mySquaredLengthsOop. otherSquaredLengths := interpreterProxy firstIndexableField: otherSquaredLengthsOop. myAngles := interpreterProxy firstIndexableField: myAnglesOop. otherAngles := interpreterProxy firstIndexableField: otherAnglesOop. rowBase := interpreterProxy firstIndexableField: rowBaseOop. rowInsertRemove := interpreterProxy firstIndexableField: rowInsertRemoveOop. rowInsertRemoveCount := interpreterProxy firstIndexableField: rowInsertRemoveCountOop. "Note: myPointsSize and mySquaredLengthsSize variables eliminated to reduce method temporary variable count for closure-enabled images" "PointArrays" "myPointsSize := (interpreterProxy stSizeOf: myPointsOop) bitShift: -1." otherPointsSize := (interpreterProxy stSizeOf: otherPointsOop) bitShift: -1. myVectorsSize := (interpreterProxy stSizeOf: myVectorsOop) bitShift: -1. otherVectorsSize := (interpreterProxy stSizeOf: otherVectorsOop) bitShift: -1. "IntegerArrays" "mySquaredLengthsSize := interpreterProxy stSizeOf: mySquaredLengthsOop." otherSquaredLengthsSize := interpreterProxy stSizeOf: otherSquaredLengthsOop. rowBaseSize := interpreterProxy stSizeOf: rowBaseOop. interpreterProxy success: rowBaseSize = (interpreterProxy stSizeOf: rowInsertRemoveOop) & (rowBaseSize = (interpreterProxy stSizeOf: rowInsertRemoveCountOop)) & (rowBaseSize > otherVectorsSize). interpreterProxy failed ifTrue: [self msg: 'failed 4'. ^ nil]. interpreterProxy success: (interpreterProxy stSizeOf: mySquaredLengthsOop) >= (myVectorsSize - 1) & (((interpreterProxy stSizeOf: myPointsOop) bitShift: -1) >= myVectorsSize) & (otherSquaredLengthsSize >= (otherVectorsSize - 1)) & (otherPointsSize >= otherVectorsSize) & ((interpreterProxy stSizeOf: myAnglesOop) >= (myVectorsSize - 1)) & ((interpreterProxy stSizeOf: otherAnglesOop) >= (otherVectorsSize - 1)). interpreterProxy failed ifTrue: [self msg: 'failed 5'. ^ nil]. "maxSizeAndRefFlag contains the maxium feature size (pixel) and also indicates whether the reference flag (boolean) is set. Therefore the maximum size is moved to the left and the reference flag is stored in the LSB. Note: This is necessary to avoid more than 12 primitive parameters" forReference := maxSizeAndRefFlag bitAnd: 1. maxSize := maxSizeAndRefFlag bitShift: -1. maxDist := 1 bitShift: 29. forReference ifTrue: [additionalMultiInsertRemoveCost := 0] ifFalse: [additionalMultiInsertRemoveCost := maxSize * maxSize bitShift: -10]. "C indices!!!!" rowBase at: 0 put: 0. rowInsertRemove at: 0 put: 0. rowInsertRemoveCount at: 0 put: 2. insertRemove := 0 - additionalMultiInsertRemoveCost. jLimiT := otherVectorsSize. otherPointsSize >= (jLimiT - 1) & (otherSquaredLengthsSize >= (jLimiT - 1)) ifFalse: [^ interpreterProxy primitiveFail]. 1 to: jLimiT do: [:j | jM1 := j - 1. insertRemove := insertRemove + ((otherSquaredLengths at: jM1) + (self cSquaredDistanceFrom: (otherPoints + (jM1 bitShift: 1)) to: myPoints) bitShift: -7) + additionalMultiInsertRemoveCost. rowInsertRemove at: j put: insertRemove. rowBase at: j put: insertRemove * j. rowInsertRemoveCount at: j put: j + 1]. insertRemove := (rowInsertRemove at: 0) - additionalMultiInsertRemoveCost. 1 to: myVectorsSize do: [:i | iM1 := i - 1. iM1T2 := iM1 bitShift: 1. substBase := rowBase at: 0. insertRemove := insertRemove + ((mySquaredLengths at: iM1) + (self cSquaredDistanceFrom: (myPoints + iM1T2) to: otherPoints) bitShift: -7) + additionalMultiInsertRemoveCost. rowInsertRemove at: 0 put: insertRemove. rowBase at: 0 put: insertRemove * i. rowInsertRemoveCount at: 0 put: i + 1. jLimiT := otherVectorsSize. 1 to: jLimiT do: [:j | jM1 := j - 1. jM1T2 := jM1 bitShift: 1. removeBase := rowBase at: j. insertBase := rowBase at: jM1. remove := (mySquaredLengths at: iM1) + (self cSquaredDistanceFrom: (myPoints + iM1T2) to: (otherPoints + (j bitShift: 1))) bitShift: -7. (insertRemove := rowInsertRemove at: j) = 0 ifTrue: [removeBase := removeBase + remove] ifFalse: [removeBase := removeBase + insertRemove + (remove * (rowInsertRemoveCount at: j)). remove := remove + insertRemove]. insert := (otherSquaredLengths at: jM1) + (self cSquaredDistanceFrom: (otherPoints + jM1T2) to: (myPoints + (i bitShift: 1))) bitShift: -7. (insertRemove := rowInsertRemove at: jM1) = 0 ifTrue: [insertBase := insertBase + insert] ifFalse: [insertBase := insertBase + insertRemove + (insert * (rowInsertRemoveCount at: jM1)). insert := insert + insertRemove]. forReference ifTrue: [substBase := maxDist] ifFalse: [subst := (self cSquaredDistanceFrom: (otherVectors + jM1T2) to: (myVectors + iM1T2)) + (self cSquaredDistanceFrom: (otherPoints + jM1T2) to: (myPoints + iM1T2)) * (16 + (self cSubstAngleFactorFrom: (otherAngles at: jM1) to: (myAngles at: iM1))) bitShift: -11. substBase := substBase + subst]. (substBase <= removeBase and: [substBase <= insertBase]) ifTrue: [base := substBase. insertRemove := 0. insertRemoveCount := 1] ifFalse: [removeBase <= insertBase ifTrue: [base := removeBase. insertRemove := remove + additionalMultiInsertRemoveCost. insertRemoveCount := (rowInsertRemoveCount at: j) + 1] ifFalse: [base := insertBase. insertRemove := insert + additionalMultiInsertRemoveCost. insertRemoveCount := (rowInsertRemoveCount at: jM1) + 1]]. substBase := rowBase at: j. rowBase at: j put: (base min: maxDist). rowInsertRemove at: j put: (insertRemove min: maxDist). rowInsertRemoveCount at: j put: insertRemoveCount]. insertRemove := rowInsertRemove at: 0]. ^ base asOop: SmallInteger ! Item was changed: ----- Method: HostWindowPlugin>>primitiveShowHostWindow:bits:width:height:depth:left:right:top:bottom: (in category 'system primitives') ----- primitiveShowHostWindow: windowIndex bits: dispBits width: w height: h depth: d left: left right: right top: top bottom: bottom "Host window analogue of DisplayScreen> primShowRectLeft:right:top:bottom: (Interpreter>primitiveShowDisplayRect) which takes the window index, bitmap details and the rectangle bounds. Fail if the windowIndex is invalid or the platform routine returns false to indicate failure" |ok| + <var: #dispBits type: #'unsigned char *'> - self var: #dispBits type: 'unsigned char * '. self primitive: 'primitiveShowHostWindowRect' parameters: #(SmallInteger WordArray SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger). "Tell the vm to copy pixel's from dispBits to the screen - this is just ioShowDisplay with the extra parameter of the windowIndex integer" ok := self cCode: 'ioShowDisplayOnWindow(dispBits, w, h, d, left, right, top, bottom, windowIndex)'. ok ifFalse:[interpreterProxy primitiveFail]! Item was changed: ----- Method: InternetConfigPlugin>>primitiveGetMacintoshFileTypeAndCreatorFrom: (in category 'system primitives') ----- primitiveGetMacintoshFileTypeAndCreatorFrom: aFileName | oop ptr keyLength creator | + <var: #aFile declareC: 'char aFile[256]'> + <var: #creator declareC: 'char creator[8]'> + <var: #ptr type: 'char *'> self primitive: 'primitiveGetMacintoshFileTypeAndCreatorFrom' parameters: #(String). + - self var: #aFile declareC: 'char aFile[256]'. - self var: #creator declareC: 'char creator[8]'. - self var: #ptr type: 'char *'. - keyLength := interpreterProxy byteSizeOf: aFileName cPtrAsOop. self sqInternetGetMacintoshFileTypeAndCreatorFrom: aFileName keySize: keyLength into: creator. oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: 8. ptr := interpreterProxy firstIndexableField: oop. 0 to: 7 do:[:i| ptr at: i put: (creator at: i)]. ^oop. ! Item was changed: ----- Method: InternetConfigPlugin>>primitiveGetStringKeyedBy: (in category 'system primitives') ----- primitiveGetStringKeyedBy: aKey | oop ptr size aString keyLength | + <var: #aString declareC: 'char aString[1025]'> + <var: #ptr type: 'char *'> self primitive: 'primitiveGetStringKeyedBy' parameters: #(String). - self var: #aString declareC: 'char aString[1025]'. - self var: #ptr type: 'char *'. keyLength := interpreterProxy byteSizeOf: aKey cPtrAsOop. size := self sqInternetConfigurationGetStringKeyedBy: aKey keySize: keyLength into: aString. oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: size. ptr := interpreterProxy firstIndexableField: oop. 0 to: size-1 do:[:i| ptr at: i put: (aString at: i)]. ^oop. ! Item was changed: ----- Method: Interpreter class>>initializePrimitiveTable (in category 'initialization') ----- initializePrimitiveTable "This table generates a C function address table use in primitiveResponse along with dispatchFunctionPointerOn:in:" "NOTE: The real limit here is 2047 because of the method header layout but there is no point in going over the needed size" MaxPrimitiveIndex := 575. PrimitiveTable := Array new: MaxPrimitiveIndex + 1. self table: PrimitiveTable from: #( "Integer Primitives (0-19)" (0 primitiveFail) (1 primitiveAdd) (2 primitiveSubtract) (3 primitiveLessThan) (4 primitiveGreaterThan) (5 primitiveLessOrEqual) (6 primitiveGreaterOrEqual) (7 primitiveEqual) (8 primitiveNotEqual) (9 primitiveMultiply) (10 primitiveDivide) (11 primitiveMod) (12 primitiveDiv) (13 primitiveQuo) (14 primitiveBitAnd) (15 primitiveBitOr) (16 primitiveBitXor) (17 primitiveBitShift) (18 primitiveMakePoint) (19 primitiveFail) "Guard primitive for simulation -- *must* fail" "LargeInteger Primitives (20-39)" (20 primitiveFail) (21 primitiveAddLargeIntegers) (22 primitiveSubtractLargeIntegers) (23 primitiveLessThanLargeIntegers) (24 primitiveGreaterThanLargeIntegers) (25 primitiveLessOrEqualLargeIntegers) (26 primitiveGreaterOrEqualLargeIntegers) (27 primitiveEqualLargeIntegers) (28 primitiveNotEqualLargeIntegers) (29 primitiveMultiplyLargeIntegers) (30 primitiveDivideLargeIntegers) (31 primitiveModLargeIntegers) (32 primitiveDivLargeIntegers) (33 primitiveQuoLargeIntegers) (34 primitiveBitAndLargeIntegers) (35 primitiveBitOrLargeIntegers) (36 primitiveBitXorLargeIntegers) (37 primitiveBitShiftLargeIntegers) (38 primitiveFail) (39 primitiveFail) "Float Primitives (40-59)" (40 primitiveAsFloat) (41 primitiveFloatAdd) (42 primitiveFloatSubtract) (43 primitiveFloatLessThan) (44 primitiveFloatGreaterThan) (45 primitiveFloatLessOrEqual) (46 primitiveFloatGreaterOrEqual) (47 primitiveFloatEqual) (48 primitiveFloatNotEqual) (49 primitiveFloatMultiply) (50 primitiveFloatDivide) (51 primitiveTruncated) (52 primitiveFractionalPart) (53 primitiveExponent) (54 primitiveTimesTwoPower) (55 primitiveSquareRoot) (56 primitiveSine) (57 primitiveArctan) (58 primitiveLogN) (59 primitiveExp) "Subscript and Stream Primitives (60-67)" (60 primitiveAt) (61 primitiveAtPut) (62 primitiveSize) (63 primitiveStringAt) (64 primitiveStringAtPut) (65 primitiveFail) "was primitiveNext which no longer pays its way (normal Smalltalk code is faster)" (66 primitiveFail) "was primitiveNextPut which no longer pays its way (normal Smalltalk code is faster)" (67 primitiveFail) "was primitiveAtEnd which no longer pays its way (normal Smalltalk code is faster)" "StorageManagement Primitives (68-79)" (68 primitiveObjectAt) (69 primitiveObjectAtPut) (70 primitiveNew) (71 primitiveNewWithArg) (72 primitiveArrayBecomeOneWay) "Blue Book: primitiveBecome" (73 primitiveInstVarAt) (74 primitiveInstVarAtPut) (75 primitiveAsOop) (76 primitiveStoreStackp) "Blue Book: primitiveAsObject" (77 primitiveSomeInstance) (78 primitiveNextInstance) (79 primitiveNewMethod) "Control Primitives (80-89)" (80 primitiveBlockCopy) (81 primitiveValue) (82 primitiveValueWithArgs) (83 primitivePerform) (84 primitivePerformWithArgs) (85 primitiveSignal) (86 primitiveWait) (87 primitiveResume) (88 primitiveSuspend) (89 primitiveFlushCache) "Input/Output Primitives (90-109)" (90 primitiveMousePoint) (91 primitiveTestDisplayDepth) "Blue Book: primitiveCursorLocPut" (92 primitiveSetDisplayMode) "Blue Book: primitiveCursorLink" (93 primitiveInputSemaphore) (94 primitiveGetNextEvent) "Blue Book: primitiveSampleInterval" (95 primitiveInputWord) (96 primitiveFail) "primitiveCopyBits" (97 primitiveSnapshot) (98 primitiveStoreImageSegment) (99 primitiveLoadImageSegment) (100 primitivePerformInSuperclass) "Blue Book: primitiveSignalAtTick" (101 primitiveBeCursor) (102 primitiveBeDisplay) (103 primitiveScanCharacters) (104 primitiveFail) "primitiveDrawLoop" (105 primitiveStringReplace) (106 primitiveScreenSize) (107 primitiveMouseButtons) (108 primitiveKbdNext) (109 primitiveKbdPeek) "System Primitives (110-119)" (110 primitiveEquivalent) (111 primitiveClass) (112 primitiveBytesLeft) (113 primitiveQuit) (114 primitiveExitToDebugger) (115 primitiveChangeClass) "Blue Book: primitiveOopsLeft" (116 primitiveFlushCacheByMethod) (117 primitiveExternalCall) (118 primitiveDoPrimitiveWithArgs) (119 primitiveFlushCacheSelective) "Squeak 2.2 and earlier use 119. Squeak 2.3 and later use 116. Both are supported for backward compatibility." "Miscellaneous Primitives (120-127)" (120 primitiveCalloutToFFI) (121 primitiveImageName) (122 primitiveNoop) "Blue Book: primitiveImageVolume" (123 primitiveValueUninterruptably) "@@@: Remove this when all VMs have support" (124 primitiveLowSpaceSemaphore) (125 primitiveSignalAtBytesLeft) "Squeak Primitives Start Here" "Squeak Miscellaneous Primitives (128-149)" (126 primitiveDeferDisplayUpdates) (127 primitiveShowDisplayRect) (128 primitiveArrayBecome) (129 primitiveSpecialObjectsOop) (130 primitiveFullGC) (131 primitiveIncrementalGC) (132 primitiveObjectPointsTo) (133 primitiveSetInterruptKey) (134 primitiveInterruptSemaphore) (135 primitiveMillisecondClock) (136 primitiveSignalAtMilliseconds) (137 primitiveSecondsClock) (138 primitiveSomeObject) (139 primitiveNextObject) (140 primitiveBeep) (141 primitiveClipboardText) (142 primitiveVMPath) (143 primitiveShortAt) (144 primitiveShortAtPut) (145 primitiveConstantFill) "NOTE: When removing the obsolete indexed primitives, the following two should go become #primitiveIntegerAt / atPut" (146 primitiveFail) "primitiveReadJoystick" (147 primitiveFail) "primitiveWarpBits" (148 primitiveClone) (149 primitiveGetAttribute) "File Primitives (150-169) - NO LONGER INDEXED" (150 159 primitiveFail) (160 primitiveAdoptInstance) (161 164 primitiveFail) (165 primitiveIntegerAt) "hacked in here for now" (166 primitiveIntegerAtPut) (167 primitiveYield) (168 primitiveCopyObject) + (169 primitiveNotIdentical) - (169 primitiveFail) "Sound Primitives (170-199) - NO LONGER INDEXED" (170 185 primitiveFail) "Old closure primitives" (186 primitiveFail) "was primitiveClosureValue" (187 primitiveFail) "was primitiveClosureValueWithArgs" "Perform method directly" (188 primitiveExecuteMethodArgsArray) (189 primitiveExecuteMethod) "Sound Primitives (continued) - NO LONGER INDEXED" (190 194 primitiveFail) "Unwind primitives" (195 primitiveFindNextUnwindContext) (196 primitiveTerminateTo) (197 primitiveFindHandlerContext) (198 primitiveMarkUnwindMethod) (199 primitiveMarkHandlerMethod) "new closure primitives (were Networking primitives)" (200 primitiveClosureCopyWithCopiedValues) (201 primitiveClosureValue) "value" (202 primitiveClosureValue) "value:" (203 primitiveClosureValue) "value:value:" (204 primitiveClosureValue) "value:value:value:" (205 primitiveClosureValue) "value:value:value:value:" (206 primitiveClosureValueWithArgs) "valueWithArguments:" (207 209 primitiveFail) "reserved for Cog primitives" (210 primitiveAt) "Compatibility with Cog StackInterpreter Context primitives" (211 primitiveAtPut) "Compatibility with Cog StackInterpreter Context primitives" (212 primitiveSize) "Compatibility with Cog StackInterpreter Context primitives" (213 219 primitiveFail) "reserved for Cog primitives" (220 primitiveFail) "reserved for Cog primitives" (221 primitiveClosureValueNoContextSwitch) "valueNoContextSwitch" (222 primitiveClosureValueNoContextSwitch) "valueNoContextSwitch:" (223 229 primitiveFail) "reserved for Cog primitives" (230 primitiveRelinquishProcessor) (231 primitiveForceDisplayUpdate) (232 primitiveFormPrint) (233 primitiveSetFullScreen) (234 primitiveFail) "primBitmapdecompressfromByteArrayat" (235 primitiveFail) "primStringcomparewithcollated" (236 primitiveFail) "primSampledSoundconvert8bitSignedFromto16Bit" (237 primitiveFail) "primBitmapcompresstoByteArray" (238 241 primitiveFail) "serial port primitives" (242 primitiveFail) (243 primitiveFail) "primStringtranslatefromtotable" (244 primitiveFail) "primStringfindFirstInStringinSetstartingAt" (245 primitiveFail) "primStringindexOfAsciiinStringstartingAt" (246 primitiveFail) "primStringfindSubstringinstartingAtmatchTable" (247 primitiveSnapshotEmbedded) (248 primitiveInvokeObjectAsMethod) (249 primitiveArrayBecomeOneWayCopyHash) "VM Implementor Primitives (250-255)" (250 primitiveClearVMProfile) (251 primitiveControlVMProfiling "primitiveStartVMProfiling") (252 primitiveVMProfileSamplesInto "primitiveStopVMProfiling") (253 primitiveFail "primitiveVMProfileInfoInto") (254 primitiveVMParameter) (255 primitiveInstVarsPutFromStack) "Never used except in Disney tests. Remove after 2.3 release." "Quick Push Const Methods" (256 primitivePushSelf) (257 primitivePushTrue) (258 primitivePushFalse) (259 primitivePushNil) (260 primitivePushMinusOne) (261 primitivePushZero) (262 primitivePushOne) (263 primitivePushTwo) "Quick Push Const Methods" (264 519 primitiveLoadInstVar) "These ranges used to be used by obsiolete indexed primitives." (520 529 primitiveFail) (530 539 primitiveFail) (540 549 primitiveFail) (550 559 primitiveFail) (560 569 primitiveFail) "External primitive support primitives" (570 primitiveFlushExternalPrimitives) (571 primitiveUnloadModule) (572 primitiveListBuiltinModule) (573 primitiveListExternalModule) (574 primitiveFail) "reserved for addl. external support prims" "Unassigned Primitives" (575 primitiveFail)). ! Item was changed: ----- Method: Interpreter>>bytecodePrimMultiply (in category 'common selector sends') ----- bytecodePrimMultiply | rcvr arg result | rcvr := self internalStackValue: 1. arg := self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [rcvr := self integerValueOf: rcvr. arg := self integerValueOf: arg. result := rcvr * arg. + (arg = 0 + or: [(result // arg) = rcvr and: [self isIntegerValue: result]]) ifTrue: + [self internalPop: 2 thenPush: (self integerObjectOf: result). + ^self fetchNextBytecode "success"]] - ((arg = 0 or: [(result // arg) = rcvr]) and: [self isIntegerValue: result]) - ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: result). - ^ self fetchNextBytecode "success"]] ifFalse: [successFlag := true. self externalizeIPandSP. self primitiveFloatMultiply: rcvr byArg: arg. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]]. messageSelector := self specialSelector: 8. argumentCount := 1. self normalSend. ! Item was changed: ----- Method: Interpreter>>floatValueOf: (in category 'utilities') ----- floatValueOf: oop + "Fetch the instance variable at the given index of the given object. Answer the C + double precision floating point value of that instance variable, or fail if it is not a Float." - "Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float." - "Note: May be called by translated primitive code." + | isFloat result | + <returnTypeC: #double> + <var: #result type: #double> + "N.B. Because Slang always inlines is:instanceOf:compactClassIndex: + (because is:instanceOf:compactClassIndex: has an inline: pragma) the + phrase (self splObj: ClassArray) is expanded in-place and is _not_ evaluated if + ClassArrayCompactIndex is non-zero." + isFloat := self + is: oop + instanceOf: (self splObj: ClassFloat) + compactClassIndex: ClassFloatCompactIndex. + isFloat ifTrue: + [self cCode: '' inSmalltalk: [result := Float new: 2]. + self fetchFloatAt: oop + BaseHeaderSize into: result. + ^result]. + self primitiveFail. + ^0.0! - "DO _NOT_ USE THIS IN DEBUG PRINTING!! assertClassOf:is: sets successFlag." - - | result | - self flag: #Dan. "None of the float stuff has been converted for 64 bits" - self returnTypeC: 'double'. - self var: #result type: 'double '. - self assertClassOf: oop is: (self splObj: ClassFloat). - successFlag - ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2]. - self fetchFloatAt: oop + BaseHeaderSize into: result] - ifFalse: [result := 0.0]. - ^ result! Item was removed: - ----- Method: Interpreter>>isContextNonInt: (in category 'contexts') ----- - isContextNonInt: oop - <inline: true> - ^self isContextHeader: (self baseHeader: oop)! Item was changed: ----- Method: Interpreter>>loadFloatOrIntFrom: (in category 'utilities') ----- 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 primErrorCode non-zero." - If it is a Float, then load its value and return it. - Otherwise fail -- ie return with successFlag set to false." - | result | <inline: true> <asmLabel: false> + <returnTypeC: #double> - <returnTypeC: 'double'> - <var: #result type: 'double '> (self isIntegerObject: floatOrInt) ifTrue: [^(self integerValueOf: floatOrInt) asFloat]. + ^self floatValueOf: floatOrInt! - (self fetchClassOfNonInt: floatOrInt) = (self splObj: ClassFloat) ifTrue: - [self cCode: '' inSmalltalk: [result := Float new: 2]. - self fetchFloatAt: floatOrInt + BaseHeaderSize into: result. - ^result]. - successFlag := false! Item was changed: ----- Method: Interpreter>>popFloat (in category 'stack bytecodes') ----- popFloat + <returnTypeC: #double> + ^self floatValueOf: self popStack! - "Note: May be called by translated primitive code." - - | top result | - <returnTypeC: 'double'> - <var: #result type: 'double '> - top := self popStack. - self assertClassOf: top is: (self splObj: ClassFloat). - successFlag ifTrue: - [self cCode: '' inSmalltalk: [result := Float new: 2]. - self fetchFloatAt: top + BaseHeaderSize into: result]. - ^ result! Item was added: + ----- Method: Interpreter>>primitiveNotIdentical (in category 'object access primitives') ----- + primitiveNotIdentical + "is the receiver/first argument not the same object as the (last) argument?. + pop argumentCount because this can be used as a mirror primitive." + | thisObject otherObject | + otherObject := self stackValue: 1. + thisObject := self stackTop. + self pop: argumentCount + 1 thenPushBool: thisObject ~= otherObject! Item was changed: ----- Method: Interpreter>>stackFloatValue: (in category 'contexts') ----- stackFloatValue: offset + <returnTypeC: #double> + ^self floatValueOf: (self longAt: stackPointer - (offset*BytesPerWord))! - "Note: May be called by translated primitive code." - | result floatPointer | - <returnTypeC: 'double'> - <var: #result type: 'double '> - floatPointer := self longAt: stackPointer - (offset*BytesPerWord). - (self fetchClassOf: floatPointer) = (self splObj: ClassFloat) - ifFalse:[self primitiveFail. ^0.0]. - self cCode: '' inSmalltalk: [result := Float new: 2]. - self fetchFloatAt: floatPointer + BaseHeaderSize into: result. - ^ result! Item was removed: - ----- Method: Interpreter>>sufficientSpaceToInstantiate:indexableSize: (in category 'object access primitives') ----- - sufficientSpaceToInstantiate: classOop indexableSize: size - "Return the number of bytes required to allocate an instance of the given class with the given number of indexable fields." - "Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line." - | format atomSize| - <inline: true> - format := (self formatOfClass: classOop) >> 8 bitAnd: 15. - - "fail if attempting to call new: on non-indexable class" - ((self cCoerce: size to: 'usqInt ') > 0 and: [format < 2]) - ifTrue: [^ false]. - - format < 8 - ifTrue: ["indexable fields are words or pointers" atomSize := BytesPerWord] - ifFalse: ["indexable fields are bytes" atomSize := 1]. - ^self sufficientSpaceToAllocate: 2500 + (size * atomSize)! Item was changed: ----- Method: InterpreterPrimitives>>primitiveCrashVM (in category 'system control primitives') ----- primitiveCrashVM "Crash the VM by indirecting through a null pointer. If the sole argument + is true crash in this thread, and if it is false crash in a new thread. If the + argument is an integer use the method that implies. + bit 0 = thread to crash in; 1 => this thread + bit 1 = crash method; 0 => indirect through null pointer; 1 => call exit" + - is true crash in this thread, and if it is false crash in a new thread." | crashInThisThread | <export: true> + (objectMemory isIntegerObject: self stackTop) + ifTrue: [crashInThisThread := objectMemory integerValueOf: self stackTop] + ifFalse: [crashInThisThread := self booleanValueOf: self stackTop]. - crashInThisThread := self booleanValueOf: self stackTop. (self failed or: [argumentCount ~= 1]) ifTrue: [^self primitiveFailFor: PrimErrBadNumArgs]. self crashInThisOrAnotherThread: crashInThisThread. self pop: 1! Item was changed: ----- Method: InterpreterPrimitives>>primitiveNew (in category 'object access primitives') ----- primitiveNew "Allocate a new fixed-size instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free. May cause a GC" | class spaceOkay | class := self stackTop. "The following may cause GC!!" + spaceOkay := objectMemory sufficientSpaceToInstantiate: class indexableSize: 0. - spaceOkay := self sufficientSpaceToInstantiate: class indexableSize: 0. self success: spaceOkay. + self successful ifTrue: + [self push: (objectMemory instantiateClass: self popStack indexableSize: 0)]! - self successful ifTrue: [ self push: (objectMemory instantiateClass: self popStack indexableSize: 0) ]! Item was changed: ----- Method: InterpreterPrimitives>>primitiveNewWithArg (in category 'object access primitives') ----- primitiveNewWithArg "Allocate a new indexable instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free." | size class spaceOkay | size := self positive32BitValueOf: self stackTop. class := self stackValue: 1. self success: size >= 0. + self successful ifTrue: + ["The following may cause GC!!" + spaceOkay := objectMemory sufficientSpaceToInstantiate: class indexableSize: size. + self success: spaceOkay. + class := self stackValue: 1]. + self successful ifTrue: + [self pop: 2 thenPush: (objectMemory instantiateClass: class indexableSize: size)]! - self successful - ifTrue: ["The following may cause GC!!" - spaceOkay := self sufficientSpaceToInstantiate: class indexableSize: size. - self success: spaceOkay. - class := self stackValue: 1]. - self successful ifTrue: [self pop: 2 thenPush: (objectMemory instantiateClass: class indexableSize: size)]! Item was added: + ----- Method: InterpreterPrimitives>>primitiveNotIdentical (in category 'object access primitives') ----- + primitiveNotIdentical + "is the receiver/first argument not the same object as the (last) argument?. + pop argumentCount because this can be used as a mirror primitive." + | thisObject otherObject | + otherObject := self stackValue: 1. + thisObject := self stackTop. + self pop: argumentCount + 1 thenPushBool: thisObject ~= otherObject! Item was changed: + ----- Method: InterpreterSimulatorLSB64>>bytesPerWord (in category 'memory access') ----- - ----- Method: InterpreterSimulatorLSB64>>bytesPerWord (in category 'as yet unclassified') ----- bytesPerWord "overridden for 64-bit images..." ^ 8! Item was changed: + ----- Method: InterpreterSimulatorMSB64>>bytesPerWord (in category 'memory access') ----- - ----- Method: InterpreterSimulatorMSB64>>bytesPerWord (in category 'as yet unclassified') ----- bytesPerWord "overridden for 64-bit images..." ^ 8! Item was removed: - ----- Method: InterpreterStackPage class>>alignedByteSizeForClient: (in category 'translation') ----- - alignedByteSizeForClient: aVMClass - ^self alignedByteSize! Item was added: + ----- Method: InterpreterStackPage class>>alignedByteSizeOf:forClient: (in category 'translation') ----- + alignedByteSizeOf: anObject forClient: aVMClass + ^self alignedByteSize! Item was changed: ----- Method: LargeIntegersPlugin class>>buildCodeGeneratorUpTo: (in category 'translation') ----- buildCodeGeneratorUpTo: someClass "A hook to control generation of the plugin. Don't know how to set the debug mode otherwise if using the VMMaker gui. Possibly there is a better way." | cg | cg := super buildCodeGeneratorUpTo: someClass. "example: cg generateDebugCode: true." ^ cg! Item was changed: ----- Method: LargeIntegersPlugin>>digitAddLarge:with: (in category 'oop functions') ----- digitAddLarge: firstInteger with: secondInteger "Does not need to normalize!!" | over firstLen secondLen shortInt shortLen longInt longLen sum newSum resClass | <var: #over type: 'unsigned char '> firstLen := self byteSizeOfBytes: firstInteger. secondLen := self byteSizeOfBytes: secondInteger. resClass := interpreterProxy fetchClassOf: firstInteger. firstLen <= secondLen ifTrue: [shortInt := firstInteger. shortLen := firstLen. longInt := secondInteger. longLen := secondLen] ifFalse: [shortInt := secondInteger. shortLen := secondLen. longInt := firstInteger. longLen := firstLen]. " sum := Integer new: len neg: firstInteger negative." self remapOop: #(shortInt longInt ) in: [sum := interpreterProxy instantiateClass: resClass indexableSize: longLen]. over := self cDigitAdd: (interpreterProxy firstIndexableField: shortInt) len: shortLen with: (interpreterProxy firstIndexableField: longInt) len: longLen into: (interpreterProxy firstIndexableField: sum). over > 0 ifTrue: ["sum := sum growby: 1." + self remapOop: sum in: [newSum := interpreterProxy instantiateClass: resClass indexableSize: longLen + 1]. - interpreterProxy remapOop: sum in: [newSum := interpreterProxy instantiateClass: resClass indexableSize: longLen + 1]. self cBytesCopyFrom: (interpreterProxy firstIndexableField: sum) to: (interpreterProxy firstIndexableField: newSum) len: longLen. sum := newSum. "C index!!" (self cCoerce: (interpreterProxy firstIndexableField: sum) to: 'unsigned char *') at: longLen put: over]. ^ sum! Item was changed: ----- Method: MacMenubarPlugin>>primitiveGetItemCmd:item: (in category 'system primitives') ----- primitiveGetItemCmd: menuHandleOop item: anInteger | menuHandle aCharacter | + <var: 'menuHandle' type: 'MenuHandle'> + <var: #aCharacter type: 'CharParameter '> + <var: #ptr type: 'char *'> self primitive: 'primitiveGetItemCmd' parameters: #(Oop SmallInteger). - self var: 'menuHandle' type: 'MenuHandle'. - self var: #aCharacter type: 'CharParameter '. - self var: #ptr type: 'char *'. menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'. (self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false]. aCharacter := 0. self cCode: 'GetItemCmd(menuHandle,anInteger,&aCharacter)' inSmalltalk:[menuHandle]. ^aCharacter asSmallIntegerObj ! Item was changed: ----- Method: MacMenubarPlugin>>primitiveGetItemMark:item: (in category 'system primitives') ----- primitiveGetItemMark: menuHandleOop item: anInteger | menuHandle aCharacter | + <var: 'menuHandle' type: 'MenuHandle'> + <var: #aCharacter type: 'CharParameter '> + <var: #ptr type: 'char *'> self primitive: 'primitiveGetItemMark' parameters: #(Oop SmallInteger). - self var: 'menuHandle' type: 'MenuHandle'. - self var: #aCharacter type: 'CharParameter '. - self var: #ptr type: 'char *'. menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'. (self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false]. aCharacter := 0. self cCode: 'GetItemMark(menuHandle,anInteger,&aCharacter)' inSmalltalk:[menuHandle]. ^aCharacter asSmallIntegerObj ! Item was changed: ----- Method: MacMenubarPlugin>>primitiveGetMenuItemText:item: (in category 'system primitives') ----- primitiveGetMenuItemText: menuHandleOop item: anInteger | menuHandle size oop ptr aString | + <var: 'menuHandle' type: 'MenuHandle'> + <var: #aString type: 'Str255 '> + <var: #ptr type: 'char *'> self primitive: 'primitiveGetMenuItemText' parameters: #(Oop SmallInteger). - self var: 'menuHandle' type: 'MenuHandle'. - self var: #aString type: 'Str255 '. - self var: #ptr type: 'char *'. menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'. (self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false]. aString at: 0 put: 0. self cCode: 'GetMenuItemText(menuHandle,anInteger,aString)' inSmalltalk:[menuHandle]. size := self cCode: 'aString[0]' inSmalltalk: [0]. oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: size. ptr := interpreterProxy firstIndexableField: oop. 0 to: size-1 do:[:i| ptr at: i put: (aString at: (i+1))]. ^oop ! Item was changed: ----- Method: MacMenubarPlugin>>primitiveGetMenuTitle: (in category 'system primitives') ----- primitiveGetMenuTitle: menuHandleOop | menuHandle size oop ptr aString | + <var: 'menuHandle' type: 'MenuHandle'> + <var: #aString type: 'Str255 '> + <var: #ptr type: 'char *'> self primitive: 'primitiveGetMenuTitle' parameters: #(Oop). - self var: 'menuHandle' type: 'MenuHandle'. - self var: #aString type: 'Str255 '. - self var: #ptr type: 'char *'. menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'. (self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false]. aString at: 0 put: 0. self cCode: 'GetMenuTitle(menuHandle,aString)' inSmalltalk:[menuHandle]. size := self cCode: 'aString[0]' inSmalltalk: [0]. oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: size. ptr := interpreterProxy firstIndexableField: oop. 0 to: size-1 do:[:i| ptr at: i put: (aString at: (i+1))]. ^oop ! Item was changed: ----- Method: MacMenubarPlugin>>primitiveSetItemCmd:item:cmdChar: (in category 'system primitives') ----- primitiveSetItemCmd: menuHandleOop item: anInteger cmdChar: anIntegerCmdChar | menuHandle aCharacter | + <var: 'menuHandle' type: 'MenuHandle'> + <var: #aCharacter type: 'CharParameter '> self primitive: 'primitiveSetItemCmd' parameters: #(Oop SmallInteger SmallInteger). - self var: 'menuHandle' type: 'MenuHandle'. - self var: #aCharacter type: 'CharParameter '. menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'. (self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false]. aCharacter := anIntegerCmdChar. self cCode: 'SetItemCmd(menuHandle,anInteger,aCharacter)' inSmalltalk:[menuHandle]. ^nil ! Item was changed: ----- Method: MacMenubarPlugin>>primitiveSetItemMark:item:markChar: (in category 'system primitives') ----- primitiveSetItemMark: menuHandleOop item: anInteger markChar: aMarkChar | menuHandle aCharacter | + <var: 'menuHandle' type: 'MenuHandle'> + <var: #aCharacter type: 'CharParameter '> self primitive: 'primitiveSetItemMark' parameters: #(Oop SmallInteger SmallInteger). - self var: 'menuHandle' type: 'MenuHandle'. - self var: #aCharacter type: 'CharParameter '. menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'. (self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false]. aCharacter := aMarkChar. self cCode: 'SetItemMark(menuHandle,anInteger,aCharacter)' inSmalltalk:[menuHandle]. ^nil ! Item was changed: ----- Method: Mpeg3Plugin>>primitiveMPEG3ReadFrame:buffer:bufferOffset:x:y:w:h:ow:oh:colorModel:stream:bytesPerRow: (in category 'primitives') ----- primitiveMPEG3ReadFrame: fileHandle buffer: aBuffer bufferOffset: aBufferOffset x: xNumber y: yNumber w: width h: height ow: outWidth oh: outHeight colorModel: model stream: aNumber bytesPerRow: aByteNumber | file result outputRowsPtr bufferBaseAddr | - <var: #file declareC: 'mpeg3_t * file'> - <var: #bufferBaseAddr declareC: 'unsigned char *bufferBaseAddr'> - <var: #outputRowsPtr declareC: 'unsigned char ** outputRowsPtr'> "int mpeg3_read_frame(mpeg3_t *file, unsigned char **output_rows, int in_x, int in_y, int in_w, int in_h, int out_w, int out_h, int color_model, int stream)" + <var: #file declareC: 'mpeg3_t * file'> + <var: #bufferBaseAddr declareC: 'unsigned char *bufferBaseAddr'> + <var: #outputRowsPtr declareC: 'unsigned char ** outputRowsPtr'> self primitive: 'primitiveMPEG3ReadFrameBufferOffset' parameters: #(Oop WordArray SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger). file := self mpeg3tValueOf: fileHandle. file = nil ifTrue: [^0]. aNumber < 0 ifTrue: [ interpreterProxy success: false. ^nil ]. aNumber >= (self cCode: 'result = mpeg3_total_vstreams(file)') ifTrue: [ interpreterProxy success: false. ^0 ]. bufferBaseAddr := self cCoerce: aBuffer to: 'unsigned char *'. self cCode: 'outputRowsPtr = (unsigned char **) memoryAllocate(1,sizeof(unsigned char*) * outHeight)'. 0 to: outHeight-1 do: [:i | outputRowsPtr at: i put: (bufferBaseAddr + aBufferOffset + (aByteNumber*i))]. self cCode: 'result = mpeg3_read_frame(file,outputRowsPtr,xNumber,yNumber,width,height,outWidth,outHeight,model,aNumber)'. self cCode: 'memoryFree(outputRowsPtr)'. ^result asSmallIntegerObj ! Item was changed: ----- Method: Mpeg3Plugin>>primitiveMPEG3ReadFrame:buffer:x:y:w:h:ow:oh:colorModel:stream:bytesPerRow: (in category 'primitives') ----- primitiveMPEG3ReadFrame: fileHandle buffer: aBuffer x: xNumber y: yNumber w: width h: height ow: outWidth oh: outHeight colorModel: model stream: aNumber bytesPerRow: aByteNumber | file result outputRowsPtr bufferBaseAddr | - <var: #file type: 'mpeg3_t * '> - <var: #bufferBaseAddr type: 'unsigned char *'> - <var: #outputRowsPtr type: 'unsigned char ** '> "int mpeg3_read_frame(mpeg3_t *file, unsigned char **output_rows, int in_x, int in_y, int in_w, int in_h, int out_w, int out_h, int color_model, int stream)" + <var: #file type: 'mpeg3_t * '> + <var: #bufferBaseAddr type: 'unsigned char *'> + <var: #outputRowsPtr type: 'unsigned char ** '> self primitive: 'primitiveMPEG3ReadFrame' parameters: #(Oop WordArray SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger). file := self mpeg3tValueOf: fileHandle. file = nil ifTrue: [^0]. aNumber < 0 ifTrue: [ interpreterProxy success: false. ^nil ]. aNumber >= (self cCode: 'result = mpeg3_total_vstreams(file)') ifTrue: [ interpreterProxy success: false. ^0 ]. bufferBaseAddr := self cCoerce: aBuffer to: 'unsigned char *'. self cCode: 'outputRowsPtr = (unsigned char **) memoryAllocate(1,sizeof(unsigned char*) * outHeight)'. 0 to: outHeight-1 do: [:i | outputRowsPtr at: i put: (bufferBaseAddr + (aByteNumber*i))]. self cCode: 'result = mpeg3_read_frame(file,outputRowsPtr,xNumber,yNumber,width,height,outWidth,outHeight,model,aNumber)'. self cCode: 'memoryFree(outputRowsPtr)'. ^result asSmallIntegerObj ! Item was removed: - ----- Method: NewCoObjectMemory>>clone: (in category 'allocation') ----- - clone: obj - "Return a shallow copy of the given object. May cause GC" - "Assume: Oop is a real object, not a small integer. - Override to assert it's not a cogged method" - self assert: ((self isOopCompiledMethod: obj) not - or: [(coInterpreter methodHasCogMethod: obj) not]). - ^super clone: obj! Item was changed: ----- Method: NewObjectMemory>>eeInstantiateAndInitializeClass:indexableSize: (in category 'interpreter access') ----- eeInstantiateAndInitializeClass: classPointer indexableSize: size "NOTE: This method supports the backward-compatible split instSize field of the class format word. The sizeHiBits will go away and other shifts change by 2 when the split fields get merged in an (incompatible) image change. Will *not* cause a GC. The instantiated object is initialized." | hash header1 header2 cClass byteSize format binc header3 hdrSize sizeHiBits bm1 classFormat | <inline: false> "cannot have a negative indexable field count" self assert: size >= 0. hash := self newObjectHash. classFormat := self formatOfClass: classPointer. "Low 2 bits are 0" header1 := (classFormat bitAnd: 16r1FF00) bitOr: (hash bitAnd: HashMaskUnshifted) << HashBitsOffset. header2 := classPointer. header3 := 0. sizeHiBits := (classFormat bitAnd: 16r60000) >> 9. cClass := header1 bitAnd: CompactClassMask. "compact class field from format word" byteSize := (classFormat bitAnd: SizeMask + Size4Bit) + sizeHiBits. "size in bytes -- low 2 bits are 0" "Note this byteSize comes from the format word of the class which is pre-shifted to 4 bytes per field. Need another shift for 8 bytes per word..." byteSize := byteSize << (ShiftForWord-2). + format := self formatOfHeader: classFormat. - format := classFormat >> 8 bitAnd: 15. self flag: #sizeLowBits. format < 8 ifTrue: [format = 6 ifTrue: ["long32 bitmaps" bm1 := BytesPerWord-1. byteSize := byteSize + (size * 4) + bm1 bitAnd: LongSizeMask. "round up" binc := bm1 - ((size * 4) + bm1 bitAnd: bm1). "odd bytes" "extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)" header1 := header1 bitOr: (binc bitAnd: 4)] ifFalse: [byteSize := byteSize + (size * BytesPerWord) "Arrays and 64-bit bitmaps"] ] ifFalse: ["Strings and Methods" bm1 := BytesPerWord-1. byteSize := byteSize + size + bm1 bitAnd: LongSizeMask. "round up" binc := bm1 - (size + bm1 bitAnd: bm1). "odd bytes" "low bits of byte size go in format field" header1 := header1 bitOr: (binc bitAnd: 3) << 8. "extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)" header1 := header1 bitOr: (binc bitAnd: 4)]. byteSize > 255 ifTrue: ["requires size header word" header3 := byteSize. header1 := header1] ifFalse: [header1 := header1 bitOr: byteSize]. header3 > 0 ifTrue: ["requires full header" hdrSize := 3] ifFalse: [cClass = 0 ifTrue: [hdrSize := 2] ifFalse: [hdrSize := 1]]. ^self eeAllocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3 doFill: true format: format! Item was changed: ----- Method: NewObjectMemory>>eeInstantiateClass:indexableSize: (in category 'interpreter access') ----- eeInstantiateClass: classPointer indexableSize: size "NOTE: This method supports the backward-compatible split instSize field of the class format word. The sizeHiBits will go away and other shifts change by 2 when the split fields get merged in an (incompatible) image change. Will *not* cause a GC. Note that the instantiated object IS NOT FILLED and must be completed before returning it to Smalltalk. Since this call is used in routines that do just that we are safe. Break this rule and die." <api> | hash header1 header2 cClass byteSize format binc header3 hdrSize sizeHiBits bm1 classFormat | <inline: false> "cannot have a negative indexable field count" self assert: size >= 0. hash := self newObjectHash. classFormat := self formatOfClass: classPointer. "Low 2 bits are 0" header1 := (classFormat bitAnd: 16r1FF00) bitOr: (hash bitAnd: HashMaskUnshifted) << HashBitsOffset. header2 := classPointer. header3 := 0. sizeHiBits := (classFormat bitAnd: 16r60000) >> 9. cClass := header1 bitAnd: CompactClassMask. "compact class field from format word" byteSize := (classFormat bitAnd: SizeMask + Size4Bit) + sizeHiBits. "size in bytes -- low 2 bits are 0" "Note this byteSize comes from the format word of the class which is pre-shifted to 4 bytes per field. Need another shift for 8 bytes per word..." byteSize := byteSize << (ShiftForWord-2). + format := self formatOfHeader: classFormat. - format := classFormat >> 8 bitAnd: 15. self flag: #sizeLowBits. format < 8 ifTrue: [format = 6 ifTrue: ["long32 bitmaps" bm1 := BytesPerWord-1. byteSize := byteSize + (size * 4) + bm1 bitAnd: LongSizeMask. "round up" binc := bm1 - ((size * 4) + bm1 bitAnd: bm1). "odd bytes" "extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)" header1 := header1 bitOr: (binc bitAnd: 4)] ifFalse: [byteSize := byteSize + (size * BytesPerWord) "Arrays and 64-bit bitmaps"] ] ifFalse: ["Strings and Methods" bm1 := BytesPerWord-1. byteSize := byteSize + size + bm1 bitAnd: LongSizeMask. "round up" binc := bm1 - (size + bm1 bitAnd: bm1). "odd bytes" "low bits of byte size go in format field" header1 := header1 bitOr: (binc bitAnd: 3) << 8. "extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)" header1 := header1 bitOr: (binc bitAnd: 4)]. byteSize > 255 ifTrue: ["requires size header word" header3 := byteSize. header1 := header1] ifFalse: [header1 := header1 bitOr: byteSize]. header3 > 0 ifTrue: ["requires full header" hdrSize := 3] ifFalse: [cClass = 0 ifTrue: [hdrSize := 2] ifFalse: [hdrSize := 1]]. ^self eeAllocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3! Item was added: + ----- Method: NewObjectMemory>>findStringBeginningWith: (in category 'debug support') ----- + findStringBeginningWith: aCString + "Print the oops of all string-like things that start with the same characters as aCString" + <api> + <var: #aCString type: #'char *'> + | cssz obj sz | + cssz := self strlen: aCString. + obj := self firstObject. + [self oop: obj isLessThan: freeStart] whileTrue: + [(self isFreeObject: obj) + ifTrue: + [sz := self sizeOfFree: obj] + ifFalse: + [((self isBytesNonInt: obj) + and: [(self lengthOf: obj) >= cssz + and: [(self str: aCString n: (self pointerForOop: obj + BaseHeaderSize) cmp: cssz) = 0]]) ifTrue: + [coInterpreter printHex: obj; space; printNum: (self lengthOf: obj); space; printOopShort: obj; cr]. + sz := self sizeBitsOf: obj]. + obj := self oopFromChunk: obj + sz]! Item was changed: ----- Method: NewspeakInterpreter class>>initializePrimitiveTable (in category 'initialization') ----- initializePrimitiveTable "This table generates a C function address table use in primitiveResponse along with dispatchFunctionPointerOn:in:" "NOTE: The real limit here is 2047 because of the method header layout but there is no point in going over the needed size" MaxPrimitiveIndex := 575. MaxQuickPrimitiveIndex := 519. PrimitiveTable := Array new: MaxPrimitiveIndex + 1. self table: PrimitiveTable from: #( "Integer Primitives (0-19)" (0 primitiveFail) (1 primitiveAdd) (2 primitiveSubtract) (3 primitiveLessThan) (4 primitiveGreaterThan) (5 primitiveLessOrEqual) (6 primitiveGreaterOrEqual) (7 primitiveEqual) (8 primitiveNotEqual) (9 primitiveMultiply) (10 primitiveDivide) (11 primitiveMod) (12 primitiveDiv) (13 primitiveQuo) (14 primitiveBitAnd) (15 primitiveBitOr) (16 primitiveBitXor) (17 primitiveBitShift) (18 primitiveMakePoint) (19 primitiveFail) "Guard primitive for simulation -- *must* fail" "LargeInteger Primitives (20-39)" "32-bit logic is aliased to Integer prims above" (20 37 primitiveFail) "Float Primitives (38-59)" (38 primitiveAt) "for compatibility with Cog's primitiveFloatAt" (39 primitiveAtPut) "for compatibility with Cog's primitiveFloatAtPut" (40 primitiveAsFloat) (41 primitiveFloatAdd) (42 primitiveFloatSubtract) (43 primitiveFloatLessThan) (44 primitiveFloatGreaterThan) (45 primitiveFloatLessOrEqual) (46 primitiveFloatGreaterOrEqual) (47 primitiveFloatEqual) (48 primitiveFloatNotEqual) (49 primitiveFloatMultiply) (50 primitiveFloatDivide) (51 primitiveTruncated) (52 primitiveFractionalPart) (53 primitiveExponent) (54 primitiveTimesTwoPower) (55 primitiveSquareRoot) (56 primitiveSine) (57 primitiveArctan) (58 primitiveLogN) (59 primitiveExp) "Subscript and Stream Primitives (60-67)" (60 primitiveAt) (61 primitiveAtPut) (62 primitiveSize) (63 primitiveStringAt) (64 primitiveStringAtPut) (65 primitiveNext) (66 primitiveNextPut) (67 primitiveAtEnd) "StorageManagement Primitives (68-79)" (68 primitiveObjectAt) (69 primitiveObjectAtPut) (70 primitiveNew) (71 primitiveNewWithArg) (72 primitiveArrayBecomeOneWay) "Blue Book: primitiveBecome" (73 primitiveInstVarAt) (74 primitiveInstVarAtPut) (75 primitiveAsOop) (76 primitiveStoreStackp) "Blue Book: primitiveAsObject" (77 primitiveSomeInstance) (78 primitiveNextInstance) (79 primitiveNewMethod) "Control Primitives (80-89)" (80 primitiveBlockCopy) (81 primitiveValue) (82 primitiveValueWithArgs) (83 primitivePerform) (84 primitivePerformWithArgs) (85 primitiveSignal) (86 primitiveWait) (87 primitiveResume) (88 primitiveSuspend) (89 primitiveFlushCache) "Input/Output Primitives (90-109)" (90 primitiveMousePoint) (91 primitiveTestDisplayDepth) "Blue Book: primitiveCursorLocPut" (92 primitiveSetDisplayMode) "Blue Book: primitiveCursorLink" (93 primitiveInputSemaphore) (94 primitiveGetNextEvent) "Blue Book: primitiveSampleInterval" (95 primitiveInputWord) (96 primitiveFail) "was primitiveObsoleteIndexedPrimitive; was primitiveCopyBits" (97 primitiveSnapshot) (98 primitiveStoreImageSegment) (99 primitiveLoadImageSegment) (100 primitivePerformInSuperclass) "Blue Book: primitiveSignalAtTick" (101 primitiveBeCursor) (102 primitiveBeDisplay) (103 primitiveScanCharacters) (104 primitiveFail) "was primitiveObsoleteIndexedPrimitive; was primitiveDrawLoop" (105 primitiveStringReplace) (106 primitiveScreenSize) (107 primitiveMouseButtons) (108 primitiveKbdNext) (109 primitiveKbdPeek) "System Primitives (110-119)" (110 primitiveEquivalent) (111 primitiveClass) (112 primitiveBytesLeft) (113 primitiveQuit) (114 primitiveExitToDebugger) (115 primitiveChangeClass) "Blue Book: primitiveOopsLeft" (116 primitiveFlushCacheByMethod) (117 primitiveExternalCall) (118 primitiveDoPrimitiveWithArgs) (119 primitiveFlushCacheBySelector) "Squeak 2.2 and earlier use 119. Squeak 2.3 and later use 116. Both are supported for backward compatibility." "Miscellaneous Primitives (120-127)" (120 primitiveCalloutToFFI) (121 primitiveImageName) (122 primitiveNoop) "Blue Book: primitiveImageVolume" (123 primitiveFail) "was primitiveValueUninterruptably" (124 primitiveLowSpaceSemaphore) (125 primitiveSignalAtBytesLeft) "Squeak Primitives Start Here" "Squeak Miscellaneous Primitives (128-149)" (126 primitiveDeferDisplayUpdates) (127 primitiveShowDisplayRect) (128 primitiveArrayBecome) (129 primitiveSpecialObjectsOop) (130 primitiveFullGC) (131 primitiveIncrementalGC) (132 primitiveObjectPointsTo) (133 primitiveSetInterruptKey) (134 primitiveInterruptSemaphore) (135 primitiveMillisecondClock) (136 primitiveSignalAtMilliseconds) (137 primitiveSecondsClock) (138 primitiveSomeObject) (139 primitiveNextObject) (140 primitiveBeep) (141 primitiveClipboardText) (142 primitiveVMPath) (143 primitiveShortAt) (144 primitiveShortAtPut) (145 primitiveConstantFill) "NOTE: When removing the obsolete indexed primitives, the following two should go become #primitiveIntegerAt / atPut" (146 primitiveFail) "primitiveReadJoystick" (147 primitiveFail) "primitiveWarpBits" (148 primitiveClone) (149 primitiveGetAttribute) "File Primitives (150-169) - NO LONGER INDEXED" (150 159 primitiveFail) (160 primitiveAdoptInstance) (161 primitiveArrayBecomeOneWayForceImmutables) (162 primitiveArrayBecomeForceImmutables) (163 primitiveGetImmutability) (164 primitiveSetImmutability) (165 primitiveIntegerAt) "hacked in here for now" (166 primitiveIntegerAtPut) (167 primitiveYield) (168 primitiveCopyObject) + (169 primitiveNotIdentical) - (169 primitiveFail) "Sound Primitives (170-199) - NO LONGER INDEXED" (170 185 primitiveFail) "Old closure primitives" (186 primitiveFail) "was primitiveClosureValue" (187 primitiveFail) "was primitiveClosureValueWithArgs" "Perform method directly" (188 primitiveExecuteMethodArgsArray) (189 primitiveExecuteMethod) "Sound Primitives (continued) - NO LONGER INDEXED" (190 194 primitiveFail) "Unwind primitives" (195 primitiveFindNextUnwindContext) (196 primitiveTerminateTo) (197 primitiveFindHandlerContext) (198 primitiveMarkUnwindMethod) (199 primitiveMarkHandlerMethod) "new closure primitives (were Networking primitives)" (200 primitiveClosureCopyWithCopiedValues) (201 primitiveClosureValue) "value" (202 primitiveClosureValue) "value:" (203 primitiveClosureValue) "value:value:" (204 primitiveClosureValue) "value:value:value:" (205 primitiveClosureValue) "value:value:value:value:" (206 primitiveClosureValueWithArgs) "valueWithArguments:" (207 209 primitiveFail) "reserved for Cog primitives" (210 primitiveAt) "Compatibility with Cog StackInterpreter Context primitives" (211 primitiveAtPut) "Compatibility with Cog StackInterpreter Context primitives" (212 primitiveSize) "Compatibility with Cog StackInterpreter Context primitives" (213 219 primitiveFail) "reserved for Cog primitives" (220 primitiveFail) "reserved for Cog primitives" (221 primitiveClosureValueNoContextSwitch) "valueNoContextSwitch" (222 primitiveClosureValueNoContextSwitch) "valueNoContextSwitch:" (223 225 primitiveFail) "reserved for Cog primitives" "Newsqueak debug primitives" (226 primitiveHeaderWords) "Used to encode protected access" (227 primitiveFail) "Other Primitives (228-249)" (228 primitiveFail) (229 primitiveFail) (230 primitiveRelinquishProcessor) (231 primitiveForceDisplayUpdate) (232 primitiveFormPrint) (233 primitiveSetFullScreen) (234 primitiveFail) "primBitmapdecompressfromByteArrayat" (235 primitiveFail) "primStringcomparewithcollated" (236 primitiveFail) "primSampledSoundconvert8bitSignedFromto16Bit" (237 primitiveFail) "primBitmapcompresstoByteArray" (238 241 primitiveFail) "serial port primitives" (242 primitiveFail) (243 primitiveFail) "primStringtranslatefromtotable" (244 primitiveFail) "primStringfindFirstInStringinSetstartingAt" (245 primitiveFail) "primStringindexOfAsciiinStringstartingAt" (246 primitiveFail) "primStringfindSubstringinstartingAtmatchTable" (247 primitiveSnapshotEmbedded) (248 primitiveInvokeObjectAsMethod) (249 primitiveArrayBecomeOneWayCopyHash) "VM Implementor Primitives (250-255)" (250 primitiveClearVMProfile) (251 primitiveControlVMProfiling "primitiveStartVMProfiling") (252 primitiveVMProfileSamplesInto "primitiveStopVMProfiling") (253 primitiveFail "N.B. primitiveCollectCogCodeConstituents in CoInterpreter below") (254 primitiveVMParameter) (255 primitiveFail) "Quick Push Const Methods" (256 nil) "primitivePushSelf" (257 nil) "primitivePushTrue" (258 nil) "primitivePushFalse" (259 nil) "primitivePushNil" (260 nil) "primitivePushMinusOne" (261 nil) "primitivePushZero" (262 nil) "primitivePushOne" (263 nil) "primitivePushTwo" "Quick Push Const Methods" (264 519 nil) "primitiveLoadInstVar" (520 primitiveFail) "MIDI Primitives (521-539) - NO LONGER INDEXED" (521 529 primitiveFail) (530 539 primitiveFail) "reserved for extended MIDI primitives" "Experimental Asynchrous File Primitives - NO LONGER INDEXED" (540 545 primitiveFail) "Used to encode private access" (546 primitiveFail) (547 primitiveFail) "Pen Tablet Primitives - NO LONGER INDEXED" (548 549 primitiveFail) "Sound Codec Primitives - NO LONGER INDEXED" (550 569 primitiveFail) "External primitive support primitives" (570 primitiveFlushExternalPrimitives) (571 primitiveUnloadModule) (572 primitiveListBuiltinModule) (573 primitiveListExternalModule) (574 primitiveFail) "reserved for addl. external support prims" "Unassigned Primitives" (575 primitiveFail)). ! Item was changed: ----- Method: NewspeakInterpreter>>allocateMemory:minimum:imageFile:headerSize: (in category 'as yet unclassified') ----- allocateMemory: heapSize minimum: minimumMemory imageFile: fileStream headerSize: headerSize "Translate to C function call with (case sensitive) camelCase. The purpose of this method is to document the translation. The default implementation is sqAllocateMemory(minimumMemory, heapSize). This may be redefined to make use of the image file and header size parameters for efficient implementation with mmap(). See CCodeGenerator>>writeDefaultMacrosOn: which specifies a default implementation." + <inline: true> + <returnTypeC: #'char *'> + <var: #fileStream type: #sqImageFile> - self inline: true. - self returnTypeC: 'char *'. - self var: #fileStream type: 'sqImageFile'. ^ self allocateMemory: heapSize Minimum: minimumMemory ImageFile: fileStream + HeaderSize: headerSize! - HeaderSize: headerSize - ! Item was removed: - ----- Method: NewspeakInterpreter>>assertClassOf:is:compactClassIndex: (in category 'utilities') ----- - assertClassOf: oop is: classOop compactClassIndex: compactClassIndex - "Succeed if the oop is an instance of the given class. Fail if the object is an integer. - If the class has a (non-zero) compactClassIndex use that to speed up the check. - N.B. Inlining should result in classOop not being accessed if compactClassIndex - is non-zero." - - <inline: true> - self success: (self is: oop instanceOf: classOop compactClassIndex: compactClassIndex)! Item was changed: ----- Method: NewspeakInterpreter>>bytecodePrimMultiply (in category 'common selector sends') ----- bytecodePrimMultiply | rcvr arg result | rcvr := self internalStackValue: 1. arg := self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [rcvr := self integerValueOf: rcvr. arg := self integerValueOf: arg. result := rcvr * arg. + (arg = 0 + or: [(result // arg) = rcvr and: [self isIntegerValue: result]]) ifTrue: + [self internalPop: 2 thenPush: (self integerObjectOf: result). + ^self fetchNextBytecode "success"]] - ((arg = 0 or: [(result // arg) = rcvr]) and: [self isIntegerValue: result]) - ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: result). - ^ self fetchNextBytecode "success"]] ifFalse: [self initPrimCall. self externalizeIPandSP. self primitiveFloatMultiply: rcvr byArg: arg. self internalizeIPandSP. self successful ifTrue: [^ self fetchNextBytecode "success"]]. messageSelector := self specialSelector: 8. argumentCount := 1. self normalSend. ! Item was changed: ----- Method: NewspeakInterpreter>>commonVariable:at:cacheIndex: (in category 'indexing primitive support') ----- commonVariable: rcvr at: index cacheIndex: atIx "This code assumes the receiver has been identified at location atIx in the atCache." | stSize fmt fixedFields result | stSize := atCache at: atIx+AtCacheSize. ((self cCoerce: index to: 'usqInt ') >= 1 and: [(self cCoerce: index to: 'usqInt ') <= (self cCoerce: stSize to: 'usqInt ')]) 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 fetchLong32: 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 primitiveFailFor: ((self formatOf: rcvr) <= 1 + ifTrue: [PrimErrBadReceiver] + ifFalse: [PrimErrBadIndex])! - self primitiveFailFor: PrimErrBadIndex! Item was changed: ----- Method: NewspeakInterpreter>>commonVariable:at:put:cacheIndex: (in category 'indexing primitive support') ----- commonVariable: rcvr at: index put: value cacheIndex: atIx "This code assumes the receiver has been identified at location atIx in the atCache." "It also assumes that all immutability checking has been done by the caller." | stSize fmt fixedFields valToPut | <inline: true> stSize := atCache at: atIx+AtCacheSize. ((self cCoerce: index to: 'usqInt ') >= 1 and: [(self cCoerce: index to: 'usqInt ') <= (self cCoerce: stSize to: 'usqInt ')]) ifTrue: [fmt := atCache at: atIx+AtCacheFmt. fmt <= 4 ifTrue: [fixedFields := atCache at: atIx+AtCacheFixedFields. ^ self storePointer: index + fixedFields - 1 ofObject: rcvr withValue: value]. fmt < 8 ifTrue: "Bitmap" [valToPut := self positive32BitValueOf: value. self successful ifTrue: [^self storeLong32: index - 1 ofObject: rcvr withValue: valToPut]. ^ self primitiveFailFor: PrimErrBadArgument]. fmt >= 16 "Note fmt >= 16 is an artificial flag for strings" ifTrue: [valToPut := self asciiOfCharacter: value. self successful ifFalse: [^ self primitiveFailFor: PrimErrBadArgument]] ifFalse: [valToPut := value]. (self isIntegerObject: valToPut) ifTrue: [valToPut := self integerValueOf: valToPut. ((valToPut >= 0) and: [valToPut <= 255]) ifFalse: [^ self primitiveFailFor: PrimErrBadArgument]. ^ self storeByte: index - 1 ofObject: rcvr withValue: valToPut]. ^self primitiveFailFor: PrimErrInappropriate]. + ^self primitiveFailFor: ((self formatOf: rcvr) <= 1 + ifTrue: [PrimErrBadReceiver] + ifFalse: [PrimErrBadIndex])! - self primitiveFailFor: PrimErrBadIndex! Item was changed: ----- Method: NewspeakInterpreter>>floatArg: (in category 'plugin primitive support') ----- floatArg: index "Like #stackFloatValue: but access method arguments left-to-right" + | oop | - | result oop | <returnTypeC: #double> - <var: #result type: #double> oop := self methodArg: index. oop = 0 ifTrue:[^0.0]. "methodArg: failed" + ^self floatValueOf: oop! - "N.B. Because Slang always inlines isClassOfNonImm:equalTo:compactClassIndex: - (because isClassOfNonImm:equalTo:compactClassIndex: has an inline: pragma) the - phrase (self splObj: ClassArray) is expanded in-place and is _not_ evaluated if - ClassArrayCompactIndex is non-zero." - (self isClassOfNonImm: oop equalTo: (self splObj: ClassFloat) compactClassIndex: ClassFloatCompactIndex) ifTrue: - [self cCode: '' inSmalltalk: [result := Float new: 2]. - self fetchFloatAt: oop + BaseHeaderSize into: result. - ^result]. - self primitiveFail. - ^0.0! Item was changed: ----- Method: NewspeakInterpreter>>floatValueOf: (in category 'utilities') ----- floatValueOf: oop + "Fetch the instance variable at the given index of the given object. Answer the C + double precision floating point value of that instance variable, or fail if it is not a Float." - "Fetch the instance variable at the given index of the given object. Return the - C double precision floating point value of that object, or fail if it is not a Float." + | isFloat result | - | result | <returnTypeC: #double> <var: #result type: #double> + "N.B. Because Slang always inlines is:instanceOf:compactClassIndex: + (because is:instanceOf:compactClassIndex: has an inline: pragma) the + phrase (self splObj: ClassArray) is expanded in-place and is _not_ evaluated if + ClassArrayCompactIndex is non-zero." + isFloat := self + is: oop + instanceOf: (self splObj: ClassFloat) + compactClassIndex: ClassFloatCompactIndex. + isFloat ifTrue: + [self cCode: '' inSmalltalk: [result := Float new: 2]. + self fetchFloatAt: oop + BaseHeaderSize into: result. + ^result]. + self primitiveFail. + ^0.0! - self flag: #Dan. "None of the float stuff has been converted for 64 bits" - "N.B. Because Slang always inlines assertClassOf:is:compactClassIndex: - (because assertClassOf:is:compactClassIndex: has an inline: pragma) the - phrase (self splObj: ClassArray) is expanded in-place and is _not_ - evaluated if ClassArrayCompactIndex is non-zero." - (self is: oop - instanceOf: (self splObj: ClassFloat) - compactClassIndex: ClassFloatCompactIndex) - ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2]. - self fetchFloatAt: oop + BaseHeaderSize into: result. - ^result] - ifFalse: - [self primitiveFail. - ^0.0]! Item was changed: ----- Method: NewspeakInterpreter>>initializeExtraClassInstVarIndices (in category 'initialization') ----- initializeExtraClassInstVarIndices "Initialize metaclassSizeBytes and thisClassIndex which are used in debug printing, and classNameIndex which is used not only for debug printing but for is:KindOf: & is:MemberOf: via classNameOf:is: (evil but a reality we have to accept)." | classArrayObj classArrayClass | classNameIndex := 6. "default" thisClassIndex := 5. "default" classArrayObj := self splObj: ClassArray. classArrayClass := self fetchClassOfNonInt: classArrayObj. metaclassSizeBytes := self sizeBitsOf: classArrayClass. "determine actual (Metaclass instSize * 4)" InstanceSpecificationIndex + 1 to: (self lengthOf: classArrayClass) do: [:i| (self fetchPointer: i ofObject: classArrayClass) = classArrayObj ifTrue: [thisClassIndex := i]]. InstanceSpecificationIndex + 1 to: (self lengthOf: classArrayObj) do: [:i| | oop | oop := self fetchPointer: i ofObject: classArrayObj. ((self isBytes: oop) and: [(self lengthOf: oop) = 5 + and: [(self str: 'Array' n: (self firstFixedField: oop) cmp: 5) = 0]]) ifTrue: - and: [(self str: #Array n: (self firstFixedField: oop) cmp: 5) = 0]]) ifTrue: [classNameIndex := i]]! Item was changed: ----- Method: NewspeakInterpreter>>loadFloatOrIntFrom: (in category 'utilities') ----- 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 primErrorCode non-zero." - If it is a Float, then load its value and return it. - Otherwise fail -- ie return with primErrorCode non-zero." - | result | <inline: true> <asmLabel: false> <returnTypeC: #double> - <var: #result type: #double> (self isIntegerObject: floatOrInt) ifTrue: [^(self integerValueOf: floatOrInt) asFloat]. + ^self floatValueOf: floatOrInt! - self assertClassOf: floatOrInt - is: (self splObj: ClassFloat) - compactClassIndex: ClassFloatCompactIndex. - self cCode: '' inSmalltalk: [result := Float new: 2]. - self successful ifTrue: - [self fetchFloatAt: floatOrInt + BaseHeaderSize into: result]. - ^result! Item was changed: ----- Method: NewspeakInterpreter>>popFloat (in category 'stack bytecodes') ----- popFloat + <returnTypeC: #double> + ^self floatValueOf: self popStack! - "Note: May be called by translated primitive code." - - | top result | - <returnTypeC: 'double'> - <var: #result type: 'double '> - top := self popStack. - self assertClassOf: top is: (self splObj: ClassFloat). - self successful ifTrue: - [self cCode: '' inSmalltalk: [result := Float new: 2]. - self fetchFloatAt: top + BaseHeaderSize into: result]. - ^ result! Item was added: + ----- Method: NewspeakInterpreter>>primitiveNotIdentical (in category 'object access primitives') ----- + primitiveNotIdentical + "is the receiver/first argument not the same object as the (last) argument?. + pop argumentCount because this can be used as a mirror primitive." + | thisObject otherObject | + otherObject := self stackValue: 1. + thisObject := self stackTop. + self pop: argumentCount + 1 thenPushBool: thisObject ~= otherObject! Item was changed: ----- Method: NewspeakInterpreter>>printContext: (in category 'debug printing') ----- printContext: aContext | sender ip sp na spc | <api> <inline: false> self shortPrintContext: aContext. sender := self fetchPointer: SenderIndex ofObject: aContext. ip := self fetchPointer: InstructionPointerIndex ofObject: aContext. self print: 'sender '; shortPrintOop: sender. + self print: 'ip '; printNum: ip; print: ' ('; printNum: (self integerValueOf: ip); space; printHex: (self integerValueOf: ip); printChar: $); cr. - self print: 'ip '; printNum: ip; print: ' ('; printNum: (self integerValueOf: ip); printHex: (self integerValueOf: ip); printChar: $); cr. sp := self fetchPointer: StackPointerIndex ofObject: aContext. self print: 'sp '; printNum: sp; print: ' ('; printNum: (self integerValueOf: sp); printChar: $); cr. (self isMethodContext: aContext) ifTrue: [self print: 'method '; shortPrintOop: (self fetchPointer: MethodIndex ofObject: aContext). self print: 'closure '; shortPrintOop: (self fetchPointer: ClosureIndex ofObject: aContext). self print: 'receiver '; shortPrintOop: (self fetchPointer: ReceiverIndex ofObject: aContext)] ifFalse: [na := self fetchPointer: BlockArgumentCountIndex ofObject: aContext. self print: 'numargs '; printNum: na; print: ' ('; printNum: (self integerValueOf: na); printChar: $); cr. spc := self fetchPointer: InitialIPIndex ofObject: aContext. self print: 'startpc '; printNum: spc; print: ' ('; printNum: (self integerValueOf: spc); printChar: $); cr. self print: 'home '; shortPrintOop: (self fetchPointer: HomeIndex ofObject: aContext)]. sp := self integerValueOf: sp. sp := sp min: (self lengthOf: aContext) - ReceiverIndex. 1 to: sp do: [:i| self print: ' '; printNum: i; space; shortPrintOop: (self fetchPointer: ReceiverIndex + i ofObject: aContext)]! Item was changed: ----- Method: NewspeakInterpreter>>printContext:WithSP: (in category 'debug printing') ----- printContext: aContext WithSP: theSP | sender ip na spc sp | <api> <inline: false> self shortPrintContext: aContext. sender := self fetchPointer: SenderIndex ofObject: aContext. ip := self fetchPointer: InstructionPointerIndex ofObject: aContext. sp := self integerObjectOf: (self stackPointerIndexFor: theSP context: aContext) - ReceiverIndex. self print: 'sender '; shortPrintOop: sender. + self print: 'ip '; printNum: ip; print: ' ('; printNum: (self integerValueOf: ip); space; printHex: (self integerValueOf: ip); printChar: $); cr. - self print: 'ip '; printNum: ip; print: ' ('; printNum: (self integerValueOf: ip); printHex: (self integerValueOf: ip); printChar: $); cr. self print: 'sp '; printNum: sp; print: ' ('; printNum: (self integerValueOf: sp); printChar: $); cr. (self isMethodContext: aContext) ifTrue: [self print: 'method '; shortPrintOop: (self fetchPointer: MethodIndex ofObject: aContext). self print: 'closure '; shortPrintOop: (self fetchPointer: ClosureIndex ofObject: aContext). self print: 'receiver '; shortPrintOop: (self fetchPointer: ReceiverIndex ofObject: aContext)] ifFalse: [na := self fetchPointer: BlockArgumentCountIndex ofObject: aContext. self print: 'numargs '; printNum: na; print: ' ('; printNum: (self integerValueOf: na); printChar: $); cr. spc := self fetchPointer: InitialIPIndex ofObject: aContext. self print: 'startpc '; printNum: spc; print: ' ('; printNum: (self integerValueOf: spc); printChar: $); cr. self print: 'home '; shortPrintOop: (self fetchPointer: HomeIndex ofObject: aContext)]. sp := self integerValueOf: sp. sp := sp min: (self lengthOf: aContext) - ReceiverIndex. 1 to: sp do: [:i| self print: ' '; printNum: i; space; shortPrintOop: (self fetchPointer: ReceiverIndex + i ofObject: aContext)]! Item was changed: ----- Method: NewspeakInterpreter>>stObject:at: (in category 'indexing primitive support') ----- stObject: array at: index "Return what ST would return for <obj> at: index." | hdr fmt totalLength fixedFields stSize | <inline: false> hdr := self baseHeader: array. + fmt := self formatOfHeader: hdr. - fmt := (hdr >> 8) bitAnd: 16rF. totalLength := self lengthOf: array baseHeader: hdr format: fmt. fixedFields := self fixedFieldsOf: array format: fmt length: totalLength. (fmt = 3 and: [self isContextHeader: hdr]) ifTrue: [stSize := self fetchStackPointerOf: array] ifFalse: [stSize := totalLength - fixedFields]. + ((self oop: index isGreaterThanOrEqualTo: 1) + and: [self oop: index isLessThanOrEqualTo: stSize]) ifTrue: + [^self subscript: array with: (index + fixedFields) format: fmt]. + self primitiveFailFor: (fmt <= 1 ifTrue: [PrimErrBadReceiver] ifFalse: [PrimErrBadIndex]). + ^0! - ((self cCoerce: index to: 'usqInt ') >= 1 - and: [(self cCoerce: index to: 'usqInt ') <= (self cCoerce: stSize to: 'usqInt ')]) - ifTrue: [^ self subscript: array with: (index + fixedFields) format: fmt] - ifFalse: [self primitiveFailFor: PrimErrBadIndex. ^ 0].! Item was changed: ----- Method: NewspeakInterpreter>>stObject:at:put: (in category 'indexing primitive support') ----- stObject: array at: index put: value "Do what ST would return for <obj> at: index put: value." | hdr fmt totalLength fixedFields stSize | <inline: false> hdr := self baseHeader: array. + fmt := self formatOfHeader: hdr. - fmt := (hdr >> 8) bitAnd: 16rF. totalLength := self lengthOf: array baseHeader: hdr format: fmt. fixedFields := self fixedFieldsOf: array format: fmt length: totalLength. (fmt = 3 and: [self isContextHeader: hdr]) ifTrue: [stSize := self fetchStackPointerOf: array] ifFalse: [stSize := totalLength - fixedFields]. + ((self oop: index isGreaterThanOrEqualTo: 1) + and: [self oop: index isLessThanOrEqualTo: stSize]) - ((self cCoerce: index to: 'usqInt ') >= 1 - and: [(self cCoerce: index to: 'usqInt ') <= (self cCoerce: stSize to: 'usqInt ')]) ifTrue: [self subscript: array with: (index + fixedFields) storing: value format: fmt] + ifFalse: [self primitiveFailFor: (fmt <= 1 ifTrue: [PrimErrBadReceiver] ifFalse: [PrimErrBadIndex])]! - ifFalse: [self primitiveFailFor: PrimErrBadIndex]! Item was changed: ----- Method: NewspeakInterpreter>>stackFloatValue: (in category 'internal interpreter access') ----- stackFloatValue: offset + <returnTypeC: #double> + ^self floatValueOf: (self longAt: stackPointer - (offset*BytesPerWord))! - "Note: May be called by translated primitive code." - | result floatPointer | - <returnTypeC: 'double'> - <var: #result type: 'double '> - floatPointer := self longAt: stackPointer - (offset*BytesPerWord). - (self fetchClassOf: floatPointer) = (self splObj: ClassFloat) - ifFalse:[self primitiveFail. ^0.0]. - self cCode: '' inSmalltalk: [result := Float new: 2]. - self fetchFloatAt: floatPointer + BaseHeaderSize into: result. - ^ result! Item was removed: - ----- Method: NewspeakInterpreter>>sufficientSpaceToInstantiate:indexableSize: (in category 'object access primitives') ----- - sufficientSpaceToInstantiate: classOop indexableSize: size - "Return the number of bytes required to allocate an instance of the given class with the given number of indexable fields." - "Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line." - | format atomSize| - <inline: true> - format := (self formatOfClass: classOop) >> 8 bitAnd: 15. - - "fail if attempting to call new: on non-indexable class" - ((self cCoerce: size to: 'usqInt ') > 0 and: [format < 2]) - ifTrue: [^ false]. - - format < 8 - ifTrue: ["indexable fields are words or pointers" atomSize := BytesPerWord] - ifFalse: ["indexable fields are bytes" atomSize := 1]. - ^self sufficientSpaceToAllocate: 2500 + (size * atomSize)! Item was changed: VMClass subclass: #ObjectMemory instanceVariableNames: 'memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop rootTable rootTableCount extraRoots extraRootCount weakRoots weakRootCount child field parentField freeBlock lastHash allocationCount lowSpaceThreshold signalLowSpace compStart compEnd fwdTableNext fwdTableLast remapBuffer remapBufferCount allocationsBetweenGCs tenuringThreshold gcBiasToGrow gcBiasToGrowGCLimit gcBiasToGrowThreshold statFullGCs statIncrGCs statFullGCUsecs statIncrGCUsecs statGCEndTime statIGCDeltaUsecs statTenures statRootTableOverflows freeContexts freeLargeContexts interruptCheckCounter totalObjectCount shrinkThreshold growHeadroom headerTypeBytes youngStartLocal statMarkCount statMarkCountLocal statSweepCount statMkFwdCount statCompMoveCount statGrowMemory statShrinkMemory statRootTableCount statAllocationCount statSurvivorCount statSpecialMarkCount forceTenureFlag gcStartUsecs' + classVariableNames: 'AllButHashBits AllButImmutabilityBit AllButMarkBit AllButMarkBitAndTypeMask AllButRootBit Done ExtraRootSize GCTopMarker HashBits HeaderTypeClass HeaderTypeExtraBytes HeaderTypeFree HeaderTypeGC LongSizeNumBits NilContext RemapBufferSize RootTableRedZone RootTableSize StartField StartObj Upward WeakRootTableSize WordMask' - classVariableNames: 'AllButHashBits AllButImmutabilityBit AllButMarkBit AllButMarkBitAndTypeMask AllButRootBit Done ExtraRootSize GCTopMarker HashBits HeaderTypeClass HeaderTypeExtraBytes HeaderTypeFree HeaderTypeGC NilContext RemapBufferSize RootTableRedZone RootTableSize StartField StartObj Upward WeakRootTableSize WordMask' poolDictionaries: 'VMBasicConstants VMObjectIndices VMSqueakV3BytecodeConstants VMSqueakV3ObjectRepresentationConstants' category: 'VMMaker-Interpreter'! !ObjectMemory commentStamp: '<historical>' prior: 0! This class describes a 32-bit direct-pointer object memory for Smalltalk. The model is very simple in principle: a pointer is either a SmallInteger or a 32-bit direct object pointer. SmallIntegers are tagged with a low-order bit equal to 1, and an immediate 31-bit 2s-complement signed value in the rest of the word. All object pointers point to a header, which may be followed by a number of data fields. This object memory achieves considerable compactness by using a variable header size (the one complexity of the design). The format of the 0th header word is as follows: 3 bits reserved for gc (mark, root, unused) 12 bits object hash (for HashSets) 5 bits compact class index 4 bits object format 6 bits object size in 32-bit words 2 bits header type (0: 3-word, 1: 2-word, 2: forbidden, 3: 1-word) If a class is in the compact class table, then this is the only header information needed. If it is not, then it will have another header word at offset -4 bytes with its class in the high 30 bits, and the header type repeated in its low 2 bits. It the objects size is greater than 255 bytes, then it will have yet another header word at offset -8 bytes with its full word size in the high 30 bits and its header type repeated in the low two bits. The object format field provides the remaining information as given in the formatOf: method (including isPointers, isVariable, isBytes, and the low 2 size bits of byte-sized objects). This implementation includes incremental (2-generation) and full garbage collection, each with compaction and rectification of direct pointers. It also supports a bulk-become (exchange object identity) feature that allows many objects to be becomed at once, as when all instances of a class must be grown or shrunk. There is now a simple 64-bit version of the object memory. It is the simplest possible change that could work. It merely sign-extends all integer oops, and extends all object headers and oops by adding 32 zeroes in the high bits. The format of the base header word is changed in one minor, not especially elegant, way. Consider the old 32-bit header: ggghhhhhhhhhhhhcccccffffsssssstt The 64-bit header is almost identical, except that the size field (now being in units of 8 bytes, has a zero in its low-order bit. At the same time, the byte-size residue bits for byte objects, which are in the low order bits of formats 8-11 and 12-15, are now in need of another bit of residue. So, the change is as follows: ggghhhhhhhhhhhhcccccffffsssssrtt where bit r supplies the 4's bit of the byte size residue for byte objects. Oh, yes, this is also needed now for 'variableWord' objects, since their size in 32-bit words requires a low-order bit. See the comment in formatOf: for the change allowing for 64-bit wide bitmaps, now dubbed 'variableLong'.! Item was changed: ----- Method: ObjectMemory class>>initializeObjectHeaderConstants (in category 'initialization') ----- initializeObjectHeaderConstants BytesPerWord ifNil: [BytesPerWord := 4]. "May get called on fileIn, so supply default" BaseHeaderSize := BytesPerWord. WordMask := (1 bitShift: BytesPerWord*8) - 1. "masks for type field" TypeMask := 3. AllButTypeMask := WordMask - TypeMask. "type field values" HeaderTypeSizeAndClass := 0. HeaderTypeClass := 1. HeaderTypeFree := 2. HeaderTypeShort := 3. HeaderTypeExtraBytes := { BytesPerWord * 2. BytesPerWord. 0. 0 }. "type field values used during the mark phase of GC" HeaderTypeGC := 2. GCTopMarker := 3. "neither an oop, nor an oop+1, this value signals that we have crawled back up to the top of the marking phase." "Base header word bit fields" HashBits := 16r1FFE0000. HashBitsOffset := 17. HashMaskUnshifted := 16rFFF. self assert: (HashMaskUnshifted bitShift: HashBitsOffset) = HashBits. AllButHashBits := WordMask - HashBits. SizeMask := 16rFC. Size4Bit := 0. BytesPerWord = 8 ifTrue: [SizeMask := 16rF8. "Lose the 4 bit in temp 64-bit chunk format" Size4Bit := 4]. "But need it for ST size" "Note SizeMask + Size4Bit gives the mask needed for size fits of format word in classes. This is used in instantiateClass:indexableSize: " LongSizeMask := WordMask - 16rFF + SizeMask. + LongSizeNumBits := 30. "30 bits of size info in long size filed." CompactClassMask := 16r1F000. "masks for root and mark bits" MarkBit := 1 bitShift: BytesPerWord*8 - 1. "Top bit" RootBit := 1 bitShift: BytesPerWord*8 - 2. "Next-to-Top bit" AllButMarkBit := WordMask - MarkBit. AllButRootBit := WordMask - RootBit. AllButMarkBitAndTypeMask := AllButTypeMask - MarkBit. ImmutabilityBit := 1 bitShift: BytesPerWord*8 - 3. "Next-to-Next-To-Top bit" AllButImmutabilityBit := WordMask - ImmutabilityBit! Item was changed: ----- Method: ObjectMemory>>compactClassAt: (in category 'interpreter access') ----- compactClassAt: ccIndex + "Index must be between 1 and compactClassArray size. A zero compact class + index in the base header indicate that the class is in the class header word." - "Index must be between 1 and compactClassArray size. (A zero compact class index in the base header indicate that the class is in the class header word.)" <api> + | classesArray | + classesArray := self fetchPointer: CompactClasses ofObject: self specialObjectsOop. + ^self fetchPointer: ccIndex - 1 ofObject: classesArray! - | classArray | - classArray := self fetchPointer: CompactClasses ofObject: self specialObjectsOop. - ^self fetchPointer: (ccIndex - 1) ofObject: classArray! Item was added: + ----- Method: ObjectMemory>>instSpecOfClass: (in category 'object format') ----- + instSpecOfClass: classPointer + "This is the same as the field stored in every object header" + + ^self formatOfHeader: (self formatOfClass: classPointer)! Item was changed: ----- Method: ObjectMemory>>instantiateClass:indexableSize: (in category 'interpreter access') ----- instantiateClass: classPointer indexableSize: size "NOTE: This method supports the backward-compatible split instSize field of the class format word. The sizeHiBits will go away and other shifts change by 2 when the split fields get merged in an (incompatible) image change." <api> | hash header1 header2 cClass byteSize format binc header3 hdrSize newObj sizeHiBits bm1 classFormat | <inline: false> self assert: size >= 0. "'cannot have a negative indexable field count" hash := self newObjectHash. classFormat := self formatOfClass: classPointer. "Low 2 bits are 0" header1 := (classFormat bitAnd: 16r1FF00) bitOr: (hash bitAnd: HashMaskUnshifted) << HashBitsOffset. header2 := classPointer. header3 := 0. sizeHiBits := (classFormat bitAnd: 16r60000) >> 9. cClass := header1 bitAnd: CompactClassMask. "compact class field from format word" byteSize := (classFormat bitAnd: SizeMask + Size4Bit) + sizeHiBits. "size in bytes -- low 2 bits are 0" "Note this byteSize comes from the format word of the class which is pre-shifted to 4 bytes per field. Need another shift for 8 bytes per word..." byteSize := byteSize << (ShiftForWord-2). + format := self formatOfHeader: classFormat. - format := classFormat >> 8 bitAnd: 15. self flag: #sizeLowBits. format < 8 ifTrue: [format = 6 ifTrue: ["long32 bitmaps" bm1 := BytesPerWord-1. byteSize := byteSize + (size * 4) + bm1 bitAnd: LongSizeMask. "round up" binc := bm1 - ((size * 4) + bm1 bitAnd: bm1). "odd bytes" "extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)" header1 := header1 bitOr: (binc bitAnd: 4)] ifFalse: [byteSize := byteSize + (size * BytesPerWord) "Arrays and 64-bit bitmaps"]] ifFalse: ["Strings and Methods" bm1 := BytesPerWord-1. byteSize := byteSize + size + bm1 bitAnd: LongSizeMask. "round up" binc := bm1 - (size + bm1 bitAnd: bm1). "odd bytes" "low bits of byte size go in format field" header1 := header1 bitOr: (binc bitAnd: 3) << 8. "extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)" header1 := header1 bitOr: (binc bitAnd: 4)]. byteSize > 255 ifTrue: ["requires size header word" header3 := byteSize. header1 := header1] ifFalse: [header1 := header1 bitOr: byteSize]. hdrSize := header3 > 0 ifTrue: [3 "requires full header"] ifFalse: [cClass = 0 ifTrue: [2] ifFalse: [1]]. newObj := self allocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3 doFill: true format: format. ^ newObj! Item was added: + ----- Method: ObjectMemory>>isContextNonInt: (in category 'contexts') ----- + isContextNonInt: oop + <inline: true> + ^self isContextHeader: (self baseHeader: oop)! Item was changed: ----- Method: ObjectMemory>>shorten:toIndexableSize: (in category 'allocation') ----- shorten: obj toIndexableSize: nSlots "Currently this works for pointer objects only, and is almost certainly wrong for 64 bits." | deltaBytes desiredLength fixedFields fmt hdr totalLength | (self isPointers: obj) ifFalse: [^obj]. hdr := self baseHeader: obj. + fmt := self formatOfHeader: hdr. - fmt := (hdr >> 8) bitAnd: 16rF. totalLength := self lengthOf: obj baseHeader: hdr format: fmt. fixedFields := self fixedFieldsOf: obj format: fmt length: totalLength. desiredLength := fixedFields + nSlots. deltaBytes := (totalLength - desiredLength) * BytesPerWord. self setSizeOfFree: obj + BaseHeaderSize + (desiredLength * BytesPerWord) to: deltaBytes. (self headerType: obj) caseOf: { [HeaderTypeSizeAndClass] -> [self longAt: obj put: hdr - deltaBytes]. [HeaderTypeClass] -> [self longAt: obj put: ((hdr bitClear: SizeMask) bitOr: (hdr bitAnd: SizeMask) - deltaBytes)]. [HeaderTypeShort] -> [self longAt: obj put: ((hdr bitClear: SizeMask) bitOr: (hdr bitAnd: SizeMask) - deltaBytes)] }. ^obj! Item was added: + ----- Method: ObjectMemory>>sufficientSpaceToInstantiate:indexableSize: (in category 'allocation') ----- + sufficientSpaceToInstantiate: classOop indexableSize: size + "Return the number of bytes required to allocate an instance of the given class with the given number of indexable fields." + "Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line." + <var: #size type: #usqInt> + | format allocSize | + <inline: true> + (format := self instSpecOfClass: classOop) < 8 + ifTrue: + ["indexable fields are words or pointers" + size ~= 0 ifTrue: + ["fail if attempting to call new: on non-indexable class" + format < 2 ifTrue: + [^false]. + "fail if attempting to allocate over 2 Gb, since this overflows 32-bit arithmetic" + size >> (LongSizeNumBits - BytesPerWord) > 0 ifTrue: + [^false]]. + allocSize := size * BytesPerWord] + ifFalse: + ["indexable fields are bytes" + "fail if attempting to allocate over 2 Gb, since this overflows 32-bit arithmetic" + size >> LongSizeNumBits > 0 ifTrue: + [^false]. + allocSize := size]. + ^self sufficientSpaceToAllocate: 2500 + allocSize! Item was changed: ----- Method: SimpleStackBasedCogit class>>initializePrimitiveTableForSqueakV3 (in category 'class initialization') ----- initializePrimitiveTableForSqueakV3 "Initialize the table of primitive generators. This does not include normal primitives implemened in the coInterpreter." "SimpleStackBasedCogit initializePrimitiveTableForSqueakV3" MaxCompiledPrimitiveIndex := 222. primitiveTable := CArrayAccessor on: (Array new: MaxCompiledPrimitiveIndex + 1). self table: primitiveTable from: #( "Integer Primitives (0-19)" (1 genPrimitiveAdd 1) (2 genPrimitiveSubtract 1) (3 genPrimitiveLessThan 1) (4 genPrimitiveGreaterThan 1) (5 genPrimitiveLessOrEqual 1) (6 genPrimitiveGreaterOrEqual 1) (7 genPrimitiveEqual 1) (8 genPrimitiveNotEqual 1) (9 genPrimitiveMultiply 1 processorHasMultiply:) (10 genPrimitiveDivide 1 processorHasDivQuoRem:) (11 genPrimitiveMod 1 processorHasDivQuoRem:) (12 genPrimitiveDiv 1 processorHasDivQuoRem:) (13 genPrimitiveQuo 1 processorHasDivQuoRem:) (14 genPrimitiveBitAnd 1) (15 genPrimitiveBitOr 1) (16 genPrimitiveBitXor 1) (17 genPrimitiveBitShift 1) "(18 primitiveMakePoint)" "(19 primitiveFail)" "Guard primitive for simulation -- *must* fail" "LargeInteger Primitives (20-39)" "(20 primitiveFail)" "(21 primitiveAddLargeIntegers)" "(22 primitiveSubtractLargeIntegers)" "(23 primitiveLessThanLargeIntegers)" "(24 primitiveGreaterThanLargeIntegers)" "(25 primitiveLessOrEqualLargeIntegers)" "(26 primitiveGreaterOrEqualLargeIntegers)" "(27 primitiveEqualLargeIntegers)" "(28 primitiveNotEqualLargeIntegers)" "(29 primitiveMultiplyLargeIntegers)" "(30 primitiveDivideLargeIntegers)" "(31 primitiveModLargeIntegers)" "(32 primitiveDivLargeIntegers)" "(33 primitiveQuoLargeIntegers)" "(34 primitiveBitAndLargeIntegers)" "(35 primitiveBitOrLargeIntegers)" "(36 primitiveBitXorLargeIntegers)" "(37 primitiveBitShiftLargeIntegers)" "Float Primitives (38-59)" "(38 primitiveFloatAt)" "(39 primitiveFloatAtPut)" (40 genPrimitiveAsFloat 0 processorHasDoublePrecisionFloatingPointSupport:) (41 genPrimitiveFloatAdd 1 processorHasDoublePrecisionFloatingPointSupport:) (42 genPrimitiveFloatSubtract 1 processorHasDoublePrecisionFloatingPointSupport:) (43 genPrimitiveFloatLessThan 1 processorHasDoublePrecisionFloatingPointSupport:) (44 genPrimitiveFloatGreaterThan 1 processorHasDoublePrecisionFloatingPointSupport:) (45 genPrimitiveFloatLessOrEqual 1 processorHasDoublePrecisionFloatingPointSupport:) (46 genPrimitiveFloatGreaterOrEqual 1 processorHasDoublePrecisionFloatingPointSupport:) (47 genPrimitiveFloatEqual 1 processorHasDoublePrecisionFloatingPointSupport:) (48 genPrimitiveFloatNotEqual 1 processorHasDoublePrecisionFloatingPointSupport:) (49 genPrimitiveFloatMultiply 1 processorHasDoublePrecisionFloatingPointSupport:) (50 genPrimitiveFloatDivide 1 processorHasDoublePrecisionFloatingPointSupport:) "(51 primitiveTruncated)" "(52 primitiveFractionalPart)" "(53 primitiveExponent)" "(54 primitiveTimesTwoPower)" (55 genPrimitiveFloatSquareRoot 0 processorHasDoublePrecisionFloatingPointSupport:) "(56 primitiveSine)" "(57 primitiveArctan)" "(58 primitiveLogN)" "(59 primitiveExp)" "Subscript and Stream Primitives (60-67)" (60 genPrimitiveAt 1) "(61 primitiveAtPut)" (62 genPrimitiveSize 0) (63 genPrimitiveStringAt 1) "(64 primitiveStringAtPut)" "The stream primitives no longer pay their way; normal Smalltalk code is faster." "(65 primitiveFail)""was primitiveNext" "(66 primitiveFail)" "was primitiveNextPut" "(67 primitiveFail)" "was primitiveAtEnd" "StorageManagement Primitives (68-79)" "(68 primitiveObjectAt)" "(69 primitiveObjectAtPut)" "(70 primitiveNew)" "(71 primitiveNewWithArg)" "(72 primitiveArrayBecomeOneWay)" "Blue Book: primitiveBecome" "(73 primitiveInstVarAt)" "(74 primitiveInstVarAtPut)" (75 genPrimitiveIdentityHash 0) "(76 primitiveStoreStackp)" "Blue Book: primitiveAsObject" "(77 primitiveSomeInstance)" "(78 primitiveNextInstance)" "(79 primitiveNewMethod)" "Control Primitives (80-89)" "(80 primitiveFail)" "Blue Book: primitiveBlockCopy" "(81 primitiveFail)" "Blue Book: primitiveValue" "(82 primitiveFail)" "Blue Book: primitiveValueWithArgs" "(83 primitivePerform)" "(84 primitivePerformWithArgs)" "(85 primitiveSignal)" "(86 primitiveWait)" "(87 primitiveResume)" "(88 primitiveSuspend)" "(89 primitiveFlushCache)" "Input/Output Primitives (90-109); We won't compile any of these" "System Primitives (110-119)" (110 genPrimitiveEquivalent 1) "(111 genPrimitiveClass)" "(112 primitiveBytesLeft)" "(113 primitiveQuit)" "(114 primitiveExitToDebugger)" "(115 primitiveChangeClass)" "Blue Book: primitiveOopsLeft" "(116 primitiveFlushCacheByMethod)" "(117 primitiveExternalCall)" "(118 primitiveDoPrimitiveWithArgs)" "(119 primitiveFlushCacheSelective)" "Squeak 2.2 and earlier use 119. Squeak 2.3 and later use 116. Both are supported for backward compatibility." "Miscellaneous Primitives (120-127); We won't compile any of these" "Squeak Primitives Start Here" "Squeak Miscellaneous Primitives (128-149); We won't compile any of these" "File Primitives (150-169) - NO LONGER INDEXED; We won't compile any of these" + (169 genPrimitiveNotEquivalent 1) "Sound Primitives (170-199) - NO LONGER INDEXED; We won't compile any of these" "Old closure primitives" "(186 primitiveFail)" "was primitiveClosureValue" "(187 primitiveFail)" "was primitiveClosureValueWithArgs" "Perform method directly" "(188 primitiveExecuteMethodArgsArray)" "(189 primitiveExecuteMethod)" "Sound Primitives (continued) - NO LONGER INDEXED; We won't compile any of these" "(190 194 primitiveFail)" "Unwind primitives" "(195 primitiveFindNextUnwindContext)" "(196 primitiveTerminateTo)" "(197 primitiveFindHandlerContext)" (198 genFastPrimFail "primitiveMarkUnwindMethod") (199 genFastPrimFail "primitiveMarkHandlerMethod") "new closure primitives (were Networking primitives)" "(200 primitiveClosureCopyWithCopiedValues)" (201 genPrimitiveClosureValue) "value" (202 genPrimitiveClosureValue) "value:" (203 genPrimitiveClosureValue) "value:value:" (204 genPrimitiveClosureValue) "value:value:value:" (205 genPrimitiveClosureValue) "value:value:value:value:" "(206 genPrimitiveClosureValueWithArgs)" "valueWithArguments:" "(207 209 primitiveFail)" "reserved for Cog primitives" "(210 primitiveContextAt)" "(211 primitiveContextAtPut)" "(212 primitiveContextSize)" "(213 217 primitiveFail)" "reserved for Cog primitives" "(218 primitiveDoNamedPrimitiveWithArgs)" "(219 primitiveFail)" "reserved for Cog primitives" "(220 primitiveFail)" "reserved for Cog primitives" (221 genPrimitiveClosureValue) "valueNoContextSwitch" (222 genPrimitiveClosureValue) "valueNoContextSwitch:" "(223 229 primitiveFail)" "reserved for Cog primitives" )! Item was changed: ----- Method: SimpleStackBasedCogit>>genPrimitiveEquivalent (in category 'primitive generators') ----- genPrimitiveEquivalent "Stack looks like receiver (also in ResultReceiverReg) arg return address" | jumpFalse | <var: #jumpFalse type: #'AbstractInstruction *'> self MoveMw: BytesPerWord r: SPReg R: TempReg. self CmpR: TempReg R: ReceiverResultReg. jumpFalse := self JumpNonZero: 0. self annotate: (self MoveCw: objectMemory trueObject R: ReceiverResultReg) objRef: objectMemory trueObject. self flag: 'currently caller pushes result'. self RetN: BytesPerWord * 2. + jumpFalse jmpTarget: (self annotate: (self MoveCw: objectMemory falseObject R: ReceiverResultReg) + objRef: objectMemory falseObject). - jumpFalse jmpTarget: (self - annotate: (self MoveCw: objectMemory falseObject R: ReceiverResultReg) - objRef: objectMemory falseObject). self RetN: BytesPerWord * 2. ^0! Item was added: + ----- Method: SimpleStackBasedCogit>>genPrimitiveNotEquivalent (in category 'primitive generators') ----- + genPrimitiveNotEquivalent + "Stack looks like + receiver (also in ResultReceiverReg) + arg + return address" + | jumpFalse | + <var: #jumpFalse type: #'AbstractInstruction *'> + self MoveMw: BytesPerWord r: SPReg R: TempReg. + self CmpR: TempReg R: ReceiverResultReg. + jumpFalse := self JumpZero: 0. + self annotate: (self MoveCw: objectMemory trueObject R: ReceiverResultReg) + objRef: objectMemory trueObject. + self flag: 'currently caller pushes result'. + self RetN: BytesPerWord * 2. + jumpFalse jmpTarget: (self annotate: (self MoveCw: objectMemory falseObject R: ReceiverResultReg) + objRef: objectMemory falseObject). + self RetN: BytesPerWord * 2. + ^0! Item was changed: ----- Method: SmartSyntaxPluginCodeGenerator>>generateRemapOopIn:on:indent: (in category 'translating builtins') ----- generateRemapOopIn: aNode on: aStream indent: level "Generate the C code for this message onto the given stream." | idList | idList := aNode args first nameOrValue. idList class == Array ifFalse: [idList := Array with: idList]. idList do: [:each | aStream nextPutAll: 'interpreterProxy->pushRemappableOop('; nextPutAll: each asString; nextPutAll: ');'] separatedBy: [aStream crtab: level]. aStream cr. aNode args second emitCCodeOn: aStream level: level generator: self. level timesRepeat: [aStream tab]. idList reversed do: [:each | aStream nextPutAll: each asString; nextPutAll: ' = interpreterProxy->popRemappableOop()'] separatedBy: [aStream nextPut: $;; crtab: level].! Item was changed: ----- Method: SoundPlugin>>primitiveSoundGetVolume (in category 'primitives') ----- primitiveSoundGetVolume "Set the sound input recording level." + | left right results | + <var: #left type: #double> + <var: #right type: #double> - | left right results | self primitive: 'primitiveSoundGetVolume' parameters: #( ). - self var: #left type: 'double '. - self var: #right type: 'double '. left := 0. right := 0. self cCode: 'snd_Volume((double *) &left,(double *) &right)'. interpreterProxy pushRemappableOop: (right asOop: Float). interpreterProxy pushRemappableOop: (left asOop: Float). interpreterProxy pushRemappableOop: (interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 2). results := interpreterProxy popRemappableOop. interpreterProxy storePointer: 0 ofObject: results withValue: interpreterProxy popRemappableOop. interpreterProxy storePointer: 1 ofObject: results withValue: interpreterProxy popRemappableOop. ^ results! Item was changed: ----- Method: SoundPlugin>>primitiveSoundRecordSamplesInto:startingAt: (in category 'primitives') ----- primitiveSoundRecordSamplesInto: buf startingAt: startWordIndex "Record a buffer's worth of 16-bit sound samples." | bufSizeInBytes samplesRecorded bufPtr byteOffset bufLen | + <var: #bufPtr type: #'char*'> - self var: #bufPtr type: 'char*'. self primitive: 'primitiveSoundRecordSamples' parameters: #(WordArray SmallInteger ). interpreterProxy failed ifFalse: [bufSizeInBytes := (interpreterProxy slotSizeOf: buf cPtrAsOop) * 4. interpreterProxy success: (startWordIndex >= 1 and: [startWordIndex - 1 * 2 < bufSizeInBytes])]. interpreterProxy failed ifFalse:[ byteOffset := (startWordIndex - 1) * 2. bufPtr := (self cCoerce: buf to: 'char*') + byteOffset. bufLen := bufSizeInBytes - byteOffset. samplesRecorded := self cCode: 'snd_RecordSamplesIntoAtLength(bufPtr, 0, bufLen)' inSmalltalk:[bufPtr. bufLen. 0]. ]. ^ samplesRecorded asPositiveIntegerObj! Item was changed: ----- Method: StackInterpreter class>>initializePrimitiveTable (in category 'initialization') ----- (excessive size, no diff calculated) Item was changed: ----- Method: StackInterpreter>>allocateMemory:minimum:imageFile:headerSize: (in category 'image save/restore') ----- allocateMemory: heapSize minimum: minimumMemory imageFile: fileStream headerSize: headerSize "Translate to C function call with (case sensitive) camelCase. The purpose of this method is to document the translation. The default implementation is sqAllocateMemory(minimumMemory, heapSize). This may be redefined to make use of the image file and header size parameters for efficient implementation with mmap(). See CCodeGenerator>>writeDefaultMacrosOn: which specifies a default implementation." + <inline: true> + <returnTypeC: #'char *'> + <var: #fileStream type: #sqImageFile> - self inline: true. - self returnTypeC: 'char *'. - self var: #fileStream type: 'sqImageFile'. ^ self allocateMemory: heapSize Minimum: minimumMemory ImageFile: fileStream HeaderSize: headerSize ! Item was removed: - ----- Method: StackInterpreter>>assertClassOf:is:compactClassIndex: (in category 'utilities') ----- - assertClassOf: oop is: classOop compactClassIndex: compactClassIndex - "Succeed if the oop is an instance of the given class. Fail if the object is an integer. - If the class has a (non-zero) compactClassIndex use that to speed up the check. - N.B. Inlining should result in classOop not being accessed if compactClassIndex - is non-zero." - - <inline: true> - self success: (objectMemory is: oop instanceOf: classOop compactClassIndex: compactClassIndex)! Item was changed: ----- Method: StackInterpreter>>bereaveAllMarriedContexts (in category 'frame access') ----- bereaveAllMarriedContexts "Enumerate all contexts and convert married contexts to widowed contexts so that the snapshot contains only single contexts. This allows the test for being married to avoid checking for a context's frame pointer being in bounds. Thanks to Greg Nuyens for this idea." | oop | <asmLabel: false> oop := objectMemory firstObject. [oop < objectMemory freeStart] whileTrue: [((objectMemory isFreeObject: oop) not + and: [(objectMemory isContextNonInt: oop) - and: [(self isContextNonInt: oop) and: [self isMarriedOrWidowedContext: oop]]) ifTrue: [self markContextAsDead: oop]. oop := objectMemory objectAfter: oop]! Item was changed: ----- Method: StackInterpreter>>bytecodePrimMultiply (in category 'common selector sends') ----- bytecodePrimMultiply | rcvr arg result | rcvr := self internalStackValue: 1. arg := self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [rcvr := objectMemory integerValueOf: rcvr. arg := objectMemory integerValueOf: arg. result := rcvr * arg. + (arg = 0 + or: [(result // arg) = rcvr and: [objectMemory isIntegerValue: result]]) ifTrue: + [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result). + ^self fetchNextBytecode "success"]] - ((arg = 0 or: [(result // arg) = rcvr]) and: [objectMemory isIntegerValue: result]) - ifTrue: [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result). - ^ self fetchNextBytecode "success"]] ifFalse: [self initPrimCall. self externalizeIPandSP. self primitiveFloatMultiply: rcvr byArg: arg. self internalizeIPandSP. self successful ifTrue: [^ self fetchNextBytecode "success"]]. messageSelector := self specialSelector: 8. argumentCount := 1. self normalSend! Item was changed: ----- Method: StackInterpreter>>commonSend (in category 'message sending') ----- commonSend "Send a message, starting lookup with the receiver's class." "Assume: messageSelector and argumentCount have been set, and that the receiver and arguments have been pushed onto the stack," "Note: This method is inlined into the interpreter dispatch loop." <sharedCodeNamed: 'commonSend' inCase: 131> self sendBreak: messageSelector + BaseHeaderSize point: (objectMemory lengthOf: messageSelector) receiver: (self internalStackValue: argumentCount). + self printSends ifTrue: + [self printActivationNameForSelector: messageSelector startClass: lkupClass; cr]. self internalFindNewMethod. self internalExecuteNewMethod. self fetchNextBytecode! Item was changed: ----- Method: StackInterpreter>>commonVariable:at:cacheIndex: (in category 'indexing primitive support') ----- commonVariable: rcvr at: index cacheIndex: atIx "This code assumes the receiver has been identified at location atIx in the atCache." | stSize fmt fixedFields result | <inline: true> stSize := atCache at: atIx+AtCacheSize. ((self oop: index isGreaterThanOrEqualTo: 1) and: [self oop: index isLessThanOrEqualTo: stSize]) ifTrue: [fmt := atCache at: atIx+AtCacheFmt. fmt <= 4 ifTrue: [self assert: (objectMemory isContextNonInt: rcvr) not. fixedFields := atCache at: atIx+AtCacheFixedFields. ^ objectMemory fetchPointer: index + fixedFields - 1 ofObject: rcvr]. fmt < 8 ifTrue: "Bitmap" [result := objectMemory fetchLong32: index - 1 ofObject: rcvr. ^self positive32BitIntegerFor: result]. fmt >= 16 "Note fmt >= 16 is an artificial flag for strings" ifTrue: "String" [^ self characterForAscii: (objectMemory fetchByte: index - 1 ofObject: rcvr)] ifFalse: "ByteArray" [^ objectMemory integerObjectOf: (objectMemory fetchByte: index - 1 ofObject: rcvr)]]. + ^self primitiveFailFor: ((objectMemory formatOf: rcvr) <= 1 + ifTrue: [PrimErrBadReceiver] + ifFalse: [PrimErrBadIndex])! - ^self primitiveFailFor: PrimErrBadIndex! Item was changed: ----- Method: StackInterpreter>>commonVariable:at:put:cacheIndex: (in category 'indexing primitive support') ----- commonVariable: rcvr at: index put: value cacheIndex: atIx "This code assumes the receiver has been identified at location atIx in the atCache." | stSize fmt fixedFields valToPut | <inline: true> stSize := atCache at: atIx+AtCacheSize. ((self oop: index isGreaterThanOrEqualTo: 1) and: [self oop: index isLessThanOrEqualTo: stSize]) ifTrue: [fmt := atCache at: atIx+AtCacheFmt. fmt <= 4 ifTrue: [self assert: (objectMemory isContextNonInt: rcvr) not. fixedFields := atCache at: atIx+AtCacheFixedFields. ^ objectMemory storePointer: index + fixedFields - 1 ofObject: rcvr withValue: value]. fmt < 8 ifTrue: "Bitmap" [valToPut := self positive32BitValueOf: value. self successful ifTrue: [objectMemory storeLong32: index - 1 ofObject: rcvr withValue: valToPut]. ^ nil]. fmt >= 16 "Note fmt >= 16 is an artificial flag for strings" ifTrue: [valToPut := self asciiOfCharacter: value. self successful ifFalse: [^ nil]] ifFalse: [valToPut := value]. (objectMemory isIntegerObject: valToPut) ifTrue: [valToPut := objectMemory integerValueOf: valToPut. ((valToPut >= 0) and: [valToPut <= 255]) ifFalse: [^ self primitiveFail]. ^ objectMemory storeByte: index - 1 ofObject: rcvr withValue: valToPut]]. + ^self primitiveFailFor: ((objectMemory formatOf: rcvr) <= 1 + ifTrue: [PrimErrBadReceiver] + ifFalse: [PrimErrBadIndex])! - ^self primitiveFailFor: PrimErrBadIndex! Item was added: + ----- Method: StackInterpreter>>findClassForSelector:lookupClass:do: (in category 'debug support') ----- + findClassForSelector: aSelector lookupClass: startClass do: unaryBlock + "Search startClass' class hierarchy looking for aSelector and if found, evaluate unaryBlock + with the class where the selector is found. Otherwise evaluate unaryBlock with nil." + | currClass classDict classDictSize i | + currClass := startClass. + [classDict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: currClass. + classDictSize := objectMemory fetchWordLengthOf: classDict. + i := SelectorStart. + [i < classDictSize] whileTrue: + [aSelector = (objectMemory fetchPointer: i ofObject: classDict) ifTrue: + [^unaryBlock value: currClass]. + i := i + 1]. + currClass := self superclassOf: currClass. + currClass = objectMemory nilObject] whileFalse. + ^unaryBlock value: nil "selector not found in superclass chain" + ! Item was added: + ----- Method: StackInterpreter>>findSelectorAndClassForMethod:lookupClass:do: (in category 'debug support') ----- + findSelectorAndClassForMethod: meth lookupClass: startClass do: binaryBlock + "Search startClass' class hierarchy searching for method and if found, evaluate aBinaryBlock + with the selector and class where the method is found. Otherwise evaluate aBinaryBlock + with doesNotUnderstand: and nil." + | currClass classDict classDictSize methodArray i | + currClass := startClass. + [classDict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: currClass. + classDictSize := objectMemory fetchWordLengthOf: classDict. + methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict. + i := 0. + [i <= (classDictSize - SelectorStart)] whileTrue: + [meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue: + [^binaryBlock + value: (objectMemory fetchPointer: i + SelectorStart ofObject: classDict) + value: currClass]. + i := i + 1]. + currClass := self superclassOf: currClass. + currClass = objectMemory nilObject] whileFalse. + ^binaryBlock "method not found in superclass chain" + value: (objectMemory splObj: SelectorDoesNotUnderstand) + value: nil! Item was changed: ----- Method: StackInterpreter>>floatArg: (in category 'plugin primitive support') ----- floatArg: index "Like #stackFloatValue: but access method arguments left-to-right" + | oop | - | result oop | <returnTypeC: #double> - <var: #result type: #double> oop := self methodArg: index. oop = 0 ifTrue:[^0.0]. "methodArg: failed" + ^self floatValueOf: oop! - "N.B. Because Slang always inlines assertClassOf:is:compactClassIndex: - (because assertClassOf:is:compactClassIndex: has an inline: pragma) the - phrase (self splObj: ClassArray) is expanded in-place and is _not_ - evaluated if ClassArrayCompactIndex is non-zero." - self assertClassOf: oop is: (objectMemory splObj: ClassFloat) - compactClassIndex: ClassFloatCompactIndex. - self successful ifTrue: - [self cCode: '' inSmalltalk: [result := Float new: 2]. - objectMemory fetchFloatAt: oop + BaseHeaderSize into: result. - ^result]. - ^0.0! Item was changed: ----- Method: StackInterpreter>>floatValueOf: (in category 'utilities') ----- floatValueOf: oop "Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float." "Note: May be called by translated primitive code." + | isFloat result | - | result | <returnTypeC: #double> <var: #result type: #double> + "N.B. Because Slang always inlines is:instanceOf:compactClassIndex: + (because is:instanceOf:compactClassIndex: has an inline: pragma) the + phrase (self splObj: ClassArray) is expanded in-place and is _not_ evaluated if + ClassArrayCompactIndex is non-zero." + isFloat := objectMemory + is: oop + instanceOf: (objectMemory splObj: ClassFloat) + compactClassIndex: ClassFloatCompactIndex. + isFloat ifTrue: - self flag: #Dan. "None of the float stuff has been converted for 64 bits" - "N.B. Because Slang always inlines assertClassOf:is:compactClassIndex: - (because assertClassOf:is:compactClassIndex: has an inline: pragma) the - phrase (self splObj: ClassArray) is expanded in-place and is _not_ - evaluated if ClassArrayCompactIndex is non-zero." - self assertClassOf: oop - is: (objectMemory splObj: ClassFloat) - compactClassIndex: ClassFloatCompactIndex. - self successful ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2]. + objectMemory fetchFloatAt: oop + BaseHeaderSize into: result. + ^result]. + self primitiveFail. - objectMemory fetchFloatAt: oop + BaseHeaderSize into: result. - ^result]. ^0.0! Item was changed: ----- Method: StackInterpreter>>getStackPointer (in category 'primitive support') ----- getStackPointer "For Alien FFI" <api> <returnTypeC: #'sqInt *'> + ^self cCoerceSimple: stackPointer to: #'sqInt *'! - ^stackPointer! Item was changed: ----- Method: StackInterpreter>>initializeExtraClassInstVarIndices (in category 'initialization') ----- initializeExtraClassInstVarIndices "Initialize metaclassSizeBytes and thisClassIndex which are used in debug printing, and classNameIndex which is used not only for debug printing but for is:KindOf: & is:MemberOf: via classNameOf:is: (evil but a reality we have to accept)." | classArrayObj classArrayClass | classArrayObj := objectMemory splObj: ClassArray. classArrayClass := objectMemory fetchClassOfNonInt: classArrayObj. metaclassSizeBytes := objectMemory sizeBitsOf: classArrayClass. "determine actual (Metaclass instSize * 4)" thisClassIndex := 5. "default" InstanceSpecificationIndex + 1 to: (objectMemory lengthOf: classArrayClass) do: [:i| (objectMemory fetchPointer: i - 1 ofObject: classArrayClass) = classArrayObj ifTrue: [thisClassIndex := i - 1]]. classNameIndex := 6. "default" InstanceSpecificationIndex + 1 to: (objectMemory lengthOf: classArrayObj) do: [:i| | oop | oop := objectMemory fetchPointer: i - 1 ofObject: classArrayObj. ((objectMemory isBytes: oop) and: [(objectMemory lengthOf: oop) = 5 + and: [(self str: 'Array' n: (objectMemory firstFixedField: oop) cmp: 5) = 0]]) ifTrue: - and: [(self str: #Array n: (objectMemory firstFixedField: oop) cmp: 5) = 0]]) ifTrue: [classNameIndex := i - 1]]! Item was removed: - ----- Method: StackInterpreter>>instSpecOfClass: (in category 'object format') ----- - instSpecOfClass: classPointer - "This is the same as the field stored in every object header" - - ^(objectMemory formatOfClass: classPointer) >> 8 bitAnd: 16rF! Item was removed: - ----- Method: StackInterpreter>>isContextNonInt: (in category 'internal interpreter access') ----- - isContextNonInt: oop - <inline: true> - ^objectMemory isContextHeader: (objectMemory baseHeader: oop)! Item was removed: - ----- Method: StackInterpreter>>isFloatObjectNonInt:floatClass: (in category 'internal interpreter access') ----- - isFloatObjectNonInt: oop floatClass: floatClass - ^ClassFloatCompactIndex ~= 0 - ifTrue: [(objectMemory compactClassIndexOf: oop) = ClassFloatCompactIndex] - ifFalse: [(objectMemory fetchClassOfNonInt: oop) = floatClass]! Item was changed: ----- Method: StackInterpreter>>loadFloatOrIntFrom: (in category 'utilities') ----- 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 primErrorCode non-zero." - If it is a Float, then load its value and return it. - Otherwise fail -- ie return with primErrorCode non-zero." - | result | <inline: true> <asmLabel: false> <returnTypeC: #double> - <var: #result type: #double> (objectMemory isIntegerObject: floatOrInt) ifTrue: [^(objectMemory integerValueOf: floatOrInt) asFloat]. + ^self floatValueOf: floatOrInt! - self assertClassOf: floatOrInt - is: (objectMemory splObj: ClassFloat) - compactClassIndex: ClassFloatCompactIndex. - self cCode: '' inSmalltalk: [result := Float new: 2]. - self successful ifTrue: - [objectMemory fetchFloatAt: floatOrInt + BaseHeaderSize into: result]. - ^result! Item was changed: ----- Method: StackInterpreter>>noInlineTemporary:in: (in category 'internal interpreter access') ----- noInlineTemporary: offset in: theFP <var: #theFP type: #'char *'> <inline: false> ^self temporary: offset in: theFP! Item was changed: ----- Method: StackInterpreter>>popFloat (in category 'stack bytecodes') ----- popFloat - "Note: May be called by translated primitive code." - - | top result | <returnTypeC: #double> + ^self floatValueOf: self popStack! - <var: #result type: #double> - top := self popStack. - "N.B. Because Slang always inlines assertClassOf:is:compactClassIndex: - (because assertClassOf:is:compactClassIndex: has an inline: pragma) the - phrase (self splObj: ClassArray) is expanded in-place and is _not_ - evaluated if ClassArrayCompactIndex is non-zero." - self assertClassOf: top - is: (objectMemory splObj: ClassFloat) - compactClassIndex: ClassFloatCompactIndex. - self successful ifTrue: - [self cCode: '' inSmalltalk: [result := Float new: 2]. - objectMemory fetchFloatAt: top + BaseHeaderSize into: result]. - ^ result! Item was changed: ----- Method: StackInterpreter>>primitiveObject:perform:withArguments:lookedUpIn: (in category 'control primitives') ----- primitiveObject: actualReceiver perform: selector withArguments: argumentArray lookedUpIn: lookupClass "Common routine used by perform:withArgs:, perform:withArgs:inSuperclass:, object:perform:withArgs:inClass: et al. Answer nil on success. NOTE: The case of doesNotUnderstand: is not a failure to perform. The only failures are arg types and consistency of argumentCount. Since we're in the stack VM we can assume there is space to push the arguments provided they are within limits (max argument count is 15). We can therefore deal with the arbitrary amount of state to remove from the stack (lookup class, selector, mirror receiver) and arbitrary argument orders by deferring popping anything until we know whether the send has succeeded. So on failure we merely have to remove the actual receiver and arguments pushed, and on success we have to slide the actual receiver and arguments down to replace the original ones." | arraySize performArgCount delta | (objectMemory isArray: argumentArray) ifFalse: [^self primitiveFailFor: PrimErrBadArgument]. "Check if number of arguments is reasonable; MaxNumArgs isn't available so just use LargeContextSize" arraySize := objectMemory fetchWordLengthOf: argumentArray. arraySize > (LargeContextSize / BytesPerWord) ifTrue: [^self primitiveFailFor: PrimErrBadNumArgs]. performArgCount := argumentCount. "Push newMethod to save it in case of failure, then push the actual receiver and args out of the array." self push: newMethod. self push: actualReceiver. "Copy the arguments to the stack, and execute" 1 to: arraySize do: [:index| self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray)]. argumentCount := arraySize. messageSelector := selector. self sendBreak: messageSelector + BaseHeaderSize point: (objectMemory lengthOf: messageSelector) receiver: actualReceiver. + self printSends ifTrue: + [self printActivationNameForSelector: messageSelector startClass: lookupClass; cr]. self findNewMethodInClass: lookupClass. "Only test CompiledMethods for argument count - any other objects playacting as CMs will have to take their chances" ((objectMemory isOopCompiledMethod: newMethod) and: [(self argumentCountOf: newMethod) ~= argumentCount]) ifTrue: ["Restore the state by popping all those array entries and pushing back the selector and array, and fail" self pop: arraySize + 1. newMethod := self popStack. ^self primitiveFailFor: PrimErrBadNumArgs]. "Cannot fail this primitive from here-on. Slide the actual receiver and arguments down to replace the perform arguments and saved newMethod and then execute the new method. Use argumentCount not arraySize because an MNU may have changed it." delta := BytesPerWord * (performArgCount + 2). "+2 = receiver + saved newMethod" argumentCount * BytesPerWord to: 0 by: BytesPerWord negated do: [:offset| stackPages longAt: stackPointer + offset + delta put: (stackPages longAt: stackPointer + offset)]. self pop: performArgCount + 2. self executeNewMethod. self initPrimCall. "Recursive xeq affects primErrorCode" ^nil! Item was added: + ----- Method: StackInterpreter>>printActivationNameForMethod:startClass:isBlock:firstTemporary: (in category 'debug printing') ----- + printActivationNameForMethod: aMethod startClass: startClass isBlock: isBlock firstTemporary: maybeMessage + | methClass methodSel | + <inline: false> + isBlock ifTrue: + [self print: '[] in ']. + self findSelectorAndClassForMethod: aMethod + lookupClass: startClass + do: [:sel :class| + methodSel := sel. + methClass := class]. + ((self addressCouldBeOop: startClass) and: [methClass notNil]) + ifTrue: + [startClass = methClass + ifTrue: [self printNameOfClass: methClass count: 5] + ifFalse: + [self printNameOfClass: startClass count: 5. + self printChar: $(. + self printNameOfClass: methClass count: 5. + self printChar: $)]] + ifFalse: [self print: 'INVALID CLASS']. + self printChar: $>. + (objectMemory addressCouldBeOop: methodSel) + ifTrue: + [(objectMemory isBytes: methodSel) + ifTrue: [self printStringOf: methodSel] + ifFalse: [self printOopShort: methodSel]] + ifFalse: [self print: 'INVALID SELECTOR']. + (methodSel = (objectMemory splObj: SelectorDoesNotUnderstand) + and: [(objectMemory addressCouldBeObj: maybeMessage) + and: [(objectMemory fetchClassOfNonInt: maybeMessage) = (objectMemory splObj: ClassMessage)]]) ifTrue: + ["print arg message selector" + methodSel := objectMemory fetchPointer: MessageSelectorIndex ofObject: maybeMessage. + self print: ' '. + self printStringOf: methodSel]! Item was added: + ----- Method: StackInterpreter>>printActivationNameForSelector:startClass: (in category 'debug printing') ----- + printActivationNameForSelector: aSelector startClass: startClass + | methClass | + <inline: false> + (objectMemory addressCouldBeObj: startClass) + ifTrue: + [self findClassForSelector: aSelector + lookupClass: startClass + do: [:class| methClass := class]. + (methClass isNil or: [startClass = methClass]) + ifTrue: + [self printNameOfClass: methClass count: 5.. + self printChar: $>. + methClass ifNil: + [self printStringOf: (objectMemory splObj: SelectorDoesNotUnderstand). + self print: ' ']] + ifFalse: + [self printNameOfClass: startClass count: 5. + self printChar: $(. + self printNameOfClass: methClass count: 5. + self printChar: $). + self printChar: $>]] + ifFalse: [self print: 'INVALID CLASS']. + (objectMemory addressCouldBeOop: aSelector) + ifTrue: + [(objectMemory isBytes: aSelector) + ifTrue: [self printStringOf: aSelector] + ifFalse: [self printOopShort: aSelector]] + ifFalse: [self print: 'INVALID SELECTOR']! Item was changed: ----- Method: StackInterpreter>>printContext: (in category 'debug printing') ----- printContext: aContext | sender ip sp | <inline: false> self shortPrintContext: aContext. sender := objectMemory fetchPointer: SenderIndex ofObject: aContext. ip := objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext. (objectMemory isIntegerObject: sender) ifTrue: [(self checkIsStillMarriedContext: aContext currentFP: framePointer) ifTrue: [self print: 'married (assuming framePointer valid)'; cr] ifFalse: [self print: 'widdowed (assuming framePointer valid)'; cr]. self print: 'sender '; printNum: sender; print: ' ('; printHexPtr: (self withoutSmallIntegerTags: sender); printChar: $); cr. self print: 'ip '; printNum: ip; print: ' ('; printHexPtr: (self withoutSmallIntegerTags: ip); printChar: $); cr] ifFalse: [self print: 'sender '; shortPrintOop: sender. + self print: 'ip '; printNum: ip; print: ' ('; printNum: (objectMemory integerValueOf: ip); space; printHex: (objectMemory integerValueOf: ip); printChar: $); cr]. - self print: 'ip '; printNum: ip; print: ' ('; printNum: (objectMemory integerValueOf: ip); printHex: (objectMemory integerValueOf: ip); printChar: $); cr]. sp := objectMemory fetchPointer: StackPointerIndex ofObject: aContext. sp := sp min: (objectMemory lengthOf: aContext) - ReceiverIndex. self print: 'sp '; printNum: sp; print: ' ('; printNum: (objectMemory integerValueOf: sp); printChar: $); cr. self print: 'method '; shortPrintOop: (objectMemory fetchPointer: MethodIndex ofObject: aContext). self print: 'closure '; shortPrintOop: (objectMemory fetchPointer: ClosureIndex ofObject: aContext). self print: 'receiver '; shortPrintOop: (objectMemory fetchPointer: ReceiverIndex ofObject: aContext). sp := objectMemory integerValueOf: sp. 1 to: sp do: [:i| self print: ' '; printNum: i; space; shortPrintOop: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)]! Item was changed: ----- Method: StackInterpreter>>printOop: (in category 'debug printing') ----- printOop: oop | cls fmt lastIndex startIP bytecodesPerLine | <inline: false> self printHex: oop. (objectMemory isIntegerObject: oop) ifTrue: [^self cCode: 'printf("=%ld\n", integerValueOf(oop))' inSmalltalk: [self print: (self shortPrint: oop); cr]]. (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: [self printHex: oop; print: ' is not on the heap'; cr. ^nil]. (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: [self printHex: oop; print: ' is misaligned'; cr. ^nil]. (objectMemory isFreeObject: oop) ifTrue: [self print: ' free chunk of size '; printNum: (objectMemory sizeOfFree: oop); cr. ^nil]. self print: ': a(n) '. self printNameOfClass: (cls := objectMemory fetchClassOfNonInt: oop) count: 5. cls = (objectMemory splObj: ClassFloat) ifTrue: [self cr; printFloat: (self dbgFloatValueOf: oop); cr. ^nil]. fmt := objectMemory formatOf: oop. fmt > 4 ifTrue: [self print: ' nbytes '; printNum: (objectMemory byteSizeOf: oop)]. self cr. (fmt > 4 and: [fmt < 12]) ifTrue: ["This will answer false if splObj: ClassAlien is nilObject" (self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifTrue: [self print: ' datasize '; printNum: (self sizeOfAlienData: oop). self print: ((self isIndirectAlien: oop) ifTrue: [' indirect @ '] ifFalse: [(self isPointerAlien: oop) ifTrue: [' pointer @ '] ifFalse: [' direct @ ']]). + self printHex: (self startOfAlienData: oop) asUnsignedInteger; cr. - self printHex: (self startOfAlienData: oop); cr. ^nil]. (objectMemory isWords: oop) ifTrue: [lastIndex := 64 min: ((objectMemory byteSizeOf: oop) / BytesPerWord). lastIndex > 0 ifTrue: [1 to: lastIndex do: [:index| self space; printHex: (objectMemory fetchLong32: index - 1 ofObject: oop). (index \\ self elementsPerPrintOopLine) = 0 ifTrue: [self cr]]. (lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse: [self cr]]. ^nil]. ^self printStringOf: oop; cr]. lastIndex := 64 min: (startIP := (objectMemory lastPointerOf: oop) / BytesPerWord). lastIndex > 0 ifTrue: [1 to: lastIndex do: [:index| self cCode: 'printHex(fetchPointerofObject(index - 1, oop)); putchar('' '')' inSmalltalk: [self space; printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space. self print: (self shortPrint: (objectMemory fetchPointer: index - 1 ofObject: oop))]. (index \\ self elementsPerPrintOopLine) = 0 ifTrue: [self cr]]. (lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse: [self cr]]. (objectMemory isCompiledMethod: oop) ifFalse: [startIP > 64 ifTrue: [self print: '...'; cr]] ifTrue: [startIP := startIP * BytesPerWord + 1. lastIndex := objectMemory lengthOf: oop. lastIndex - startIP > 100 ifTrue: [lastIndex := startIP + 100]. bytecodesPerLine := 10. startIP to: lastIndex do: [:index| | byte | byte := objectMemory fetchByte: index - 1 ofObject: oop. self cCode: 'printf(" %02x/%-3d", byte,byte)' inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte]. ((index - startIP + 1) \\ bytecodesPerLine) = 0 ifTrue: [self cr]]. ((lastIndex - startIP + 1) \\ bytecodesPerLine) = 0 ifFalse: [self cr]]! Item was added: + ----- Method: StackInterpreter>>printSends (in category 'debug printing') ----- + printSends + ^false! Item was changed: ----- Method: StackInterpreter>>pushMaybeContextReceiverVariable: (in category 'stack bytecodes') ----- pushMaybeContextReceiverVariable: fieldIndex "Must trap accesses to married and widowed contexts. But don't want to check on all inst var accesses. This method is only used by the long-form bytecodes, evading the cost. Note that the method, closure and receiver fields of married contexts are correctly initialized so they don't need special treatment on read. Only sender, instruction pointer and stack pointer need to be intercepted on reads." | rcvr | <inline: true> rcvr := self receiver. (fieldIndex < MethodIndex + and: [objectMemory isContextNonInt: rcvr]) - and: [self isContextNonInt: rcvr]) ifTrue: [self internalPush: (self instVar: fieldIndex ofContext: rcvr)] ifFalse: [self internalPush: (objectMemory fetchPointer: fieldIndex ofObject: rcvr)]! Item was added: + ----- Method: StackInterpreter>>shortPrintFrame:AndNCallers: (in category 'debug printing') ----- + shortPrintFrame: theFP AndNCallers: n + <api> + <inline: false> + <var: #theFP type: #'char *'> + (n > 0 and: [stackPages couldBeFramePointer: theFP]) ifTrue: + [self shortPrintFrame: theFP. + self shortPrintFrame: (self frameCallerFP: theFP) AndNCallers: n - 1]! Item was changed: ----- Method: StackInterpreter>>stObject:at: (in category 'indexing primitive support') ----- stObject: array at: index "Return what ST would return for <obj> at: index." | hdr fmt totalLength fixedFields stSize | <inline: false> hdr := objectMemory baseHeader: array. fmt := objectMemory formatOfHeader: hdr. totalLength := objectMemory lengthOf: array baseHeader: hdr format: fmt. fixedFields := objectMemory fixedFieldsOf: array format: fmt length: totalLength. + (fmt = 3 and: [objectMemory isContextHeader: hdr]) - (fmt = 3 and: [self isContextHeader: hdr]) ifTrue: + [stSize := self stackPointerForMaybeMarriedContext: array. - [stSize := self fetchStackPointerOf: array. ((self oop: index isGreaterThanOrEqualTo: 1) and: [(self oop: index isLessThanOrEqualTo: stSize) and: [self isStillMarriedContext: array]]) ifTrue: [^self noInlineTemporary: index - 1 in: (self frameOfMarriedContext: array)]] ifFalse: [stSize := totalLength - fixedFields]. ((self oop: index isGreaterThanOrEqualTo: 1) + and: [self oop: index isLessThanOrEqualTo: stSize]) ifTrue: + [^self subscript: array with: (index + fixedFields) format: fmt]. + self primitiveFailFor: (fmt <= 1 ifTrue: [PrimErrBadReceiver] ifFalse: [PrimErrBadIndex]). + ^0! - and: [self oop: index isLessThanOrEqualTo: stSize]) - ifTrue: [^self subscript: array with: (index + fixedFields) format: fmt] - ifFalse: [self primitiveFailFor: PrimErrBadIndex. ^ 0]! Item was changed: ----- Method: StackInterpreter>>stObject:at:put: (in category 'indexing primitive support') ----- stObject: array at: index put: value "Do what ST would return for <obj> at: index put: value." | hdr fmt totalLength fixedFields stSize | <inline: false> hdr := objectMemory baseHeader: array. fmt := objectMemory formatOfHeader: hdr. totalLength := objectMemory lengthOf: array baseHeader: hdr format: fmt. fixedFields := objectMemory fixedFieldsOf: array format: fmt length: totalLength. + (fmt = 3 + and: [objectMemory isContextHeader: hdr]) - (fmt = 3 and: [self isContextHeader: hdr]) ifTrue: + [stSize := self stackPointerForMaybeMarriedContext: array. - [stSize := self fetchStackPointerOf: array. ((self oop: index isGreaterThanOrEqualTo: 1) and: [(self oop: index isLessThanOrEqualTo: stSize) and: [self isStillMarriedContext: array]]) ifTrue: [self noInlineTemporary: index - 1 in: (self frameOfMarriedContext: array) put: value. ^self]] ifFalse: [stSize := totalLength - fixedFields]. ((self oop: index isGreaterThanOrEqualTo: 1) and: [self oop: index isLessThanOrEqualTo: stSize]) ifTrue: [self subscript: array with: (index + fixedFields) storing: value format: fmt] + ifFalse: [self primitiveFailFor: (fmt <= 1 ifTrue: [PrimErrBadReceiver] ifFalse: [PrimErrBadIndex])]! - ifFalse: [self primitiveFailFor: PrimErrBadIndex]! Item was changed: ----- Method: StackInterpreter>>stackFloatValue: (in category 'internal interpreter access') ----- stackFloatValue: offset "In the StackInterpreter stacks grow down." - | result floatPointer | <returnTypeC: #double> + ^self floatValueOf: (stackPages longAt: stackPointer + (offset*BytesPerWord))! - <var: #result type: #double> - floatPointer := stackPages longAt: stackPointer + (offset*BytesPerWord). - - "N.B. Because Slang always inlines assertClassOf:is:compactClassIndex: - (because assertClassOf:is:compactClassIndex: has an inline: pragma) the - phrase (self splObj: ClassArray) is expanded in-place and is _not_ - evaluated if ClassArrayCompactIndex is non-zero." - self assertClassOf: floatPointer - is: (objectMemory splObj: ClassFloat) - compactClassIndex: ClassFloatCompactIndex. - self successful ifTrue: - [self cCode: '' inSmalltalk: [result := Float new: 2]. - objectMemory fetchFloatAt: floatPointer + BaseHeaderSize into: result. - ^result]. - ^0.0! Item was changed: ----- Method: StackInterpreter>>storeMaybeContextReceiverVariable:withValue: (in category 'stack bytecodes') ----- storeMaybeContextReceiverVariable: fieldIndex withValue: anObject "Must trap accesses to married and widowed contexts. But don't want to check on all inst var accesses. This method is only used by the long-form bytecodes, evading the cost." | rcvr | rcvr := self receiver. (fieldIndex <= ReceiverIndex + and: [(objectMemory isContextNonInt: rcvr) - and: [(self isContextNonInt: rcvr) and: [self isMarriedOrWidowedContext: rcvr]]) ifTrue: [self instVar: fieldIndex ofContext: rcvr put: anObject] ifFalse: [objectMemory storePointer: fieldIndex ofObject: rcvr withValue: anObject] ! Item was removed: - ----- Method: StackInterpreter>>sufficientSpaceToInstantiate:indexableSize: (in category 'object access primitives') ----- - sufficientSpaceToInstantiate: classOop indexableSize: size - "Return the number of bytes required to allocate an instance of the given class with the given number of indexable fields." - "Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line." - | format atomSize| - <inline: true> - format := self instSpecOfClass: classOop. - - "fail if attempting to call new: on non-indexable class" - ((self cCoerce: size to: 'usqInt ') > 0 and: [format < 2]) - ifTrue: [^ false]. - - format < 8 - ifTrue: ["indexable fields are words or pointers" atomSize := BytesPerWord] - ifFalse: ["indexable fields are bytes" atomSize := 1]. - ^objectMemory sufficientSpaceToAllocate: 2500 + (size * atomSize)! Item was changed: ----- Method: StackInterpreterPrimitives>>primitiveClone (in category 'object access primitives') ----- primitiveClone "Return a shallow copy of the receiver. Special-case non-single contexts (because of context-to-stack mapping). Can't fail for contexts cuz of image context instantiation code (sigh)." | rcvr newCopy | rcvr := self stackTop. (objectMemory isIntegerObject: rcvr) ifTrue: [newCopy := rcvr] ifFalse: + [(objectMemory isContextNonInt: rcvr) - [(self isContextNonInt: rcvr) ifTrue: [newCopy := self cloneContext: rcvr] ifFalse: [newCopy := objectMemory clone: rcvr]. newCopy = 0 ifTrue: [^self primitiveFailFor: PrimErrNoMemory]]. self pop: 1 thenPush: newCopy! Item was changed: ----- Method: StackInterpreterPrimitives>>primitiveContextAt (in category 'indexing primitives') ----- primitiveContextAt "Special version of primitiveAt for accessing contexts. Written to be varargs for use from mirror primitives." | index value aContext spouseFP hdr fmt totalLength fixedFields stSize | <inline: false> <var: #spouseFP type: #'char *'> index := self stackTop. (objectMemory isIntegerObject: index) ifFalse: [^self primitiveFailFor: PrimErrBadArgument]. index := objectMemory integerValueOf: index. aContext := self stackValue: 1. "Duplicating much of stObject:at:put: here allows stObject:at:put: to omit tests for contexts." hdr := objectMemory baseHeader: aContext. (objectMemory isContextHeader: hdr) ifFalse: "might be an instance of a subclass" [value := self stObject: aContext at: index. + ^self successful ifTrue: + [self pop: argumentCount + 1 thenPush: value]]. - ^self pop: argumentCount thenPush: value]. self externalWriteBackHeadFramePointers. (self isStillMarriedContext: aContext) ifFalse: [fmt := objectMemory formatOfHeader: hdr. totalLength := objectMemory lengthOf: aContext baseHeader: hdr format: fmt. fixedFields := objectMemory fixedFieldsOf: aContext format: fmt length: totalLength. + stSize := self fetchStackPointerOf: aContext. - stSize := self stackPointerForMaybeMarriedContext: aContext. (index between: 1 and: stSize) ifFalse: [^self primitiveFailFor: PrimErrBadIndex]. value := self subscript: aContext with: (index + fixedFields) format: fmt. ^self pop: argumentCount + 1 thenPush: value]. spouseFP := self frameOfMarriedContext: aContext. (index between: 1 and: (self stackPointerIndexForFrame: spouseFP)) ifFalse: [^self primitiveFailFor: PrimErrBadIndex]. value := self temporary: index - 1 in: spouseFP. self pop: argumentCount + 1 thenPush: value! Item was changed: ----- Method: StackInterpreterPrimitives>>primitiveContextAtPut (in category 'indexing primitives') ----- primitiveContextAtPut "Special version of primitiveAtPut for accessing contexts. Written to be varargs for use from mirror primitives." | index value aContext spouseFP hdr fmt totalLength fixedFields stSize | <inline: false> <var: #spouseFP type: #'char *'> value := self stackTop. index := self stackValue: 1. aContext := self stackValue: 2. (objectMemory isIntegerObject: index) ifFalse: [^self primitiveFailFor: PrimErrBadArgument]. "Duplicating much of stObject:at:put: here allows stObject:at:put: to omit tests for contexts." hdr := objectMemory baseHeader: aContext. index := objectMemory integerValueOf: index. (objectMemory isContextHeader: hdr) ifFalse: "might be an instance of a subclass" [self stObject: aContext at: index put: value. + ^self successful ifTrue: + [self pop: argumentCount + 1 thenPush: value]]. - ^self pop: argumentCount + 1 thenPush: value]. self externalWriteBackHeadFramePointers. (self isStillMarriedContext: aContext) ifFalse: [fmt := objectMemory formatOfHeader: hdr. totalLength := objectMemory lengthOf: aContext baseHeader: hdr format: fmt. fixedFields := objectMemory fixedFieldsOf: aContext format: fmt length: totalLength. + stSize := self fetchStackPointerOf: aContext. - stSize := self stackPointerForMaybeMarriedContext: aContext. (index between: 1 and: stSize) ifFalse: [^self primitiveFailFor: PrimErrBadIndex]. self subscript: aContext with: (index + fixedFields) storing: value format: fmt. ^self pop: argumentCount + 1 thenPush: value]. spouseFP := self frameOfMarriedContext: aContext. (index between: 1 and: (self stackPointerIndexForFrame: spouseFP)) ifFalse: [^self primitiveFailFor: PrimErrBadIndex]. self temporary: index - 1 in: spouseFP put: value. ^self pop: argumentCount + 1 thenPush: value! Item was changed: ----- Method: StackInterpreterPrimitives>>primitiveCopyObject (in category 'object access primitives') ----- primitiveCopyObject "Primitive. Copy the state of the receiver from the argument. Fail if receiver and argument are of a different class. Fail if the receiver or argument are non-pointer objects. Fail if the receiver or argument are contexts (because of context-to-stack mapping). Fail if receiver and argument have different lengths (for indexable objects). " | rcvr arg length | self methodArgumentCount = 1 ifFalse: [^self primitiveFail]. arg := self stackObjectValue: 0. rcvr := self stackObjectValue: 1. self failed ifTrue:[^nil]. (objectMemory isPointers: rcvr) ifFalse: [^self primitiveFail]. + ((objectMemory isContextNonInt: rcvr) + or: [objectMemory isContextNonInt: arg]) ifTrue: - ((self isContextNonInt: rcvr) - or: [self isContextNonInt: arg]) ifTrue: [^self primitiveFail]. (objectMemory fetchClassOfNonInt: rcvr) = (objectMemory fetchClassOfNonInt: arg) ifFalse: [^self primitiveFail]. length := objectMemory lengthOf: rcvr. length = (objectMemory lengthOf: arg) ifFalse: [^self primitiveFail]. "Now copy the elements" + 0 to: length-1 do: + [:i| - 0 to: length-1 do:[:i| objectMemory storePointer: i ofObject: rcvr withValue: (objectMemory fetchPointer: i ofObject: arg)]. "Note: The above could be faster for young receivers but I don't think it'll matter" + self pop: 1 "pop arg; answer receiver" - self pop: 1. "pop arg; answer receiver" ! Item was changed: ----- Method: StackInterpreterPrimitives>>primitiveDoNamedPrimitiveWithArgs (in category 'plugin primitives') ----- primitiveDoNamedPrimitiveWithArgs "Simulate an primitiveExternalCall invocation (e.g. for the Debugger). Do not cache anything. e.g. ContextPart>>tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments" | argumentArray arraySize methodArg methodHeader moduleName functionName moduleLength functionLength + spec addr primRcvr ctxtRcvr isArray | - spec addr primRcvr ctxtRcvr | <var: #addr declareC: 'void (*addr)()'> argumentArray := self stackTop. (objectMemory isArray: argumentArray) ifFalse: [^self primitiveFailFor: -2]. "invalid args" arraySize := objectMemory fetchWordLengthOf: argumentArray. self success: (self roomToPushNArgs: arraySize). methodArg := self stackObjectValue: 2. self successful ifFalse: [^self primitiveFailFor: -2]. "invalid args" (objectMemory isOopCompiledMethod: methodArg) ifFalse: [^self primitiveFailFor: -2]. "invalid args" methodHeader := self headerOf: methodArg. (self literalCountOfHeader: methodHeader) > 2 ifFalse: [^self primitiveFailFor: -3]. "invalid methodArg state" + isArray := objectMemory + is: (spec := objectMemory fetchPointer: 1 "first literal" ofObject: methodArg) + instanceOf: (objectMemory splObj: ClassArray) + compactClassIndex: ClassArrayCompactIndex. + (isArray - (self assertClassOf: (spec := objectMemory fetchPointer: 1 "first literal" ofObject: methodArg) - is: (objectMemory splObj: ClassArray) - compactClassIndex: ClassArrayCompactIndex). - (self successful and: [(objectMemory lengthOf: spec) = 4 and: [(self primitiveIndexOfMethodHeader: methodHeader) = 117]]) ifFalse: [^self primitiveFailFor: -3]. "invalid methodArg state" (self argumentCountOfMethodHeader: methodHeader) = arraySize ifFalse: [^self primitiveFailFor: -2]. "invalid args (Array args wrong size)" "The function has not been loaded yet. Fetch module and function name." moduleName := objectMemory fetchPointer: 0 ofObject: spec. moduleName = objectMemory nilObject ifTrue: [moduleLength := 0] ifFalse: [self success: (objectMemory isBytes: moduleName). moduleLength := objectMemory lengthOf: moduleName. self cCode: '' inSmalltalk: [ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName)) "??" ifTrue: [moduleLength := 0 "Cause all of these to fail"]]]. functionName := objectMemory fetchPointer: 1 ofObject: spec. self success: (objectMemory isBytes: functionName). functionLength := objectMemory lengthOf: functionName. self successful ifFalse: [^self primitiveFailFor: -3]. "invalid methodArg state" addr := self ioLoadExternalFunction: functionName + BaseHeaderSize OfLength: functionLength FromModule: moduleName + BaseHeaderSize OfLength: moduleLength. addr = 0 ifTrue: [^self primitiveFailFor: -1]. "could not find function; answer generic failure (see below)" "Cannot fail this primitive from now on. Can only fail the external primitive." objectMemory pushRemappableOop: (argumentArray := self popStack). objectMemory pushRemappableOop: (primRcvr := self popStack). objectMemory pushRemappableOop: self popStack. "the method" objectMemory pushRemappableOop: self popStack. "the context receiver" self push: primRcvr. "replace context receiver with actual receiver" argumentCount := arraySize. 1 to: arraySize do: [:index| self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray)]. "Run the primitive (sets primFailCode)" lkupClass := objectMemory nilObject. self callExternalPrimitive: addr. ctxtRcvr := objectMemory popRemappableOop. methodArg := objectMemory popRemappableOop. primRcvr := objectMemory popRemappableOop. argumentArray := objectMemory popRemappableOop. self successful ifFalse: "If primitive failed, then restore state for failure code" [self pop: arraySize + 1. self push: ctxtRcvr. self push: methodArg. self push: primRcvr. self push: argumentArray. argumentCount := 3. "Hack. A nil prim error code (primErrorCode = 1) is interpreted by the image as meaning this primitive is not implemented. So to pass back nil as an error code we use -1 to indicate generic failure." primFailCode = 1 ifTrue: [primFailCode := -1]]! Item was changed: ----- Method: StackInterpreterPrimitives>>primitivePerform (in category 'control primitives') ----- primitivePerform <returnTypeC: #void> | performSelector newReceiver lookupClass performMethod | performSelector := messageSelector. performMethod := newMethod. messageSelector := self stackValue: argumentCount - 1. newReceiver := self stackValue: argumentCount. "NOTE: the following lookup may fail and be converted to #doesNotUnderstand:, so we must adjust argumentCount and slide args now, so that will work." "Slide arguments down over selector" argumentCount := argumentCount - 1. argumentCount to: 1 by: -1 do: [:i| stackPages longAt: stackPointer + (i * BytesPerWord) put: (stackPages longAt: stackPointer + ((i - 1) * BytesPerWord))]. self pop: 1. lookupClass := objectMemory fetchClassOf: newReceiver. self sendBreak: messageSelector + BaseHeaderSize point: (objectMemory lengthOf: messageSelector) receiver: newReceiver. + self printSends ifTrue: + [self printActivationNameForSelector: messageSelector startClass: lookupClass; cr]. self findNewMethodInClass: lookupClass. "Only test CompiledMethods for argument count - other objects will have to take their chances" ((objectMemory isOopCompiledMethod: newMethod) and: [(self argumentCountOf: newMethod) = argumentCount]) ifFalse: ["Slide the args back up (sigh) and re-insert the selector." self unPop: 1. 1 to: argumentCount by: 1 do: [:i | stackPages longAt: stackPointer + ((i - 1) * BytesPerWord) put: (stackPages longAt: stackPointer + (i * BytesPerWord))]. stackPages longAt: stackPointer + (argumentCount * BytesPerWord) put: messageSelector. argumentCount := argumentCount + 1. newMethod := performMethod. messageSelector := performSelector. ^self primitiveFail]. self executeNewMethod. "Recursive xeq affects primErrorCode" self initPrimCall! Item was changed: ----- Method: StackToRegisterMappingCogit class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCodeGen aCodeGen var: #methodAbortTrampolines declareC: 'sqInt methodAbortTrampolines[4]'; var: #picAbortTrampolines declareC: 'sqInt picAbortTrampolines[4]'; var: #picMissTrampolines declareC: 'sqInt picMissTrampolines[4]'; var: 'ceEnter0ArgsPIC' declareC: 'void (*ceEnter0ArgsPIC)(void)'; var: 'ceEnter1ArgsPIC' declareC: 'void (*ceEnter1ArgsPIC)(void)'; var: 'ceEnter2ArgsPIC' declareC: 'void (*ceEnter2ArgsPIC)(void)'; var: #ceEnterCogCodePopReceiverArg0Regs declareC: 'void (*ceEnterCogCodePopReceiverArg0Regs)(void)'; var: #realCEEnterCogCodePopReceiverArg0Regs declareC: 'void (*realCEEnterCogCodePopReceiverArg0Regs)(void)'; var: #ceEnterCogCodePopReceiverArg1Arg0Regs declareC: 'void (*ceEnterCogCodePopReceiverArg1Arg0Regs)(void)'; var: #realCEEnterCogCodePopReceiverArg1Arg0Regs declareC: 'void (*realCEEnterCogCodePopReceiverArg1Arg0Regs)(void)'; var: 'simStack' + declareC: 'CogSimStackEntry simStack[', ((CoInterpreter bindingOf: #LargeContextSize) value * 5 / 4 // BytesPerWord) asString, ']'; - declareC: 'CogSimStackEntry simStack[256]'; var: 'simSelf' type: #CogSimStackEntry; var: #optStatus type: #CogSSOptStatus. aCodeGen addSelectorTranslation: #register to: (aCodeGen cFunctionNameFor: 'registerr'); addSelectorTranslation: #register: to: (aCodeGen cFunctionNameFor: 'registerr:')! Item was added: + ----- Method: StackToRegisterMappingCogit>>genPrimitiveNotEquivalent (in category 'primitive generators') ----- + genPrimitiveNotEquivalent + "Receiver and arg in registers. + Stack looks like + return address" + | jumpFalse | + <var: #jumpFalse type: #'AbstractInstruction *'> + self CmpR: Arg0Reg R: ReceiverResultReg. + jumpFalse := self JumpZero: 0. + self annotate: (self MoveCw: objectMemory trueObject R: ReceiverResultReg) + objRef: objectMemory trueObject. + self RetN: 0. + jumpFalse jmpTarget: (self annotate: (self MoveCw: objectMemory falseObject R: ReceiverResultReg) + objRef: objectMemory falseObject). + self RetN: 0. + ^0! Item was changed: ----- Method: TMethod>>prepareMethodIn: (in category 'transformations') ----- prepareMethodIn: aCodeGen "Record sends of builtin operators, map sends of the special selector dispatchOn:in: with case statement nodes, and map sends of caseOf:[otherwise:] to switch statements. Note: Only replaces top-level sends of dispatchOn:in: et al and caseOf:[otherwise:]. These must be top-level statements; they cannot appear in expressions. As a hack also update the types of variables introduced to implement cascades correctly. This has to be done at teh same time as this is done, so why not piggy back here?" | replacements |. cascadeVariableNumber ifNotNil: [declarations keysAndValuesDo: [:varName :decl| decl isBlock ifTrue: [self assert: ((varName beginsWith: 'cascade') and: [varName last isDigit]). locals add: varName. self declarationAt: varName put: (decl value: self value: aCodeGen), ' ', varName]]]. replacements := IdentityDictionary new. parseTree nodesDo: [:node| node isSend ifTrue: [(aCodeGen builtin: node selector) ifTrue: [node isBuiltinOperator: true] ifFalse: [(CaseStatements includes: node selector) ifTrue: [replacements at: node put: (self buildCaseStmt: node)]. (#(caseOf: #caseOf:otherwise:) includes: node selector) ifTrue: [replacements at: node put: (self buildSwitchStmt: node)]]]. ((node isAssignment or: [node isReturn]) and: [node expression isSwitch]) ifTrue: [replacements at: node put: (self transformSwitchExpression: node)]]. + replacements isEmpty ifFalse: + [parseTree := parseTree replaceNodesIn: replacements] + ! - [parseTree := parseTree replaceNodesIn: replacements]! Item was changed: ----- Method: ThreadedFFICalloutStateForARM class>>instVarNamesAndTypesForTranslationDo: (in category 'translation') ----- instVarNamesAndTypesForTranslationDo: aBinaryBlock "enumerate aBinaryBlock with the names and C type strings for the inst vars to include in a ReentrantFFICalloutState struct." superclass instVarNamesAndTypesForTranslationDo: aBinaryBlock. self instVarNames do: [:ivn| aBinaryBlock value: ivn value: (ivn caseOf: { + ['integerRegisters'] -> [{#sqInt. '[', ThreadedARMFFIPlugin numRegArgs printString, ']'}] } - ['integerRegisters'] -> [{#sqInt. '[', ReentrantARMFFIPlugin numRegArgs printString, ']'}] } otherwise: [#sqInt])]! Item was changed: ----- Method: ThreadedFFICalloutStateForPPC class>>instVarNamesAndTypesForTranslationDo: (in category 'translation') ----- instVarNamesAndTypesForTranslationDo: aBinaryBlock "enumerate aBinaryBlock with the names and C type strings for the inst vars to include in a ReentrantFFICalloutState struct." superclass instVarNamesAndTypesForTranslationDo: aBinaryBlock. self instVarNames do: [:ivn| aBinaryBlock value: ivn value: (ivn caseOf: { + ['integerRegisters'] -> [{#sqInt. '[', ThreadedPPCBEFFIPlugin numRegArgs printString, ']'}]. + ['floatRegisters'] -> [{#double. '[', ThreadedPPCBEFFIPlugin numRegArgs printString, ']'}] } - ['integerRegisters'] -> [{#sqInt. '[', ReentrantPPCBEFFIPlugin numRegArgs printString, ']'}]. - ['floatRegisters'] -> [{#double. '[', ReentrantPPCBEFFIPlugin numRegArgs printString, ']'}] } otherwise: [#sqInt])]! Item was changed: ----- Method: ThreadedFFIPlugin class>>preambleCCode (in category 'translation') ----- preambleCCode "For a source of builtin defines grep for builtin_define in a gcc release config directory." ^' #include "sqAssert.h" /* for assert */ - #undef halt /* sqAssert.h provides a halt used in the interpreter */ #ifdef _MSC_VER # define alloca _alloca #endif #if defined(__GNUC__) && (defined(_X86_) || defined(i386) || defined(__i386) || defined(__i386__)) # define setsp(sp) asm volatile ("movl %0,%%esp" : : "m"(sp)) # define getsp() ({ void *esp; asm volatile ("movl %%esp,%0" : "=r"(esp) : ); esp;}) #endif #if !!defined(getsp) # define getsp() 0 #endif #if !!defined(setsp) # define setsp(ignored) 0 #endif #if !!defined(STACK_ALIGN_BYTES) # if __APPLE__ && __MACH__ && __i386__ # define STACK_ALIGN_BYTES 16 # elif __linux__ && __i386__ # define STACK_ALIGN_BYTES 16 # elif defined(__amd64__) || defined(__x86_64__) || defined(__amd64) || defined(__x86_64) # define STACK_ALIGN_BYTES 16 # elif defined(powerpc) || defined(__powerpc__) || defined(_POWER) || defined(__POWERPC__) || defined(__PPC__) # define STACK_ALIGN_BYTES 16 # elif defined(__sparc64__) || defined(__sparcv9__) || defined(__sparc_v9__) /* must preceed 32-bit sparc defs */ # define STACK_ALIGN_BYTES 16 # elif defined(sparc) || defined(__sparc__) || defined(__sparclite__) # define STACK_ALIGN_BYTES 8 # else # define STACK_ALIGN_BYTES 0 # endif #endif /* !!defined(STACK_ALIGN_BYTES) */ #if !!defined(STACK_OFFSET_BYTES) # define STACK_OFFSET_BYTES 0 #endif #if defined(_X86_) || defined(i386) || defined(__i386) || defined(__i386__) /* Both Mac OS X x86 and Win32 x86 return structs of a power of two in size * less than or equal to eight bytes in length in registers. Linux never does so. */ # if __linux__ # define WIN32_X86_STRUCT_RETURN 0 # else # define WIN32_X86_STRUCT_RETURN 1 # endif # if WIN32 # define PLATFORM_API_USES_CALLEE_POPS_CONVENTION 1 # else # define PLATFORM_API_USES_CALLEE_POPS_CONVENTION 0 # endif # if defined(__MINGW32__) && (__GNUC__ >= 3) /* * cygwin -mno-cygwin (MinGW) gcc 3.4.x''s alloca is a library routine that answers * %esp + 4, so the outgoing stack is offset by one word if uncorrected. * Grab the actual stack pointer to correct. */ # define ALLOCA_LIES_SO_USE_GETSP 1 # endif #endif /* defined(_X86_) || defined(i386) || defined(__i386) || defined(__i386__) */ #if !!defined(ALLOCA_LIES_SO_USE_GETSP) # define ALLOCA_LIES_SO_USE_GETSP 0 #endif /* The dispatchOn:in:with:with: generates an unwanted call on error. Just squash it. */ #define error(foo) 0 /* but print assert failures. */ void warning(char *s) { /* Print an error message but don''t exit. */ printf("\n%s\n", s); } '! Item was added: + ----- Method: VMClass>>mem:cp:y: (in category 'C library simulation') ----- + mem: aString cp: bString y: n + <doNotGenerate> + "implementation of memcpy(3)" + ^self st: aString rn: bString cpy: n! Item was changed: ----- Method: VMClass>>sizeof: (in category 'translation support') ----- sizeof: objectSymbolOrClass <doNotGenerate> | index | objectSymbolOrClass isInteger ifTrue: [self flag: #Dan. ^BytesPerWord]. objectSymbolOrClass isSymbol ifTrue: [(objectSymbolOrClass last == $* or: [#long == objectSymbolOrClass or: [#'unsigned long' == objectSymbolOrClass]]) ifTrue: [^BytesPerWord]. index := #( #sqLong #usqLong #double #int #'unsigned int' #float #short #'unsigned short' #char #'unsigned char' #'signed char') indexOf: objectSymbolOrClass ifAbsent: [self error: 'unrecognized C type name']. ^#(8 8 8 4 4 4 2 2 1 1 1) at: index]. ^(objectSymbolOrClass isBehavior ifTrue: [objectSymbolOrClass] + ifFalse: [objectSymbolOrClass class]) + alignedByteSizeOf: objectSymbolOrClass + forClient: self! - ifFalse: [objectSymbolOrClass class]) alignedByteSizeForClient: self! Item was changed: ----- Method: VMPluginCodeGenerator>>emitCHeaderOn: (in category 'C code generator') ----- emitCHeaderOn: aStream "Write a C file header onto the given stream." aStream nextPutAll: (self fileHeaderVersionStampForSourceClass: pluginClass). aStream cr; cr. #('<math.h>' '<stdio.h>' '<stdlib.h>' '<string.h>' '<time.h>') reverseDo: [:hdr| headerFiles addFirst: hdr]. "Additional header files; include C library ones first." self emitHeaderFiles: (headerFiles select: [:hdr| hdr includes: $<]) on: aStream. aStream cr; nextPutAll:'/* Default EXPORT macro that does nothing (see comment in sq.h): */ #define EXPORT(returnType) returnType /* Do not include the entire sq.h file but just those parts needed. */ /* The virtual machine proxy definition */ #include "sqVirtualMachine.h" /* Configuration options */ #include "sqConfig.h" /* Platform specific definitions */ #include "sqPlatformSpecific.h" #define true 1 #define false 0 #define null 0 /* using ''null'' because nil is predefined in Think C */ #ifdef SQUEAK_BUILTIN_PLUGIN #undef EXPORT // was #undef EXPORT(returnType) but screws NorCroft cc #define EXPORT(returnType) static returnType #endif'; cr; cr. headerFiles addLast: '"sqMemoryAccess.h"'. "Additional header files; include squeak VM ones last" self emitHeaderFiles: (headerFiles reject: [:hdr| hdr includes: $<]) on: aStream. pluginClass preambleCCode ifNotNil: [:preamble| aStream cr; nextPutAll: preamble]. aStream cr.! |
«
Return to Squeak VM
|
1 view|%1 views
| Free forum by Nabble | Edit this page |