Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.837.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.837 Author: eem Time: 28 July 2014, 7:24:22.923 pm UUID: e32a7e76-4a4d-48ae-adf6-28d22f64b157 Ancestors: VMMaker.oscog-eem.836
Sista: Provide a SistaVM flag for <option: SistaVM> pragmas.
Implement the inlined ops in callPrimitiveMethod for the current Sista spec in StackInterpreter.
Implement the SistaV1 bytecode table for StackToRegisterMappingCogit
All: Rationalize the length functions, deleting byteLengthOf:, fetchLong32LengthOf: & fetchWordLengthOf: and providing numBytesOf:, num16BitUnitsOf:, num32BitUnitsOf:, num64BitUnitsOf: and numBytesOf:.
Provide fetch/storeShort16:ofObject:[withValue:] and fetch/storeLong64:ofObject:[withValue:].
Recategorize ObjectMemory methods categorized as object access in SpurMemoryManager as object access.
Spur: provide unpinObject: for InterpreterProxy.
=============== Diff against VMMaker.oscog-eem.836 ===============
Item was changed: ----- Method: CoInterpreter>>assertValidExecutionPointe:r:s:imbar:line: (in category 'debug support') ----- assertValidExecutionPointe: lip r: lifp s: lisp imbar: inInterpreter line: ln <var: #lip type: #usqInt> <var: #lifp type: #'char *'> <var: #lisp type: #'char *'> | methodField cogMethod theIP | <var: #cogMethod type: #'CogMethod *'> self assert: stackPage = (stackPages stackPageFor: lifp) l: ln. self assert: stackPage = stackPages mostRecentlyUsedPage l: ln. self assert: (self deferStackLimitSmashAround: #assertValidStackLimits: asSymbol with: ln). self assert: lifp < stackPage baseAddress l: ln. self assert: lisp < lifp l: ln. self assert: lifp > lisp l: ln. self assert: lisp >= (stackPage realStackLimit - self stackLimitOffset) l: ln. self assert: (lifp - lisp) < LargeContextSize l: ln. methodField := self frameMethodField: lifp. inInterpreter ifTrue: [self assert: (self isMachineCodeFrame: lifp) not l: ln. self assert: method = methodField l: ln. self cppIf: MULTIPLEBYTECODESETS ifTrue: [self assert: (self methodUsesAlternateBytecodeSet: method) = (bytecodeSetSelector = 256) l: ln]. (self asserta: (objectMemory cheapAddressCouldBeInHeap: methodField) l: ln) ifTrue: [theIP := lip = cogit ceReturnToInterpreterPC ifTrue: [self iframeSavedIP: lifp] ifFalse: [lip]. self assert: (theIP >= (methodField + (objectMemory lastPointerOf: methodField)) + and: [theIP < (methodField + (objectMemory numBytesOf: methodField) + objectMemory baseHeaderSize - 1)]) - and: [theIP < (methodField + (objectMemory byteLengthOf: methodField) + objectMemory baseHeaderSize - 1)]) l: ln]. self assert: ((self iframeIsBlockActivation: lifp) or: [(self pushedReceiverOrClosureOfFrame: lifp) = (self iframeReceiver: lifp)]) l: ln] ifFalse: [self assert: (self isMachineCodeFrame: lifp) l: ln. ((self asserta: methodField asUnsignedInteger >= cogit minCogMethodAddress l: ln) and: [self asserta: methodField asUnsignedInteger < cogit maxCogMethodAddress l: ln]) ifTrue: [cogMethod := self mframeHomeMethod: lifp. self assert: (lip > (methodField + ((self mframeIsBlockActivation: lifp) ifTrue: [self sizeof: CogBlockMethod] ifFalse: [self sizeof: CogMethod])) and: [lip < (methodField + cogMethod blockSize)]) l: ln]. self assert: ((self mframeIsBlockActivation: lifp) or: [(self pushedReceiverOrClosureOfFrame: lifp) = (self mframeReceiver: lifp)]) l: ln]. (self isBaseFrame: lifp) ifTrue: [self assert: (self frameHasContext: lifp) l: ln. self assert: (self frameContext: lifp) = (stackPages longAt: stackPage baseAddress - BytesPerWord) l: ln]!
Item was changed: ----- Method: CoInterpreter>>assertValidStackedInstructionPointersIn:line: (in category 'debug support') ----- assertValidStackedInstructionPointersIn: aStackPage line: ln "Check that the stacked instruction pointers in the given page are correct. Checks the interpreter sender/machine code callee contract." <var: #aStackPage type: #'StackPage *'> <var: #theFP type: #'char *'> <var: #callerFP type: #'char *'> <var: #theIP type: #usqInt> <var: #theMethod type: #'CogMethod *'> <inline: false> | prevFrameWasCogged theFP callerFP theMethod theIP methodObj | (self asserta: (stackPages isFree: aStackPage) not l: ln) ifFalse: [^false]. prevFrameWasCogged := false. "The top of stack of an inactive page is always the instructionPointer. The top of stack of the active page may be the instructionPointer if it has been pushed, which is indicated by a 0 instructionPointer." (stackPage = aStackPage and: [instructionPointer ~= 0]) ifTrue: [theIP := instructionPointer. theFP := framePointer] ifFalse: [theIP := (stackPages longAt: aStackPage headSP) asUnsignedInteger. theFP := aStackPage headFP. stackPage = aStackPage ifTrue: [self assert: framePointer = theFP l: ln]]. [(self isMachineCodeFrame: theFP) ifTrue: [theMethod := self mframeHomeMethod: theFP. self assert: (theIP = cogit ceCannotResumePC or: [theIP >= theMethod asUnsignedInteger and: [theIP < (theMethod asUnsignedInteger + theMethod blockSize)]]) l: ln. prevFrameWasCogged := true] ifFalse: "assert-check the interpreter frame." [methodObj := self iframeMethod: theFP. prevFrameWasCogged ifTrue: [self assert: theIP = cogit ceReturnToInterpreterPC l: ln]. theIP = cogit ceReturnToInterpreterPC ifTrue: [theIP := self iframeSavedIP: theFP]. self assert: (theIP >= (methodObj + (objectMemory lastPointerOf: methodObj)) + and: [theIP < (methodObj + (objectMemory numBytesOf: methodObj) + objectMemory baseHeaderSize - 1)]) - and: [theIP < (methodObj + (objectMemory byteLengthOf: methodObj) + objectMemory baseHeaderSize - 1)]) l: ln. prevFrameWasCogged := false]. theIP := (stackPages longAt: theFP + FoxCallerSavedIP) asUnsignedInteger. (callerFP := self frameCallerFP: theFP) ~= 0] whileTrue: [theFP := callerFP]. self assert: theIP = cogit ceBaseFrameReturnPC l: ln. ^true!
Item was changed: ----- Method: CoInterpreter>>printMethodCacheFor: (in category 'debug printing') ----- printMethodCacheFor: thing <api> 0 to: MethodCacheSize - 1 by: MethodCacheEntrySize do: [:i | | s c m p | s := methodCache at: i + MethodCacheSelector. c := methodCache at: i + MethodCacheClass. m := methodCache at: i + MethodCacheMethod. p := methodCache at: i + MethodCachePrimFunction. ((thing = -1 or: [s = thing or: [c = thing or: [p = thing or: [m = thing or: [(objectMemory addressCouldBeObj: m) and: [(self maybeMethodHasCogMethod: m) and: [(self cogMethodOf: m) asInteger = thing]]]]]]]) and: [(objectMemory addressCouldBeOop: s) and: [c ~= 0 and: [(self addressCouldBeClassObj: c) or: [self addressCouldBeClassObj: (objectMemory classForClassTag: c)]]]]) ifTrue: [self cCode: [] inSmalltalk: [self transcript ensureCr]. self printNum: i; cr; tab. (objectMemory isBytesNonImm: s) + ifTrue: [self cCode: 'printf("%x %.*s\n", s, numBytesOf(s), (char *)firstIndexableField(s))' - ifTrue: [self cCode: 'printf("%x %.*s\n", s, byteLengthOf(s), (char *)firstIndexableField(s))' inSmalltalk: [self printHex: s; space; print: (self stringOf: s); cr]] ifFalse: [self shortPrintOop: s]. self tab. (self addressCouldBeClassObj: c) ifTrue: [self shortPrintOop: c] ifFalse: [self printNum: c; space; shortPrintOop: (objectMemory classForClassTag: c)]. self tab; shortPrintOop: m; tab. self cCode: [p > 1024 ifTrue: [self printHexnp: p] ifFalse: [self printNum: p]] inSmalltalk: [p isSymbol ifTrue: [self print: p] ifFalse: [self printNum: p]]. self cr]]!
Item was changed: ----- Method: CoInterpreterMT>>wakeHighestPriority (in category 'process primitive support') ----- wakeHighestPriority "Return the highest priority process that is ready to run. To save time looking at many empty lists before finding a runnable process the VM maintains a variable holding the highest priority runnable process. If this variable is 0 then the VM does not know the highest priority and must search all lists.
Override to answer nil when there is no runnable process instead of aborting. In the threaded VM the abort test is done in transferTo:from: becaue there may be some thread waiting to own the VM. The transfer to the thread shouldn't be done here because not all clients call this in the right context (allowing a longjmp back to the threadSchedulingLoop)." | schedLists p processList proc ctxt | schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer. p := highestRunnableProcessPriority = 0 + ifTrue: [objectMemory numSlotsOf: schedLists] - ifTrue: [objectMemory fetchWordLengthOf: schedLists] ifFalse: [highestRunnableProcessPriority]. [(p := p - 1) >= 0] whileTrue: [processList := objectMemory fetchPointer: p ofObject: schedLists. [self isEmptyList: processList] whileFalse: ["Only answer processes with a runnable suspendedContext. Discard those that aren't; the VM would crash otherwise." proc := self removeFirstLinkOfList: processList. ctxt := objectMemory fetchPointer: SuspendedContextIndex ofObject: proc. (self isLiveContext: ctxt) ifTrue: [highestRunnableProcessPriority := p + 1. ^proc]. self warning: 'evicted zombie process from run queue']]. ^nil!
Item was changed: ----- Method: CogVMSimulator>>classAndSelectorOfMethod:forReceiver: (in category 'debug support') ----- classAndSelectorOfMethod: meth forReceiver: rcvr | mClass dict length methodArray | mClass := objectMemory fetchClassOf: rcvr. [dict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: mClass. + length := objectMemory numSlotsOf: dict. - length := objectMemory fetchWordLengthOf: dict. methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dict. 0 to: length-SelectorStart-1 do: [:index | meth = (objectMemory fetchPointer: index ofObject: methodArray) ifTrue: [^ Array with: mClass with: (objectMemory fetchPointer: index + SelectorStart ofObject: dict)]]. mClass := objectMemory fetchPointer: SuperclassIndex ofObject: mClass. mClass = objectMemory nilObject] whileFalse: []. ^ Array with: (objectMemory fetchClassOf: rcvr) with: (objectMemory splObj: SelectorDoesNotUnderstand)!
Item was changed: ----- Method: Cogit>>bcpcsAndDescriptorsFor:do: (in category 'tests-method map') ----- bcpcsAndDescriptorsFor: aMethod do: trinaryBlock <doNotGenerate> | bsOffset nExts byte descriptor endpc latestContinuation pc primIdx | ((primIdx := coInterpreter primitiveIndexOf: aMethod) > 0 and: [coInterpreter isQuickPrimitiveIndex: primIdx]) ifTrue: [^self]. latestContinuation := pc := coInterpreter startPCOfMethod: aMethod. trinaryBlock value: pc value: nil value: nil. "stackCheck/entry pc" bsOffset := self bytecodeSetOffsetFor: aMethod. nExts := 0. + endpc := objectMemory numBytesOf: aMethod. - endpc := objectMemory byteLengthOf: aMethod. [pc <= endpc] whileTrue: [byte := objectMemory fetchByte: pc ofObject: aMethod. descriptor := self generatorAt: byte + bsOffset. trinaryBlock value: pc value: byte value: descriptor. (descriptor isReturn and: [pc >= latestContinuation]) ifTrue: [endpc := pc]. (descriptor isBranch or: [descriptor isBlockCreation]) ifTrue: [| targetPC | descriptor isBlockCreation ifTrue: [trinaryBlock value: pc + descriptor numBytes value: nil value: nil]. "stackCheck/entry pc" targetPC := self latestContinuationPCFor: descriptor at: pc exts: nExts in: aMethod. self assert: targetPC < endpc. latestContinuation := latestContinuation max: targetPC]. pc := pc + descriptor numBytes. nExts := descriptor isExtension ifTrue: [nExts + 1] ifFalse: [0]]!
Item was changed: ----- Method: Cogit>>blockStartPcsIn: (in category 'disassembly') ----- blockStartPcsIn: aMethod "Answer the start bytecopde pcs in a method in compilation order, i.e. depth-first. Blocks must occur in pc/depth-first order for binary tree block dispatch to work." | startpcs pc latestContinuation end descriptor byte bsOffset nExts | <doNotGenerate> startpcs := OrderedCollection new. startpcs add: (pc := latestContinuation := coInterpreter startPCOfMethod: aMethod). + end := objectMemory numBytesOf: aMethod. - end := objectMemory byteLengthOf: aMethod. bsOffset := self bytecodeSetOffsetFor: aMethod. nExts := 0. [pc <= end] whileTrue: [byte := objectMemory fetchByte: pc ofObject: aMethod. descriptor := self generatorAt: byte + bsOffset. (descriptor isReturn and: [pc >= latestContinuation]) ifTrue: [end := pc]. (descriptor isBranch or: [descriptor isBlockCreation]) ifTrue: [| targetPC | targetPC := self latestContinuationPCFor: descriptor at: pc exts: nExts in: aMethod. latestContinuation := latestContinuation max: targetPC]. pc := pc + descriptor numBytes. descriptor isBlockCreation ifTrue: [startpcs add: pc]. nExts := descriptor isExtension ifTrue: [nExts + 1] ifFalse: [0]]. ^startpcs!
Item was changed: ----- Method: Cogit>>compileCogMethod: (in category 'compile abstract instructions') ----- compileCogMethod: selector <returnTypeC: #'CogMethod *'> | numBytecodes numBlocks numCleanBlocks result extra | hasYoungReferent := (objectMemory isYoungObject: methodObj) or: [objectMemory isYoung: selector]. methodOrBlockNumArgs := coInterpreter argumentCountOf: methodObj. inBlock := false. primInvokeLabel := nil. postCompileHook := nil. maxLitIndex := -1. extra := ((primitiveIndex := coInterpreter primitiveIndexOf: methodObj) > 0 and: [(coInterpreter isQuickPrimitiveIndex: primitiveIndex) not]) ifTrue: [30] ifFalse: [10]. initialPC := coInterpreter startPCOfMethod: methodObj. "initial estimate. Actual endPC is determined in scanMethod." endPC := (coInterpreter isQuickPrimitiveIndex: primitiveIndex) ifTrue: [initialPC - 1] + ifFalse: [objectMemory numBytesOf: methodObj]. - ifFalse: [objectMemory byteLengthOf: methodObj]. numBytecodes := endPC - initialPC + 1. self allocateOpcodes: (numBytecodes + extra) * 10 bytecodes: numBytecodes ifFail: [^coInterpreter cCoerceSimple: MethodTooBig to: #'CogMethod *']. (numBlocks := self scanMethod) < 0 ifTrue: [^coInterpreter cCoerceSimple: numBlocks to: #'CogMethod *']. numCleanBlocks := self scanForCleanBlocks. self allocateBlockStarts: numBlocks + numCleanBlocks. blockCount := 0. numCleanBlocks > 0 ifTrue: [self addCleanBlockStarts]. (self maybeAllocAndInitCounters and: [self maybeAllocAndInitIRCs]) ifFalse: "Inaccurate error code, but it'll do. This will likely never fail." [^coInterpreter cCoerceSimple: InsufficientCodeSpace to: #'CogMethod *']. blockEntryLabel := nil. methodLabel dependent: nil. (result := self compileEntireMethod) < 0 ifTrue: [^coInterpreter cCoerceSimple: result to: #'CogMethod *']. ^self generateCogMethod: selector!
Item was changed: ----- Method: Cogit>>endPCOf: (in category 'compiled methods') ----- endPCOf: aMethod <var: #descriptor type: #'BytecodeDescriptor *'> | pc end latestContinuation descriptor prim distance targetPC byte bsOffset nExts | pc := latestContinuation := coInterpreter startPCOfMethod: aMethod. (prim := coInterpreter primitiveIndexOf: aMethod) > 0 ifTrue: [(coInterpreter isQuickPrimitiveIndex: prim) ifTrue: [^pc - 1]]. bsOffset := self bytecodeSetOffsetFor: aMethod. nExts := 0. + end := objectMemory numBytesOf: aMethod. - end := objectMemory byteLengthOf: aMethod. [pc <= end] whileTrue: [byte := objectMemory fetchByte: pc ofObject: aMethod. descriptor := self generatorAt: byte + bsOffset. (descriptor isReturn and: [pc >= latestContinuation]) ifTrue: [end := pc]. (descriptor isBranch or: [descriptor isBlockCreation]) ifTrue: [distance := self spanFor: descriptor at: pc exts: nExts in: aMethod. targetPC := pc + descriptor numBytes + distance. latestContinuation := latestContinuation max: targetPC. descriptor isBlockCreation ifTrue: [pc := pc + distance]]. nExts := descriptor isExtension ifTrue: [nExts + 1] ifFalse: [0]. pc := pc + descriptor numBytes]. ^end!
Item was changed: ----- Method: Cogit>>mapFor:bcpc:performUntil:arg: (in category 'method map') ----- mapFor: cogMethod bcpc: startbcpc performUntil: functionSymbol arg: arg "Machine-code <-> bytecode pc mapping support. Evaluate functionSymbol for each mcpc, bcpc pair in the map until the function returns non-zero, answering that result, or 0 if it fails to. This works only for frameful methods." <var: #cogMethod type: #'CogBlockMethod *'> <var: #functionSymbol declareC: 'sqInt (*functionSymbol)(BytecodeDescriptor *desc, sqInt isBackwardBranch, char *mcpc, sqInt bcpc, void *arg)'> <var: #arg type: #'void *'> <inline: true> | isInBlock mcpc bcpc endbcpc map mapByte homeMethod aMethodObj result latestContinuation byte descriptor bsOffset nExts | <var: #descriptor type: #'BytecodeDescriptor *'> <var: #homeMethod type: #'CogMethod *'> self assert: cogMethod stackCheckOffset > 0. "In both CMMethod and CMBlock cases find the start of the map and skip forward to the bytecode pc map entry for the stack check." cogMethod cmType = CMMethod ifTrue: [isInBlock := false. homeMethod := self cCoerceSimple: cogMethod to: #'CogMethod *'. self assert: startbcpc = (coInterpreter startPCOfMethodHeader: homeMethod methodHeader). map := self mapStartFor: homeMethod. self assert: ((objectMemory byteAt: map) >> AnnotationShift = IsAbsPCReference or: [(objectMemory byteAt: map) >> AnnotationShift = IsObjectReference or: [(objectMemory byteAt: map) >> AnnotationShift = IsRelativeCall or: [(objectMemory byteAt: map) >> AnnotationShift = IsDisplacementX2N]]]). latestContinuation := startbcpc. aMethodObj := homeMethod methodObject. + endbcpc := (objectMemory numBytesOf: aMethodObj) - 1. - endbcpc := (objectMemory byteLengthOf: aMethodObj) - 1. bsOffset := self bytecodeSetOffsetForHeader: homeMethod methodHeader] ifFalse: [isInBlock := true. homeMethod := cogMethod cmHomeMethod. map := self findMapLocationForMcpc: cogMethod asUnsignedInteger + (self sizeof: CogBlockMethod) inMethod: homeMethod. self assert: map ~= 0. self assert: ((objectMemory byteAt: map) >> AnnotationShift = HasBytecodePC "fiducial" or: [(objectMemory byteAt: map) >> AnnotationShift = IsDisplacementX2N]). [(objectMemory byteAt: map) >> AnnotationShift ~= HasBytecodePC] whileTrue: [map := map - 1]. map := map - 1. "skip fiducial; i.e. the map entry for the pc immediately following the method header." aMethodObj := homeMethod methodObject. bcpc := startbcpc - (self blockCreationBytecodeSizeForHeader: homeMethod methodHeader). bsOffset := self bytecodeSetOffsetForHeader: homeMethod methodHeader. byte := (objectMemory fetchByte: bcpc ofObject: aMethodObj) + bsOffset. descriptor := self generatorAt: byte. endbcpc := self nextBytecodePCFor: descriptor at: bcpc exts: -1 in: aMethodObj]. bcpc := startbcpc. mcpc := cogMethod asUnsignedInteger + cogMethod stackCheckOffset. nExts := 0. "The stack check maps to the start of the first bytecode, the first bytecode being effectively after frame build." result := self perform: functionSymbol with: nil with: false with: (self cCoerceSimple: mcpc to: #'char *') with: startbcpc with: arg. result ~= 0 ifTrue: [^result]. "Now skip up through the bytecode pc map entry for the stack check." [(objectMemory byteAt: map) >> AnnotationShift ~= HasBytecodePC] whileTrue: [map := map - 1]. map := map - 1. [(mapByte := objectMemory byteAt: map) ~= MapEnd] whileTrue: "defensive; we exit on bcpc" [mapByte >= FirstAnnotation ifTrue: [| annotation nextBcpc isBackwardBranch | annotation := mapByte >> AnnotationShift. mcpc := mcpc + (mapByte bitAnd: DisplacementMask). (self isPCMappedAnnotation: annotation alternateInstructionSet: bsOffset > 0) ifTrue: [[byte := (objectMemory fetchByte: bcpc ofObject: aMethodObj) + bsOffset. descriptor := self generatorAt: byte. isInBlock ifTrue: [bcpc >= endbcpc ifTrue: [^0]] ifFalse: [(descriptor isReturn and: [bcpc >= latestContinuation]) ifTrue: [^0]. (descriptor isBranch or: [descriptor isBlockCreation]) ifTrue: [| targetPC | targetPC := self latestContinuationPCFor: descriptor at: bcpc exts: nExts in: aMethodObj. latestContinuation := latestContinuation max: targetPC]]. nextBcpc := self nextBytecodePCFor: descriptor at: bcpc exts: nExts in: aMethodObj. descriptor isMapped or: [isInBlock and: [descriptor isMappedInBlock]]] whileFalse: [bcpc := nextBcpc. nExts := descriptor isExtension ifTrue: [nExts + 1] ifFalse: [0]]. isBackwardBranch := descriptor isBranch and: [self isBackwardBranch: descriptor at: bcpc exts: nExts in: aMethodObj]. result := self perform: functionSymbol with: descriptor with: isBackwardBranch with: (self cCoerceSimple: mcpc to: #'char *') with: bcpc with: arg. result ~= 0 ifTrue: [^result]. bcpc := nextBcpc. nExts := descriptor isExtension ifTrue: [nExts + 1] ifFalse: [0]]. self maybeRememberPrevMap: annotation absPCMcpc: mcpc] ifFalse: [mcpc := mcpc + (mapByte >= DisplacementX2N ifTrue: [mapByte - DisplacementX2N << AnnotationShift] ifFalse: [mapByte])]. map := map - 1]. ^0!
Item was changed: ----- Method: Cogit>>method:hasSameCodeAs: (in category 'garbage collection') ----- method: methodA hasSameCodeAs: methodB "For the purposes of become: see if the two methods are similar, i.e. can be safely becommed. This is pretty strict. All literals and bytecodes must be identical. Only trailer bytes and header flags can differ." <inline: false> | headerA headerB numLitsA endPCA | headerA := coInterpreter headerOf: methodA. headerB := coInterpreter headerOf: methodB. numLitsA := coInterpreter literalCountOfHeader: headerA. endPCA := self endPCOf: methodA. ((coInterpreter argumentCountOfMethodHeader: headerA) ~= (coInterpreter argumentCountOfMethodHeader: headerB) or: [(coInterpreter temporaryCountOfMethodHeader: headerA) ~= (coInterpreter temporaryCountOfMethodHeader: headerB) or: [(coInterpreter primitiveIndexOfMethod: methodA header: headerA) ~= (coInterpreter primitiveIndexOfMethod: methodB header: headerB) or: [numLitsA ~= (coInterpreter literalCountOfHeader: headerB) + or: [endPCA > (objectMemory numBytesOf: methodB)]]]]) ifTrue: - or: [endPCA > (objectMemory byteLengthOf: methodB)]]]]) ifTrue: [^false]. 1 to: numLitsA - 1 do: [:li| (objectMemory fetchPointer: li ofObject: methodA) ~= (objectMemory fetchPointer: li ofObject: methodB) ifTrue: [^false]]. (coInterpreter startPCOfMethod: methodA) to: endPCA do: [:bi| (objectMemory fetchByte: bi ofObject: methodA) ~= (objectMemory fetchByte: bi ofObject: methodB) ifTrue: [^false]]. ^true!
Item was changed: ----- Method: Cogit>>method:hasSameCodeAs:checkPenultimate: (in category 'garbage collection') ----- method: methodA hasSameCodeAs: methodB checkPenultimate: comparePenultimateLiteral "For the purposes of become: see if the two methods are similar, i.e. can be safely becommed. This is pretty strict. All literals and bytecodes must be identical. Only trailer bytes and header flags can differ." <inline: false> | headerA headerB numLitsA endPCA | headerA := coInterpreter headerOf: methodA. headerB := coInterpreter headerOf: methodB. numLitsA := coInterpreter literalCountOfHeader: headerA. endPCA := self endPCOf: methodA. ((coInterpreter argumentCountOfMethodHeader: headerA) ~= (coInterpreter argumentCountOfMethodHeader: headerB) or: [(coInterpreter temporaryCountOfMethodHeader: headerA) ~= (coInterpreter temporaryCountOfMethodHeader: headerB) or: [(coInterpreter primitiveIndexOfMethod: methodA header: headerA) ~= (coInterpreter primitiveIndexOfMethod: methodB header: headerB) or: [numLitsA ~= (coInterpreter literalCountOfHeader: headerB) + or: [endPCA > (objectMemory numBytesOf: methodB)]]]]) ifTrue: - or: [endPCA > (objectMemory byteLengthOf: methodB)]]]]) ifTrue: [^false]. 1 to: numLitsA - 1 do: [:li| (objectMemory fetchPointer: li ofObject: methodA) ~= (objectMemory fetchPointer: li ofObject: methodB) ifTrue: [(li < (numLitsA - 1) "If the method doesn't use the penultimate literal then don't fail the comparison." or: [comparePenultimateLiteral]) ifTrue: [^false]]]. (coInterpreter startPCOfMethod: methodA) to: endPCA do: [:bi| (objectMemory fetchByte: bi ofObject: methodA) ~= (objectMemory fetchByte: bi ofObject: methodB) ifTrue: [^false]]. ^true!
Item was changed: ----- Method: Cogit>>spanForCleanBlockStartingAt: (in category 'compile abstract instructions') ----- spanForCleanBlockStartingAt: startPC <var: #descriptor type: #'BytecodeDescriptor *'> | pc end descriptor | pc := startPC. + end := objectMemory numBytesOf: methodObj. - end := objectMemory byteLengthOf: methodObj. [pc <= end] whileTrue: [descriptor := self generatorAt: (objectMemory fetchByte: pc ofObject: methodObj) + bytecodeSetOffset. pc := pc + descriptor numBytes. descriptor isReturn ifTrue: [^pc - startPC]]. self error: 'couldn''t locate end of clean block'. ^0!
Item was removed: - ----- Method: CurrentImageCoInterpreterFacade>>byteLengthOf: (in category 'accessing') ----- - byteLengthOf: anOop - | obj | - obj := self objectForOop: anOop. - obj class isBytes ifTrue: - [^obj basicSize]. - self error: 'cannot determine byte size of argument'!
Item was changed: ----- Method: CurrentImageCoInterpreterFacade>>byteSizeOf: (in category 'accessing') ----- byteSizeOf: anOop + | obj elementSize | + obj := self objectForOop: anOop. + ([obj class isImmediateClass] + on: MessageNotUnderstood + do: [:ex| obj class == SmallInteger]) ifTrue: + [^0]. + elementSize := + [obj class elementSize] + on: MessageNotUnderstood + do: [:ex| obj class isBytes ifTrue: [1] ifFalse: [Smalltalk wordSize]]. + ^obj basicSize * elementSize! - ^(self objectForOop: anOop) basicSize!
Item was added: + ----- Method: CurrentImageCoInterpreterFacade>>numBytesOf: (in category 'accessing') ----- + numBytesOf: objOop + "Answer the number of indexable bytes in the given non-immediate object. + Does not adjust the size of contexts by stackPointer." + | obj elementSize | + obj := self objectForOop: objOop. + self deny: ([obj class isImmediateClass] + on: MessageNotUnderstood + do: [:ex| obj class == SmallInteger]). + elementSize := + [obj class elementSize] + on: MessageNotUnderstood + do: [:ex| obj class isBytes ifTrue: [1] ifFalse: [Smalltalk wordSize]]. + ^obj basicSize * elementSize!
Item was changed: ----- Method: Interpreter>>activateNewClosureMethod: (in category 'control primitives') ----- activateNewClosureMethod: blockClosure "Similar to activateNewMethod but for Closure and newMethod." | theBlockClosure closureMethod newContext methodHeader numCopied where outerContext |
DoAssertionChecks ifTrue: [self okayOop: blockClosure]. outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure. DoAssertionChecks ifTrue: [self okayOop: outerContext]. closureMethod := self fetchPointer: MethodIndex ofObject: outerContext. methodHeader := self headerOf: closureMethod. self pushRemappableOop: blockClosure. newContext := self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit). "All for one, and one for all!!"
"allocateOrRecycleContext: may cause a GC; restore blockClosure and refetch outerContext et al" theBlockClosure := self popRemappableOop. outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: theBlockClosure. + numCopied := (self numSlotsOf: theBlockClosure) - ClosureFirstCopiedValueIndex. - numCopied := (self fetchWordLengthOf: theBlockClosure) - ClosureFirstCopiedValueIndex.
"Assume: newContext will be recorded as a root if necessary by the call to newActiveContext: below, so we can use unchecked stores." where := newContext + BaseHeaderSize. self longAt: where + (SenderIndex << ShiftForWord) put: activeContext. self longAt: where + (InstructionPointerIndex << ShiftForWord) put: (self fetchPointer: ClosureStartPCIndex ofObject: theBlockClosure). self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: argumentCount + numCopied). self longAt: where + (MethodIndex << ShiftForWord) put: (self fetchPointer: MethodIndex ofObject: outerContext). self longAt: where + (ClosureIndex << ShiftForWord) put: theBlockClosure. self longAt: where + (ReceiverIndex << ShiftForWord) put: (self fetchPointer: ReceiverIndex ofObject: outerContext).
"Copy the arguments..." 1 to: argumentCount do: [:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord) put: (self stackValue: argumentCount-i)].
"Copy the copied values..." where := newContext + BaseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << ShiftForWord). 0 to: numCopied - 1 do: [:i| self longAt: where + (i << ShiftForWord) put: (self fetchPointer: i + ClosureFirstCopiedValueIndex ofObject: theBlockClosure)].
"The initial instructions in the block nil-out remaining temps."
self pop: argumentCount + 1. self newActiveContext: newContext!
Item was changed: ----- Method: Interpreter>>findClassOfMethod:forReceiver: (in category 'debug support') ----- findClassOfMethod: meth forReceiver: rcvr
| currClass classDict classDictSize methodArray i done | currClass := self fetchClassOf: rcvr. done := false. [done] whileFalse: [ classDict := self fetchPointer: MethodDictionaryIndex ofObject: currClass. + classDictSize := self numSlotsOf: classDict. - classDictSize := self fetchWordLengthOf: classDict. methodArray := self fetchPointer: MethodArrayIndex ofObject: classDict. i := 0. [i < (classDictSize - SelectorStart)] whileTrue: [ meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [ ^currClass ]. i := i + 1. ]. currClass := self fetchPointer: SuperclassIndex ofObject: currClass. done := currClass = nilObj. ]. ^self fetchClassOf: rcvr "method not found in superclass chain"!
Item was changed: ----- Method: Interpreter>>findSelectorOfMethod:forReceiver: (in category 'debug support') ----- findSelectorOfMethod: meth forReceiver: rcvr
| currClass done classDict classDictSize methodArray i | currClass := self fetchClassOf: rcvr. done := false. [done] whileFalse: [ classDict := self fetchPointer: MethodDictionaryIndex ofObject: currClass. + classDictSize := self numSlotsOf: classDict. - classDictSize := self fetchWordLengthOf: classDict. methodArray := self fetchPointer: MethodArrayIndex ofObject: classDict. i := 0. [i <= (classDictSize - SelectorStart)] whileTrue: [ meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [ ^(self fetchPointer: i + SelectorStart ofObject: classDict) ]. i := i + 1. ]. currClass := self fetchPointer: SuperclassIndex ofObject: currClass. done := currClass = nilObj. ]. ^ nilObj "method not found in superclass chain"!
Item was changed: ----- Method: Interpreter>>lookupMethodInDictionary: (in category 'message sending') ----- lookupMethodInDictionary: dictionary "This method lookup tolerates integers as Dictionary keys to support execution of images in which Symbols have been compacted out" | length index mask wrapAround nextSelector methodArray | <inline: true> + length := self numSlotsOf: dictionary. - length := self fetchWordLengthOf: dictionary. mask := length - SelectorStart - 1. (self isIntegerObject: messageSelector) ifTrue: [index := (mask bitAnd: (self integerValueOf: messageSelector)) + SelectorStart] ifFalse: [index := (mask bitAnd: (self hashBitsOf: messageSelector)) + SelectorStart].
"It is assumed that there are some nils in this dictionary, and search will stop when one is encountered. However, if there are no nils, then wrapAround will be detected the second time the loop gets to the end of the table." wrapAround := false. [true] whileTrue: [nextSelector := self fetchPointer: index ofObject: dictionary. nextSelector = nilObj ifTrue: [^ false]. nextSelector = messageSelector ifTrue: [methodArray := self fetchPointer: MethodArrayIndex ofObject: dictionary. newMethod := self fetchPointer: index - SelectorStart ofObject: methodArray. "Check if newMethod is a CompiledMethod." (self isCompiledMethod: newMethod) ifTrue: [primitiveIndex := self primitiveIndexOf: newMethod. primitiveIndex > MaxPrimitiveIndex ifTrue: ["If primitiveIndex is out of range, set to zero before putting in cache. This is equiv to primFail, and avoids the need to check on every send." primitiveIndex := 0]] ifFalse: ["indicate that this is no compiled method - use primitiveInvokeObjectAsMethod" primitiveIndex := 248]. ^ true]. index := index + 1. index = length ifTrue: [wrapAround ifTrue: [^ false]. wrapAround := true. index := SelectorStart]]!
Item was changed: ----- Method: Interpreter>>primitiveClosureCopyWithCopiedValues (in category 'control primitives') ----- primitiveClosureCopyWithCopiedValues | newClosure copiedValues numCopiedValues numArgs | numArgs := self stackIntegerValue: 1. copiedValues := self stackTop. self success: (self fetchClassOf: copiedValues) = (self splObj: ClassArray). successFlag ifFalse: [^self primitiveFail]. + numCopiedValues := self numSlotsOf: copiedValues. - numCopiedValues := self fetchWordLengthOf: copiedValues. newClosure := self closureNumArgs: numArgs "greater by 1 due to preIncrement of localIP" instructionPointer: instructionPointer + 2 - (method+BaseHeaderSize) numCopiedValues: numCopiedValues. "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores." self storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: (self stackValue: 2). numCopiedValues > 0 ifTrue: ["Allocation may have done a GC and copiedValues may have moved." copiedValues := self stackTop. 0 to: numCopiedValues - 1 do: [:i| "Assume: have just allocated a new BlockClosure; it must be young. Thus, can use unchecked stores." self storePointerUnchecked: i + ClosureFirstCopiedValueIndex ofObject: newClosure withValue: (self fetchPointer: i ofObject: copiedValues)]]. self pop: 3 thenPush: newClosure!
Item was changed: ----- Method: Interpreter>>primitiveClosureValueWithArgs (in category 'control primitives') ----- primitiveClosureValueWithArgs | argumentArray arraySize cntxSize blockClosure blockArgumentCount closureMethod index outerContext | argumentArray := self stackTop. (self isArray: argumentArray) ifFalse: [^self primitiveFail].
"Check for enough space in thisContext to push all args" + arraySize := self numSlotsOf: argumentArray. + cntxSize := self numSlotsOf: activeContext. - arraySize := self fetchWordLengthOf: argumentArray. - cntxSize := self fetchWordLengthOf: activeContext. (self stackPointerIndex + arraySize) < cntxSize ifFalse: [^self primitiveFail].
blockClosure := self stackValue: argumentCount. blockArgumentCount := self argumentCountOfClosure: blockClosure. arraySize = blockArgumentCount ifFalse: [^self primitiveFail].
"Somewhat paranoiac checks we need while debugging that we may be able to discard in a robust system." outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure. (self isContext: outerContext) ifFalse: [^self primitiveFail]. closureMethod := self fetchPointer: MethodIndex ofObject: outerContext. "Check if the closure's method is actually a CompiledMethod." (self isOopCompiledMethod: closureMethod) ifFalse: [^self primitiveFail].
self popStack.
"Copy the arguments to the stack, and activate" index := 1. [index <= arraySize] whileTrue: [self push: (self fetchPointer: index - 1 ofObject: argumentArray). index := index + 1].
argumentCount := arraySize. self activateNewClosureMethod: blockClosure. self quickCheckForInterrupts!
Item was changed: ----- Method: Interpreter>>primitiveDoPrimitiveWithArgs (in category 'control primitives') ----- primitiveDoPrimitiveWithArgs | argumentArray arraySize index cntxSize primIdx | argumentArray := self stackTop. + arraySize := self numSlotsOf: argumentArray. + cntxSize := self numSlotsOf: activeContext. - arraySize := self fetchWordLengthOf: argumentArray. - cntxSize := self fetchWordLengthOf: activeContext. self success: self stackPointerIndex + arraySize < cntxSize. (self isArray: argumentArray) ifFalse: [^ self primitiveFail].
primIdx := self stackIntegerValue: 1. successFlag ifFalse: [^ self primitiveFail]. "invalid args"
"Pop primIndex and argArray, then push args in place..." self pop: 2. primitiveIndex := primIdx. argumentCount := arraySize. index := 1. [index <= argumentCount] whileTrue: [self push: (self fetchPointer: index - 1 ofObject: argumentArray). index := index + 1].
"Run the primitive (sets successFlag)" self pushRemappableOop: argumentArray. "prim might alloc/gc" lkupClass := nilObj. self primitiveResponse. argumentArray := self popRemappableOop. successFlag ifFalse: ["If primitive failed, then restore state for failure code" self pop: arraySize. self pushInteger: primIdx. self push: argumentArray. argumentCount := 2]!
Item was changed: ----- Method: Interpreter>>primitiveExecuteMethodArgsArray (in category 'control primitives') ----- primitiveExecuteMethodArgsArray "receiver, argsArray, then method are on top of stack. Execute method against receiver and args. Allow for up to two extra arguments (e.g. for mirror primitives). Set primitiveFunctionPointer because no cache lookup has been done for the method, and hence primitiveFunctionPointer is stale." | methodArgument argCnt argumentArray | methodArgument := self stackTop. argumentArray := self stackValue: 1. ((self isOopCompiledMethod: methodArgument) and: [self isArray: argumentArray]) ifFalse: [^self primitiveFail]. argCnt := self argumentCountOf: methodArgument. + argCnt = (self numSlotsOf: argumentArray) ifFalse: - argCnt = (self fetchWordLengthOf: argumentArray) ifFalse: [^self primitiveFail]. argumentCount > 2 ifTrue: "CompiledMethod class>>receiver:withArguments:executeMethod: SqueakObjectPrimitives class >> receiver:withArguments:apply: VMMirror>>ifFail:object:with:executeMethod: et al" [argumentCount > 4 ifTrue: [^self primitiveFail]. self stackValue: argumentCount put: (self stackValue: 2)]. "replace actual receiver with desired receiver" "and push the actual arguments" self pop: argumentCount. 0 to: argCnt - 1 do: [:i| self push: (self fetchPointer: i ofObject: argumentArray)]. newMethod := methodArgument. primitiveIndex := self primitiveIndexOf: newMethod. primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: nil. argumentCount := argCnt. "We set the messageSelector for executeMethod below since things like the at cache read messageSelector and so it cannot be left stale." messageSelector := self nilObject. self executeNewMethod. "Recursive xeq affects successFlag" successFlag := true!
Item was changed: ----- Method: Interpreter>>primitiveFormPrint (in category 'I/O primitives') ----- primitiveFormPrint "On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."
| landscapeFlag vScale hScale rcvr bitsArray w h depth pixelsPerWord wordsPerLine bitsArraySize ok |
<var: #vScale type: 'double '> <var: #hScale type: 'double '> landscapeFlag := self booleanValueOf: self stackTop. vScale := self floatValueOf: (self stackValue: 1). hScale := self floatValueOf: (self stackValue: 2). rcvr := self stackValue: 3. (rcvr isIntegerObject: rcvr) ifTrue: [self success: false]. successFlag ifTrue: [ ((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]) ifFalse: [self success: false]]. successFlag ifTrue: [ bitsArray := self fetchPointer: 0 ofObject: rcvr. w := self fetchInteger: 1 ofObject: rcvr. h := self fetchInteger: 2 ofObject: rcvr. depth := self fetchInteger: 3 ofObject: rcvr. (w > 0 and: [h > 0]) ifFalse: [self success: false]. pixelsPerWord := 32 // depth. wordsPerLine := (w + (pixelsPerWord - 1)) // pixelsPerWord. ((rcvr isIntegerObject: rcvr) not and: [self isWordsOrBytes: bitsArray]) ifTrue: [ + bitsArraySize := self numBytesOf: bitsArray. - bitsArraySize := self byteLengthOf: bitsArray. self success: (bitsArraySize = (wordsPerLine * h * 4))] ifFalse: [self success: false]]. successFlag ifTrue: [ ok := self cCode: 'ioFormPrint(bitsArray + BaseHeaderSize, w, h, depth, hScale, vScale, landscapeFlag)'. self success: ok]. successFlag ifTrue: [ self pop: 3]. "pop hScale, vScale, and landscapeFlag; leave rcvr on stack" !
Item was changed: ----- Method: Interpreter>>primitivePerformAt: (in category 'control primitives') ----- primitivePerformAt: lookupClass "Common routine used by perform:withArgs: and perform:withArgs:inSuperclass:"
"NOTE: The case of doesNotUnderstand: is not a failure to perform. The only failures are arg types and consistency of argumentCount."
| performSelector argumentArray arraySize index cntxSize performMethod performArgCount | argumentArray := self stackTop. (self isArray: argumentArray) ifFalse:[^self primitiveFail].
successFlag ifTrue: ["Check for enough space in thisContext to push all args" + arraySize := self numSlotsOf: argumentArray. + cntxSize := self numSlotsOf: activeContext. - arraySize := self fetchWordLengthOf: argumentArray. - cntxSize := self fetchWordLengthOf: activeContext. self success: (self stackPointerIndex + arraySize) < cntxSize]. successFlag ifFalse: [^nil].
performSelector := messageSelector. performMethod := newMethod. performArgCount := argumentCount. "pop the arg array and the selector, then push the args out of the array, as if they were on the stack" self popStack. messageSelector := self popStack.
"Copy the arguments to the stack, and execute" index := 1. [index <= arraySize] whileTrue: [self push: (self fetchPointer: index - 1 ofObject: argumentArray). index := index + 1]. argumentCount := arraySize.
self findNewMethodInClass: lookupClass.
"Only test CompiledMethods for argument count - any other objects playacting as CMs will have to take their chances" (self isOopCompiledMethod: newMethod) ifTrue: [self success: (self argumentCountOf: newMethod) = argumentCount].
successFlag ifTrue: [self executeNewMethod. "Recursive xeq affects successFlag" successFlag := true] ifFalse: ["Restore the state by popping all those array entries and pushing back the selector and array, and fail" self pop: argumentCount. self push: messageSelector. self push: argumentArray. messageSelector := performSelector. newMethod := performMethod. argumentCount := performArgCount] !
Item was changed: ----- Method: Interpreter>>primitiveStopVMProfiling (in category 'process primitives') ----- primitiveStopVMProfiling "Primitive. Stop the VM profiler and either copy the histogram data into the supplied arguments, if they're non-nil. Fail if the arguments are not of the right type or size." | vmHistArrayOrNil vmHist vmBins easHistArrayOrNil easHist easBins | <var: #vmHist type: #'long *'> <var: #vmBins type: #long> <var: #easHist type: #'long *'> <var: #easBins type: #long> self success: argumentCount = 2. vmHistArrayOrNil := self stackObjectValue: 1. easHistArrayOrNil := self stackObjectValue: 0. successFlag ifFalse: [^nil]. "Both args must be either nil or arrays. If they're arrays and the wrong size we incorrectly stop profiling." ((vmHistArrayOrNil = nilObj or: [(self fetchClassOfNonImm: vmHistArrayOrNil) = (self splObj: ClassArray)]) and: [(self fetchClassOfNonImm: vmHistArrayOrNil) = (self fetchClassOfNonImm: easHistArrayOrNil)]) ifFalse: [^self primitiveFail]. self cCode: 'ioControlProfile(0,&vmHist,&vmBins,&easHist,&easBins)' inSmalltalk: [vmHist := vmBins := easHist := easBins := 0]. vmHistArrayOrNil ~= nilObj ifTrue: + [((self numSlotsOf: vmHistArrayOrNil) = vmBins + and: [(self numSlotsOf: easHistArrayOrNil) = easBins]) ifFalse: - [((self fetchWordLengthOf: vmHistArrayOrNil) = vmBins - and: [(self fetchWordLengthOf: easHistArrayOrNil) = easBins]) ifFalse: [^self primitiveFail]. 0 to: vmBins - 1 do: [:i| self storePointerUnchecked: i ofObject: vmHistArrayOrNil withValue: (self integerObjectOf: (vmHist at: i))]. 0 to: easBins - 1 do: [:i| self storePointerUnchecked: i ofObject: easHistArrayOrNil withValue: (self integerObjectOf: (easHist at: i))]]. self pop: argumentCount!
Item was changed: ----- Method: Interpreter>>primitiveVMProfileInfoInto (in category 'process primitives') ----- primitiveVMProfileInfoInto "Primitive. Answer whether the profiler is running or not. If the argument is an Array of suitable size fill it with the following information: 1. the addresses of the first element of the VM histogram (the first address in the executable) 2. the address following the last element (the last address in the executable, excluding dynamically linked libraries) 3. the size of the VM histogram in bins (each bin is a 4 byte unsigned long) 4. the size of the VM histogram in bins (each bin is a 4 byte unsigned long)" | info running exeStart exeLimit vmBins easBins | <var: #exeStart type: #'char *'> <var: #exeLimit type: #'char *'> <var: #vmBins type: #long> <var: #easBins type: #long> self success: argumentCount = 1. successFlag ifTrue: [info := self stackObjectValue: 0. info ~= nilObj ifTrue: [self assertClassOf: info is: (self splObj: ClassArray). + self success: (self numSlotsOf: info) >= 4]]. - self success: (self fetchWordLengthOf: info) >= 4]]. successFlag ifFalse: [^nil]. self cCode: 'ioProfileStatus(&running,&exeStart,&exeLimit,0,&vmBins,0,&easBins)' inSmalltalk: [running := exeStart := exeLimit := vmBins := easBins := 0]. info ~= nilObj ifTrue: [self storePointerUnchecked: 0 ofObject: info withValue: (self integerObjectOf: (self oopForPointer: exeStart)). self storePointerUnchecked: 1 ofObject: info withValue: (self integerObjectOf: (self oopForPointer: exeLimit)). self storePointerUnchecked: 2 ofObject: info withValue: (self integerObjectOf: vmBins). self storePointerUnchecked: 3 ofObject: info withValue: (self integerObjectOf: easBins)]. self pop: 2 thenPushBool: running!
Item was changed: ----- Method: Interpreter>>primitiveVMProfileSamplesInto (in category 'process primitives') ----- primitiveVMProfileSamplesInto "Primitive. 0 args: Answer whether the VM Profiler is running or not. 1 arg: Copy the sample data into the supplied argument, which must be a Bitmap of suitable size. Answer the number of samples copied into the buffer." | sampleBuffer sampleBufferAddress running bufferSize numSamples | <var: #bufferSize type: #long> <var: #sampleBufferAddress type: #'unsigned long *'> self cCode: 'ioNewProfileStatus(&running,&bufferSize)' inSmalltalk: [running := false. bufferSize := 0]. argumentCount = 0 ifTrue: [^self pop: 1 thenPushBool: running]. self success: argumentCount = 1. successFlag ifTrue: [sampleBuffer := self stackObjectValue: 0. self assertClassOf: sampleBuffer is: (self splObj: ClassBitmap). + self success: (self numSlotsOf: sampleBuffer) >= bufferSize]. - self success: (self fetchWordLengthOf: sampleBuffer) >= bufferSize]. successFlag ifFalse: [^nil]. sampleBufferAddress := self firstFixedField: sampleBuffer. numSamples := self cCode: 'ioNewProfileSamplesInto(sampleBufferAddress)' inSmalltalk: [sampleBufferAddress := sampleBufferAddress]. self pop: argumentCount + 1 thenPushInteger: numSamples!
Item was changed: ----- Method: Interpreter>>primitiveValueWithArgs (in category 'control primitives') ----- primitiveValueWithArgs | argumentArray blockContext blockArgumentCount arrayArgumentCount initialIP | argumentArray := self popStack. blockContext := self popStack. blockArgumentCount := self argumentCountOfBlock: blockContext. "If the argArray isnt actually an Array we ahve to unpop the above two" (self isArray: argumentArray) ifFalse: [self unPop:2. ^self primitiveFail].
+ successFlag ifTrue: [arrayArgumentCount := self numSlotsOf: argumentArray. - successFlag ifTrue: [arrayArgumentCount := self fetchWordLengthOf: argumentArray. self success: (arrayArgumentCount = blockArgumentCount and: [(self fetchPointer: CallerIndex ofObject: blockContext) = nilObj])]. successFlag ifTrue: [self transfer: arrayArgumentCount fromIndex: 0 ofObject: argumentArray toIndex: TempFrameStart ofObject: blockContext. "Assume: The call to transfer:... makes blockContext a root if necessary, allowing use to use unchecked stored in the following code. " initialIP := self fetchPointer: InitialIPIndex ofObject: blockContext. self storePointerUnchecked: InstructionPointerIndex ofObject: blockContext withValue: initialIP. self storeStackPointerValue: arrayArgumentCount inContext: blockContext. self storePointerUnchecked: CallerIndex ofObject: blockContext withValue: activeContext. self newActiveContext: blockContext] ifFalse: [self unPop: 2]!
Item was changed: ----- Method: Interpreter>>wakeHighestPriority (in category 'process primitive support') ----- wakeHighestPriority "Return the highest priority process that is ready to run." "Note: It is a fatal VM error if there is no runnable process." | schedLists p processList | schedLists := self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer. + p := self numSlotsOf: schedLists. - p := self fetchWordLengthOf: schedLists. p := p - 1. "index of last indexable field" processList := self fetchPointer: p ofObject: schedLists. [self isEmptyList: processList] whileTrue: [p := p - 1. p < 0 ifTrue: [self error: 'scheduler could not find a runnable process']. processList := self fetchPointer: p ofObject: schedLists]. ^ self removeFirstLinkOfList: processList!
Item was changed: ----- Method: InterpreterPrimitives>>primitiveClipboardText (in category 'I/O primitives') ----- primitiveClipboardText "When called with a single string argument, post the string to the clipboard. When called with zero arguments, return a string containing the current clipboard contents." | s sz | argumentCount = 1 ifTrue: [s := self stackTop. (objectMemory isBytes: s) ifFalse: [^ self primitiveFail]. self successful ifTrue: + [sz := objectMemory numBytesOf: s. - [sz := objectMemory byteLengthOf: s. self clipboardWrite: sz From: s + objectMemory baseHeaderSize At: 0. self pop: 1]] ifFalse: [sz := self clipboardSize. objectMemory hasSpurMemoryManagerAPI ifTrue: [s := objectMemory allocateBytes: sz classIndex: ClassByteStringCompactIndex. s ifNil: [^self primitiveFail]] ifFalse: [(objectMemory sufficientSpaceToAllocate: sz) ifFalse: [^self primitiveFail]. s := objectMemory instantiateClass: (objectMemory splObj: ClassByteString) indexableSize: sz]. self clipboardRead: sz Into: s + objectMemory baseHeaderSize At: 0. self pop: 1 thenPush: s]!
Item was changed: ----- Method: InterpreterPrimitives>>primitiveClosureValueWithArgs (in category 'control primitives') ----- primitiveClosureValueWithArgs | argumentArray arraySize blockClosure numArgs closureMethod index outerContext | argumentArray := self stackTop. (objectMemory isArray: argumentArray) ifFalse: [^self primitiveFail].
"Check for enough space in thisContext to push all args" + arraySize := objectMemory numSlotsOf: argumentArray. - arraySize := objectMemory fetchWordLengthOf: argumentArray. (self roomToPushNArgs: arraySize) ifFalse: [^self primitiveFail].
blockClosure := self stackValue: argumentCount. numArgs := self argumentCountOfClosure: blockClosure. arraySize = numArgs ifFalse: [^self primitiveFail].
"Somewhat paranoiac checks we need while debugging that we may be able to discard in a robust system." outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure. (objectMemory isContext: outerContext) ifFalse: [^self primitiveFail]. closureMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext. "Check if the closure's method is actually a CompiledMethod." (objectMemory isOopCompiledMethod: closureMethod) ifFalse: [^self primitiveFail].
self popStack.
"Copy the arguments to the stack, and activate" index := 1. [index <= numArgs] whileTrue: [self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray). index := index + 1].
"Note we use activateNewMethod, not executeNewMethod, to avoid quickCheckForInterrupts. Don't check until we have a full activation." self activateNewClosureMethod: blockClosure numArgs: numArgs mayContextSwitch: true!
Item was changed: ----- Method: InterpreterPrimitives>>primitiveFormPrint (in category 'I/O primitives') ----- primitiveFormPrint "On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."
| landscapeFlag vScale hScale rcvr bitsArray w h depth pixelsPerWord wordsPerLine bitsArraySize ok |
<var: #vScale type: 'double '> <var: #hScale type: 'double '> landscapeFlag := self booleanValueOf: self stackTop. vScale := self floatValueOf: (self stackValue: 1). hScale := self floatValueOf: (self stackValue: 2). rcvr := self stackValue: 3. ((objectMemory isPointers: rcvr) and: [(objectMemory lengthOf: rcvr) >= 4]) ifFalse: [self success: false]. self successful ifTrue: [bitsArray := objectMemory fetchPointer: 0 ofObject: rcvr. w := self fetchInteger: 1 ofObject: rcvr. h := self fetchInteger: 2 ofObject: rcvr. depth := self fetchInteger: 3 ofObject: rcvr. (w > 0 and: [h > 0]) ifFalse: [self success: false]. pixelsPerWord := 32 // depth. wordsPerLine := (w + (pixelsPerWord - 1)) // pixelsPerWord. (objectMemory isWordsOrBytes: bitsArray) ifTrue: + [bitsArraySize := objectMemory numBytesOf: bitsArray. - [bitsArraySize := objectMemory byteLengthOf: bitsArray. self success: (bitsArraySize = (wordsPerLine * h * 4))] ifFalse: [self success: false]]. self successful ifTrue: [ok := self cCode: 'ioFormPrint(bitsArray + BaseHeaderSize, w, h, depth, hScale, vScale, landscapeFlag)'. self success: ok]. self successful ifTrue: [self pop: 3] "pop hScale, vScale, and landscapeFlag; leave rcvr on stack"!
Item was changed: ----- Method: InterpreterPrimitives>>primitiveShortAt (in category 'sound primitives') ----- primitiveShortAt "Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Return the contents of the given index. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."
+ | index rcvr value | + index := self stackTop.. + (objectMemory isIntegerObject: index) ifFalse: - | index rcvr sz addr value | - index := self stackIntegerValue: 0. - self successful ifFalse: [^self primitiveFailFor: PrimErrBadArgument]. rcvr := self stackValue: 1. (objectMemory isWordsOrBytes: rcvr) ifFalse: [^self primitiveFailFor: PrimErrInappropriate]. + ((index >= 1) and: [index <= (objectMemory num16BitUnitsOf: rcvr)]) ifFalse: - sz := (objectMemory numSlotsOf: rcvr) * objectMemory bytesPerOop // 2. "number of 16-bit fields" - ((index >= 1) and: [index <= sz]) ifFalse: [^self primitiveFailFor: PrimErrBadIndex]. + value := objectMemory fetchShort16: index - 1 ofObject: rcvr. - addr := rcvr + objectMemory baseHeaderSize + (2 * (index - 1)). - value := objectMemory shortAt: addr. self pop: 2 thenPushInteger: value!
Item was changed: ----- Method: InterpreterPrimitives>>primitiveShortAtPut (in category 'sound primitives') ----- primitiveShortAtPut + "Treat the receiver, which can be indexible by either bytes or words, as an array + of signed 16-bit values. Set the contents of the given index to the given value. + Note that the index specifies the i-th 16-bit entry, not the i-th byte or word." - "Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Set the contents of the given index to the given value. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."
+ | index rcvr value | + value := self stackTop. + index := self stackValue: 1. + ((objectMemory isIntegerObject: value) + and: [(objectMemory isIntegerObject: index) + and: [value := objectMemory integerValueOf: value. + (value >= -32768) and: [value <= 32767]]]) ifFalse: - | index rcvr sz addr value | - value := self stackIntegerValue: 0. - index := self stackIntegerValue: 1. - (self successful and: [(value >= -32768) and: [value <= 32767]]) ifFalse: [^self primitiveFailFor: PrimErrBadArgument]. rcvr := self stackValue: 2. (objectMemory isWordsOrBytes: rcvr) ifFalse: [^self primitiveFailFor: PrimErrInappropriate]. + (index >= 1 and: [index <= (objectMemory num16BitUnitsOf: rcvr)]) ifFalse: - sz := ((objectMemory sizeBitsOf: rcvr) - BaseHeaderSize) // 2. "number of 16-bit fields" - (index >= 1 and: [index <= sz]) ifFalse: [^self primitiveFailFor: PrimErrBadIndex]. + objectMemory storeShort16: index - 1 ofObject: rcvr withValue: value. + self pop: 3 thenPush: (objectMemory integerObjectOf: value)! - addr := rcvr + BaseHeaderSize + (2 * (index - 1)). - objectMemory shortAt: addr put: value. - self pop: 3 thenPush: (objectMemory integerObjectOf: value) "pop all; return value"!
Item was changed: ----- Method: InterpreterPrimitives>>primitiveStopVMProfiling (in category 'process primitives') ----- primitiveStopVMProfiling "Primitive. Stop the VM profiler and either copy the histogram data into the supplied arguments, if they're non-nil. Fail if the arguments are not of the right type or size." | vmHistArrayOrNil vmHist vmBins easHistArrayOrNil easHist easBins | <var: #vmHist type: #'long *'> <var: #vmBins type: #long> <var: #easHist type: #'long *'> <var: #easBins type: #long> self success: argumentCount = 2. vmHistArrayOrNil := self stackObjectValue: 1. easHistArrayOrNil := self stackObjectValue: 0. self successful ifFalse: [^nil]. "Both args must be either nil or arrays. If they're arrays and the wrong size we incorrectly stop profiling." ((vmHistArrayOrNil = objectMemory nilObject or: [(objectMemory fetchClassOfNonImm: vmHistArrayOrNil) = (objectMemory splObj: ClassArray)]) and: [(objectMemory fetchClassOfNonImm: vmHistArrayOrNil) = (objectMemory fetchClassOfNonImm: easHistArrayOrNil)]) ifFalse: [^self primitiveFail]. self cCode: 'ioControlProfile(0,&vmHist,&vmBins,&easHist,&easBins)' inSmalltalk: [vmHist := vmBins := easHist := easBins := 0]. vmHistArrayOrNil ~= objectMemory nilObject ifTrue: + [((objectMemory numSlotsOf: vmHistArrayOrNil) = vmBins + and: [(objectMemory numSlotsOf: easHistArrayOrNil) = easBins]) ifFalse: - [((objectMemory fetchWordLengthOf: vmHistArrayOrNil) = vmBins - and: [(objectMemory fetchWordLengthOf: easHistArrayOrNil) = easBins]) ifFalse: [^self primitiveFail]. 0 to: vmBins - 1 do: [:i| objectMemory storePointerUnchecked: i ofObject: vmHistArrayOrNil withValue: (objectMemory integerObjectOf: (vmHist at: i))]. 0 to: easBins - 1 do: [:i| objectMemory storePointerUnchecked: i ofObject: easHistArrayOrNil withValue: (objectMemory integerObjectOf: (easHist at: i))]]. self pop: argumentCount!
Item was changed: ----- Method: InterpreterPrimitives>>primitiveVMProfileInfoInto (in category 'process primitives') ----- primitiveVMProfileInfoInto "Primitive. Answer whether the profiler is running or not. If the argument is an Array of suitable size fill it with the following information: 1. the addresses of the first element of the VM histogram (the first address in the executable) 2. the address following the last element (the last address in the executable, excluding dynamically linked libraries) 3. the size of the VM histogram in bins (each bin is a 4 byte unsigned long) 4. the size of the VM histogram in bins (each bin is a 4 byte unsigned long)" | info running exeStart exeLimit vmBins easBins | <var: #exeStart type: #'char *'> <var: #exeLimit type: #'char *'> <var: #vmBins type: #long> <var: #easBins type: #long> self success: argumentCount = 1. self successful ifTrue: [info := self stackObjectValue: 0. info ~= objectMemory nilObject ifTrue: [self assertClassOf: info is: (objectMemory splObj: ClassArray). + self success: (objectMemory numSlotsOf: info) >= 4]]. - self success: (objectMemory fetchWordLengthOf: info) >= 4]]. self successful ifFalse: [^nil]. self cCode: 'ioProfileStatus(&running,&exeStart,&exeLimit,0,&vmBins,0,&easBins)' inSmalltalk: [running := exeStart := exeLimit := vmBins := easBins := 0]. info ~= objectMemory nilObject ifTrue: [objectMemory storePointerUnchecked: 0 ofObject: info withValue: (objectMemory integerObjectOf: (self oopForPointer: exeStart)). objectMemory storePointerUnchecked: 1 ofObject: info withValue: (objectMemory integerObjectOf: (self oopForPointer: exeLimit)). objectMemory storePointerUnchecked: 2 ofObject: info withValue: (objectMemory integerObjectOf: vmBins). objectMemory storePointerUnchecked: 3 ofObject: info withValue: (objectMemory integerObjectOf: easBins)]. self pop: 2 thenPushBool: running!
Item was changed: ----- Method: InterpreterPrimitives>>primitiveVMProfileSamplesInto (in category 'process primitives') ----- primitiveVMProfileSamplesInto "Primitive. 0 args: Answer whether the VM Profiler is running or not. 1 arg: Copy the sample data into the supplied argument, which must be a Bitmap of suitable size. Answer the number of samples copied into the buffer." | sampleBuffer sampleBufferAddress running bufferSize numSamples | <var: #bufferSize type: #long> <var: #sampleBufferAddress type: #'unsigned long *'> self cCode: 'ioNewProfileStatus(&running,&bufferSize)' inSmalltalk: [running := false. bufferSize := 0]. argumentCount = 0 ifTrue: [^self pop: 1 thenPushBool: running]. self success: argumentCount = 1. self successful ifTrue: [sampleBuffer := self stackObjectValue: 0. self assertClassOf: sampleBuffer is: (objectMemory splObj: ClassBitmap). + self success: (objectMemory numSlotsOf: sampleBuffer) >= bufferSize]. - self success: (objectMemory fetchWordLengthOf: sampleBuffer) >= bufferSize]. self successful ifFalse: [^nil]. sampleBufferAddress := objectMemory firstFixedField: sampleBuffer. numSamples := self cCode: 'ioNewProfileSamplesInto(sampleBufferAddress)' inSmalltalk: [sampleBufferAddress := sampleBufferAddress]. self pop: argumentCount + 1 thenPushInteger: numSamples!
Item was added: + ----- Method: InterpreterProxy>>unpinObject: (in category 'object access') ----- + unpinObject: anObject + <option: #(atLeastVMProxyMajor:minor: 1 13)> + ^self shouldBeImplemented!
Item was changed: ----- Method: InterpreterSimulator>>classAndSelectorOfMethod:forReceiver: (in category 'debug support') ----- classAndSelectorOfMethod: meth forReceiver: rcvr | mClass dict length methodArray | mClass := self fetchClassOf: rcvr. [dict := self fetchPointer: MethodDictionaryIndex ofObject: mClass. + length := self numSlotsOf: dict. - length := self fetchWordLengthOf: dict. methodArray := self fetchPointer: MethodArrayIndex ofObject: dict. 0 to: length-SelectorStart-1 do: [:index | meth = (self fetchPointer: index ofObject: methodArray) ifTrue: [^ Array with: mClass with: (self fetchPointer: index + SelectorStart ofObject: dict)]]. mClass := self fetchPointer: SuperclassIndex ofObject: mClass. mClass = nilObj] whileFalse: []. ^ Array with: (self fetchClassOf: rcvr) with: (self splObj: SelectorDoesNotUnderstand)!
Item was removed: - ----- Method: NewObjectMemory>>goodContextSize: (in category 'contexts') ----- - goodContextSize: oop - | numSlots | - numSlots := self numSlotsOf: oop. - ^numSlots = SmallContextSlots or: [numSlots = LargeContextSlots]!
Item was removed: - ----- Method: NewObjectMemory>>numSlotsOf: (in category 'interpreter access') ----- - numSlotsOf: obj - "Answer the number of oop-sized elements in the given object. - Unlike lengthOf: this does not adjust the length of a context - by the stackPointer and so can be used e.g. by cloneContext:" - <api> - | header sz | - header := self baseHeader: obj. - sz := (header bitAnd: TypeMask) = HeaderTypeSizeAndClass - ifTrue: [(self sizeHeader: obj) bitAnd: AllButTypeMask] - ifFalse: [header bitAnd: SizeMask]. - ^sz - BaseHeaderSize >> ShiftForWord!
Item was changed: ----- Method: NewObjectMemory>>printWronglySizedContexts: (in category 'debug printing') ----- printWronglySizedContexts: printContexts "Scan the heap printing the oops of any and all contexts whose size is not either SmallContextSize or LargeContextSize" | oop | <api> oop := self firstAccessibleObject. [oop = nil] whileFalse: [((self isContextNonImm: oop) and: [self badContextSize: oop]) ifTrue: + [self printHex: oop; space; printNum: (self numBytesOf: oop); cr. - [self printHex: oop; space; printNum: (self byteLengthOf: oop); cr. printContexts ifTrue: [coInterpreter printContext: oop]]. oop := self accessibleObjectAfter: oop]!
Item was changed: + ----- Method: NewObjectMemory>>sizeBitsOf: (in category 'object access') ----- - ----- Method: NewObjectMemory>>sizeBitsOf: (in category 'header access') ----- sizeBitsOf: oop "Answer the number of bytes in the given object, including its base header, rounded up to an integral number of words." "Note: byte indexable objects need to have low bits subtracted from this size." <inline: true> | header | header := self baseHeader: oop. ^(header bitAnd: TypeMask) = HeaderTypeSizeAndClass ifTrue: [(self sizeHeader: oop) bitAnd: LongSizeMask] ifFalse: [header bitAnd: SizeMask]!
Item was changed: + ----- Method: NewObjectMemory>>sizeBitsOfSafe: (in category 'object access') ----- - ----- Method: NewObjectMemory>>sizeBitsOfSafe: (in category 'header access') ----- sizeBitsOfSafe: oop "Compute the size of the given object from the cc and size fields in its header. This works even if its type bits are not correct."
| header type | header := self baseHeader: oop. type := self rightType: header. ^type = HeaderTypeSizeAndClass ifTrue: [(self sizeHeader: oop) bitAnd: AllButTypeMask] ifFalse: [header bitAnd: SizeMask]!
Item was added: + ----- Method: NewObjectMemory>>unpinObject: (in category 'primitive support') ----- + unpinObject: objOop + "For forward-compatibility with Spur. Fail; ObjectMemory does not support pinning." + <api> + coInterpreter primitiveFailFor: PrimErrUnsupported!
Item was changed: ----- Method: NewspeakInterpreter>>activateNewClosureMethod: (in category 'control primitives') ----- activateNewClosureMethod: blockClosure "Similar to activateNewMethod but for Closure and newMethod." | theBlockClosure closureMethod newContext methodHeader numCopied where outerContext |
DoAssertionChecks ifTrue: [self okayOop: blockClosure]. outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure. DoAssertionChecks ifTrue: [self okayOop: outerContext]. closureMethod := self fetchPointer: MethodIndex ofObject: outerContext. methodHeader := self headerOf: closureMethod. self pushRemappableOop: blockClosure. newContext := self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit). "All for one, and one for all!!"
"allocateOrRecycleContext: may cause a GC; restore blockClosure and refetch outerContext et al" theBlockClosure := self popRemappableOop. outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: theBlockClosure. + numCopied := (self numSlotsOf: theBlockClosure) - ClosureFirstCopiedValueIndex. - numCopied := (self fetchWordLengthOf: theBlockClosure) - ClosureFirstCopiedValueIndex.
"Assume: newContext will be recorded as a root if necessary by the call to newActiveContext: below, so we can use unchecked stores." where := newContext + BaseHeaderSize. self longAt: where + (SenderIndex << ShiftForWord) put: activeContext. self longAt: where + (InstructionPointerIndex << ShiftForWord) put: (self fetchPointer: ClosureStartPCIndex ofObject: theBlockClosure). self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: argumentCount + numCopied). self longAt: where + (MethodIndex << ShiftForWord) put: (self fetchPointer: MethodIndex ofObject: outerContext). self longAt: where + (ClosureIndex << ShiftForWord) put: theBlockClosure. self longAt: where + (ReceiverIndex << ShiftForWord) put: (self fetchPointer: ReceiverIndex ofObject: outerContext).
"Copy the arguments..." 1 to: argumentCount do: [:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord) put: (self stackValue: argumentCount-i)].
"Copy the copied values..." where := newContext + BaseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << ShiftForWord). 0 to: numCopied - 1 do: [:i| self longAt: where + (i << ShiftForWord) put: (self fetchPointer: i + ClosureFirstCopiedValueIndex ofObject: theBlockClosure)].
"The initial instructions in the block nil-out remaining temps."
self pop: argumentCount + 1. self newActiveContext: newContext!
Item was changed: ----- Method: NewspeakInterpreter>>findClassOfMethod:forReceiver: (in category 'debug support') ----- findClassOfMethod: meth forReceiver: rcvr
| currClass classDict classDictSize methodArray i done | currClass := self fetchClassOf: rcvr. done := false. [done] whileFalse: [ classDict := self fetchPointer: MessageDictionaryIndex ofObject: currClass. + classDictSize := self numSlotsOf: classDict. - classDictSize := self fetchWordLengthOf: classDict. methodArray := self fetchPointer: MethodArrayIndex ofObject: classDict. i := 0. [i < (classDictSize - SelectorStart)] whileTrue: [ meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [ ^currClass ]. i := i + 1. ]. currClass := self fetchPointer: SuperclassIndex ofObject: currClass. done := currClass = nilObj. ]. ^self fetchClassOf: rcvr "method not found in superclass chain"!
Item was changed: ----- Method: NewspeakInterpreter>>findSelectorOfMethod:forReceiver: (in category 'debug support') ----- findSelectorOfMethod: meth forReceiver: rcvr
| currClass done classDict classDictSize methodArray i | currClass := self fetchClassOf: rcvr. done := false. [done] whileFalse: [ classDict := self fetchPointer: MessageDictionaryIndex ofObject: currClass. + classDictSize := self numSlotsOf: classDict. - classDictSize := self fetchWordLengthOf: classDict. methodArray := self fetchPointer: MethodArrayIndex ofObject: classDict. i := 0. [i <= (classDictSize - SelectorStart)] whileTrue: [ meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [ ^(self fetchPointer: i + SelectorStart ofObject: classDict) ]. i := i + 1. ]. currClass := self fetchPointer: SuperclassIndex ofObject: currClass. done := currClass = nilObj. ]. ^ nilObj "method not found in superclass chain"!
Item was changed: ----- Method: NewspeakInterpreter>>lookupMethodInDictionary: (in category 'message sending') ----- lookupMethodInDictionary: dictionary "This method lookup tolerates integers as Dictionary keys to support execution of images in which Symbols have been compacted out" | length index mask wrapAround nextSelector methodArray | <inline: true> + length := self numSlotsOf: dictionary. - length := self fetchWordLengthOf: dictionary. mask := length - SelectorStart - 1. (self isIntegerObject: messageSelector) ifTrue: [index := (mask bitAnd: (self integerValueOf: messageSelector)) + SelectorStart] ifFalse: [index := (mask bitAnd: (self hashBitsOf: messageSelector)) + SelectorStart].
"It is assumed that there are some nils in this dictionary, and search will stop when one is encountered. However, if there are no nils, then wrapAround will be detected the second time the loop gets to the end of the table." wrapAround := false. [true] whileTrue: [nextSelector := self fetchPointer: index ofObject: dictionary. nextSelector = nilObj ifTrue: [^ false]. nextSelector = messageSelector ifTrue: [methodArray := self fetchPointer: MethodArrayIndex ofObject: dictionary. newMethod := self fetchPointer: index - SelectorStart ofObject: methodArray. ^true]. index := index + 1. index = length ifTrue: [wrapAround ifTrue: [^false]. wrapAround := true. index := SelectorStart]]!
Item was changed: ----- Method: NewspeakInterpreter>>primitiveClosureCopyWithCopiedValues (in category 'control primitives') ----- primitiveClosureCopyWithCopiedValues | newClosure copiedValues numCopiedValues numArgs | numArgs := self stackIntegerValue: 1. copiedValues := self stackTop. (self fetchClassOf: copiedValues) = (self splObj: ClassArray) ifFalse: [^self primitiveFail]. + numCopiedValues := self numSlotsOf: copiedValues. - numCopiedValues := self fetchWordLengthOf: copiedValues. newClosure := self closureNumArgs: numArgs "greater by 1 due to preIncrement of localIP" instructionPointer: instructionPointer + 2 - (method+BaseHeaderSize) numCopiedValues: numCopiedValues. "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores." self storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: (self stackValue: 2). numCopiedValues > 0 ifTrue: ["Allocation may have done a GC and copiedValues may have moved." copiedValues := self stackTop. 0 to: numCopiedValues - 1 do: [:i| "Assume: have just allocated a new BlockClosure; it must be young. Thus, can use unchecked stores." self storePointerUnchecked: i + ClosureFirstCopiedValueIndex ofObject: newClosure withValue: (self fetchPointer: i ofObject: copiedValues)]]. self pop: 3 thenPush: newClosure!
Item was changed: ----- Method: NewspeakInterpreter>>primitiveClosureValueWithArgs (in category 'control primitives') ----- primitiveClosureValueWithArgs | argumentArray arraySize cntxSize blockClosure blockArgumentCount closureMethod index outerContext | argumentArray := self stackTop. (self isArray: argumentArray) ifFalse: [^self primitiveFail].
"Check for enough space in thisContext to push all args" + arraySize := self numSlotsOf: argumentArray. + cntxSize := self numSlotsOf: activeContext. - arraySize := self fetchWordLengthOf: argumentArray. - cntxSize := self fetchWordLengthOf: activeContext. (self stackPointerIndex + arraySize) < cntxSize ifFalse: [^self primitiveFail].
blockClosure := self stackValue: argumentCount. blockArgumentCount := self argumentCountOfClosure: blockClosure. arraySize = blockArgumentCount ifFalse: [^self primitiveFail].
"Somewhat paranoiac checks we need while debugging that we may be able to discard in a robust system." outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure. (self isContext: outerContext) ifFalse: [^self primitiveFail]. closureMethod := self fetchPointer: MethodIndex ofObject: outerContext. "Check if the closure's method is actually a CompiledMethod." ((self isNonIntegerObject: closureMethod) and: [self isCompiledMethod: closureMethod]) ifFalse: [^self primitiveFail].
self popStack.
"Copy the arguments to the stack, and activate" index := 1. [index <= arraySize] whileTrue: [self push: (self fetchPointer: index - 1 ofObject: argumentArray). index := index + 1].
argumentCount := arraySize. self activateNewClosureMethod: blockClosure. self quickCheckForInterrupts!
Item was changed: ----- Method: NewspeakInterpreter>>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 index methodArg methodHeader spec moduleName functionName moduleLength functionLength addr | <var: #addr declareC: 'void (*addr)()'>
argumentArray := self stackTop. (self isArray: argumentArray) ifFalse: [^self primitiveFail]. "invalid args" + arraySize := self numSlotsOf: argumentArray. - arraySize := self fetchWordLengthOf: argumentArray. self success: (self roomToPushNArgs: arraySize).
methodArg := self stackObjectValue: 2. self successful ifFalse: [^self primitiveFail]. "invalid args"
(self isCompiledMethod: methodArg) ifFalse: [^self primitiveFail]. "invalid args"
methodHeader := self headerOf: methodArg.
(self literalCountOfHeader: methodHeader) > 2 ifFalse: [^self primitiveFail]. "invalid methodArg state" self assertClassOf: (spec := self fetchPointer: 1 "first literal" ofObject: methodArg) is: (self splObj: ClassArray). (self successful and: [(self lengthOf: spec) = 4 and: [(self primitiveIndexOfMethodHeader: methodHeader) = 117]]) ifFalse: [^self primitiveFail]. "invalid methodArg state"
(self argumentCountOfMethodHeader: methodHeader) = arraySize ifFalse: [^self primitiveFail]. "invalid args (Array args wrong size)"
"The function has not been loaded yet. Fetch module and function name." moduleName := self fetchPointer: 0 ofObject: spec. moduleName = nilObj ifTrue: [moduleLength := 0] ifFalse: [self success: (self isBytes: moduleName). moduleLength := self lengthOf: moduleName. self cCode: '' inSmalltalk: [ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName)) "??" ifTrue: [moduleLength := 0 "Cause all of these to fail"]]]. functionName := self fetchPointer: 1 ofObject: spec. self success: (self isBytes: functionName). functionLength := self lengthOf: functionName. self successful ifFalse: [^self primitiveFail]. "invalid methodArg state"
addr := self ioLoadExternalFunction: functionName + BaseHeaderSize OfLength: functionLength FromModule: moduleName + BaseHeaderSize OfLength: moduleLength. addr = 0 ifTrue: [^self primitiveFail]. "could not find function"
"Cannot fail this primitive from now on. Can only fail the external primitive." self pop: 1. argumentCount := arraySize. index := 1. [index <= arraySize] whileTrue: [self push: (self fetchPointer: index - 1 ofObject: argumentArray). index := index + 1].
"Run the primitive (sets primFailCode)" self pushRemappableOop: argumentArray. "prim might alloc/gc in callback" lkupClass := nilObj. self callExternalPrimitive: addr. argumentArray := self popRemappableOop. self successful ifFalse: "If primitive failed, then restore state for failure code" [self pop: arraySize thenPush: argumentArray. argumentCount := 3]!
Item was changed: ----- Method: NewspeakInterpreter>>primitiveDoPrimitiveWithArgs (in category 'control primitives') ----- primitiveDoPrimitiveWithArgs | argumentArray arraySize index cntxSize primIdx | argumentArray := self stackTop. + arraySize := self numSlotsOf: argumentArray. + cntxSize := self numSlotsOf: activeContext. - arraySize := self fetchWordLengthOf: argumentArray. - cntxSize := self fetchWordLengthOf: activeContext. self success: self stackPointerIndex + arraySize < cntxSize. (self isArray: argumentArray) ifFalse: [^ self primitiveFail].
primIdx := self stackIntegerValue: 1. self successful ifFalse: [^ self primitiveFail]. "invalid args"
primitiveFunctionPointer := self functionPointerFor: primIdx inClass: nil. primitiveFunctionPointer = 0 ifTrue: [^self primitiveFail].
"Pop primIndex and argArray, then push args in place..." self pop: 2. argumentCount := arraySize. index := 1. [index <= argumentCount] whileTrue: [self push: (self fetchPointer: index - 1 ofObject: argumentArray). index := index + 1].
self isPrimitiveFunctionPointerAnIndex ifTrue: [self externalQuickPrimitiveResponse. ^nil].
"Run the primitive (sets successFlag)" self pushRemappableOop: argumentArray. "prim might alloc/gc" lkupClass := nilObj. "Run the primitive (sets primFailCode)" self slowPrimitiveResponse. argumentArray := self popRemappableOop. self successful ifFalse: ["If primitive failed, then restore state for failure code" self pop: arraySize. self pushInteger: primIdx. self push: argumentArray. argumentCount := 2]!
Item was changed: ----- Method: NewspeakInterpreter>>primitiveExecuteMethodArgsArray (in category 'control primitives') ----- primitiveExecuteMethodArgsArray "receiver, argsArray, then method are on top of stack. Execute method against receiver and args. Allow for up to two extra arguments (e.g. for mirror primitives). Set primitiveFunctionPointer because no cache lookup has been done for the method, and hence primitiveFunctionPointer is stale." | methodArgument argCnt argumentArray primitiveIndex | methodArgument := self stackTop. argumentArray := self stackValue: 1. ((self isOopCompiledMethod: methodArgument) and: [self isArray: argumentArray]) ifFalse: [^self primitiveFailFor: PrimErrBadArgument]. argCnt := self argumentCountOf: methodArgument. + argCnt = (self numSlotsOf: argumentArray) ifFalse: - argCnt = (self fetchWordLengthOf: argumentArray) ifFalse: [^self primitiveFailFor: PrimErrBadNumArgs]. argumentCount > 2 ifTrue: "CompiledMethod class>>receiver:withArguments:executeMethod: SqueakObjectPrimitives class >> receiver:withArguments:apply: VMMirror>>ifFail:object:with:executeMethod: et al" [argumentCount > 4 ifTrue: [^self primitiveFailFor: PrimErrUnsupported]. self stackValue: argumentCount put: (self stackValue: 2)]. "replace actual receiver with desired receiver" "and push the actual arguments" self pop: argumentCount. 0 to: argCnt - 1 do: [:i| self push: (self fetchPointer: i ofObject: argumentArray)]. newMethod := methodArgument. primitiveIndex := self primitiveIndexOf: newMethod. primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: nil. argumentCount := argCnt. "We set the messageSelector for executeMethod below since things like the at cache read messageSelector and so it cannot be left stale." messageSelector := self nilObject. self executeNewMethod. "Recursive xeq affects primErrorCode" self initPrimCall!
Item was changed: ----- Method: NewspeakInterpreter>>primitiveFormPrint (in category 'I/O primitives') ----- primitiveFormPrint "On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."
| landscapeFlag vScale hScale rcvr bitsArray w h depth pixelsPerWord wordsPerLine bitsArraySize ok |
<var: #vScale type: 'double '> <var: #hScale type: 'double '> landscapeFlag := self booleanValueOf: self stackTop. vScale := self floatValueOf: (self stackValue: 1). hScale := self floatValueOf: (self stackValue: 2). rcvr := self stackValue: 3. (rcvr isIntegerObject: rcvr) ifTrue: [self success: false]. self successful ifTrue: [ ((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]) ifFalse: [self success: false]]. self successful ifTrue: [ bitsArray := self fetchPointer: 0 ofObject: rcvr. w := self fetchInteger: 1 ofObject: rcvr. h := self fetchInteger: 2 ofObject: rcvr. depth := self fetchInteger: 3 ofObject: rcvr. (w > 0 and: [h > 0]) ifFalse: [self success: false]. pixelsPerWord := 32 // depth. wordsPerLine := (w + (pixelsPerWord - 1)) // pixelsPerWord. ((rcvr isIntegerObject: rcvr) not and: [self isWordsOrBytes: bitsArray]) ifTrue: [ + bitsArraySize := self numBytesOf: bitsArray. - bitsArraySize := self byteLengthOf: bitsArray. self success: (bitsArraySize = (wordsPerLine * h * 4))] ifFalse: [self success: false]]. self successful ifTrue: [ ok := self cCode: 'ioFormPrint(bitsArray + BaseHeaderSize, w, h, depth, hScale, vScale, landscapeFlag)'. self success: ok]. self successful ifTrue: [ self pop: 3]. "pop hScale, vScale, and landscapeFlag; leave rcvr on stack" !
Item was changed: ----- Method: NewspeakInterpreter>>primitivePerformAt: (in category 'control primitives') ----- primitivePerformAt: lookupClass "Common routine used by perform:withArgs: and perform:withArgs:inSuperclass:"
"NOTE: The case of doesNotUnderstand: is not a failure to perform. The only failures are arg types and consistency of argumentCount."
| performSelector argumentArray arraySize index cntxSize performMethod performArgCount | argumentArray := self stackTop. (self isArray: argumentArray) ifFalse:[^self primitiveFail].
self successful ifTrue: ["Check for enough space in thisContext to push all args" + arraySize := self numSlotsOf: argumentArray. + cntxSize := self numSlotsOf: activeContext. - arraySize := self fetchWordLengthOf: argumentArray. - cntxSize := self fetchWordLengthOf: activeContext. self success: (self stackPointerIndex + arraySize) < cntxSize]. self successful ifFalse: [^nil].
performSelector := messageSelector. performMethod := newMethod. performArgCount := argumentCount. "pop the arg array and the selector, then push the args out of the array, as if they were on the stack" self popStack. messageSelector := self popStack.
"Copy the arguments to the stack, and execute" index := 1. [index <= arraySize] whileTrue: [self push: (self fetchPointer: index - 1 ofObject: argumentArray). index := index + 1]. argumentCount := arraySize.
self fastLogSend: messageSelector. self sendBreakpoint: messageSelector receiver: receiver. self findNewMethodInClass: lookupClass.
"Only test CompiledMethods for argument count - any other objects playacting as CMs will have to take their chances" (self isCompiledMethod: newMethod) ifTrue: [self success: (self argumentCountOf: newMethod) = argumentCount].
self successful ifTrue: [self executeNewMethod. "Recursive xeq affects successFlag" self initPrimCall] ifFalse: ["Restore the state by popping all those array entries and pushing back the selector and array, and fail" self pop: argumentCount. self push: messageSelector. self push: argumentArray. messageSelector := performSelector. newMethod := performMethod. argumentCount := performArgCount] !
Item was changed: ----- Method: NewspeakInterpreter>>primitiveVMProfileSamplesInto (in category 'process primitives') ----- primitiveVMProfileSamplesInto "Primitive. 0 args: Answer whether the VM Profiler is running or not. 1 arg: Copy the sample data into the supplied argument, which must be a Bitmap of suitable size. Answer the number of samples copied into the buffer." | sampleBuffer sampleBufferAddress running bufferSize numSamples | <var: #bufferSize type: #long> <var: #sampleBufferAddress type: #'unsigned long *'> self cCode: 'ioNewProfileStatus(&running,&bufferSize)' inSmalltalk: [running := false. bufferSize := 0]. argumentCount = 0 ifTrue: [^self pop: 1 thenPushBool: running]. self success: argumentCount = 1. self successful ifTrue: [sampleBuffer := self stackObjectValue: 0. self assertClassOf: sampleBuffer is: (self splObj: ClassBitmap). + self success: (self numSlotsOf: sampleBuffer) >= bufferSize]. - self success: (self fetchWordLengthOf: sampleBuffer) >= bufferSize]. self successful ifFalse: [^nil]. sampleBufferAddress := self firstFixedField: sampleBuffer. numSamples := self cCode: 'ioNewProfileSamplesInto(sampleBufferAddress)' inSmalltalk: [sampleBufferAddress := sampleBufferAddress]. self pop: argumentCount + 1 thenPushInteger: numSamples!
Item was changed: ----- Method: NewspeakInterpreter>>primitiveValueWithArgs (in category 'control primitives') ----- primitiveValueWithArgs | argumentArray blockContext blockArgumentCount arrayArgumentCount initialIP | argumentArray := self popStack. blockContext := self popStack. blockArgumentCount := self argumentCountOfBlock: blockContext. "If the argArray isnt actually an Array we ahve to unpop the above two" (self isArray: argumentArray) ifFalse: [self unPop:2. ^self primitiveFail].
+ self successful ifTrue: [arrayArgumentCount := self numSlotsOf: argumentArray. - self successful ifTrue: [arrayArgumentCount := self fetchWordLengthOf: argumentArray. self success: (arrayArgumentCount = blockArgumentCount and: [(self fetchPointer: CallerIndex ofObject: blockContext) = nilObj])]. self successful ifTrue: [self transfer: arrayArgumentCount fromIndex: 0 ofObject: argumentArray toIndex: TempFrameStart ofObject: blockContext. "Assume: The call to transfer:... makes blockContext a root if necessary, allowing use to use unchecked stored in the following code. " initialIP := self fetchPointer: InitialIPIndex ofObject: blockContext. self storePointerUnchecked: InstructionPointerIndex ofObject: blockContext withValue: initialIP. self storeStackPointerValue: arrayArgumentCount inContext: blockContext. self storePointerUnchecked: CallerIndex ofObject: blockContext withValue: activeContext. self newActiveContext: blockContext] ifFalse: [self unPop: 2]!
Item was changed: ----- Method: NewspeakInterpreter>>printAllStacks (in category 'debug printing') ----- printAllStacks "Print all the stacks of all running processes, including those that are currently suspended." <api> | oop classObj proc semaphoreClass schedLists processList | <inline: false> proc := self activeProcess. self printNameOfClass: (self fetchClassOf: proc) count: 5; space; printHex: proc. self print: ' priority '; printNum: (self quickFetchInteger: PriorityIndex ofObject: proc); cr. self printContextCallStackOf: activeContext. semaphoreClass := self classSemaphore. oop := self firstObject. [self oop: oop isLessThan: freeBlock] whileTrue: [classObj := self fetchClassOfNonImm: oop. (classObj = semaphoreClass) ifTrue: [self printProcsOnList: oop]. oop := self objectAfter: oop]. schedLists := self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer. + (self numSlotsOf: schedLists) - 1 to: 0 by: -1 do: - (self fetchWordLengthOf: schedLists) - 1 to: 0 by: -1 do: [:pri| processList := self fetchPointer: pri ofObject: schedLists. (self isEmptyList: processList) ifFalse: [self cr; print: 'processes at priority '; printNum: pri + 1. self printProcsOnList: processList]]!
Item was changed: ----- Method: NewspeakInterpreter>>validInstructionPointer:inMethod: (in category 'debug support') ----- validInstructionPointer: anInstrPointer inMethod: aMethod ^anInstrPointer >= (aMethod + (self lastPointerOf: aMethod) + 1) + and: [anInstrPointer < (aMethod + (self numBytesOf: aMethod))]! - and: [anInstrPointer < (aMethod + (self byteLengthOf: aMethod))]!
Item was changed: ----- Method: NewspeakInterpreter>>wakeHighestPriority (in category 'process primitive support') ----- wakeHighestPriority "Return the highest priority process that is ready to run." "Note: It is a fatal VM error if there is no runnable process." | schedLists p processList | schedLists := self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer. + p := self numSlotsOf: schedLists. - p := self fetchWordLengthOf: schedLists. p := p - 1. "index of last indexable field" processList := self fetchPointer: p ofObject: schedLists. [self isEmptyList: processList] whileTrue: [p := p - 1. p < 0 ifTrue: [self error: 'scheduler could not find a runnable process']. processList := self fetchPointer: p ofObject: schedLists]. ^ self removeFirstLinkOfList: processList!
Item was changed: ----- Method: NewspeakInterpreterSimulator>>classAndSelectorOfMethod:forReceiver: (in category 'debug support') ----- classAndSelectorOfMethod: meth forReceiver: rcvr | mClass dict length methodArray | mClass := self fetchClassOf: rcvr. [dict := self fetchPointer: MethodDictionaryIndex ofObject: mClass. + length := self numSlotsOf: dict. - length := self fetchWordLengthOf: dict. methodArray := self fetchPointer: MethodArrayIndex ofObject: dict. 0 to: length-SelectorStart-1 do: [:index | meth = (self fetchPointer: index ofObject: methodArray) ifTrue: [^ Array with: mClass with: (self fetchPointer: index + SelectorStart ofObject: dict)]]. mClass := self fetchPointer: SuperclassIndex ofObject: mClass. mClass = nilObj] whileFalse: []. ^ Array with: (self fetchClassOf: rcvr) with: (self splObj: SelectorDoesNotUnderstand)!
Item was changed: ----- Method: ObjectMemory>>badContextSize: (in category 'contexts') ----- badContextSize: oop + ^(self numBytesOf: oop) ~= (SmallContextSize-BaseHeaderSize) + and: [(self numBytesOf: oop) ~= (LargeContextSize-BaseHeaderSize)]! - ^(self byteLengthOf: oop) ~= (SmallContextSize-BaseHeaderSize) - and: [(self byteLengthOf: oop) ~= (LargeContextSize-BaseHeaderSize)]!
Item was removed: - ----- Method: ObjectMemory>>byteLengthOf: (in category 'indexing primitive support') ----- - byteLengthOf: obj - "Return the number of indexable bytes in the given object. - This is basically a special copy of lengthOf: for BitBlt. But it is also - whoorishly used for the Cogit." - <api> - | header sz fmt | - header := self baseHeader: obj. - sz := (header bitAnd: TypeMask) = HeaderTypeSizeAndClass - ifTrue: [(self sizeHeader: obj) bitAnd: AllButTypeMask] - ifFalse: [header bitAnd: SizeMask]. - fmt := self formatOfHeader: header. - ^fmt < self firstByteFormat - ifTrue: [(sz - BaseHeaderSize)] "words" - ifFalse: [(sz - BaseHeaderSize) - (fmt bitAnd: 3)] "bytes"!
Item was changed: + ----- Method: ObjectMemory>>byteSizeOf: (in category 'object access') ----- - ----- Method: ObjectMemory>>byteSizeOf: (in category 'object format') ----- byteSizeOf: oop <api> - | header format size | (self isIntegerObject: oop) ifTrue:[^0]. + ^self numBytesOf: oop! - header := self baseHeader: oop. - format := self formatOfHeader: header. - size := (header bitAnd: TypeMask) = HeaderTypeSizeAndClass - ifTrue: [(self sizeHeader: oop) bitAnd: LongSizeMask] - ifFalse: [header bitAnd: SizeMask]. - size := size - (header bitAnd: Size4Bit). - ^format < self firstByteFormat - ifTrue: [ size - BaseHeaderSize "32-bit longs"] - ifFalse: [ (size - BaseHeaderSize) - (format bitAnd: 3) "bytes"]!
Item was changed: ----- Method: ObjectMemory>>changeClassOf:to: (in category 'interpreter access') ----- changeClassOf: rcvr to: argClass "Attempt to change the class of the receiver to the argument given that the format of the receiver matches the format of the argument. If successful, answer 0, otherwise answer an error code indicating the reason for failure. Fail if the receiver is an instance of a compact class and the argument isn't, or if the format of the receiver is incompatible with the format of the argument, or if the argument is a fixed class and the receiver's size differs from the size that an instance of the argument should have." | classHdr sizeHiBits argClassInstByteSize argFormat rcvrFormat rcvrHdr ccIndex | "Check what the format of the class says" classHdr := self formatOfClass: argClass. "Low 2 bits are 0"
"Compute the size of instances of the class (used for fixed field classes only)" sizeHiBits := (classHdr bitAnd: 16r60000) >> 9. classHdr := classHdr bitAnd: 16r1FFFF. argClassInstByteSize := (classHdr bitAnd: SizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0"
"Check the receiver's format against that of the class" argFormat := self formatOfHeader: classHdr. rcvrHdr := self baseHeader: rcvr. rcvrFormat := self formatOfHeader: rcvrHdr. "If the receiver is a byte object we need to clear the number of odd bytes from the format." rcvrFormat > self firstByteFormat ifTrue: [rcvrFormat := rcvrFormat bitAnd: 16rC]. argFormat = rcvrFormat ifFalse: [^PrimErrInappropriate]. "no way"
"For fixed field classes, the sizes must match. Note: argClassInstByteSize-4 because base header is included in class size." argFormat < self arrayFormat ifTrue: + [(argClassInstByteSize - BaseHeaderSize) ~= (self numBytesOf: rcvr) ifTrue: - [(argClassInstByteSize - BaseHeaderSize) ~= (self byteLengthOf: rcvr) ifTrue: [^PrimErrBadReceiver]] ifFalse: [argFormat = self indexablePointersFormat ifTrue: "For indexable plus fixed fields the receiver must be at least big enough." + [(argClassInstByteSize - BaseHeaderSize) > (self numBytesOf: rcvr) ifTrue: - [(argClassInstByteSize - BaseHeaderSize) > (self byteLengthOf: rcvr) ifTrue: [^PrimErrBadReceiver]]].
(self headerTypeOfHeader: rcvrHdr) = HeaderTypeShort ifTrue: "Compact classes. Check if the arg's class is compact and exchange ccIndex" [ccIndex := classHdr bitAnd: CompactClassMask. ccIndex = 0 ifTrue: [^PrimErrInappropriate]. "class is not compact" self cppIf: IMMUTABILITY ifTrue: [(rcvrHdr bitAnd: ImmutabilityBit) ~= 0 ifTrue: [^PrimErrNoModification]]. self baseHeader: rcvr put: ((rcvrHdr bitClear: CompactClassMask) bitOr: ccIndex)] ifFalse: "Exchange the class pointer, which could make rcvr a root for argClass" [self cppIf: IMMUTABILITY ifTrue: [(rcvrHdr bitAnd: ImmutabilityBit) ~= 0 ifTrue: [^PrimErrNoModification]]. "N.B. the recursive scan-mark algorithm uses the header word's size and compact class fields to determine the header type when it reuses the header type bits for the mark state. So it is alas an invariant that non-compact headers have a 0 compact class field." (self compactClassIndexOfHeader: rcvrHdr) ~= 0 ifTrue: [self baseHeader: rcvr put: (rcvrHdr bitClear: CompactClassMask)]. self longAt: rcvr - BaseHeaderSize put: (argClass bitOr: (self headerTypeOfHeader: rcvrHdr)). (self oop: rcvr isLessThan: youngStart) ifTrue: [self possibleRootStoreInto: rcvr value: argClass]]. "ok" ^0!
Item was changed: + ----- Method: ObjectMemory>>characterObjectOf: (in category 'object access') ----- - ----- Method: ObjectMemory>>characterObjectOf: (in category 'primitive support') ----- characterObjectOf: characterCode <api> ^(characterCode between: 0 and: 255) ifTrue: [self fetchPointer: characterCode ofObject: self characterTable] ifFalse: [nilObj]!
Item was changed: + ----- Method: ObjectMemory>>compactClassIndexOf: (in category 'object access') ----- - ----- Method: ObjectMemory>>compactClassIndexOf: (in category 'header access') ----- compactClassIndexOf: oop <api> <inline: true> ^((self baseHeader: oop) >> self compactClassFieldLSB) bitAnd: 16r1F!
Item was changed: + ----- Method: ObjectMemory>>fetchByte:ofObject: (in category 'object access') ----- - ----- Method: ObjectMemory>>fetchByte:ofObject: (in category 'interpreter access') ----- fetchByte: byteIndex ofObject: oop <api> ^self byteAt: oop + BaseHeaderSize + byteIndex!
Item was changed: + ----- Method: ObjectMemory>>fetchClassOf: (in category 'object access') ----- - ----- Method: ObjectMemory>>fetchClassOf: (in category 'interpreter access') ----- fetchClassOf: oop | ccIndex | <inline: true> <asmLabel: false> ^(self isIntegerObject: oop) ifTrue: [self splObj: ClassSmallInteger] ifFalse: [(ccIndex := (self compactClassIndexOf: oop)) = 0 ifTrue: [(self classHeader: oop) bitAnd: AllButTypeMask] ifFalse: [self compactClassAt: ccIndex]]!
Item was changed: + ----- Method: ObjectMemory>>fetchClassOfNonImm: (in category 'object access') ----- - ----- Method: ObjectMemory>>fetchClassOfNonImm: (in category 'interpreter access') ----- fetchClassOfNonImm: oop | ccIndex | <inline: true> <asmLabel: false> ^(ccIndex := (self compactClassIndexOf: oop)) = 0 ifTrue: [(self classHeader: oop) bitAnd: AllButTypeMask] ifFalse: [self compactClassAt: ccIndex]!
Item was changed: + ----- Method: ObjectMemory>>fetchLong32:ofObject: (in category 'object access') ----- - ----- Method: ObjectMemory>>fetchLong32:ofObject: (in category 'interpreter access') ----- fetchLong32: fieldIndex ofObject: oop " index by 32-bit units, and return a 32-bit value. Intended to replace fetchWord:ofObject:"
^ self long32At: oop + BaseHeaderSize + (fieldIndex << 2)!
Item was removed: - ----- Method: ObjectMemory>>fetchLong32LengthOf: (in category 'interpreter access') ----- - fetchLong32LengthOf: objectPointer - "Gives size appropriate for, eg, fetchLong32" - - | sz | - sz := self sizeBitsOf: objectPointer. - ^ (sz - BaseHeaderSize) >> 2!
Item was added: + ----- Method: ObjectMemory>>fetchLong64:ofObject: (in category 'object access') ----- + fetchLong64: longIndex ofObject: oop + <returnTypeC: #sqLong> + ^self long64At: oop + BaseHeaderSize + (8 * (longIndex - 1))!
Item was changed: + ----- Method: ObjectMemory>>fetchPointer:ofObject: (in category 'object access') ----- - ----- Method: ObjectMemory>>fetchPointer:ofObject: (in category 'interpreter access') ----- fetchPointer: fieldIndex ofObject: oop "index by word size, and return a pointer as long as the word size" <api> ^self longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord)!
Item was added: + ----- Method: ObjectMemory>>fetchShort16:ofObject: (in category 'object access') ----- + fetchShort16: shortIndex ofObject: oop + ^self shortAt: oop + BaseHeaderSize + (2 * (shortIndex - 1))!
Item was removed: - ----- Method: ObjectMemory>>fetchWordLengthOf: (in category 'interpreter access') ----- - fetchWordLengthOf: objectPointer - "NOTE: this gives size appropriate for fetchPointer: n, but not in general for, eg, fetchLong32, etc." - - | sz | - sz := self sizeBitsOf: objectPointer. - ^ (sz - BaseHeaderSize) >> ShiftForWord!
Item was changed: + ----- Method: ObjectMemory>>firstFixedField: (in category 'object access') ----- - ----- Method: ObjectMemory>>firstFixedField: (in category 'object format') ----- firstFixedField: oop
<returnTypeC: #'void *'> ^ self pointerForOop: oop + BaseHeaderSize!
Item was changed: + ----- Method: ObjectMemory>>formatOf: (in category 'object access') ----- - ----- Method: ObjectMemory>>formatOf: (in category 'header access') ----- formatOf: oop " 0 no fields 1 fixed fields only (all containing pointers) 2 indexable fields only (all containing pointers) 3 both fixed and indexable fields (all containing pointers) 4 both fixed and indexable weak fields (all containing pointers).
5 unused (reserved for ephemerons?) 6 indexable word fields only (no pointers) 7 indexable long (64-bit) fields (only in 64-bit images)
8-11 indexable byte fields only (no pointers) (low 2 bits are low 2 bits of size) 12-15 compiled methods: # of literal oops specified in method header, followed by indexable bytes (same interpretation of low 2 bits as above) " <inline: true> ^((self baseHeader: oop) >> self instFormatFieldLSB) bitAnd: 16rF!
Item was changed: + ----- Method: ObjectMemory>>formatOfHeader: (in category 'object access') ----- - ----- Method: ObjectMemory>>formatOfHeader: (in category 'header access') ----- formatOfHeader: header " 0 no fields 1 fixed fields only (all containing pointers) 2 indexable fields only (all containing pointers) 3 both fixed and indexable fields (all containing pointers) 4 both fixed and indexable weak fields (all containing pointers).
5 unused 6 indexable word fields only (no pointers) 7 indexable long (64-bit) fields (only in 64-bit images)
8-11 indexable byte fields only (no pointers) (low 2 bits are low 2 bits of size) 12-15 compiled methods: # of literal oops specified in method header, followed by indexable bytes (same interpretation of low 2 bits as above) " <inline: true> ^header >> self instFormatFieldLSB bitAnd: 16rF!
Item was changed: ----- Method: ObjectMemory>>goodContextSize: (in category 'contexts') ----- goodContextSize: oop + | numSlots | + numSlots := self numSlotsOf: oop. + ^numSlots = SmallContextSlots or: [numSlots = LargeContextSlots]! - ^(self byteLengthOf: oop) = (SmallContextSize-BaseHeaderSize) - or: [(self byteLengthOf: oop) = (LargeContextSize-BaseHeaderSize)]!
Item was changed: + ----- Method: ObjectMemory>>is:instanceOf: (in category 'object access') ----- - ----- Method: ObjectMemory>>is:instanceOf: (in category 'header access') ----- is: oop instanceOf: classOop "Answer if oop is an instance of the given class. If the class has a (non-zero) compactClassIndex use that to speed up the check."
<inline: true> (self isIntegerObject: oop) ifTrue: [^classOop = (self splObj: ClassSmallInteger)].
^self isClassOfNonImm: oop equalTo: classOop!
Item was changed: + ----- Method: ObjectMemory>>is:instanceOf:compactClassIndex: (in category 'object access') ----- - ----- Method: ObjectMemory>>is:instanceOf:compactClassIndex: (in category 'header access') ----- is: oop instanceOf: classOop compactClassIndex: compactClassIndex "Answer if oop is an instance of the given class. 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 oop's compact class index and compactClassIndex are non-zero."
<inline: true> (self isIntegerObject: oop) ifTrue: [^false].
^self isClassOfNonImm: oop equalTo: classOop compactClassIndex: compactClassIndex!
Item was changed: + ----- Method: ObjectMemory>>isClassOfNonImm:equalTo:compactClassIndex: (in category 'object access') ----- - ----- Method: ObjectMemory>>isClassOfNonImm:equalTo:compactClassIndex: (in category 'header access') ----- isClassOfNonImm: oop equalTo: classOop compactClassIndex: compactClassIndex "Answer if the given (non-immediate) object is an instance of the given class that may have a compactClassIndex (if compactClassIndex is non-zero). N.B. Inlining and/or compiler optimization should result in classOop not being accessed if oop's compact class index and compactClassIndex are non-zero. N.B. Generally one cannot assume that if compactClassIndex is non-zero the instances of the corresponding class always have the compactClassIndex because the compact class index is only non-zero in short header instances."
| ccIndex | <inline: true> <asmLabel: false> self assert: (self isIntegerObject: oop) not.
ccIndex := self compactClassIndexOf: oop. ccIndex = 0 ifTrue: [^((self classHeader: oop) bitAnd: AllButTypeMask) = classOop]. compactClassIndex ~= 0 ifTrue: [^compactClassIndex = ccIndex]. ^classOop = (self compactClassAt: ccIndex)!
Item was changed: + ----- Method: ObjectMemory>>lengthOf: (in category 'object access') ----- - ----- Method: ObjectMemory>>lengthOf: (in category 'indexing primitive support') ----- lengthOf: oop "Return the number of indexable bytes or words in the given object. Assume the argument is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result."
<api> | header | <inline: true> <asmLabel: false> header := self baseHeader: oop. ^self lengthOf: oop baseHeader: header format: (self formatOfHeader: header)!
Item was changed: + ----- Method: ObjectMemory>>lengthOf:baseHeader:format: (in category 'object access') ----- - ----- Method: ObjectMemory>>lengthOf:baseHeader:format: (in category 'indexing primitive support') ----- lengthOf: oop baseHeader: hdr format: fmt "Return the number of fixed and indexable bytes, words, or object pointers in the given object. Assume the given oop is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result of this method."
| sz | <inline: true> <asmLabel: false> (hdr bitAnd: TypeMask) = HeaderTypeSizeAndClass ifTrue: [ sz := (self sizeHeader: oop) bitAnd: LongSizeMask ] ifFalse: [ sz := (hdr bitAnd: SizeMask)]. sz := sz - (hdr bitAnd: Size4Bit). fmt <= self lastPointerFormat ifTrue: [ ^ (sz - BaseHeaderSize) >> ShiftForWord "words"]. ^fmt < self firstByteFormat ifTrue: [(sz - BaseHeaderSize) >> 2 "32-bit longs"] ifFalse: [(sz - BaseHeaderSize) - (fmt bitAnd: 3) "bytes"]!
Item was added: + ----- Method: ObjectMemory>>num16BitUnitsOf: (in category 'object access') ----- + num16BitUnitsOf: objOop + "Answer the number of 16-bit units in the given non-immediate object. + N..B. Rounds down 8-bit units, so a 5 byte object has 2 16-bit units. + Does not adjust the size of contexts by stackPointer." + ^(self numBytesOf: objOop) >> 1!
Item was added: + ----- Method: ObjectMemory>>num32BitUnitsOf: (in category 'object access') ----- + num32BitUnitsOf: objOop + "Answer the number of 16-bit units in the given non-immediate object. + N..B. Rounds down 8-bit units, so a 7 byte object has 1 32-bit unit. + Does not adjust the size of contexts by stackPointer." + ^(self numBytesOf: objOop) >> 2!
Item was added: + ----- Method: ObjectMemory>>num64BitUnitsOf: (in category 'object access') ----- + num64BitUnitsOf: objOop + "Answer the number of 16-bit units in the given non-immediate object. + N..B. Rounds down 8-bit units, so a 15 byte object has 1 64-bit unit. + Does not adjust the size of contexts by stackPointer." + ^(self numBytesOf: objOop) >> 3!
Item was added: + ----- Method: ObjectMemory>>numBytesOf: (in category 'object access') ----- + numBytesOf: objOop + "Answer the number of indexable bytes in the given non-immediate object. + Does not adjust the size of contexts by stackPointer." + <api> + | header sz fmt | + header := self baseHeader: objOop. + sz := (header bitAnd: TypeMask) = HeaderTypeSizeAndClass + ifTrue: [(self sizeHeader: objOop) bitAnd: AllButTypeMask] + ifFalse: [header bitAnd: SizeMask]. + fmt := self formatOfHeader: header. + ^fmt < self firstByteFormat + ifTrue: [(sz - BaseHeaderSize)] "words" + ifFalse: [(sz - BaseHeaderSize) - (fmt bitAnd: 3)] "bytes"!
Item was added: + ----- Method: ObjectMemory>>numSlotsOf: (in category 'object access') ----- + numSlotsOf: obj + "Answer the number of oop-sized elements in the given object. + Unlike lengthOf: this does not adjust the length of a context + by the stackPointer and so can be used e.g. by cloneContext:" + <api> + | header sz | + header := self baseHeader: obj. + sz := (header bitAnd: TypeMask) = HeaderTypeSizeAndClass + ifTrue: [(self sizeHeader: obj) bitAnd: AllButTypeMask] + ifFalse: [header bitAnd: SizeMask]. + ^sz - BaseHeaderSize >> ShiftForWord!
Item was changed: ----- Method: ObjectMemory>>printWronglySizedContexts (in category 'debug printing') ----- printWronglySizedContexts "Scan the heap printing the oops of any and all contexts whose size is not either SmallContextSize or LargeContextSize" | oop | <api> oop := self firstAccessibleObject. [oop = nil] whileFalse: [((self isContextNonImm: oop) and: [self badContextSize: oop]) ifTrue: + [self printHex: oop; space; printNum: (self numBytesOf: oop); cr]. - [self printHex: oop; space; printNum: (self byteLengthOf: oop); cr]. oop := self accessibleObjectAfter: oop]!
Item was changed: + ----- Method: ObjectMemory>>sizeBitsOf: (in category 'object access') ----- - ----- Method: ObjectMemory>>sizeBitsOf: (in category 'header access') ----- sizeBitsOf: oop "Answer the number of bytes in the given object, including its base header, rounded up to an integral number of words." "Note: byte indexable objects need to have low bits subtracted from this size."
| header | header := self baseHeader: oop. (header bitAnd: TypeMask) = HeaderTypeSizeAndClass ifTrue: [ ^ (self sizeHeader: oop) bitAnd: LongSizeMask ] ifFalse: [ ^ header bitAnd: SizeMask ].!
Item was changed: + ----- Method: ObjectMemory>>sizeBitsOfSafe: (in category 'object access') ----- - ----- Method: ObjectMemory>>sizeBitsOfSafe: (in category 'header access') ----- sizeBitsOfSafe: oop "Compute the size of the given object from the cc and size fields in its header. This works even if its type bits are not correct."
| header type | header := self baseHeader: oop. type := self rightType: header. type = HeaderTypeSizeAndClass ifTrue: [ ^ (self sizeHeader: oop) bitAnd: AllButTypeMask ] ifFalse: [ ^ header bitAnd: SizeMask ].!
Item was changed: + ----- Method: ObjectMemory>>slotSizeOf: (in category 'object access') ----- - ----- Method: ObjectMemory>>slotSizeOf: (in category 'object format') ----- slotSizeOf: oop "Returns the number of slots in the receiver. If the receiver is a byte object, return the number of bytes. Otherwise return the number of words." (self isIntegerObject: oop) ifTrue:[^0]. ^self lengthOf: oop!
Item was changed: + ----- Method: ObjectMemory>>storeByte:ofObject:withValue: (in category 'object access') ----- - ----- Method: ObjectMemory>>storeByte:ofObject:withValue: (in category 'interpreter access') ----- storeByte: byteIndex ofObject: oop withValue: valueByte
^ self byteAt: oop + BaseHeaderSize + byteIndex put: valueByte!
Item was changed: + ----- Method: ObjectMemory>>storeLong32:ofObject:withValue: (in category 'object access') ----- - ----- Method: ObjectMemory>>storeLong32:ofObject:withValue: (in category 'interpreter access') ----- storeLong32: fieldIndex ofObject: oop withValue: valueWord
^ self long32At: oop + BaseHeaderSize + (fieldIndex << 2) put: valueWord!
Item was added: + ----- Method: ObjectMemory>>storeLong64:ofObject:withValue: (in category 'object access') ----- + storeLong64: longIndex ofObject: oop withValue: value + <var: #value type: #sqLong> + ^self long64At: oop + BaseHeaderSize + (8 * (longIndex - 1)) put: value!
Item was changed: + ----- Method: ObjectMemory>>storePointer:ofObject:withValue: (in category 'object access') ----- - ----- Method: ObjectMemory>>storePointer:ofObject:withValue: (in category 'interpreter access') ----- storePointer: fieldIndex ofObject: oop withValue: valuePointer "Note must check here for stores of young objects into old ones."
(self oop: oop isLessThan: youngStart) ifTrue: [ self possibleRootStoreInto: oop value: valuePointer. ].
^ self longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord) put: valuePointer!
Item was changed: + ----- Method: ObjectMemory>>storePointerUnchecked:ofObject:withValue: (in category 'object access') ----- - ----- Method: ObjectMemory>>storePointerUnchecked:ofObject:withValue: (in category 'interpreter access') ----- storePointerUnchecked: fieldIndex ofObject: oop withValue: valuePointer "Like storePointer:ofObject:withValue:, but the caller guarantees that the object being stored into is a young object or is already marked as a root." <api> <inline: true> ^self longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord) put: valuePointer!
Item was added: + ----- Method: ObjectMemory>>storeShort16:ofObject:withValue: (in category 'object access') ----- + storeShort16: shortIndex ofObject: oop withValue: value + ^self shortAt: oop + BaseHeaderSize + (2 * (shortIndex - 1)) put: value!
Item was changed: ----- Method: Spur32BitMemoryManager>>changeClassOf:to: (in category 'interpreter access') ----- changeClassOf: rcvr to: argClass "Attempt to change the class of the receiver to the argument given that the format of the receiver matches the format of the argument. If successful, answer 0, otherwise answer an error code indicating the reason for failure. Fail if the format of the receiver is incompatible with the format of the argument, or if the argument is a fixed class and the receiver's size differs from the size that an instance of the argument should have." <inline: false> | classFormat fixedFields instFormat normalizedInstFormat newFormat classIndex | classFormat := self formatOfClass: argClass. fixedFields := self fixedFieldsOfClassFormat: classFormat. classFormat := self instSpecOfClassFormat: classFormat. instFormat := self formatOf: rcvr. normalizedInstFormat := self classFormatForInstanceFormat: instFormat.
(normalizedInstFormat > self lastPointerFormat and: [normalizedInstFormat = classFormat]) ifTrue: [newFormat := instFormat] ifFalse: [normalizedInstFormat <= self lastPointerFormat ifTrue: [classFormat > self lastPointerFormat ifTrue: [^PrimErrInappropriate]. (self numSlotsOf: rcvr) < fixedFields ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat] ifFalse: [| instBytes | + instBytes := self numBytesOf: rcvr. - instBytes := self byteLengthOf: rcvr. normalizedInstFormat caseOf: { [self sixtyFourBitIndexableFormat] -> [(classFormat < self sixtyFourBitIndexableFormat or: [classFormat >= self firstCompiledMethodFormat]) ifTrue: [^PrimErrInappropriate]. newFormat := classFormat]. [self firstLongFormat] -> [(classFormat < self sixtyFourBitIndexableFormat or: [classFormat >= self firstCompiledMethodFormat]) ifTrue: [^PrimErrInappropriate]. (classFormat = self sixtyFourBitIndexableFormat and: [instBytes anyMask: 1]) ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat]. [self firstShortFormat] -> [(classFormat < self sixtyFourBitIndexableFormat or: [classFormat >= self firstCompiledMethodFormat]) ifTrue: [^PrimErrInappropriate]. classFormat caseOf: { [self sixtyFourBitIndexableFormat] -> [(instBytes anyMask: 3) ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat]. [self firstLongFormat] -> [(instBytes anyMask: 1) ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat]. [self firstByteFormat] -> [newFormat := classFormat + (4 - instBytes bitAnd: 3)] }]. [self firstByteFormat] -> [(classFormat < self sixtyFourBitIndexableFormat or: [classFormat >= self firstCompiledMethodFormat]) ifTrue: [^PrimErrInappropriate]. classFormat caseOf: { [self sixtyFourBitIndexableFormat] -> [(instBytes anyMask: 7) ifTrue: [^PrimErrBadReceiver]]. [self firstLongFormat] -> [(instBytes anyMask: 3) ifTrue: [^PrimErrBadReceiver]]. [self firstShortFormat] -> [(instBytes anyMask: 1) ifTrue: [^PrimErrBadReceiver]] }. newFormat := classFormat]. [self firstCompiledMethodFormat] -> [classFormat ~= self firstCompiledMethodFormat ifTrue: [^PrimErrInappropriate]. newFormat := instFormat] }]].
(classIndex := self ensureBehaviorHash: argClass) < 0 ifTrue: [^classIndex negated]. self set: rcvr classIndexTo: classIndex formatTo: newFormat. "ok" ^0!
Item was changed: ----- Method: Spur64BitMemoryManager>>changeClassOf:to: (in category 'interpreter access') ----- changeClassOf: rcvr to: argClass "Attempt to change the class of the receiver to the argument given that the format of the receiver matches the format of the argument. If successful, answer 0, otherwise answer an error code indicating the reason for failure. Fail if the format of the receiver is incompatible with the format of the argument, or if the argument is a fixed class and the receiver's size differs from the size that an instance of the argument should have." <inline: false> | classFormat fixedFields instFormat normalizedInstFormat newFormat classIndex | classFormat := self formatOfClass: argClass. fixedFields := self fixedFieldsOfClassFormat: classFormat. classFormat := self instSpecOfClassFormat: classFormat. instFormat := self formatOf: rcvr. normalizedInstFormat := self classFormatForInstanceFormat: instFormat.
(normalizedInstFormat > self lastPointerFormat and: [normalizedInstFormat = classFormat]) ifTrue: [newFormat := instFormat] ifFalse: [normalizedInstFormat <= self lastPointerFormat ifTrue: [classFormat > self lastPointerFormat ifTrue: [^PrimErrInappropriate]. (self numSlotsOf: rcvr) < fixedFields ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat] ifFalse: [| instBytes | + instBytes := self numBytesOf: rcvr. - instBytes := self byteLengthOf: rcvr. normalizedInstFormat caseOf: { [self sixtyFourBitIndexableFormat] -> [(classFormat < self sixtyFourBitIndexableFormat or: [classFormat >= self firstCompiledMethodFormat]) ifTrue: [^PrimErrInappropriate]. newFormat := classFormat]. [self firstLongFormat] -> [(classFormat < self sixtyFourBitIndexableFormat or: [classFormat >= self firstCompiledMethodFormat]) ifTrue: [^PrimErrInappropriate]. (classFormat = self sixtyFourBitIndexableFormat and: [instBytes anyMask: 1]) ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat]. [self firstShortFormat] -> [(classFormat < self sixtyFourBitIndexableFormat or: [classFormat >= self firstCompiledMethodFormat]) ifTrue: [^PrimErrInappropriate]. classFormat caseOf: { [self sixtyFourBitIndexableFormat] -> [(instBytes anyMask: 7) ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat]. [self firstLongFormat] -> [(instBytes anyMask: 3) ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat + (2 - instBytes bitAnd: 1)]. [self firstByteFormat] -> [newFormat := classFormat + (8 - instBytes bitAnd: 7)] }]. [self firstByteFormat] -> [(classFormat < self sixtyFourBitIndexableFormat or: [classFormat >= self firstCompiledMethodFormat]) ifTrue: [^PrimErrInappropriate]. classFormat caseOf: { [self sixtyFourBitIndexableFormat] -> [(instBytes anyMask: 7) ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat]. [self firstLongFormat] -> [(instBytes anyMask: 3) ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat + (2 - instBytes bitAnd: 1)]. [self firstShortFormat] -> [(instBytes anyMask: 1) ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat + (4 - instBytes bitAnd: 3)] }. newFormat := classFormat]. [self firstCompiledMethodFormat] -> [classFormat ~= self firstCompiledMethodFormat ifTrue: [^PrimErrInappropriate]. newFormat := instFormat] }]].
(classIndex := self ensureBehaviorHash: argClass) < 0 ifTrue: [^classIndex negated]. self set: rcvr classIndexTo: classIndex formatTo: newFormat. "ok" ^0!
Item was removed: - ----- Method: SpurMemoryManager>>byteLengthOf: (in category 'object access') ----- - byteLengthOf: objOop - "Answer the number of indexable bytes in the given object. - Does not adjust contexts by stackPointer. - This is basically a special copy of lengthOf: for BitBlt. But it is also - whoorishly used for the Cogit." - <api> - | fmt numBytes | - <inline: true> - <asmLabel: false> - fmt := self formatOf: objOop. - numBytes := (self numSlotsOf: objOop) << self shiftForWord. - fmt <= self sixtyFourBitIndexableFormat ifTrue: - [^numBytes]. - fmt >= self firstByteFormat ifTrue: "bytes, including CompiledMethod" - [^numBytes - (fmt bitAnd: 7)]. - fmt >= self firstShortFormat ifTrue: - [^numBytes - ((fmt bitAnd: 3) << 1)]. - "fmt >= self firstLongFormat" - ^numBytes - ((fmt bitAnd: 1) << 2)!
Item was changed: ----- Method: SpurMemoryManager>>byteSizeOf: (in category 'object access') ----- byteSizeOf: oop <api> - | format | (self isImmediate: oop) ifTrue: [^0]. + ^self numBytesOf: oop! - format := self formatOf: oop. - format < self sixtyFourBitIndexableFormat ifTrue: - [^(self numSlotsOf: oop) << self shiftForWord]. - format >= self firstByteFormat ifTrue: - [^(self numSlotsOf: oop) << self shiftForWord - (format bitAnd: 7)]. - format >= self firstShortFormat ifTrue: - [^(self numSlotsOf: oop) << self shiftForWord - ((format bitAnd: 3) << 1)]. - format >= self firstLongFormat ifTrue: - [^(self numSlotsOf: oop) << self shiftForWord - ((format bitAnd: 1) << 2)]. - ^(self numSlotsOf: oop) << self shiftForWord!
Item was added: + ----- Method: SpurMemoryManager>>fetchLong64:ofObject: (in category 'object access') ----- + fetchLong64: longIndex ofObject: objOop + <returnTypeC: #sqLong> + ^self long64At: objOop + self baseHeaderSize + (8 * (longIndex - 1))!
Item was added: + ----- Method: SpurMemoryManager>>fetchShort16:ofObject: (in category 'object access') ----- + fetchShort16: shortIndex ofObject: objOop + ^self shortAt: objOop + self baseHeaderSize + (2 * (shortIndex - 1))!
Item was removed: - ----- Method: SpurMemoryManager>>fetchWordLengthOf: (in category 'object access') ----- - fetchWordLengthOf: objOop - "NOTE: this gives size appropriate for fetchPointer: n, but not in general for, eg, fetchLong32, etc. - Unlike lengthOf: this does not adjust the length of a context - by the stackPointer and so can be used e.g. by cloneContext:" - ^self numSlotsOf: objOop!
Item was added: + ----- Method: SpurMemoryManager>>num16BitUnitsOf: (in category 'object access') ----- + num16BitUnitsOf: objOop + "Answer the number of 16-bit units in the given non-immediate object. + N..B. Rounds down 8-bit units, so a 5 byte object has 2 16-bit units. + Does not adjust the size of contexts by stackPointer." + ^(self numBytesOf: objOop) >> 1!
Item was added: + ----- Method: SpurMemoryManager>>num32BitUnitsOf: (in category 'object access') ----- + num32BitUnitsOf: objOop + "Answer the number of 16-bit units in the given non-immediate object. + N..B. Rounds down 8-bit units, so a 7 byte object has 1 32-bit unit. + Does not adjust the size of contexts by stackPointer." + ^(self numBytesOf: objOop) >> 2!
Item was added: + ----- Method: SpurMemoryManager>>num64BitUnitsOf: (in category 'object access') ----- + num64BitUnitsOf: objOop + "Answer the number of 16-bit units in the given non-immediate object. + N..B. Rounds down 8-bit units, so a 15 byte object has 1 64-bit unit. + Does not adjust the size of contexts by stackPointer." + ^(self numBytesOf: objOop) >> 3!
Item was added: + ----- Method: SpurMemoryManager>>numBytesOf: (in category 'object access') ----- + numBytesOf: objOop + "Answer the number of indexable bytes in the given non-immediate object. + Does not adjust the size of contexts by stackPointer." + <api> + | fmt numBytes | + <inline: true> + <asmLabel: false> + fmt := self formatOf: objOop. + numBytes := self numSlotsOf: objOop. + numBytes := numBytes << self shiftForWord. + fmt <= self sixtyFourBitIndexableFormat ifTrue: + [^numBytes]. + fmt >= self firstByteFormat ifTrue: "bytes, including CompiledMethod" + [^numBytes - (fmt bitAnd: 7)]. + fmt >= self firstShortFormat ifTrue: + [^numBytes - ((fmt bitAnd: 3) << 1)]. + "fmt >= self firstLongFormat" + ^numBytes - ((fmt bitAnd: 1) << 2)!
Item was added: + ----- Method: SpurMemoryManager>>storeLong64:ofObject:withValue: (in category 'object access') ----- + storeLong64: longIndex ofObject: objOop withValue: value + <var: #value type: #sqLong> + ^self long64At: objOop + self baseHeaderSize + (8 * (longIndex - 1)) put: value!
Item was added: + ----- Method: SpurMemoryManager>>storeShort16:ofObject:withValue: (in category 'object access') ----- + storeShort16: shortIndex ofObject: objOop withValue: value + ^self shortAt: objOop + self baseHeaderSize + (2 * (shortIndex - 1)) put: value!
Item was added: + ----- Method: SpurMemoryManager>>unpinObject: (in category 'primitive support') ----- + unpinObject: objOop + self assert: (self isNonImmediate: objOop). + self setIsPinnedOf: objOop to: false. + ^0!
Item was changed: ----- Method: StackInterpreter>>callPrimitiveBytecode (in category 'miscellaneous bytecodes') ----- callPrimitiveBytecode + "V4: 249 11111001 i i i i i i i i jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256) + SistaV1: 248 11111000 iiiiiiii mjjjjjjj Call Primitive #iiiiiiii + (jjjjjjj * 256) m=1 means inlined primitive, no hard return after execution." + self cppIf: SistaVM + ifTrue: + [| byte1 byte2 | + byte1 := self fetchByte. + byte2 := self fetchByte. + self fetchNextBytecode. + byte2 > 127 + ifTrue: + [self inlinePrimitiveBytecode: (byte2 bitAnd: 16r7F) << 8 + byte1] + ifFalse: + [self error: 'non-inlined callPrimitiveBytecode should not be evaluated. method activation should step beyond this bytecode.']] + ifFalse: + [self error: 'callPrimitiveBytecode should not be evaluated. method activation should step beyond this bytecode.'] + - "249 11111001 i i i i i i i i jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256)" - self error: 'should not be evaluated. method activation should step beyond this bytecode.' "We could make it a noop and not skip it in {foo}ActivateMethod, as in:
localIP := localIP + 3. self fetchNextBytecode
But for now, having {foo}ActivateMethod skip it makes it available for invoking embedded primitives."!
Item was changed: ----- Method: StackInterpreter>>closureIn:numArgs:instructionPointer:copiedValues: (in category 'control primitives') ----- closureIn: context numArgs: numArgs instructionPointer: initialIP copiedValues: copiedValues | newClosure numCopied | <inline: true> "numCopied should be zero for nil" + numCopied := objectMemory numSlotsOf: copiedValues. - numCopied := objectMemory fetchWordLengthOf: copiedValues. ClassBlockClosureCompactIndex ~= 0 ifTrue: [newClosure := objectMemory eeInstantiateSmallClassIndex: ClassBlockClosureCompactIndex format: objectMemory indexablePointersFormat numSlots: ClosureFirstCopiedValueIndex + numCopied] ifFalse: [newClosure := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassBlockClosure) numSlots: ClosureFirstCopiedValueIndex + numCopied]. "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores." objectMemory storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: context; storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: initialIP); storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: numArgs). 0 to: numCopied - 1 do: [:i| objectMemory storePointerUnchecked: i + ClosureFirstCopiedValueIndex ofObject: newClosure withValue: (objectMemory fetchPointer: i ofObject: copiedValues)]. ^newClosure!
Item was changed: ----- Method: StackInterpreter>>copiedValueCountOfClosure: (in category 'internal interpreter access') ----- copiedValueCountOfClosure: closurePointer <api> "for Cogit" + ^(objectMemory numSlotsOf: closurePointer) - ClosureFirstCopiedValueIndex! - ^(objectMemory fetchWordLengthOf: closurePointer) - ClosureFirstCopiedValueIndex!
Item was changed: ----- Method: StackInterpreter>>findClassContainingMethod:startingAt: (in category 'debug support') ----- findClassContainingMethod: meth startingAt: classObj | currClass classDict classDictSize methodArray i | currClass := classObj. [self assert: (objectMemory isForwarded: currClass) not. classDict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: currClass. self assert: (objectMemory isForwarded: classDict) not. + classDictSize := objectMemory numSlotsOf: classDict. - classDictSize := objectMemory fetchWordLengthOf: classDict. methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict. self assert: (objectMemory isForwarded: methodArray) not. i := 0. [i < (classDictSize - SelectorStart)] whileTrue: [meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue: [^currClass]. i := i + 1]. currClass := self superclassOf: currClass. currClass = objectMemory nilObject] whileFalse. ^currClass "method not found in superclass chain"!
Item was changed: ----- 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 numSlotsOf: classDict. - 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 changed: ----- 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 numSlotsOf: classDict. - 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>>findSelectorOfMethod: (in category 'debug support') ----- findSelectorOfMethod: methArg | meth classObj classDict classDictSize methodArray i | (objectMemory addressCouldBeObj: methArg) ifFalse: [^objectMemory nilObject]. (objectMemory isForwarded: methArg) ifTrue: [meth := objectMemory followForwarded: methArg] ifFalse: [meth := methArg]. (objectMemory isOopCompiledMethod: meth) ifFalse: [^objectMemory nilObject]. classObj := self methodClassOf: meth. (self addressCouldBeClassObj: classObj) ifTrue: [classDict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: classObj. + classDictSize := objectMemory numSlotsOf: classDict. - classDictSize := objectMemory fetchWordLengthOf: classDict. methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict. i := 0. [i < (classDictSize - SelectorStart)] whileTrue: [meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue: [^(objectMemory fetchPointer: i + SelectorStart ofObject: classDict)]. i := i + 1]]. ^objectMemory nilObject!
Item was changed: ----- Method: StackInterpreter>>highestPriorityProcess (in category 'process primitive support') ----- highestPriorityProcess "Answer the highest priority process that is ready to run, but unlike wakeHighestPriority do not remove it from the list. To save time looking at many empty lists before finding a runnable process the VM maintains a variable holding the highest priority runnable process. If this variable is 0 then the VM does not know the highest priority and must search all lists. Note: It is a fatal VM error if there is no runnable process." | schedLists p processList processOrNil | <inline: false> schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer. p := highestRunnableProcessPriority = 0 + ifTrue: [objectMemory numSlotsOf: schedLists] - ifTrue: [objectMemory fetchWordLengthOf: schedLists] ifFalse: [highestRunnableProcessPriority]. p := p - 1. "index of last indexable field" [processList := objectMemory fetchPointer: p ofObject: schedLists. processOrNil := objectMemory fetchPointer: FirstLinkIndex ofObject: processList. processOrNil = objectMemory nilObject] whileTrue: [(p := p - 1) < 0 ifTrue: [^nil]]. highestRunnableProcessPriority := p + 1. ^processOrNil!
Item was added: + ----- Method: StackInterpreter>>inlinePrimitiveBytecode: (in category 'miscellaneous bytecodes') ----- + inlinePrimitiveBytecode: primIndex + "SistaV1: 248 11111000 iiiiiiii mjjjjjjj Call Primitive #iiiiiiii + (jjjjjjj * 256) m=1 means inlined primitive, no hard return after execution." + <option: #SistaVM> + | result result64 | + primIndex caseOf: { + "0 unchecked SmallInteger #+. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)" + [0] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop) + + (objectMemory integerValueOf: (self internalStackValue: 1))). + self internalPop: 1; internalStackTopPut: result]. + "1 unchecked SmallInteger #-. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)" + [1] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop) + - (objectMemory integerValueOf: (self internalStackValue: 1))). + self internalPop: 1; internalStackTopPut: result]. + "2 unchecked SmallInteger #*. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)" + [2] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop) + * (objectMemory integerValueOf: (self internalStackValue: 1))). + self internalPop: 1; internalStackTopPut: result]. + "3 unchecked SmallInteger #/. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)" + [3] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop) + / (objectMemory integerValueOf: (self internalStackValue: 1))). + self internalPop: 1; internalStackTopPut: result]. + "4 unchecked SmallInteger #//. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)" + [4] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop) + // (objectMemory integerValueOf: (self internalStackValue: 1))). + self internalPop: 1; internalStackTopPut: result]. + "5 unchecked SmallInteger #\. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)" + [5] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop) + \ (objectMemory integerValueOf: (self internalStackValue: 1))). + self internalPop: 1; internalStackTopPut: result]. + "6 unchecked SmallInteger #quo:. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)" + [6] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop) + quo: (objectMemory integerValueOf: (self internalStackValue: 1))). + self internalPop: 1; internalStackTopPut: result]. + + "16 unchecked SmallInteger #bitAnd:. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)" + [16] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop) + bitAnd: (objectMemory integerValueOf: (self internalStackValue: 1))). + self internalPop: 1; internalStackTopPut: result]. + "17 unchecked SmallInteger #bitOr:. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)" + [17] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop) + bitOr: (objectMemory integerValueOf: (self internalStackValue: 1))). + self internalPop: 1; internalStackTopPut: result]. + "18 unchecked SmallInteger #bitXor:. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)" + [18] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop) + bitXor: (objectMemory integerValueOf: (self internalStackValue: 1))). + self internalPop: 1; internalStackTopPut: result]. + "19 unchecked SmallInteger #bitShift:. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)" + [19] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop) + bitShift: (objectMemory integerValueOf: (self internalStackValue: 1))). + self internalPop: 1; internalStackTopPut: result]. + + "32 unchecked SmallInteger #>. Both arguments are SmallIntegers" + [32] -> [result := objectMemory booleanObjectOf: (self internalStackTop > (self internalStackValue: 1)). + self internalPop: 1; internalStackTopPut: result]. + "33 unchecked SmallInteger #<. Both arguments are SmallIntegers" + [33] -> [result := objectMemory booleanObjectOf: (self internalStackTop < (self internalStackValue: 1)). + self internalPop: 1; internalStackTopPut: result]. + "34 unchecked SmallInteger #>=. Both arguments are SmallIntegers" + [34] -> [result := objectMemory booleanObjectOf: (self internalStackTop >= (self internalStackValue: 1)). + self internalPop: 1; internalStackTopPut: result]. + "35 unchecked SmallInteger #<=. Both arguments are SmallIntegers" + [35] -> [result := objectMemory booleanObjectOf: (self internalStackTop <= (self internalStackValue: 1)). + self internalPop: 1; internalStackTopPut: result]. + "36 unchecked SmallInteger #=. Both arguments are SmallIntegers" + [36] -> [result := objectMemory booleanObjectOf: (self internalStackTop = (self internalStackValue: 1)). + self internalPop: 1; internalStackTopPut: result]. + "37 unchecked SmallInteger #~=. Both arguments are SmallIntegers" + [37] -> [result := objectMemory booleanObjectOf: (self internalStackTop ~= (self internalStackValue: 1)). + self internalPop: 1; internalStackTopPut: result]. + + "64 unchecked Pointer Object>>at:. The receiver is guaranteed to be a pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger" + [64] -> [result := objectMemory + fetchPointer: (objectMemory integerValueOf: self internalStackTop) + ofObject: (self internalStackValue: 1). + self internalPop: 1; internalStackTopPut: result]. + "65 unchecked Byte Object>>at:. The receiver is guaranteed to be a non-pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger. The result is a SmallInteger." + [65] -> [result := objectMemory + fetchByte: (objectMemory integerValueOf: self internalStackTop) + ofObject: (self internalStackValue: 1). + self internalPop: 1; internalStackTopPut: (objectMemory integerObjectOf: result)]. + "66 unchecked Word Object>>at:. The receiver is guaranteed to be a non-pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger. The result is a SmallInteger." + [66] -> [result := objectMemory + fetchShort: (objectMemory integerValueOf: self internalStackTop) + ofObject: (self internalStackValue: 1). + self internalPop: 1; internalStackTopPut: (objectMemory integerObjectOf: result)]. + "67 unchecked DoubleWord Object>>at:. The receiver is guaranteed to be a non-pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger. The result is a SmallInteger or a LargePositiveInteger." + [67] -> [result := objectMemory + fetchLong32: (objectMemory integerValueOf: self internalStackTop) + ofObject: (self internalStackValue: 1). + self internalPop: 1; internalStackTopPut: (self signed64BitValueOf: result)]. + "68 unchecked QuadWord Object>>at:. The receiver is guaranteed to be a non-pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger. The result is a SmallInteger or a LargePositiveInteger." + [68] -> [result64 := objectMemory + fetchLong64: (objectMemory integerValueOf: self internalStackTop) + ofObject: (self internalStackValue: 1). + self internalPop: 1; internalStackTopPut: (self signed64BitValueOf: result)]. + + "80 unchecked Pointer Object>>at:put:. The receiver is guaranteed to be a pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger" + [80] -> [result := self internalStackTop. + objectMemory + storePointer: (objectMemory integerValueOf: (self internalStackValue: 1)) + ofObject: (self internalStackValue: 1) + withValue: result. + self internalPop: 2; internalStackTopPut: result]. + "81 unchecked Byte Object>>at:put:. The receiver is guaranteed to be a non-pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger. The argument is a SmallInteger. The primitive stores the least significant 8 bits." + [81] -> [result := self internalStackTop. + objectMemory + storeByte: (objectMemory integerValueOf: (self internalStackValue: 1)) + ofObject: (self internalStackValue: 1) + withValue: (objectMemory integerValueOf: result). + self internalPop: 2; internalStackTopPut: result]. + "82 unchecked Word Object>>at:put:. The receiver is guaranteed to be a non-pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger. The argument is a SmallInteger. The primitive stores the least significant 16 bits." + [82] -> [result := self internalStackTop. + objectMemory + storeShort: (objectMemory integerValueOf: (self internalStackValue: 1)) + ofObject: (self internalStackValue: 1) + withValue: (objectMemory integerValueOf: result). + self internalPop: 2; internalStackTopPut: result]. + "83 unchecked DoubleWord Object>>at:put:. The receiver is guaranteed to be a non-pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger. The argument is a SmallInteger. The primitive stores the least significant 32 bits." + [83] -> [result := self internalStackTop. + objectMemory + storeLong32: (objectMemory integerValueOf: (self internalStackValue: 1)) + ofObject: (self internalStackValue: 1) + withValue: (objectMemory integerValueOf: result). + self internalPop: 2; internalStackTopPut: result]. + "84 unchecked QuadWord Object>>at:put:. The receiver is guaranteed to be a non-pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger. The argument is a SmallInteger. The primitive stores the least significant 64 bits." + [84] -> [result := self internalStackTop. + objectMemory + storeLong64: (objectMemory integerValueOf: (self internalStackValue: 1)) + ofObject: (self internalStackValue: 1) + withValue: (objectMemory integerValueOf: result). + self internalPop: 2; internalStackTopPut: result] } + otherwise: + [localIP := localIP - 3. + self respondToUnknownBytecode]!
Item was changed: ----- Method: StackInterpreter>>longPrintOop: (in category 'debug printing') ----- longPrintOop: oop <api> | fmt lastIndex startIP bytecodesPerLine column | ((objectMemory isImmediate: oop) or: [(objectMemory addressCouldBeObj: oop) not or: [(oop bitAnd: objectMemory allocationUnit - 1) ~= 0 or: [(objectMemory isFreeObject: oop) or: [objectMemory isForwarded: oop]]]]) ifTrue: [self printOop: oop. ^self]. self printHex: oop. (objectMemory fetchClassOfNonImm: oop) ifNil: [self print: ' has a nil class!!!!'] ifNotNil: [:class| self print: ': a(n) '; printNameOfClass: class count: 5; print: ' ('. objectMemory hasSpurMemoryManagerAPI ifTrue: [self printHexnp: (objectMemory compactClassIndexOf: oop); print: '=>']. self printHexnp: class; print: ')']. fmt := objectMemory formatOf: oop. self print: ' format '; printHexnp: fmt. fmt > objectMemory lastPointerFormat + ifTrue: [self print: ' nbytes '; printNum: (objectMemory numBytesOf: oop)] - ifTrue: [self print: ' nbytes '; printNum: (objectMemory byteLengthOf: oop)] ifFalse: [(objectMemory isIndexableFormat: fmt) ifTrue: [| len | len := objectMemory lengthOf: oop. self print: ' size '; printNum: len - (objectMemory fixedFieldsOf: oop format: fmt length: len)]]. objectMemory printHeaderTypeOf: oop. self print: ' hash '; printHexnp: (objectMemory rawHashBitsOf: oop). self cr. (fmt between: objectMemory firstByteFormat and: objectMemory firstCompiledMethodFormat - 1) ifTrue: [^self printStringOf: oop; cr]. (fmt between: objectMemory firstLongFormat and: objectMemory firstByteFormat - 1) ifTrue: [^self]. "this is nonsense. apologies." startIP := (objectMemory lastPointerOf: oop) + BytesPerOop - objectMemory baseHeaderSize / BytesPerOop. lastIndex := 256 min: startIP. lastIndex > 0 ifTrue: [1 to: lastIndex do: [:i| | fieldOop | fieldOop := objectMemory fetchPointer: i - 1 ofObject: oop. self space; printNum: i - 1; space; printHex: fieldOop; space. (i = 1 and: [objectMemory isCompiledMethod: oop]) ifTrue: [self printMethodHeaderOop: fieldOop] ifFalse: [self cCode: [self printOopShort: fieldOop] inSmalltalk: [self print: (self shortPrint: fieldOop)]]. 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 := 8. column := 1. startIP to: lastIndex do: [:index| | byte | column = 1 ifTrue: [self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)' inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']]. byte := objectMemory fetchByte: index - 1 ofObject: oop. self cCode: 'printf(" %02x/%-3d", byte,byte)' inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte]. column := column + 1. column > bytecodesPerLine ifTrue: [column := 1. self cr]]. column = 1 ifFalse: [self cr]]!
Item was changed: ----- Method: StackInterpreter>>lookupMethodFor:InDictionary: (in category 'message sending') ----- lookupMethodFor: selector InDictionary: dictionary "Lookup the argument selector in aDictionary and answer either the method or nil, if not found. This method lookup tolerates integers as Dictionary keys to support execution of images in which Symbols have been compacted out." | length index mask wrapAround nextSelector methodArray | <inline: true> <asmLabel: false> + length := objectMemory numSlotsOf: dictionary. - length := objectMemory fetchWordLengthOf: dictionary. mask := length - SelectorStart - 1. index := SelectorStart + (objectMemory methodDictionaryHash: selector mask: mask).
"It is assumed that there are some nils in this dictionary, and search will stop when one is encountered. However, if there are no nils, then wrapAround will be detected the second time the loop gets to the end of the table." wrapAround := false. [true] whileTrue: [nextSelector := objectMemory fetchPointer: index ofObject: dictionary. nextSelector = objectMemory nilObject ifTrue: [^nil]. (objectMemory isOopForwarded: nextSelector) ifTrue: [nextSelector := objectMemory fixFollowedField: index + SelectorStart ofObject: dictionary withInitialValue: nextSelector]. nextSelector = selector ifTrue: [methodArray := objectMemory followObjField: MethodArrayIndex ofObject: dictionary. ^objectMemory followField: index - SelectorStart ofObject: methodArray]. index := index + 1. index = length ifTrue: [wrapAround ifTrue: [^nil]. wrapAround := true. index := SelectorStart]]. ^nil "for Slang"!
Item was changed: ----- Method: StackInterpreter>>lookupMethodInDictionary: (in category 'message sending') ----- lookupMethodInDictionary: dictionary "This method lookup tolerates integers as Dictionary keys to support execution of images in which Symbols have been compacted out." | length index mask wrapAround nextSelector methodArray | <inline: true> <asmLabel: false> + length := objectMemory numSlotsOf: dictionary. - length := objectMemory fetchWordLengthOf: dictionary. mask := length - SelectorStart - 1. "Use linear search on small dictionaries; its cheaper. Also the limit can be set to force linear search of all dictionaries, which supports the booting of images that need rehashing (e.g. because a tracer has generated an image with different hashes but hasn't rehashed it yet.)" mask <= methodDictLinearSearchLimit ifTrue: [index := 0. [index <= mask] whileTrue: [nextSelector := objectMemory fetchPointer: index + SelectorStart ofObject: dictionary. (objectMemory isOopForwarded: nextSelector) ifTrue: [nextSelector := objectMemory fixFollowedField: index + SelectorStart ofObject: dictionary withInitialValue: nextSelector]. nextSelector = messageSelector ifTrue: [methodArray := objectMemory followObjField: MethodArrayIndex ofObject: dictionary. newMethod := objectMemory followField: index ofObject: methodArray. ^true]. index := index + 1]. ^false]. index := SelectorStart + (objectMemory methodDictionaryHash: messageSelector mask: mask).
"It is assumed that there are some nils in this dictionary, and search will stop when one is encountered. However, if there are no nils, then wrapAround will be detected the second time the loop gets to the end of the table." wrapAround := false. [true] whileTrue: [nextSelector := objectMemory fetchPointer: index ofObject: dictionary. nextSelector = objectMemory nilObject ifTrue: [^false]. (objectMemory isOopForwarded: nextSelector) ifTrue: [nextSelector := objectMemory fixFollowedField: index + SelectorStart ofObject: dictionary withInitialValue: nextSelector]. nextSelector = messageSelector ifTrue: [methodArray := objectMemory followObjField: MethodArrayIndex ofObject: dictionary. newMethod := objectMemory followField: index - SelectorStart ofObject: methodArray. ^true]. index := index + 1. index = length ifTrue: [wrapAround ifTrue: [^false]. wrapAround := true. index := SelectorStart]]. ^false "for Slang"!
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 numSlotsOf: argumentArray. - arraySize := objectMemory fetchWordLengthOf: argumentArray. arraySize > LargeContextSlots 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 sendBreakpoint: messageSelector receiver: actualReceiver. self printSends ifTrue: [self printActivationNameForSelector: messageSelector startClass: lookupClass; cr]. self findNewMethodInClassTag: (objectMemory classTagForClass: 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 changed: ----- Method: StackInterpreter>>printAllStacks (in category 'debug printing') ----- printAllStacks "Print all the stacks of all running processes, including those that are currently suspended." <api> | proc semaphoreClass mutexClass schedLists p processList | <inline: false> proc := self activeProcess. self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5; space; printHex: proc. self print: ' priority '; printNum: (self quickFetchInteger: PriorityIndex ofObject: proc); cr. self printCallStackFP: framePointer. "first the current activation" schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer. "then the runnable processes" p := highestRunnableProcessPriority = 0 + ifTrue: [objectMemory numSlotsOf: schedLists] - ifTrue: [objectMemory fetchWordLengthOf: schedLists] ifFalse: [highestRunnableProcessPriority]. p - 1 to: 0 by: -1 do: [:pri| processList := objectMemory fetchPointer: pri ofObject: schedLists. (self isEmptyList: processList) ifFalse: [self cr; print: 'processes at priority '; printNum: pri + 1. self printProcsOnList: processList]]. self cr; print: 'suspended processes'. semaphoreClass := objectMemory classSemaphore. mutexClass := objectMemory classMutex. objectMemory hasSpurMemoryManagerAPI ifTrue: [semaphoreClass := objectMemory compactIndexOfClass: semaphoreClass. mutexClass := objectMemory compactIndexOfClass: mutexClass. objectMemory allHeapEntitiesDo: [:obj| | classIdx | classIdx := objectMemory classIndexOf: obj. (classIdx = semaphoreClass or: [classIdx = mutexClass]) ifTrue: [self printProcsOnList: obj]]] ifFalse: [objectMemory allObjectsDoSafely: [:obj| | classObj | classObj := objectMemory fetchClassOfNonImm: obj. (classObj = semaphoreClass or: [classObj = mutexClass]) ifTrue: [self printProcsOnList: obj]]]!
Item was changed: ----- Method: StackInterpreter>>printMethodCacheFor: (in category 'debug printing') ----- printMethodCacheFor: thing <api> 0 to: MethodCacheSize - 1 by: MethodCacheEntrySize do: [:i | | s c m p | s := methodCache at: i + MethodCacheSelector. c := methodCache at: i + MethodCacheClass. m := methodCache at: i + MethodCacheMethod. p := methodCache at: i + MethodCachePrimFunction. ((thing = -1 or: [s = thing or: [c = thing or: [p = thing or: [m = thing]]]]) and: [(objectMemory addressCouldBeOop: s) and: [c ~= 0 and: [(self addressCouldBeClassObj: c) or: [self addressCouldBeClassObj: (objectMemory classForClassTag: c)]]]]) ifTrue: [self cCode: [] inSmalltalk: [self transcript ensureCr]. self printNum: i; cr; tab. (objectMemory isBytesNonImm: s) + ifTrue: [self cCode: 'printf("%x %.*s\n", s, numBytesOf(s), (char *)firstIndexableField(s))' - ifTrue: [self cCode: 'printf("%x %.*s\n", s, byteLengthOf(s), (char *)firstIndexableField(s))' inSmalltalk: [self printHex: s; space; print: (self stringOf: s); cr]] ifFalse: [self shortPrintOop: s]. self tab. (self addressCouldBeClassObj: c) ifTrue: [self shortPrintOop: c] ifFalse: [self printNum: c; space; shortPrintOop: (objectMemory classForClassTag: c)]. self tab; shortPrintOop: m; tab. self cCode: [p > 1024 ifTrue: [self printHexnp: p] ifFalse: [self printNum: p]] inSmalltalk: [p isSymbol ifTrue: [self print: p] ifFalse: [self printNum: p]]. self cr]]!
Item was changed: ----- Method: StackInterpreter>>printMethodDictionary: (in category 'debug printing') ----- printMethodDictionary: dictionary <api> | methodArray | methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dictionary. + SelectorStart to: (objectMemory numSlotsOf: dictionary) - 1 do: - SelectorStart to: (objectMemory fetchWordLengthOf: dictionary) - 1 do: [:index | | selector meth | selector := objectMemory fetchPointer: index ofObject: dictionary. selector ~= objectMemory nilObject ifTrue: [meth := objectMemory fetchPointer: index - SelectorStart ofObject: methodArray. self printOopShort: selector; print: ' => '; printOopShort: meth; print: ' ('; printHex: selector; print: ' => '; printHex: meth; putchar: $); cr]]!
Item was changed: ----- Method: StackInterpreter>>printOop: (in category 'debug printing') ----- printOop: oop | cls fmt lastIndex startIP bytecodesPerLine column | <inline: false> (objectMemory isImmediate: oop) ifTrue: [^self shortPrintOop: oop]. self printHex: oop. (objectMemory addressCouldBeObj: oop) ifFalse: [^self print: ((oop bitAnd: objectMemory allocationUnit - 1) ~= 0 ifTrue: [' is misaligned'] ifFalse: [self whereIs: oop]); cr]. (objectMemory isFreeObject: oop) ifTrue: [^self print: ' is a free chunk of size '; printNum: (objectMemory sizeOfFree: oop); cr]. (objectMemory isForwarded: oop) ifTrue: [^self print: ' is a forwarded object to '; printHex: (objectMemory followForwarded: oop); print: ' of slot size '; printNum: (objectMemory numSlotsOfAny: oop); cr]. self print: ': a(n) '. self printNameOfClass: (cls := objectMemory fetchClassOfNonImm: oop) count: 5. cls = (objectMemory splObj: ClassFloat) ifTrue: [^self cr; printFloat: (self dbgFloatValueOf: oop); cr]. fmt := objectMemory formatOf: oop. fmt > objectMemory lastPointerFormat ifTrue: + [self print: ' nbytes '; printNum: (objectMemory numBytesOf: oop)]. - [self print: ' nbytes '; printNum: (objectMemory byteLengthOf: oop)]. self cr. (fmt between: objectMemory firstLongFormat and: objectMemory firstCompiledMethodFormat - 1) 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]. (objectMemory isWords: oop) ifTrue: + [lastIndex := 64 min: ((objectMemory numBytesOf: oop) / BytesPerWord). - [lastIndex := 64 min: ((objectMemory byteLengthOf: 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]]. ^self]. ^self printStringOf: oop; cr]. "this is nonsense. apologies." startIP := (objectMemory lastPointerOf: oop) + BytesPerOop - objectMemory baseHeaderSize / BytesPerOop. lastIndex := 256 min: startIP. lastIndex > 0 ifTrue: [1 to: lastIndex do: [:index| self cCode: [self printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space] 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 := 8. column := 1. startIP to: lastIndex do: [:index| | byte | column = 1 ifTrue: [self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)' inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']]. byte := objectMemory fetchByte: index - 1 ofObject: oop. self cCode: 'printf(" %02x/%-3d", byte,byte)' inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte]. column := column + 1. column > bytecodesPerLine ifTrue: [column := 1. self cr]]. column = 1 ifFalse: [self cr]]!
Item was changed: ----- Method: StackInterpreter>>validInstructionPointer:inMethod:framePointer: (in category 'debug support') ----- validInstructionPointer: theInstrPointer inMethod: aMethod framePointer: fp <var: #theInstrPointer type: #usqInt> <var: #aMethod type: #usqInt> <var: #fp type: #'char *'> ^self cppIf: MULTIPLEBYTECODESETS ifTrue: [| methodHeader | methodHeader := self noAssertHeaderOf: aMethod. "-1 for pre-increment in fetchNextBytecode" theInstrPointer >= (aMethod + (objectMemory lastPointerOf: aMethod) + BytesPerOop - 1) + and: [theInstrPointer < (aMethod + (objectMemory numBytesOf: aMethod) + BaseHeaderSize - 1) - and: [theInstrPointer < (aMethod + (objectMemory byteLengthOf: aMethod) + BaseHeaderSize - 1) and: ["If the method starts with a CallPrimitive opcode the instruction pointer should be past it." ((self headerIndicatesAlternateBytecodeSet: methodHeader) and: [(self alternateHeaderHasPrimitiveFlag: methodHeader) and: [theInstrPointer < (aMethod + BytesPerOop - 1 + (objectMemory lastPointerOf: aMethod) + (self sizeOfCallPrimitiveBytecode: methodHeader))]]) not]]] ifFalse: "-1 for pre-increment in fetchNextBytecode" [theInstrPointer >= (aMethod + (objectMemory lastPointerOf: aMethod) + BytesPerOop - 1) + and: [theInstrPointer < (aMethod + (objectMemory numBytesOf: aMethod) + objectMemory baseHeaderSize - 1)]]! - and: [theInstrPointer < (aMethod + (objectMemory byteLengthOf: aMethod) + objectMemory baseHeaderSize - 1)]]!
Item was changed: ----- Method: StackInterpreter>>wakeHighestPriority (in category 'process primitive support') ----- wakeHighestPriority "Return the highest priority process that is ready to run. To save time looking at many empty lists before finding a runnable process the VM maintains a variable holding the highest priority runnable process. If this variable is 0 then the VM does not know the highest priority and must search all lists. Note: It is a fatal VM error if there is no runnable process." | schedLists p processList proc ctxt | self externalWriteBackHeadFramePointers. schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer. p := highestRunnableProcessPriority = 0 + ifTrue: [objectMemory numSlotsOf: schedLists] - ifTrue: [objectMemory fetchWordLengthOf: schedLists] ifFalse: [highestRunnableProcessPriority]. [(p := p - 1) >= 0] whileTrue: [processList := objectMemory fetchPointer: p ofObject: schedLists. [self isEmptyList: processList] whileFalse: ["Only answer processes with a runnable suspendedContext. Discard those that aren't; the VM would crash otherwise." proc := self removeFirstLinkOfList: processList. ctxt := objectMemory fetchPointer: SuspendedContextIndex ofObject: proc. (self isLiveContext: ctxt) ifTrue: [highestRunnableProcessPriority := p + 1. ^proc]. self warning: 'evicted zombie process from run queue']]. self error: 'scheduler could not find a runnable process'. ^nil!
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 | <var: #addr declareC: 'void (*addr)()'> argumentArray := self stackTop. methodArg := self stackValue: 2. ((objectMemory isArray: argumentArray) and: [objectMemory isOopCompiledMethod: methodArg]) ifFalse: [^self primitiveFailFor: -2]. "invalid args" + arraySize := objectMemory numSlotsOf: argumentArray. - arraySize := objectMemory fetchWordLengthOf: argumentArray. (self roomToPushNArgs: arraySize) ifFalse: [^self primitiveFailFor: -2]. "invalid args"
methodHeader := self headerOf: methodArg. (self literalCountOfHeader: methodHeader) > 2 ifFalse: [^self primitiveFailFor: -3]. "invalid methodArg state" spec := objectMemory fetchPointer: 1 "first literal" ofObject: methodArg. isArray := self isInstanceOfClassArray: spec. (isArray and: [(objectMemory lengthOf: spec) = 4 and: [(self primitiveIndexOfMethod: methodArg header: 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)]. 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>>primitiveDoPrimitiveWithArgs (in category 'control primitives') ----- primitiveDoPrimitiveWithArgs | argumentArray arraySize index primIdx | argumentArray := self stackTop. (objectMemory isArray: argumentArray) ifFalse: [^self primitiveFail]. + arraySize := objectMemory numSlotsOf: argumentArray. - arraySize := objectMemory fetchWordLengthOf: argumentArray. self success: (self roomToPushNArgs: arraySize).
primIdx := self stackIntegerValue: 1. self successful ifFalse: [^self primitiveFail]. "invalid args"
primitiveFunctionPointer := self functionPointerFor: primIdx inClass: nil. primitiveFunctionPointer = 0 ifTrue: [^self primitiveFail].
"Pop primIndex and argArray, then push args in place..." self pop: 2. argumentCount := arraySize. index := 1. [index <= argumentCount] whileTrue: [self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray). index := index + 1].
self isPrimitiveFunctionPointerAnIndex ifTrue: [self externalQuickPrimitiveResponse. ^nil]. "We use tempOop instead of pushRemappableOop:/popRemappableOop here because in the Cogit primitiveEnterCriticalSection, primitiveSignal, primitiveResume et al longjmp back to either the interpreter or machine code, depending on the process activated. So if we're executing one of these primitives control won't actually return here and the matching popRemappableOop: wouldn't occur, potentially overflowing the remap buffer. While recursion could occur (nil tryPrimitive: 118 withArgs: #(111 #())) it counts as shooting oneself in the foot." tempOop := argumentArray. "prim might alloc/gc" "Run the primitive (sets primFailCode)" self slowPrimitiveResponse. self successful ifFalse: "If primitive failed, then restore state for failure code" [self pop: arraySize. self pushInteger: primIdx. self push: tempOop. argumentCount := 2]. tempOop := 0!
Item was changed: ----- Method: StackInterpreterPrimitives>>primitiveExecuteMethodArgsArray (in category 'control primitives') ----- primitiveExecuteMethodArgsArray "receiver, argsArray, then method are on top of stack. Execute method against receiver and args. Allow for up to two extra arguments (e.g. for mirror primitives). Set primitiveFunctionPointer because no cache lookup has been done for the method, and hence primitiveFunctionPointer is stale." | methodArgument argCnt argumentArray primitiveIndex | methodArgument := self stackTop. argumentArray := self stackValue: 1. ((objectMemory isOopCompiledMethod: methodArgument) and: [objectMemory isArray: argumentArray]) ifFalse: [^self primitiveFailFor: PrimErrBadArgument]. argCnt := self argumentCountOf: methodArgument. + argCnt = (objectMemory numSlotsOf: argumentArray) ifFalse: - argCnt = (objectMemory fetchWordLengthOf: argumentArray) ifFalse: [^self primitiveFailFor: PrimErrBadNumArgs]. argumentCount > 2 ifTrue: "CompiledMethod class>>receiver:withArguments:executeMethod: SqueakObjectPrimitives class >> receiver:withArguments:apply: VMMirror>>ifFail:object:with:executeMethod: et al" [argumentCount > 4 ifTrue: [^self primitiveFailFor: PrimErrUnsupported]. self stackValue: argumentCount put: (self stackValue: 2)]. "replace actual receiver with desired receiver" "and push the actual arguments" self pop: argumentCount. 0 to: argCnt - 1 do: [:i| self push: (objectMemory fetchPointer: i ofObject: argumentArray)]. newMethod := methodArgument. primitiveIndex := self primitiveIndexOf: newMethod. primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: nil. argumentCount := argCnt. self executeNewMethod. "Recursive xeq affects primErrorCode" self initPrimCall!
Item was changed: ----- Method: StackInterpreterSimulator>>classAndSelectorOfMethod:forReceiver: (in category 'debug support') ----- classAndSelectorOfMethod: meth forReceiver: rcvr | mClass dict length methodArray | mClass := objectMemory fetchClassOf: rcvr. [dict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: mClass. + length := objectMemory numSlotsOf: dict. - length := objectMemory fetchWordLengthOf: dict. methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dict. 0 to: length-SelectorStart-1 do: [:index | meth = (objectMemory fetchPointer: index ofObject: methodArray) ifTrue: [^ Array with: mClass with: (objectMemory fetchPointer: index + SelectorStart ofObject: dict)]]. mClass := self superclassOf: mClass. mClass = objectMemory nilObject] whileFalse. ^ Array with: (objectMemory fetchClassOf: rcvr) with: (objectMemory splObj: SelectorDoesNotUnderstand)!
Item was added: + ----- Method: StackToRegisterMappingCogit class>>initializeBytecodeTableForSistaV1 (in category 'class initialization') ----- + initializeBytecodeTableForSistaV1 + "StackToRegisterMappingCogit initializeBytecodeTableForSistaV1" + + isPushNilFunction := #sistaV1:Is:Push:Nil:. + pushNilSizeFunction := #sistaV1PushNilSize:. + self flag: + 'Special selector send class must be inlined to agree with the interpreter, which + inlines class. If class is sent to e.g. a general instance of ProtoObject then unless + class is inlined there will be an MNU. It must be that the Cointerpreter and Cogit + have identical semantics. We get away with not hardwiring the other special + selectors either because in the Cointerpreter they are not inlined or because they + are inlined only to instances of classes for which there will always be a method.'. + self generatorTableFrom: #( + "1 byte bytecodes" + "pushes" + (1 0 15 genPushReceiverVariableBytecode needsFrameNever: 1) + (1 16 31 genPushLiteralVariable16CasesBytecode needsFrameNever: 1) + (1 32 63 genPushLiteralConstantBytecode needsFrameNever: 1) + (1 64 75 genPushTemporaryVariableBytecode needsFrameIfMod16GENumArgs: 1) + (1 76 76 genPushReceiverBytecode needsFrameNever: 1) + (1 77 77 pushConstantTrueBytecode needsFrameNever: 1) + (1 78 78 pushConstantFalseBytecode needsFrameNever: 1) + (1 79 79 pushConstantNilBytecode needsFrameNever: 1) + (1 80 80 genPushConstantZeroBytecode needsFrameNever: 1) + (1 81 81 genPushConstantOneBytecode needsFrameNever: 1) + (1 82 82 genExtPushPseudoVariable) + (1 83 83 duplicateTopBytecode needsFrameNever: 1) + + (1 84 87 unknownBytecode) + + "returns" + (1 88 88 genReturnReceiver return needsFrameIfInBlock: isMappedInBlock 0) + (1 89 89 genReturnTrue return needsFrameIfInBlock: isMappedInBlock 0) + (1 90 90 genReturnFalse return needsFrameIfInBlock: isMappedInBlock 0) + (1 91 91 genReturnNil return needsFrameIfInBlock: isMappedInBlock 0) + (1 92 92 genReturnTopFromMethod return needsFrameIfInBlock: isMappedInBlock -1) + (1 93 93 genReturnNilFromBlock return needsFrameNever: -1) + (1 94 94 genReturnTopFromBlock return needsFrameNever: -1) + (1 95 95 genExtNop needsFrameNever: 0) + + "sends" + (1 96 96 genSpecialSelectorArithmetic isMapped AddRR) + (1 97 97 genSpecialSelectorArithmetic isMapped SubRR) + (1 98 98 genSpecialSelectorComparison isMapped JumpLess) + (1 99 99 genSpecialSelectorComparison isMapped JumpGreater) + (1 100 100 genSpecialSelectorComparison isMapped JumpLessOrEqual) + (1 101 101 genSpecialSelectorComparison isMapped JumpGreaterOrEqual) + (1 102 102 genSpecialSelectorComparison isMapped JumpZero) + (1 103 103 genSpecialSelectorComparison isMapped JumpNonZero) + (1 104 109 genSpecialSelectorSend isMapped) " #* #/ #\ #@ #bitShift: //" + (1 110 110 genSpecialSelectorArithmetic isMapped AndRR) + (1 111 111 genSpecialSelectorArithmetic isMapped OrRR) + (1 112 117 genSpecialSelectorSend isMapped) "#at: #at:put: #size #next #nextPut: #atEnd" + (1 118 118 genSpecialSelectorEqualsEquals needsFrameNever: notMapped -1) "not mapped because it is directly inlined (for now)" + (1 119 119 genSpecialSelectorClass needsFrameIfStackGreaterThanOne: notMapped 0) "not mapped because it is directly inlined (for now)" + (1 120 127 genSpecialSelectorSend isMapped) "#blockCopy: #value #value: #do: #new #new: #x #y" + + (1 128 143 genSendLiteralSelector0ArgsBytecode isMapped) + (1 144 159 genSendLiteralSelector1ArgBytecode isMapped) + (1 160 175 genSendLiteralSelector2ArgsBytecode isMapped) + + "jumps" + (1 176 183 genShortUnconditionalJump branch v3:ShortForward:Branch:Distance:) + (1 184 191 genShortJumpIfTrue branch isBranchTrue isMapped "because of mustBeBoolean" + v3:ShortForward:Branch:Distance:) + (1 192 199 genShortJumpIfFalse branch isBranchFalse isMapped "because of mustBeBoolean" + v3:ShortForward:Branch:Distance:) + + "stores" + (1 200 207 genStoreAndPopReceiverVariableBytecode needsFrameNever: -1) "N.B. not frameless if immutability" + (1 208 215 genStoreAndPopTemporaryVariableBytecode) + + (1 216 216 genPopStackBytecode needsFrameNever: -1) + + (1 217 223 unknownBytecode) + + "2 byte bytecodes" + (2 224 224 extABytecode extension) + (2 225 225 extBBytecode extension) + + "pushes" + (2 226 226 genExtPushReceiverVariableBytecode needsFrameNever: 1) + (2 227 227 genExtPushLiteralVariableBytecode needsFrameNever: 1) + (2 228 228 genExtPushLiteralBytecode needsFrameNever: 1) + (2 229 229 genLongPushTemporaryVariableBytecode) + (2 230 230 genPushClosureTempsBytecode) + (2 231 231 genPushNewArrayBytecode) + (2 232 232 genExtPushIntegerBytecode needsFrameNever: 1) + (2 233 233 genExtPushCharacterBytecode needsFrameNever: 1) + + "returns" + "sends" + (2 234 234 genExtSendBytecode isMapped) + (2 235 235 genExtSendSuperBytecode isMapped) + + "sista bytecodes" + (2 236 236 genExtTrapIfNotInstanceOfBehaviorsBytecode isMapped) + + "jumps" + (2 237 237 genExtUnconditionalJump branch isMapped "because of interrupt check" v4:Long:Branch:Distance:) + (2 238 238 genExtJumpIfTrue branch isBranchTrue isMapped "because of mustBeBoolean" v4:Long:Branch:Distance:) + (2 239 239 genExtJumpIfFalse branch isBranchFalse isMapped "because of mustBeBoolean" v4:Long:Branch:Distance:) + + "stores" + (2 240 240 genExtStoreAndPopReceiverVariableBytecode) + (2 241 241 genExtStoreAndPopLiteralVariableBytecode) + (2 242 242 genLongStoreAndPopTemporaryVariableBytecode) + (2 243 243 genExtStoreReceiverVariableBytecode) + (2 244 244 genExtStoreLiteralVariableBytecode) + (2 245 245 genLongStoreTemporaryVariableBytecode) + + (2 246 247 unknownBytecode) + + "3 byte bytecodes" + (3 248 248 callPrimitiveBytecode) + (3 249 249 unknownBytecode) "reserved for Push Float" + (3 250 250 genExtPushClosureBytecode block sistaV1:Block:Code:Size:) + (3 251 251 genPushRemoteTempLongBytecode) + (3 252 252 genStoreRemoteTempLongBytecode) + (3 253 253 genStoreAndPopRemoteTempLongBytecode) + + (3 254 255 unknownBytecode))!
Item was changed: SharedPool subclass: #VMBasicConstants instanceVariableNames: '' + classVariableNames: 'BaseHeaderSize Byte0Mask Byte0Shift Byte1Mask Byte1Shift Byte1ShiftNegated Byte2Mask Byte2Shift Byte3Mask Byte3Shift Byte3ShiftNegated Byte4Mask Byte4Shift Byte4ShiftNegated Byte5Mask Byte5Shift Byte5ShiftNegated Byte6Mask Byte6Shift Byte7Mask Byte7Shift Byte7ShiftNegated Bytes3to0Mask Bytes7to4Mask BytesPerOop BytesPerWord COGMTVM COGVM DisownVMLockOutFullGC DoAssertionChecks DoExpensiveAssertionChecks GCModeBecome GCModeFull GCModeIncr GCModeScavenge IMMUTABILITY MULTIPLEBYTECODESETS NewspeakVM PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrGenericFailure PrimErrInappropriate PrimErrLimitExceeded PrimErrNamedInternal PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrObjectIsPinned PrimErrObjectMayMove PrimErrUnsupported PrimErrWritePastObject PrimNoErr STACKVM ShiftForWord SistaVM VMBIGENDIAN' - classVariableNames: 'BaseHeaderSize Byte0Mask Byte0Shift Byte1Mask Byte1Shift Byte1ShiftNegated Byte2Mask Byte2Shift Byte3Mask Byte3Shift Byte3ShiftNegated Byte4Mask Byte4Shift Byte4ShiftNegated Byte5Mask Byte5Shift Byte5ShiftNegated Byte6Mask Byte6Shift Byte7Mask Byte7Shift Byte7ShiftNegated Bytes3to0Mask Bytes7to4Mask BytesPerOop BytesPerWord COGMTVM COGVM DisownVMLockOutFullGC DoAssertionChecks DoExpensiveAssertionChecks GCModeBecome GCModeFull GCModeIncr GCModeScavenge IMMUTABILITY MULTIPLEBYTECODESETS NewspeakVM PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrGenericFailure PrimErrInappropriate PrimErrLimitExceeded PrimErrNamedInternal PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrObjectIsPinned PrimErrObjectMayMove PrimErrUnsupported PrimErrWritePastObject PrimNoErr STACKVM ShiftForWord VMBIGENDIAN' poolDictionaries: '' category: 'VMMaker-Interpreter'!
!VMBasicConstants commentStamp: '<historical>' prior: 0! I am a shared pool for basic constants upon which the VM as a whole depends.
self ensureClassPool. self classPool declare: #BytesPerWord from: VMSqueakV3ObjectRepresentationConstants classPool. self classPool declare: #BaseHeaderSize from: VMSqueakV3ObjectRepresentationConstants classPool (ObjectMemory classPool keys select: [:k| k beginsWith: 'Byte']) do: [:k| self classPool declare: k from: ObjectMemory classPool]!
Item was changed: ----- Method: VMClass class>>initializeMiscConstants (in category 'initialization') ----- initializeMiscConstants "Falsify the `what type of VM is this?' flags that are defined in the various interp.h files, or in the case of VMBIGENDIAN the various sqConfig.h files. Subclass implementations need to include a super initializeMiscConstants"
| omc | VMBIGENDIAN class. "Mention this for the benefit of CCodeGenerator>>emitCConstantsOn:" self isInterpreterClass ifTrue: [STACKVM := COGVM := COGMTVM := false].
initializationOptions ifNil: [self initializationOptions: Dictionary new]. omc := initializationOptions at: #ObjectMemory ifAbsent: nil. initializationOptions at: #SqueakV3ObjectMemory "the good ole default" put: (omc ifNil: [true] ifNotNil: [(Smalltalk at: omc) inheritsFrom: ObjectMemory]); at: #SpurObjectMemory "the new condender" put: (omc ifNil: [false] ifNotNil: [(Smalltalk at: omc) inheritsFrom: SpurMemoryManager]).
"Use ifAbsentPut: so that they will get copied back to the VMMaker's options and dead code will likely be eliminated." NewspeakVM := initializationOptions at: #NewspeakVM ifAbsentPut: [false]. + SistaVM := initializationOptions at: #SistaVM ifAbsentPut: [false]. MULTIPLEBYTECODESETS := initializationOptions at: #MULTIPLEBYTECODESETS ifAbsentPut: [false]. "N.B. Not yet implemented." IMMUTABILITY := initializationOptions at: #IMMUTABILITY ifAbsentPut: [false].
"These for scripts etc... Usually they should get set by an Interpreter class's initializeMiscConstantsWith:" (initializationOptions includesKey: #STACKVM) ifTrue: [STACKVM := initializationOptions at: #STACKVM]. (initializationOptions includesKey: #COGVM) ifTrue: [COGVM := initializationOptions at: #COGVM]. (initializationOptions includesKey: #COGMTVM) ifTrue: [COGMTVM := initializationOptions at: #COGMTVM]!
Item was changed: ----- Method: VMCompiledMethodProxy>>at: (in category 'accessing') ----- at: index + ^(index between: 1 and: (objectMemory numBytesOf: oop)) - ^(index between: 1 and: (objectMemory byteLengthOf: oop)) ifTrue: [objectMemory fetchByte: index - 1 ofObject: oop] ifFalse: [self errorSubscriptBounds: index]!
Item was changed: ----- Method: VMCompiledMethodProxy>>size (in category 'accessing') ----- size + ^objectMemory numBytesOf: oop! - ^objectMemory byteLengthOf: oop!
Item was changed: ----- Method: VMMaker class>>generateSqueakCogSistaVM (in category 'configurations') ----- generateSqueakCogSistaVM "No primitives since we can use those for the Cog VM" ^VMMaker generate: CoInterpreter and: SistaStackToRegisterMappingCogit + with: #( SistaVM true + MULTIPLEBYTECODESETS true - with: #( MULTIPLEBYTECODESETS true bytecodeTableInitializer initializeBytecodeTableForSqueakV3PlusClosuresSistaV1Hybrid) to: (FileDirectory default pathFromURI: self sourceTree, '/sistasrc') platformDir: (FileDirectory default pathFromURI: self sourceTree, '/platforms') including: #()!
Item was changed: ----- Method: VMMaker class>>generateSqueakSpurCogSistaVM (in category 'configurations') ----- generateSqueakSpurCogSistaVM "No primitives since we can use those for the Cog VM" ^VMMaker generate: CoInterpreter and: SistaStackToRegisterMappingCogit + with: #( SistaVM true + ObjectMemory Spur32BitCoMemoryManager - with: #( ObjectMemory Spur32BitCoMemoryManager MULTIPLEBYTECODESETS true bytecodeTableInitializer initializeBytecodeTableForSqueakV3PlusClosuresSistaV1Hybrid) to: (FileDirectory default pathFromURI: self sourceTree, '/spursistasrc') platformDir: (FileDirectory default pathFromURI: self sourceTree, '/platforms') including:#()!
vm-dev@lists.squeakfoundation.org