Vm-dev May 2010

vm-dev@lists.squeakfoundation.org

22 participants
59 discussions

Re: [squeak-dev] Finalization enhancement for 4.2
by David T. Lewis 20 May '10

20 May '10

CC to vm-dev list, follow up on technical issues should go to vm-dev. Chris, Igor, this sounds very encouraging. Yes, I'll help on the VM side, with guidance from Andreas and others (I am not technically competent on this issue). I'll probably be off list for a few days, but will catch up on this next week. Andreas, Eliot, others - any advice or guidance? Dave On Thu, May 20, 2010 at 10:14:00AM -0500, Chris Muller wrote: > I have packaged up Igor's change-sets for the finalization fix: > > http://bugs.squeak.org/view.php?id=7525 > http://bugs.squeak.org/view.php?id=7473 > > into their respective MC packages and uploaded them to the Inbox. > > Recall the original discussion: > > http://lists.squeakfoundation.org/pipermail/vm-dev/2010-March/003958.html > > I have been running with Igor's enhanced VM and image-side > finalization patches for a few weeks now. The results are striking. > Squeak applications using large Weak-collections deteriorate to a > point of unusability without this fix because Squeak spends 95% of its > time in the finalization process, leaving no time for application > processing. With this fix installed, CPU utilization is 0% when the > application is idle, providing excellent responsiveness. > > This is a big, big, win for any application that uses Weak > collections, and a win for Squeak overall because it's own use of > weak-collections is enhanced. > > While it seems to be backward compatible, e.g. I am able to run the > enhanced VM on older images (including 3.9), and I am able to run with > these image changes on an older VM, both are required to take > advantage of the enhanced finalization. > > I would like to push this into the trunk, but will need help from the > VMMaker developers for that piece. David? > > For Magma, this wil be the most exciting and important fix since > #becomeForward:copyHash: introduced back in 2004. > > - Chris

2 1

VM Maker: VMMaker-dtl.174.mcz
by squeak-dev-noreply＠lists.squeakfoundation.org 20 May '10

20 May '10

Dave Lewis uploaded a new version of VMMaker to project VM Maker: http://www.squeaksource.com/VMMaker/VMMaker-dtl.174.mcz ==================== Summary ==================== Name: VMMaker-dtl.174 Author: dtl Time: 19 May 2010, 10:25:45 am UUID: 12e0537d-d82e-4aea-ad67-540e24a95261 Ancestors: VMMaker-dtl.173 VMMaker 4.2.1 Remove BytesPerWord BaseHeaderSize class variables from ObjectMemory, and add bytesPerWord instance variable to InterpreterSimulator. BytesPerWord is no longer global, and each interpreter knows the word size of its object memory. =============== Diff against VMMaker-dtl.173 =============== Item was added: + ----- Method: InterpreterSimulatorLSB64>>initialize (in category 'initialization') ----- + initialize + + bytesPerWord := 8. + super initialize! Item was changed: ----- Method: InterpreterSimulatorMSB>>nextLongFrom: (in category 'initialization') ----- nextLongFrom: aStream "Read a 32- or 64-bit quantity from the given (binary) stream." + ^ aStream nextNumber: self bytesPerWord! - ^ aStream nextNumber: BytesPerWord! Item was changed: ----- Method: ObjectMemory class>>initBytesPerWord: (in category 'initialization') ----- + initBytesPerWord: unused - initBytesPerWord: nBytes - BytesPerWord := nBytes. Byte0Shift := 0. Byte1Shift := 8. Byte2Shift := 16. Byte3Shift := 24. Byte4Shift := 32. Byte5Shift := 40. Byte6Shift := 48. Byte7Shift := 56. Byte0Mask := 16r00000000000000FF. Byte1Mask := 16r000000000000FF00. Byte2Mask := 16r0000000000FF0000. Byte3Mask := 16r00000000FF000000. Byte4Mask := 16r000000FF00000000. Byte5Mask := 16r0000FF0000000000. Byte6Mask := 16r00FF000000000000. Byte7Mask := 16rFF00000000000000. Bytes3to0Mask := 16r00000000FFFFFFFF. Bytes7to4Mask := 16rFFFFFFFF00000000. Byte1ShiftNegated := Byte1Shift negated. Byte3ShiftNegated := Byte3Shift negated. Byte4ShiftNegated := Byte4Shift negated. Byte5ShiftNegated := Byte5Shift negated. Byte7ShiftNegated := Byte7Shift negated! Item was changed: ----- Method: InterpreterSimulator>>printTop: (in category 'debug support') ----- printTop: n "Print important fields of the top n contexts" | ctxt classAndSel home top ip sp | ctxt := activeContext. ^ String streamContents: [:strm | 1 to: n do: [:i | home := (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext) ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt] ifFalse: [ctxt]. classAndSel := self classAndSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home) forReceiver: (self fetchPointer: ReceiverIndex ofObject: home). strm cr; nextPutAll: ctxt hex8. ctxt = home ifFalse: [strm nextPutAll: ' [] in']. strm space; nextPutAll: (self nameOfClass: classAndSel first). strm nextPutAll: '>>'; nextPutAll: (self shortPrint: classAndSel last). ctxt = activeContext + ifTrue: [ip := instructionPointer - method - (self baseHeaderSize - 2). - ifTrue: [ip := instructionPointer - method - (BaseHeaderSize - 2). sp := self stackPointerIndex - TempFrameStart + 1. top := self stackTop] ifFalse: [ip := self integerValueOf: (self fetchPointer: InstructionPointerIndex ofObject: ctxt). sp := self integerValueOf: (self fetchPointer: StackPointerIndex ofObject: ctxt). top := self longAt: ctxt + (self lastPointerOf: ctxt)]. strm cr; tab; nextPutAll: 'ip = '; print: ip. strm cr; tab; nextPutAll: 'sp = '; print: sp. strm cr; tab; nextPutAll: 'top = '; nextPutAll: (self shortPrint: top). (ctxt := (self fetchPointer: SenderIndex ofObject: ctxt)) = nilObj ifTrue: [^strm contents]. ]. ]! Item was changed: ----- Method: InterpreterSimulator>>clipboardWrite:From:At: (in category 'I/O primitives') ----- clipboardWrite: sz From: actualDataAddress At: ignored + Clipboard clipboardText: (self stringOf: actualDataAddress - self baseHeaderSize)! - Clipboard clipboardText: (self stringOf: actualDataAddress - BaseHeaderSize)! Item was changed: ----- Method: ObjectMemory>>baseHeaderSize (in category 'constants') ----- baseHeaderSize "Answer the size of an object memory header word in bytes." - "Class variable shadows the cpp macro definition in generated code." self inline: true. + ^self cCode: 'BASE_HEADER_SIZE' inSmalltalk: [self bytesPerWord] - ^self cCode: 'BASE_HEADER_SIZE' inSmalltalk: [BaseHeaderSize] ! Item was changed: ----- Method: ObjectMemory>>rootBit (in category 'constants') ----- rootBit "Next-to-Top bit" self inline: true. ^self cCode: 'ROOT_BIT' + inSmalltalk: [1 bitShift: self bytesPerWord * 8 - 2] - inSmalltalk: [1 bitShift: BytesPerWord*8 - 2] ! Item was changed: ----- Method: InterpreterSimulatorLSB>>nextLongFrom: (in category 'initialization') ----- nextLongFrom: aStream "Read a 32- or 64-bit quantity from the given (binary) stream." + ^ aStream nextLittleEndianNumber: self bytesPerWord! - ^ aStream nextLittleEndianNumber: BytesPerWord! Item was changed: ----- Method: InterpreterSimulatorMSB>>byteAt:put: (in category 'memory access') ----- byteAt: byteAddress put: byte | longWord shift lowBits bpwMinus1 longAddress | + bpwMinus1 := self bytesPerWord - 1. - bpwMinus1 := BytesPerWord-1. lowBits := byteAddress bitAnd: bpwMinus1. longAddress := byteAddress - lowBits. longWord := self longAt: longAddress. shift := (bpwMinus1 - lowBits) * 8. longWord := longWord - (longWord bitAnd: (16rFF bitShift: shift)) + (byte bitShift: shift). self longAt: longAddress put: longWord! Item was changed: ----- Method: InterpreterSimulator>>stringOf: (in category 'debug support') ----- stringOf: oop | size long nLongs chars | ^ String streamContents: [:strm | size := 100 min: (self stSizeOf: oop). + nLongs := size - 1 // self bytesPerWord + 1. - nLongs := size-1//BytesPerWord+1. 1 to: nLongs do: + [:i | long := self longAt: oop + self baseHeaderSize + (i - 1 * self bytesPerWord). - [:i | long := self longAt: oop + BaseHeaderSize + (i-1*BytesPerWord). chars := self charsOfLong: long. strm nextPutAll: (i=nLongs + ifTrue: [chars copyFrom: 1 to: size - 1 \\ self bytesPerWord + 1] - ifTrue: [chars copyFrom: 1 to: size-1\\BytesPerWord+1] ifFalse: [chars])]]! Item was changed: ----- Method: InterpreterSimulator>>vmPathGet:Length: (in category 'file primitives') ----- vmPathGet: stringBase Length: stringSize | pathName stringOop | pathName := Smalltalk vmPath. + stringOop := stringBase - self baseHeaderSize. "Due to C call in Interp" - stringOop := stringBase - BaseHeaderSize. "Due to C call in Interp" 1 to: stringSize do: [:i | self storeByte: i-1 ofObject: stringOop withValue: (pathName at: i) asciiValue]. ! Item was added: + ----- Method: InterpreterSimulatorMSB64>>initialize (in category 'initialization') ----- + initialize + + bytesPerWord := 8. + super initialize! Item was changed: ----- Method: InterpreterSimulator>>validateOopsIn: (in category 'testing') ----- validateOopsIn: object | fieldPtr limit former header | "for each oop in me see if it is legal" + fieldPtr := object + self baseHeaderSize. "first field" - fieldPtr := object + BaseHeaderSize. "first field" limit := object + (self lastPointerOf: object). "a good field" [fieldPtr > limit] whileFalse: [ former := self longAt: fieldPtr. (self validOop: former) ifFalse: [self error: 'invalid oop in pointers object']. + fieldPtr := fieldPtr + self bytesPerWord]. - fieldPtr := fieldPtr + BytesPerWord]. "class" header := self baseHeader: object. (header bitAnd: CompactClassMask) = 0 ifTrue: [ former := (self classHeader: object) bitAnd: self allButTypeMask. (self validOop: former) ifFalse: [self halt]].! Item was changed: ----- Method: InterpreterSimulator>>initialize (in category 'initialization') ----- initialize "Initialize the InterpreterSimulator when running the interpreter inside Smalltalk. The primary responsibility of this method is to allocate Smalltalk Arrays for variables that will be declared as statically-allocated global arrays in the translated code." "initialize class variables" ObjectMemory initializeWithBytesToWord: self bytesPerWord. Interpreter initialize. "Note: we must initialize ConstMinusOne differently for simulation, due to the fact that the simulator works only with +ve 32-bit values" ConstMinusOne := self integerObjectOf: -1. methodCache := Array new: MethodCacheSize. atCache := Array new: AtCacheTotalSize. self flushMethodCache. rootTable := Array new: RootTableSize. weakRoots := Array new: RootTableSize + RemapBufferSize + 100. remapBuffer := Array new: RemapBufferSize. semaphoresUseBufferA := true. semaphoresToSignalA := Array new: SemaphoresToSignalSize. semaphoresToSignalB := Array new: SemaphoresToSignalSize. externalPrimitiveTable := CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize). primitiveTable := self class primitiveTable. obsoleteNamedPrimitiveTable := CArrayAccessor on: (self class obsoleteNamedPrimitiveTable copyWith: (Array new: 3)). obsoleteIndexedPrimitiveTable := CArrayAccessor on: (self class obsoleteIndexedPrimitiveTable collect:[:spec| CArrayAccessor on: (spec ifNil:[Array new: 3] ifNotNil:[Array with: spec first with: spec second with: nil])]). pluginList := #(). mappedPluginEntries := #(). "initialize InterpreterSimulator variables used for debugging" byteCount := 0. sendCount := 0. quitBlock := [^ self]. traceOn := true. myBitBlt := BitBltSimulator new setInterpreter: self. filesOpen := OrderedCollection new. + headerTypeBytes := CArrayAccessor on: (Array with: self bytesPerWord * 2 with: self bytesPerWord with: 0 with: 0). - headerTypeBytes := CArrayAccessor on: (Array with: BytesPerWord*2 with: BytesPerWord with: 0 with: 0). transcript := Transcript. displayForm := 'Display has not yet been installed' asDisplayText form. ! Item was changed: ----- Method: ObjectMemory class>>initializeObjectHeaderConstants (in category 'initialization') ----- initializeObjectHeaderConstants - BytesPerWord ifNil: [BytesPerWord := 4]. "May get called on fileIn, so supply default" - BaseHeaderSize := BytesPerWord. - "masks for type field" TypeMask := 3. "type field values" HeaderTypeSizeAndClass := 0. HeaderTypeClass := 1. HeaderTypeFree := 2. HeaderTypeShort := 3. "type field values used during the mark phase of GC" HeaderTypeGC := 2. GCTopMarker := 3. "neither an oop, nor an oop+1, this value signals that we have crawled back up to the top of the marking phase." "Base header word bit fields" HashBits := 16r1FFE0000. HashBitsOffset := 17. CompactClassMask := 16r1F000 ! Item was changed: ----- Method: InterpreterSimulator>>writeImageFileIO: (in category 'image save/restore') ----- writeImageFileIO: numberOfBytesToWrite "Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot." | headerSize file | + self bytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet']. - BytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet']. headerSize := 64. [ file := (FileStream fileNamed: imageName) binary. file == nil ifTrue: [^nil]. { self imageFormatVersion. headerSize. numberOfBytesToWrite. self startOfMemory. specialObjectsOop. lastHash. self ioScreenSize. fullScreenFlag. extraVMMemory } do: [:long | self putLong: long toFile: file]. "Pad the rest of the header." 7 timesRepeat: [self putLong: 0 toFile: file]. "Position the file after the header." file position: headerSize. "Write the object memory." 1 to: numberOfBytesToWrite // 4 do: [:index | self putLong: (memory at: index) toFile: file]. self success: true ] ensure: [file close]! Item was changed: ----- Method: InterpreterSimulator>>firstIndexableField: (in category 'memory access') ----- firstIndexableField: oop "NOTE: overridden from Interpreter to add coercion to CArray" | hdr fmt totalLength fixedFields | self returnTypeC: 'void *'. hdr := self baseHeader: oop. fmt := (hdr >> 8) bitAnd: 16rF. totalLength := self lengthOf: oop baseHeader: hdr format: fmt. fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength. fmt < 8 ifTrue: [fmt = 6 ifTrue: ["32 bit field objects" + ^ self cCoerce: (self pointerForOop: oop + self baseHeaderSize + (fixedFields << 2)) to: 'int *']. - ^ self cCoerce: (self pointerForOop: oop + BaseHeaderSize + (fixedFields << 2)) to: 'int *']. "full word objects (pointer or bits)" + ^ self cCoerce: (self pointerForOop: oop + self baseHeaderSize + (fixedFields << self shiftForWord)) to: 'oop *'] - ^ self cCoerce: (self pointerForOop: oop + BaseHeaderSize + (fixedFields << self shiftForWord)) to: 'oop *'] ifFalse: ["Byte objects" + ^ self cCoerce: (self pointerForOop: oop + self baseHeaderSize + fixedFields) to: 'char *']! - ^ self cCoerce: (self pointerForOop: oop + BaseHeaderSize + fixedFields) to: 'char *']! Item was changed: ----- Method: InterpreterSimulator>>longPrint: (in category 'debug support') ----- longPrint: oop | lastPtr val lastLong hdrType prevVal | (self isIntegerObject: oop) ifTrue: [^ self shortPrint: oop]. ^ String streamContents: [:strm | + lastPtr := 64 * self bytesPerWord min: (self lastPointerOf: oop). - lastPtr := 64*BytesPerWord min: (self lastPointerOf: oop). hdrType := self headerType: oop. hdrType = 2 ifTrue: [lastPtr := 0]. prevVal := 0. + (self headerStart: oop) to: lastPtr by: self bytesPerWord do: - (self headerStart: oop) to: lastPtr by: BytesPerWord do: [:a | val := self longAt: oop+a. (a > 0 and: [(val = prevVal) & (a ~= lastPtr)]) ifTrue: + [prevVal = (self longAt: oop + a - (self bytesPerWord * 2)) ifFalse: [strm cr; nextPutAll: ' ...etc...']] - [prevVal = (self longAt: oop+a-(BytesPerWord*2)) ifFalse: [strm cr; nextPutAll: ' ...etc...']] ifFalse: [strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); space; space; space; nextPutAll: val hex8; space; space. + a = (self bytesPerWord * 2) negated ifTrue: - a = (BytesPerWord*2) negated ifTrue: [strm nextPutAll: 'size = ' , (val - hdrType) hex]. + a = self bytesPerWord negated ifTrue: - a = BytesPerWord negated ifTrue: [strm nextPutAll: '<' , (self nameOfClass: (val - hdrType)) , '>']. a = 0 ifTrue: [strm cr; tab; nextPutAll: (self dumpHeader: val)]. a > 0 ifTrue: [strm nextPutAll: (self shortPrint: val)]. + a = self bytesPerWord ifTrue: - a = BytesPerWord ifTrue: [(self fetchClassOf: oop) = (self splObj: ClassCompiledMethod) ifTrue: [strm cr; tab; nextPutAll: (self dumpMethodHeader: val)]]]. prevVal := val]. + lastLong := 256 min: (self sizeBitsOf: oop) - self baseHeaderSize. - lastLong := 256 min: (self sizeBitsOf: oop) - BaseHeaderSize. hdrType = 2 ifTrue: ["free" strm cr; nextPutAll: (oop+(self longAt: oop)-2) hex; space; space; nextPutAll: (oop+(self longAt: oop)-2) printString] ifFalse: [(self formatOf: oop) = 3 ifTrue: [strm cr; tab; nextPutAll: '/ next 3 fields are above SP... /'. + lastPtr + self bytesPerWord to: lastPtr+(3 * self bytesPerWord) by: self bytesPerWord do: - lastPtr+BytesPerWord to: lastPtr+(3*BytesPerWord) by: BytesPerWord do: [:a | val := self longAt: oop+a. strm cr; nextPutAll: a hex; space; space; space; nextPutAll: val hex8; space; space. (self validOop: val) ifTrue: [strm nextPutAll: (self shortPrint: val)]]] ifFalse: + [lastPtr + self bytesPerWord to: lastLong by: self bytesPerWord do: - [lastPtr+BytesPerWord to: lastLong by: BytesPerWord do: [:a | val := self longAt: oop+a. strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); space; space; space. strm nextPutAll: val hex8; space; space; nextPutAll: (self charsOfLong: val)]]]. ]! Item was changed: ----- Method: InterpreterSimulator>>stats (in category 'testing') ----- stats | oop fieldAddr fieldOop last stats v d | stats := Bag new. oop := self firstObject. 'Scanning the image...' displayProgressAt: Sensor cursorPoint from: oop to: endOfMemory during: [:bar | [oop < endOfMemory] whileTrue: [(self isFreeObject: oop) ifFalse: [stats add: #objects. fieldAddr := oop + (self lastPointerOf: oop). [fieldAddr > oop] whileTrue: [fieldOop := self longAt: fieldAddr. (self isIntegerObject: fieldOop) ifTrue: [v := self integerValueOf: fieldOop. (v between: -16000 and: 16000) ifTrue: [stats add: #ints32k] ifFalse: [stats add: #intsOther]] ifFalse: [fieldOop = nilObj ifTrue: [stats add: #nil] ifFalse: [d := fieldOop - oop. (d between: -16000 and: 16000) ifTrue: [stats add: #oops32k] ifFalse: [stats add: #oopsOther]]]. + fieldAddr := fieldAddr - self bytesPerWord]]. - fieldAddr := fieldAddr - BytesPerWord]]. bar value: oop. last := oop. last := last. oop := self objectAfter: oop]]. ^ stats sortedElements! Item was changed: ----- Method: SmartSyntaxPluginCodeGenerator>>generateCoerceToObjectFromPtr:on: (in category 'asOop:/asValue:') ----- generateCoerceToObjectFromPtr: aNode on: aStream "This code assumes no named instance variables" aStream nextPutAll: 'oopForPointer('. self emitCExpression: aNode on: aStream. + aStream nextPutAll: ') - BASE_HEADER_SIZE'! - aStream nextPutAll: ') - ', ObjectMemory baseHeaderSize asString! Item was changed: + ----- Method: InterpreterSimulator>>bytesPerWord (in category 'memory access') ----- - ----- Method: InterpreterSimulator>>bytesPerWord (in category 'initialization') ----- bytesPerWord + "BytesPerWord was a class variable in ObjectMemory, permitting each object + memory to have its own word size." - "32 bit VM returns 4, overridden for 64-bit images..." + ^ bytesPerWord ifNil: [bytesPerWord := 4]! - ^4! Item was added: + ----- Method: Interpreter>>initializeImageFormatVersionIfNeeded (in category 'image save/restore') ----- + initializeImageFormatVersionIfNeeded + "Set the imageFormatVersionNumber to a default value for this word + size. Normally this will have been set at image load time, but set it to + a reasonable default if this has not been done." + + self inline: false. + imageFormatVersionNumber = 0 + ifTrue: [self bytesPerWord == 8 + ifFalse: [imageFormatVersionNumber := 6502] + ifTrue: [imageFormatVersionNumber := 68000]] + ! Item was changed: ----- Method: SmartSyntaxPluginCodeGenerator>>generateCPtrAsOop:on:indent: (in category 'translating builtins') ----- generateCPtrAsOop: aNode on: aStream indent: anInteger aStream nextPutAll: '('. aStream nextPutAll: 'oopForPointer( '. self emitCExpression: aNode receiver on: aStream. + aStream nextPutAll: ' ) - BASE_HEADER_SIZE)'! - aStream nextPutAll: ' ) - '; - nextPutAll: ObjectMemory baseHeaderSize printString; - nextPut: $)! Item was changed: ----- Method: InterpreterSimulatorMSB>>charsOfLong: (in category 'debug support') ----- charsOfLong: long + ^ (self bytesPerWord to: 1 by: -1) collect: - ^ (BytesPerWord to: 1 by: -1) collect: [:i | ((long digitAt: i) between: 14 and: 126) ifTrue: [(long digitAt: i) asCharacter] ifFalse: [$?]]! Item was changed: ----- Method: InterpreterSimulatorMSB>>shortAt: (in category 'memory access') ----- shortAt: byteAddress "Return the half-word at byteAddress which must be even." | lowBits bpwMinus2 | + bpwMinus2 := self bytesPerWord - 2. - bpwMinus2 := BytesPerWord-2. lowBits := byteAddress bitAnd: bpwMinus2. ^ ((self longAt: byteAddress - lowBits) bitShift: (lowBits - bpwMinus2) * 8) bitAnd: 16rFFFF ! Item was changed: ----- Method: InterpreterSimulator>>imageFormatVersion (in category 'initialization') ----- imageFormatVersion "The imageFormatVersionNumber variable is initialized in Interpreter class>>declareCVarsIn: so provide the value here for simulation." ^ imageFormatVersionNumber + ifNil: [imageFormatVersionNumber := self bytesPerWord == 4 - ifNil: [imageFormatVersionNumber := BytesPerWord == 4 ifTrue: [6502] ifFalse: [68000]]! Item was changed: Interpreter subclass: #InterpreterSimulator + instanceVariableNames: 'bytesPerWord byteCount sendCount traceOn myBitBlt displayForm filesOpen imageName pluginList mappedPluginEntries inputSem quitBlock transcript displayView logging' - instanceVariableNames: 'byteCount sendCount traceOn myBitBlt displayForm filesOpen imageName pluginList mappedPluginEntries inputSem quitBlock transcript displayView logging' classVariableNames: '' poolDictionaries: '' category: 'VMMaker-InterpreterSimulation'! !InterpreterSimulator commentStamp: 'tpr 5/5/2003 12:24' prior: 0! This class defines basic memory access and primitive simulation so that the Interpreter can run simulated in the Squeak environment. It also defines a number of handy object viewing methods to facilitate pawing around in the object memory. To see the thing actually run, you could (after backing up this image and changes), execute (InterpreterSimulator new openOn: Smalltalk imageName) test and be patient both to wait for things to happen, and to accept various things that may go wrong depending on how large or unusual your image may be. We usually do this with a small and simple benchmark image. You will probably have more luck using InterpreteSimulatorLSB or InterpreterSimulatorMSB as befits your machine.! Item was changed: (excessive method size, no diff calculated) Item was changed: ----- Method: InterpreterSimulatorMSB>>byteAt: (in category 'memory access') ----- byteAt: byteAddress | lowBits bpwMinus1 | + bpwMinus1 := self bytesPerWord - 1. - bpwMinus1 := BytesPerWord-1. lowBits := byteAddress bitAnd: bpwMinus1. ^ ((self longAt: byteAddress - lowBits) bitShift: (lowBits - bpwMinus1) * 8) bitAnd: 16rFF! Item was changed: ----- Method: InterpreterSimulator>>shortPrint: (in category 'debug support') ----- shortPrint: oop | name classOop | (self isIntegerObject: oop) ifTrue: [^ '=' , (self integerValueOf: oop) printString , ' (' , (self integerValueOf: oop) hex , ')']. classOop := self fetchClassOf: oop. + (self sizeBitsOf: classOop) = (Metaclass instSize + 1 * self bytesPerWord) ifTrue: [ - (self sizeBitsOf: classOop) = (Metaclass instSize +1*BytesPerWord) ifTrue: [ ^ 'class ' , (self nameOfClass: oop)]. name := self nameOfClass: classOop. name size = 0 ifTrue: [name := '??']. name = 'String' ifTrue: [^ (self stringOf: oop) printString]. name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)]. name = 'Character' ifTrue: [^ '=' , (Character value: (self integerValueOf: (self fetchPointer: 0 ofObject: oop))) printString]. name = 'UndefinedObject' ifTrue: [^ 'nil']. name = 'False' ifTrue: [^ 'false']. name = 'True' ifTrue: [^ 'true']. name = 'Float' ifTrue: [successFlag := true. ^ '=' , (self floatValueOf: oop) printString]. name = 'Association' ifTrue: [^ '(' , + (self shortPrint: (self longAt: oop + self baseHeaderSize)) , - (self shortPrint: (self longAt: oop + BaseHeaderSize)) , ' -> ' , + (self longAt: oop + self baseHeaderSize + self bytesPerWord) hex8 , ')']. - (self longAt: oop + BaseHeaderSize + BytesPerWord) hex8 , ')']. ('AEIOU' includes: name first) ifTrue: [^ 'an ' , name] ifFalse: [^ 'a ' , name]! Item was changed: ----- Method: InterpreterSimulatorMSB>>shortAt:put: (in category 'memory access') ----- shortAt: byteAddress put: a16BitValue "Return the half-word at byteAddress which must be even." | longWord shift lowBits bpwMinus2 longAddress | + bpwMinus2 := self bytesPerWord - 2. - bpwMinus2 := BytesPerWord-2. lowBits := byteAddress bitAnd: bpwMinus2. longAddress := byteAddress - lowBits. longWord := self longAt: longAddress. shift := (bpwMinus2 - lowBits) * 8. longWord := longWord - (longWord bitAnd: (16rFFFF bitShift: shift)) + (a16BitValue bitShift: shift). self longAt: longAddress put: longWord ! Item was changed: ----- Method: InterpreterSimulator>>nameOfClass: (in category 'debug support') ----- nameOfClass: classOop + (self sizeBitsOf: classOop) = (Metaclass instSize + 1 * self bytesPerWord) ifTrue: - (self sizeBitsOf: classOop) = (Metaclass instSize +1*BytesPerWord) ifTrue: [^ (self nameOfClass: (self fetchPointer: 5 "thisClass" ofObject: classOop)) , ' class']. ^ self stringOf: (self fetchPointer: 6 "name" ofObject: classOop)! Item was changed: ----- Method: InterpreterSimulator>>printStackTemps:onStream: (in category 'debug support') ----- printStackTemps: ctxt onStream: strm | home cMethod nArgs nTemps oop | home := (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext) ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt] ifFalse: [ctxt]. cMethod := self fetchPointer: MethodIndex ofObject: home. nArgs := nTemps := 0. home = ctxt ifTrue: [strm cr; tab; nextPutAll: 'args: '. nArgs := self argumentCountOf: cMethod. 1 to: nArgs do: [:i | oop := self fetchPointer: TempFrameStart + i-1 ofObject: ctxt. strm nextPutAll: oop hex; space]. strm cr; tab; nextPutAll: 'temps: '. nTemps := self tempCountOf: cMethod. nArgs+1 to: nTemps do: [:i | oop := self fetchPointer: TempFrameStart + i-1 ofObject: ctxt. strm nextPutAll: oop hex; space]]. strm cr; tab; nextPutAll: 'stack: '. + nTemps + 1 to: (self lastPointerOf: ctxt)//self bytesPerWord - TempFrameStart do: - nTemps + 1 to: (self lastPointerOf: ctxt)//BytesPerWord - TempFrameStart do: [:i | oop := self fetchPointer: TempFrameStart + i-1 ofObject: ctxt. strm nextPutAll: oop hex; space]. ! Item was added: + ----- Method: InterpreterSimulator>>bytesPerWord: (in category 'memory access') ----- + bytesPerWord: fourOrEight + "BytesPerWord was a class variable in ObjectMemory, permitting each object + memory to have its own word size." + + bytesPerWord := fourOrEight! Item was changed: ----- Method: Interpreter>>interpret (in category 'interpreter shell') ----- interpret "This is the main interpreter loop. It normally loops forever, fetching and executing bytecodes. When running in the context of a browser plugin VM, however, it must return control to the browser periodically. This should done only when the state of the currently running Squeak thread is safely stored in the object heap. Since this is the case at the moment that a check for interrupts is performed, that is when we return to the browser if it is time to do so. Interrupt checks happen quite frequently." self inline: false. "should not be inlined into any senders" "record entry time when running as a browser plug-in" self browserPluginInitialiseIfNeeded. + self initializeImageFormatVersionIfNeeded. self internalizeIPandSP. self fetchNextBytecode. [true] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable]. localIP := localIP - 1. "undo the pre-increment of IP before returning" self externalizeIPandSP. ! Item was changed: ----- Method: InterpreterSimulator>>validate: (in category 'testing') ----- validate: oop | header type cc sz fmt nextChunk | header := self longAt: oop. type := header bitAnd: 3. type = 2 ifFalse: [type = (self rightType: header) ifFalse: [self halt]]. sz := (header bitAnd: self sizeMask) >> 2. (self isFreeObject: oop) ifTrue: [ nextChunk := oop + (self sizeOfFree: oop) ] ifFalse: [ nextChunk := oop + (self sizeBitsOf: oop) ]. nextChunk > endOfMemory ifTrue: [oop = endOfMemory ifFalse: [self halt]]. (self headerType: nextChunk) = 0 ifTrue: [ + (self headerType: (nextChunk + (self bytesPerWord * 2))) = 0 ifFalse: [self halt]]. - (self headerType: (nextChunk + (BytesPerWord*2))) = 0 ifFalse: [self halt]]. (self headerType: nextChunk) = 1 ifTrue: [ + (self headerType: (nextChunk + self bytesPerWord)) = 1 ifFalse: [self halt]]. - (self headerType: (nextChunk + BytesPerWord)) = 1 ifFalse: [self halt]]. type = 2 ifTrue: ["free block" ^ self]. fmt := (header >> 8) bitAnd: 16rF. cc := (header >> 12) bitAnd: 31. cc > 16 ifTrue: [self halt]. "up to 32 are legal, but not used" type = 0 ifTrue: ["three-word header" + ((self longAt: oop - self bytesPerWord) bitAnd: 3) = type ifFalse: [self halt]. + ((self longAt: oop-(self bytesPerWord * 2)) bitAnd: 3) = type ifFalse: [self halt]. + ((self longAt: oop - self bytesPerWord) = type) ifTrue: [self halt]. "Class word is 0" - ((self longAt: oop-BytesPerWord) bitAnd: 3) = type ifFalse: [self halt]. - ((self longAt: oop-(BytesPerWord*2)) bitAnd: 3) = type ifFalse: [self halt]. - ((self longAt: oop-BytesPerWord) = type) ifTrue: [self halt]. "Class word is 0" sz = 0 ifFalse: [self halt]]. type = 1 ifTrue: ["two-word header" + ((self longAt: oop - self bytesPerWord) bitAnd: 3) = type ifFalse: [self halt]. - ((self longAt: oop-BytesPerWord) bitAnd: 3) = type ifFalse: [self halt]. cc > 0 ifTrue: [sz = 1 ifFalse: [self halt]]. sz = 0 ifTrue: [self halt]]. type = 3 ifTrue: ["one-word header" cc = 0 ifTrue: [self halt]]. fmt = 5 ifTrue: [self halt]. fmt = 7 ifTrue: [self halt]. fmt >= 12 ifTrue: ["CompiledMethod -- check for integer header" + (self isIntegerObject: (self longAt: oop + self bytesPerWord)) ifFalse: [self halt]].! - (self isIntegerObject: (self longAt: oop + BytesPerWord)) ifFalse: [self halt]].! Item was changed: ----- Method: Interpreter class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator aCCodeGenerator addHeaderFile:'<setjmp.h>'. aCCodeGenerator var: #interpreterProxy type: #'struct VirtualMachine*'. aCCodeGenerator var: #primitiveTable declareC: 'void *primitiveTable[', (MaxPrimitiveIndex +2) printString, '] = ', self primitiveTableString. aCCodeGenerator var: #primitiveFunctionPointer declareC: 'void *primitiveFunctionPointer' . "xxxx FIX THIS STUPIDITY xxxx - ikp. What he means is use a better type than void *, apparently - tpr" aCCodeGenerator var: #methodCache declareC: 'long methodCache[', (MethodCacheSize + 1) printString, ']'. aCCodeGenerator var: #atCache declareC: 'sqInt atCache[', (AtCacheTotalSize + 1) printString, ']'. aCCodeGenerator var: #statGCTime type: #'sqLong'. aCCodeGenerator var: #statFullGCMSecs type: #'sqLong'. aCCodeGenerator var: #statIGCDeltaTime type: #'sqLong'. aCCodeGenerator var: #statIncrGCMSecs type: #'sqLong'. aCCodeGenerator var: #localIP type: #'char*'. aCCodeGenerator var: #localSP type: #'char*'. aCCodeGenerator var: #showSurfaceFn type: #'void*'. aCCodeGenerator var: 'semaphoresToSignalA' declareC: 'sqInt semaphoresToSignalA[', (SemaphoresToSignalSize + 1) printString, ']'. aCCodeGenerator var: 'semaphoresToSignalB' declareC: 'sqInt semaphoresToSignalB[', (SemaphoresToSignalSize + 1) printString, ']'. aCCodeGenerator var: #compilerHooks declareC: 'sqInt (*compilerHooks[', (CompilerHooksSize + 1) printString, '])()'. aCCodeGenerator var: #interpreterVersion declareC: 'const char *interpreterVersion = "', SmalltalkImage current datedVersion, ' [', SmalltalkImage current lastUpdateString,']"'. aCCodeGenerator var: #obsoleteIndexedPrimitiveTable declareC: 'char* obsoleteIndexedPrimitiveTable[][3] = ', self obsoleteIndexedPrimitiveTableString. aCCodeGenerator var: #obsoleteNamedPrimitiveTable declareC: 'const char* obsoleteNamedPrimitiveTable[][3] = ', self obsoleteNamedPrimitiveTableString. aCCodeGenerator var: #externalPrimitiveTable declareC: 'void *externalPrimitiveTable[', (MaxExternalPrimitiveTableSize + 1) printString, ']'. self declareCAsOop: { #instructionPointer . #method . #newMethod . #activeContext . #theHomeContext . #stackPointer } in: aCCodeGenerator. aCCodeGenerator var: #jmpBuf declareC: 'jmp_buf jmpBuf[', (MaxJumpBuf + 1) printString, ']'. aCCodeGenerator var: #suspendedCallbacks declareC: 'sqInt suspendedCallbacks[', (MaxJumpBuf + 1) printString, ']'. aCCodeGenerator var: #suspendedMethods declareC: 'sqInt suspendedMethods[', (MaxJumpBuf + 1) printString, ']'. + "Reinitialized at interpreter entry by #initializeImageFormatVersion" aCCodeGenerator var: #imageFormatVersionNumber + declareC: 'sqInt imageFormatVersionNumber = 0'! - declareC: 'sqInt imageFormatVersionNumber = ', - (BytesPerWord == 4 - ifTrue: ['6502'] - ifFalse: ['68000'])! Item was changed: ----- Method: ObjectMemory>>bytesPerWord (in category 'constants') ----- bytesPerWord "Answer the size of an object memory word in bytes." - "Class variable shadows the cpp macro definition in generated code." self inline: true. + ^self + cCode: 'BYTES_PER_WORD' + inSmalltalk: [self subclassResponsibility "InterpreterSimulator"] - ^self cCode: 'BYTES_PER_WORD' inSmalltalk: [BytesPerWord] ! Item was changed: ----- Method: VMMaker class>>versionString (in category 'version testing') ----- versionString "VMMaker versionString" + ^'4.2.1'! - ^'4.2.0'! Item was removed: - ----- Method: ObjectMemory class>>bytesPerWord (in category 'accessing') ----- - bytesPerWord - "Answer the width of an object pointer, in bytes." - - ^BytesPerWord! Item was removed: - ----- Method: InterpreterSimulatorLSB64>>bytesPerWord (in category 'initialization') ----- - bytesPerWord - "overridden for 64-bit images..." - - ^ 8! Item was removed: - ----- Method: InterpreterSimulatorMSB64>>bytesPerWord (in category 'initialization') ----- - bytesPerWord - "overridden for 64-bit images..." - - ^ 8! Item was removed: - ----- Method: ObjectMemory class>>baseHeaderSize (in category 'accessing') ----- - baseHeaderSize - "To support SmartSyntaxPluginCodeGenerator" - ^BaseHeaderSize!

1 0

VM Maker: VMMaker-dtl.173.mcz
by squeak-dev-noreply＠lists.squeakfoundation.org 20 May '10

20 May '10

Dave Lewis uploaded a new version of VMMaker to project VM Maker: http://www.squeaksource.com/VMMaker/VMMaker-dtl.173.mcz ==================== Summary ==================== Name: VMMaker-dtl.173 Author: dtl Time: 19 May 2010, 5:26:58 am UUID: bbb194b8-b409-4b48-a757-7d9466006019 Ancestors: VMMaker-dtl.172 VMMaker 4.2.0 EXPERIMENTAL - Includes numerous code changes that may cause problems for other VM projects that rely on a stable VMMaker code base. Compile a VM for either 32-bit or 64-bit image from a single generated code base. Eliminates need for separate src32 and src64 code generation from VMMaker. Various word-size dependent class variables are removed from ObjectMemory. C preprocessor macros are written to src/vm/interp.h to handle all compile-time size dependencies. The interpreter simulator uses a mix of class variables and instance methods to implement the corresponding calculations in Smalltalk. To compile a VM for 64-bit images, define the following in config.h or equivalent: #define SQ_VI_BYTES_PER_WORD 8 =============== Diff against VMMaker-dtl.172 =============== Item was changed: ----- Method: ObjectMemory>>prepareForwardingTableForBecoming:with:twoWay: (in category 'become') ----- prepareForwardingTableForBecoming: array1 with: array2 twoWay: twoWayFlag "Ensure that there are enough forwarding blocks to accomodate this become, then prepare forwarding blocks for the pointer swap. Return true if successful." "Details: Doing a GC might generate enough space for forwarding blocks if we're short. However, this is an uncommon enough case that it is better handled by primitive fail code at the Smalltalk level." "Important note on multiple references to same object - since the preparation of fwdBlocks is NOT idempotent we get VM crashes if the same object is referenced more than once in such a way as to require multiple fwdBlocks. oop1 forwardBecome: oop1 is ok since only a single fwdBlock is needed. oop1 become: oop1 would fail because the second fwdBlock woudl not have the actual object header but rather the mutated ref to the first fwdBlock. Further problems can arise with an array1 or array2 that refer multiply to the same object. This would notbe expected input for programmer writen code but might arise from automatic usage such as in ImageSegment loading. To avoid the simple and rather common case of oop1 become*: oop1, we skip such pairs and simply avoid making fwdBlocks - it is redundant anyway" | entriesNeeded entriesAvailable fieldOffset oop1 oop2 fwdBlock fwdBlkSize | + entriesNeeded := (self lastPointerOf: array1) // self bytesPerWord. "need enough entries for all oops" - entriesNeeded := (self lastPointerOf: array1) // BytesPerWord. "need enough entries for all oops" "Note: Forward blocks must be quadword aligned - see fwdTableInit:." twoWayFlag ifTrue: ["Double the number of blocks for two-way become" entriesNeeded := entriesNeeded * 2. + fwdBlkSize := self bytesPerWord * 2] - fwdBlkSize := BytesPerWord * 2] ifFalse: ["One-way become needs backPointers in fwd blocks." + fwdBlkSize := self bytesPerWord * 4]. - fwdBlkSize := BytesPerWord * 4]. entriesAvailable := self fwdTableInit: fwdBlkSize. entriesAvailable < entriesNeeded ifTrue: [self initializeMemoryFirstFree: freeBlock. "re-initialize the free block" ^ false]. fieldOffset := self lastPointerOf: array1. + [fieldOffset >= self baseHeaderSize] - [fieldOffset >= BaseHeaderSize] whileTrue: [oop1 := self longAt: array1 + fieldOffset. oop2 := self longAt: array2 + fieldOffset. "if oop1 == oop2, no need to do any work for this pair. May still be other entries in the arrays though so keep looking" oop1 = oop2 ifFalse: [fwdBlock := self fwdBlockGet: fwdBlkSize. self initForwardBlock: fwdBlock mapping: oop1 to: oop2 withBackPtr: twoWayFlag not. twoWayFlag ifTrue: ["Second block maps oop2 back to oop1 for two-way become" fwdBlock := self fwdBlockGet: fwdBlkSize. self initForwardBlock: fwdBlock mapping: oop2 to: oop1 withBackPtr: twoWayFlag not]]. + fieldOffset := fieldOffset - self bytesPerWord]. - fieldOffset := fieldOffset - BytesPerWord]. ^ true! Item was changed: ----- Method: Interpreter>>primitiveVMPath (in category 'system control primitives') ----- primitiveVMPath "Return a string containing the path name of VM's directory." | s sz | sz := self vmPathSize. s := self instantiateClass: (self splObj: ClassString) indexableSize: sz. + self vmPathGet: (s + self baseHeaderSize) Length: sz. - self vmPathGet: (s + BaseHeaderSize) Length: sz. self pop: 1 thenPush: s. ! Item was changed: ----- Method: Interpreter>>okayOop: (in category 'debug support') ----- okayOop: signedOop "Verify that the given oop is legitimate. Check address, header, and size but not class." | sz type fmt unusedBit oop | self var: #oop type: 'usqInt'. oop := self cCoerce: signedOop to: 'usqInt'. "address and size checks" (self isIntegerObject: oop) ifTrue: [ ^true ]. (oop < endOfMemory) ifFalse: [ self error: 'oop is not a valid address' ]. + ((oop \\ self bytesPerWord) = 0) - ((oop \\ BytesPerWord) = 0) ifFalse: [ self error: 'oop is not a word-aligned address' ]. sz := self sizeBitsOf: oop. (oop + sz) < endOfMemory ifFalse: [ self error: 'oop size would make it extend beyond the end of memory' ]. "header type checks" type := self headerType: oop. type = HeaderTypeFree ifTrue: [ self error: 'oop is a free chunk, not an object' ]. type = HeaderTypeShort ifTrue: [ (((self baseHeader: oop) >> 12) bitAnd: 16r1F) = 0 ifTrue: [ self error: 'cannot have zero compact class field in a short header' ]. ]. type = HeaderTypeClass ifTrue: [ + ((oop >= self bytesPerWord) and: [(self headerType: oop - self bytesPerWord) = type]) - ((oop >= BytesPerWord) and: [(self headerType: oop - BytesPerWord) = type]) ifFalse: [ self error: 'class header word has wrong type' ]. ]. type = HeaderTypeSizeAndClass ifTrue: [ + ((oop >= (self bytesPerWord * 2)) and: + [(self headerType: oop - (self bytesPerWord * 2)) = type and: + [(self headerType: oop - self bytesPerWord) = type]]) - ((oop >= (BytesPerWord*2)) and: - [(self headerType: oop - (BytesPerWord*2)) = type and: - [(self headerType: oop - BytesPerWord) = type]]) ifFalse: [ self error: 'class header word has wrong type' ]. ]. "format check" fmt := self formatOf: oop. ((fmt = 5) | (fmt = 7)) ifTrue: [ self error: 'oop has an unknown format type' ]. "mark and root bit checks" unusedBit := 16r20000000. + self bytesPerWord = 8 - BytesPerWord = 8 ifTrue: [unusedBit := unusedBit << 16. unusedBit := unusedBit << 16]. ((self longAt: oop) bitAnd: unusedBit) = 0 ifFalse: [ self error: 'unused header bit 30 is set; should be zero' ]. "xxx ((self longAt: oop) bitAnd: MarkBit) = 0 ifFalse: [ self error: 'mark bit should not be set except during GC' ]. xxx" + (((self longAt: oop) bitAnd: self rootBit) = 1 and: - (((self longAt: oop) bitAnd: RootBit) = 1 and: [oop >= youngStart]) ifTrue: [ self error: 'root bit is set in a young object' ]. ^true ! Item was changed: ----- Method: ObjectMemory class>>initializeWithBytesToWord: (in category 'initialization') ----- initializeWithBytesToWord: numberOfBytesInAWord "ObjectMemory initializeWithBytesToWord: Smalltalk wordSize" self initBytesPerWord: numberOfBytesInAWord. "Translation flags (booleans that control code generation via conditional translation):" DoAssertionChecks := false. "generate assertion checks" DoBalanceChecks := false. "generate stack balance checks" self initializeSpecialObjectIndices. self initializeObjectHeaderConstants. CtxtTempFrameStart := 6. "Copy of TempFrameStart in Interp" ContextFixedSizePlusHeader := CtxtTempFrameStart + 1. - SmallContextSize := ContextFixedSizePlusHeader + 16 * BytesPerWord. "16 indexable fields" - "Large contexts have 56 indexable fileds. Max with single header word." - "However note that in 64 bits, for now, large contexts have 3-word headers" - LargeContextSize := ContextFixedSizePlusHeader + 56 * BytesPerWord. LargeContextBit := 16r40000. "This bit set in method headers if large context is needed." NilContext := 1. "the oop for the integer 0; used to mark the end of context lists" RemapBufferSize := 25. RootTableSize := 2500. "number of root table entries (4 bytes/entry)" RootTableRedZone := RootTableSize - 100. "red zone of root table - when reached we force IGC" "tracer actions" StartField := 1. StartObj := 2. Upward := 3. Done := 4. ExtraRootSize := 2048. "max. # of external roots"! Item was changed: ----- Method: ObjectMemory>>restoreHeaderOf: (in category 'become') ----- restoreHeaderOf: oop "Restore the original header of the given oop from its forwarding block." | fwdHeader fwdBlock | fwdHeader := self longAt: oop. + fwdBlock := (fwdHeader bitAnd: self allButMarkBitAndTypeMask) << 1. - fwdBlock := (fwdHeader bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks + ifTrue: [(fwdHeader bitAnd: self markBit) = 0 - ifTrue: [(fwdHeader bitAnd: MarkBit) = 0 ifTrue: [self error: 'attempting to restore the header of an object that has no forwarding block']. self fwdBlockValidate: fwdBlock]. + self longAt: oop put: (self longAt: fwdBlock + self bytesPerWord)! - self longAt: oop put: (self longAt: fwdBlock + BytesPerWord)! Item was changed: ----- Method: Interpreter>>sufficientSpaceToInstantiate:indexableSize: (in category 'object access primitives') ----- sufficientSpaceToInstantiate: classOop indexableSize: size "Return true if there is enough space to allocate an instance of the given class with the given number of indexable fields." "Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line." | format | self inline: true. self var: #size type: 'usqInt'. self var: #bytesNeeded type: 'usqInt'. format := (self formatOfClass: classOop) >> 8 bitAnd: 16rF. "Fail if attempting to call new: on non-indexable class" (size > 0 and: [format < 2]) ifTrue: [^ false]. format < 8 ifTrue: ["indexable fields are words or pointers" + (self isExcessiveAllocationRequest: size shift: self shiftForWord) ifTrue: [^ false]. + ^ self sufficientSpaceToAllocate: 2500 + (size * self bytesPerWord)] - (self isExcessiveAllocationRequest: size shift: ShiftForWord) ifTrue: [^ false]. - ^ self sufficientSpaceToAllocate: 2500 + (size * BytesPerWord)] ifFalse: ["indexable fields are bytes" (self isExcessiveAllocationRequest: size shift: 0) ifTrue: [^ false]. ^ self sufficientSpaceToAllocate: 2500 + size] ! Item was changed: ----- Method: Interpreter>>push: (in category 'contexts') ----- push: object | sp | + self longAt: (sp := stackPointer + self bytesPerWord) put: object. - self longAt: (sp := stackPointer + BytesPerWord) put: object. stackPointer := sp.! Item was changed: ----- Method: ObjectMemory>>remapClassOf: (in category 'gc -- compaction') ----- remapClassOf: oop "Update the class of the given object, if necessary, using its forwarding table entry." "Note: Compact classes need not be remapped since the compact class field is just an index into the compact class table. The header type bits show if this object has a compact class; we needn't look up the oop's real header." | classHeader classOop fwdBlock newClassOop newClassHeader | (self headerType: oop) = HeaderTypeShort ifTrue: [^ nil]. "compact classes needn't be mapped" + classHeader := self longAt: oop - self bytesPerWord. + classOop := classHeader bitAnd: self allButTypeMask. - classHeader := self longAt: oop - BytesPerWord. - classOop := classHeader bitAnd: AllButTypeMask. (self isObjectForwarded: classOop) + ifTrue: [fwdBlock := ((self longAt: classOop) bitAnd: self allButMarkBitAndTypeMask) << 1. - ifTrue: [fwdBlock := ((self longAt: classOop) bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks ifTrue: [self fwdBlockValidate: fwdBlock]. newClassOop := self longAt: fwdBlock. newClassHeader := newClassOop bitOr: (classHeader bitAnd: TypeMask). + self longAt: oop - self bytesPerWord put: newClassHeader. - self longAt: oop - BytesPerWord put: newClassHeader. "The following ensures that become: into an old object's class makes it a root. It does nothing during either incremental or full compaction because oop will never be < youngStart." ((self oop: oop isLessThan: youngStart) and: [self oop: newClassOop isGreaterThanOrEqualTo: youngStart]) ifTrue: [self beRootWhileForwarding: oop]]! Item was changed: ----- Method: Interpreter>>primitiveObjectPointsTo (in category 'object access primitives') ----- primitiveObjectPointsTo | rcvr thang lastField | thang := self popStack. rcvr := self popStack. (self isIntegerObject: rcvr) ifTrue: [^self pushBool: false]. lastField := self lastPointerOf: rcvr. + self baseHeaderSize to: lastField by: self bytesPerWord do: - BaseHeaderSize to: lastField by: BytesPerWord do: [:i | (self longAt: rcvr + i) = thang ifTrue: [^ self pushBool: true]]. self pushBool: false.! Item was changed: ----- Method: ObjectMemory>>recycleContextIfPossible: (in category 'allocation') ----- recycleContextIfPossible: cntxOop "If possible, save the given context on a list of free contexts to be recycled." "Note: The context is not marked free, so it can be reused with minimal fuss. The recycled context lists are cleared at every garbage collect." | header | self inline: true. "only recycle young contexts (which should be most of them)" (self oop: cntxOop isGreaterThanOrEqualTo: youngStart) ifTrue: [header := self baseHeader: cntxOop. (self isMethodContextHeader: header) ifTrue: ["It's a young context, alright." + (header bitAnd: self sizeMask) = self smallContextSize - (header bitAnd: SizeMask) = SmallContextSize ifTrue: ["Recycle small contexts" self storePointerUnchecked: 0 ofObject: cntxOop withValue: freeContexts. freeContexts := cntxOop]. + (header bitAnd: self sizeMask) = self largeContextSize - (header bitAnd: SizeMask) = LargeContextSize ifTrue: ["Recycle large contexts" self storePointerUnchecked: 0 ofObject: cntxOop withValue: freeLargeContexts. freeLargeContexts := cntxOop]]]! Item was changed: ----- Method: Interpreter>>imageFormatCompatibilityVersion (in category 'image save/restore') ----- imageFormatCompatibilityVersion "This VM is backward-compatible with the immediately preceeding non-closure version." + self bytesPerWord == 4 - BytesPerWord == 4 ifTrue: [^6502] ifFalse: [^68000]! Item was changed: ----- Method: Interpreter>>pop:thenPush: (in category 'contexts') ----- pop: nItems thenPush: oop | sp | + self longAt: (sp := stackPointer - ((nItems - 1) * self bytesPerWord)) put: oop. - self longAt: (sp := stackPointer - ((nItems - 1) * BytesPerWord)) put: oop. stackPointer := sp. ! Item was changed: ----- Method: Interpreter>>byteLengthOf: (in category 'array primitive support') ----- byteLengthOf: oop "Return the number of indexable bytes in the given object. This is basically a special copy of lengthOf: for BitBlt." | header sz fmt | header := self baseHeader: oop. (header bitAnd: TypeMask) = HeaderTypeSizeAndClass + ifTrue: [ sz := (self sizeHeader: oop) bitAnd: self allButTypeMask ] + ifFalse: [ sz := header bitAnd: self sizeMask ]. - ifTrue: [ sz := (self sizeHeader: oop) bitAnd: AllButTypeMask ] - ifFalse: [ sz := header bitAnd: SizeMask ]. fmt := (header >> 8) bitAnd: 16rF. fmt < 8 + ifTrue: [ ^ (sz - self baseHeaderSize)] "words" + ifFalse: [ ^ (sz - self baseHeaderSize) - (fmt bitAnd: 3)] "bytes"! - ifTrue: [ ^ (sz - BaseHeaderSize)] "words" - ifFalse: [ ^ (sz - BaseHeaderSize) - (fmt bitAnd: 3)] "bytes"! Item was changed: ----- Method: Interpreter>>pushClosureCopyCopiedValuesBytecode (in category 'stack bytecodes') ----- pushClosureCopyCopiedValuesBytecode "The compiler has pushed the values to be copied, if any. Find numArgs and numCopied in the byte following. Create a Closure with space for the copiedValues and pop numCopied values off the stack into the closure. Set numArgs as specified, and set startpc to the pc following the block size and jump over that code." | newClosure numArgsNumCopied numArgs numCopied blockSize | + self bytesPerWord == 4 - BytesPerWord == 4 ifTrue: [imageFormatVersionNumber := 6504] ifFalse: [imageFormatVersionNumber := 68002]. numArgsNumCopied := self fetchByte. numArgs := numArgsNumCopied bitAnd: 16rF. numCopied := numArgsNumCopied bitShift: -4. "Split blockSize := (self fetchByte * 256) + self fetchByte. into two because evaluation order in C is undefined." blockSize := self fetchByte << 8. blockSize := blockSize + self fetchByte. self externalizeIPandSP. "This is a pain." newClosure := self closureNumArgs: numArgs + instructionPointer: ((self oopForPointer: localIP) + 2 - (method + self baseHeaderSize)) - instructionPointer: ((self oopForPointer: localIP) + 2 - (method+BaseHeaderSize)) numCopiedValues: numCopied. self internalizeIPandSP. "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores." self storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: activeContext. reclaimableContextCount := 0. "The closure refers to thisContext so it can't be reclaimed." numCopied > 0 ifTrue: [0 to: numCopied - 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 internalStackValue: numCopied - i - 1)]. self internalPop: numCopied]. localIP := localIP + blockSize. self fetchNextBytecode. self internalPush: newClosure! Item was changed: ----- Method: ObjectMemory class>>initBytesPerWord: (in category 'initialization') ----- initBytesPerWord: nBytes BytesPerWord := nBytes. - ShiftForWord := (BytesPerWord log: 2) rounded. Byte0Shift := 0. Byte1Shift := 8. Byte2Shift := 16. Byte3Shift := 24. Byte4Shift := 32. Byte5Shift := 40. Byte6Shift := 48. Byte7Shift := 56. Byte0Mask := 16r00000000000000FF. Byte1Mask := 16r000000000000FF00. Byte2Mask := 16r0000000000FF0000. Byte3Mask := 16r00000000FF000000. Byte4Mask := 16r000000FF00000000. Byte5Mask := 16r0000FF0000000000. Byte6Mask := 16r00FF000000000000. Byte7Mask := 16rFF00000000000000. Bytes3to0Mask := 16r00000000FFFFFFFF. Bytes7to4Mask := 16rFFFFFFFF00000000. Byte1ShiftNegated := Byte1Shift negated. Byte3ShiftNegated := Byte3Shift negated. Byte4ShiftNegated := Byte4Shift negated. Byte5ShiftNegated := Byte5Shift negated. Byte7ShiftNegated := Byte7Shift negated! Item was changed: ----- Method: ObjectMemory class>>unsignedIntegerSuffix (in category 'translation') ----- unsignedIntegerSuffix "Answer the suffix that should be appended to unsigned integer literals in generated code." + ^ 'U' + + "The U declaration is sufficient for 64-bit cases - dtl" + "^BytesPerWord = 4 ifTrue: ['U'] ifFalse: ['ULL']"! - ^BytesPerWord = 4 ifTrue: ['U'] ifFalse: ['ULL']! Item was changed: ----- Method: Interpreter>>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 | self var: #addr declareC: 'void (*addr)()'. argumentArray := self stackTop. (self isArray: argumentArray) ifFalse: [^self primitiveFail]. "invalid args" arraySize := self fetchWordLengthOf: argumentArray. self success: (self roomToPushNArgs: arraySize). methodArg := self stackObjectValue: 2. successFlag 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). (successFlag 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. successFlag ifFalse: [^self primitiveFail]. "invalid methodArg state" + addr := self ioLoadExternalFunction: functionName + self baseHeaderSize - addr := self ioLoadExternalFunction: functionName + BaseHeaderSize OfLength: functionLength + FromModule: moduleName + self baseHeaderSize - 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. successFlag ifFalse: "If primitive failed, then restore state for failure code" [self pop: arraySize thenPush: argumentArray. argumentCount := 3]! Item was changed: ----- Method: Interpreter>>pop: (in category 'contexts') ----- pop: nItems "Note: May be called by translated primitive code." + stackPointer := stackPointer - (nItems * self bytesPerWord).! - stackPointer := stackPointer - (nItems*BytesPerWord).! Item was changed: ----- Method: Interpreter>>wordSwapped: (in category 'image save/restore') ----- wordSwapped: w "Return the given 64-bit integer with its halves in the reverse order." self inline: true. + self isDefinedTrueExpression: 'BYTES_PER_WORD == 8' + inSmalltalk: [self bytesPerWord = 8] - self isDefinedTrueExpression: 'SQ_VI_BYTES_PER_WORD == 8' - inSmalltalk: [BytesPerWord = 8] comment: 'swap 32-bit ends of a 64-bit object word' ifTrue: [^ ((w bitShift: Byte4ShiftNegated) bitAnd: Bytes3to0Mask) + ((w bitShift: Byte4Shift) bitAnd: Bytes7to4Mask)] ifFalse: [self error: 'This cannot happen.'] ! Item was changed: ----- Method: Interpreter>>positive32BitIntegerFor: (in category 'primitive support') ----- positive32BitIntegerFor: integerValue | newLargeInteger | "Note - integerValue is interpreted as POSITIVE, eg, as the result of Bitmap>at:, or integer>bitAnd:." integerValue >= 0 ifTrue: [(self isIntegerValue: integerValue) ifTrue: [^ self integerObjectOf: integerValue]]. + self bytesPerWord = 4 - BytesPerWord = 4 ifTrue: ["Faster instantiateSmallClass: currently only works with integral word size." newLargeInteger := self instantiateSmallClass: (self splObj: ClassLargePositiveInteger) + sizeInBytes: self baseHeaderSize + 4] - sizeInBytes: BaseHeaderSize + 4] ifFalse: ["Cant use instantiateSmallClass: due to integral word requirement." newLargeInteger := self instantiateClass: (self splObj: ClassLargePositiveInteger) indexableSize: 4]. self storeByte: 3 ofObject: newLargeInteger withValue: ((integerValue >> 24) bitAnd: 16rFF). self storeByte: 2 ofObject: newLargeInteger withValue: ((integerValue >> 16) bitAnd: 16rFF). self storeByte: 1 ofObject: newLargeInteger withValue: ((integerValue >> 8) bitAnd: 16rFF). self storeByte: 0 ofObject: newLargeInteger withValue: (integerValue bitAnd: 16rFF). ^ newLargeInteger! Item was changed: ----- Method: Interpreter>>byteSwapByteObjectsFrom:to: (in category 'image save/restore') ----- byteSwapByteObjectsFrom: startOop to: stopAddr "Byte-swap the words of all bytes objects in a range of the image, including Strings, ByteArrays, and CompiledMethods. This returns these objects to their original byte ordering after blindly byte-swapping the entire image. For compiled methods, byte-swap only their bytecodes part." | oop fmt wordAddr methodHeader | oop := startOop. [self oop: oop isLessThan: stopAddr] whileTrue: [(self isFreeObject: oop) ifFalse: [fmt := self formatOf: oop. fmt >= 8 ifTrue: ["oop contains bytes" + wordAddr := oop + self baseHeaderSize. - wordAddr := oop + BaseHeaderSize. fmt >= 12 ifTrue: ["compiled method; start after methodHeader and literals" + methodHeader := self longAt: oop + self baseHeaderSize. + wordAddr := wordAddr + self bytesPerWord + ((methodHeader >> 10 bitAnd: 255) * self bytesPerWord)]. - methodHeader := self longAt: oop + BaseHeaderSize. - wordAddr := wordAddr + BytesPerWord + ((methodHeader >> 10 bitAnd: 255) * BytesPerWord)]. self reverseBytesFrom: wordAddr to: oop + (self sizeBitsOf: oop)]. + (fmt = 6 and: [self bytesPerWord = 8]) - (fmt = 6 and: [BytesPerWord = 8]) ifTrue: ["Object contains 32-bit half-words packed into 64-bit machine words." + wordAddr := oop + self baseHeaderSize. - wordAddr := oop + BaseHeaderSize. self reverseWordsFrom: wordAddr to: oop + (self sizeBitsOf: oop)]]. oop := self objectAfter: oop]! Item was added: + ----- Method: ObjectMemory>>shiftForWord (in category 'constants') ----- + shiftForWord + + self inline: true. + ^self + cCode: 'SHIFT_FOR_WORD' + inSmalltalk: [(self bytesPerWord log: 2) rounded] + ! Item was changed: (excessive method size, no diff calculated) 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 fetchWordLengthOf: copiedValues. newClosure := self closureNumArgs: numArgs "greater by 1 due to preIncrement of localIP" + instructionPointer: instructionPointer + 2 - (method + self baseHeaderSize) - 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: 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 - self baseHeaderSize) >> self shiftForWord! - ^ (sz - BaseHeaderSize) >> ShiftForWord! Item was changed: ----- Method: Interpreter>>unPop: (in category 'contexts') ----- unPop: nItems + stackPointer := stackPointer + (nItems * self bytesPerWord)! - stackPointer := stackPointer + (nItems*BytesPerWord)! Item was changed: ----- Method: Interpreter>>primitiveShortAtPut (in category 'array 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." | index rcvr sz addr value | value := self stackIntegerValue: 0. index := self stackIntegerValue: 1. rcvr := self stackValue: 2. self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]). successFlag ifFalse: [ ^ nil ]. + sz := ((self sizeBitsOf: rcvr) - self baseHeaderSize) // 2. "number of 16-bit fields" - sz := ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2. "number of 16-bit fields" self success: ((index >= 1) and: [index <= sz]). self success: ((value >= -32768) and: [value <= 32767]). successFlag ifTrue: [ + addr := rcvr + self baseHeaderSize + (2 * (index - 1)). - addr := rcvr + BaseHeaderSize + (2 * (index - 1)). self shortAt: addr put: value. self pop: 2. "pop index and value; leave rcvr on stack" ]! Item was changed: ----- Method: Interpreter>>activateNewMethod (in category 'message sending') ----- activateNewMethod | newContext methodHeader initialIP tempCount nilOop where | methodHeader := self headerOf: newMethod. newContext := self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit). + initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * self bytesPerWord) + 1. - initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * BytesPerWord) + 1. tempCount := (methodHeader >> 19) bitAnd: 16r3F. "Assume: newContext will be recorded as a root if necessary by the call to newActiveContext: below, so we can use unchecked stores." + where := newContext + self baseHeaderSize. + self longAt: where + (SenderIndex << self shiftForWord) put: activeContext. + self longAt: where + (InstructionPointerIndex << self shiftForWord) put: (self integerObjectOf: initialIP). + self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount). + self longAt: where + (MethodIndex << self shiftForWord) put: newMethod. + self longAt: where + (ClosureIndex << self shiftForWord) put: nilObj. - where := newContext + BaseHeaderSize. - self longAt: where + (SenderIndex << ShiftForWord) put: activeContext. - self longAt: where + (InstructionPointerIndex << ShiftForWord) put: (self integerObjectOf: initialIP). - self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: tempCount). - self longAt: where + (MethodIndex << ShiftForWord) put: newMethod. - self longAt: where + (ClosureIndex << ShiftForWord) put: nilObj. "Copy the receiver and arguments..." 0 to: argumentCount do: + [:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord) put: (self stackValue: argumentCount-i)]. - [:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord) put: (self stackValue: argumentCount-i)]. "clear remaining temps to nil in case it has been recycled" nilOop := nilObj. argumentCount+1+ReceiverIndex to: tempCount+ReceiverIndex do: + [:i | self longAt: where + (i << self shiftForWord) put: nilOop]. - [:i | self longAt: where + (i << ShiftForWord) put: nilOop]. self pop: argumentCount + 1. reclaimableContextCount := reclaimableContextCount + 1. self newActiveContext: newContext.! Item was changed: ----- Method: ObjectMemory>>lowestFreeAfter: (in category 'garbage collection') ----- lowestFreeAfter: chunk "Return the first free block after the given chunk in memory." | oop oopHeader oopHeaderType oopSize | self inline: false. oop := self oopFromChunk: chunk. [self oop: oop isLessThan: endOfMemory] whileTrue: [oopHeader := self baseHeader: oop. oopHeaderType := oopHeader bitAnd: TypeMask. oopHeaderType = HeaderTypeFree ifTrue: [^ oop] ifFalse: [oopHeaderType = HeaderTypeSizeAndClass + ifTrue: [oopSize := (self sizeHeader: oop) bitAnd: self allButTypeMask] + ifFalse: [oopSize := oopHeader bitAnd: self sizeMask]]. - ifTrue: [oopSize := (self sizeHeader: oop) bitAnd: AllButTypeMask] - ifFalse: [oopSize := oopHeader bitAnd: SizeMask]]. oop := self oopFromChunk: oop + oopSize]. self error: 'expected to find at least one free object'! Item was changed: ----- Method: ObjectMemory>>incCompMove: (in category 'gc -- compaction') ----- incCompMove: bytesFreed "Move all non-free objects between compStart and compEnd to their new locations, restoring their headers in the process. Create a new free block at the end of memory. Return the newly created free chunk. " "Note: The free block used by the allocator always must be the last free block in memory. It may take several compaction passes to make all free space bubble up to the end of memory." | oop next fwdBlock newOop header bytesToMove firstWord lastWord newFreeChunk sz target | self inline: false. self var: #firstWord type: 'usqInt'. self var: #lastWord type: 'usqInt'. self var: #w type: 'usqInt'. newOop := nil. oop := self oopFromChunk: compStart. [self oop: oop isLessThan: compEnd] whileTrue: [statCompMoveCount := statCompMoveCount + 1. next := self objectAfterWhileForwarding: oop. (self isFreeObject: oop) ifFalse: ["a moving object; unwind its forwarding block" + fwdBlock := ((self longAt: oop) bitAnd: self allButMarkBitAndTypeMask) << 1. - fwdBlock := ((self longAt: oop) bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks ifTrue: [self fwdBlockValidate: fwdBlock]. newOop := self longAt: fwdBlock. + header := self longAt: fwdBlock + self bytesPerWord. - header := self longAt: fwdBlock + BytesPerWord. self longAt: oop put: header. "restore the original header" bytesToMove := oop - newOop. "move the oop (including any extra header words) " sz := self sizeBitsOf: oop. firstWord := oop - (self extraHeaderBytes: oop). + lastWord := oop + sz - self baseHeaderSize. - lastWord := oop + sz - BaseHeaderSize. target := firstWord - bytesToMove. + firstWord to: lastWord by: self bytesPerWord - firstWord to: lastWord by: BytesPerWord do: [:w | self longAt: target put: (self longAt: w). + target := target + self bytesPerWord]]. - target := target + BytesPerWord]]. oop := next]. newOop = nil ifTrue: ["no objects moved" oop := self oopFromChunk: compStart. ((self isFreeObject: oop) and: [(self objectAfter: oop) = (self oopFromChunk: compEnd)]) ifTrue: [newFreeChunk := oop] ifFalse: [newFreeChunk := freeBlock]] ifFalse: ["initialize the newly freed memory chunk" "newOop is the last object moved; free chunk starts right after it" newFreeChunk := newOop + (self sizeBitsOf: newOop). self setSizeOfFree: newFreeChunk to: bytesFreed]. DoAssertionChecks ifTrue: [(self objectAfter: newFreeChunk) = (self oopFromChunk: compEnd) ifFalse: [self error: 'problem creating free chunk after compaction']]. (self objectAfter: newFreeChunk) = endOfMemory ifTrue: [self initializeMemoryFirstFree: newFreeChunk] ifFalse: ["newFreeChunk is not at end of memory; re-install freeBlock " self initializeMemoryFirstFree: freeBlock]. ^ newFreeChunk! Item was changed: (excessive method size, no diff calculated) Item was changed: ----- Method: Interpreter>>primitiveBeCursor (in category 'I/O primitives') ----- primitiveBeCursor "Set the cursor to the given shape. The Mac only supports 16x16 pixel cursors. Cursor offsets are handled by Smalltalk." | cursorObj maskBitsIndex maskObj bitsObj extentX extentY depth offsetObj offsetX offsetY cursorBitsIndex ourCursor | self flag: #Dan. "This is disabled until we convert bitmaps appropriately" + self bytesPerWord = 8 ifTrue: [^ self pop: argumentCount]. - BytesPerWord = 8 ifTrue: [^ self pop: argumentCount]. argumentCount = 0 ifTrue: [ cursorObj := self stackTop. maskBitsIndex := nil]. argumentCount = 1 ifTrue: [ cursorObj := self stackValue: 1. maskObj := self stackTop]. self success: (argumentCount < 2). self success: ((self isPointers: cursorObj) and: [(self lengthOf: cursorObj) >= 5]). successFlag ifTrue: [ bitsObj := self fetchPointer: 0 ofObject: cursorObj. extentX := self fetchInteger: 1 ofObject: cursorObj. extentY := self fetchInteger: 2 ofObject: cursorObj. depth := self fetchInteger: 3 ofObject: cursorObj. offsetObj := self fetchPointer: 4 ofObject: cursorObj]. self success: ((self isPointers: offsetObj) and: [(self lengthOf: offsetObj) >= 2]). successFlag ifTrue: [ offsetX := self fetchInteger: 0 ofObject: offsetObj. offsetY := self fetchInteger: 1 ofObject: offsetObj. (argumentCount = 0 and: [depth = 32]) ifTrue: [ "Support arbitrary-sized 32 bit ARGB forms --bf 3/1/2007 23:51" self success: ((extentX > 0) and: [extentY > 0]). self success: ((offsetX >= (extentX * -1)) and: [offsetX <= 0]). self success: ((offsetY >= (extentY * -1)) and: [offsetY <= 0]). + cursorBitsIndex := bitsObj + self baseHeaderSize. - cursorBitsIndex := bitsObj + BaseHeaderSize. self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = (extentX * extentY)]). self cCode: '' inSmalltalk: [ourCursor := Cursor extent: extentX @ extentY depth: 32 fromArray: ((1 to: extentX * extentY) collect: [:i | self fetchLong32: i-1 ofObject: bitsObj]) offset: offsetX @ offsetY]] ifFalse: [ self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]). self success: ((offsetX >= -16) and: [offsetX <= 0]). self success: ((offsetY >= -16) and: [offsetY <= 0]). self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]). + cursorBitsIndex := bitsObj + self baseHeaderSize. - cursorBitsIndex := bitsObj + BaseHeaderSize. self cCode: '' inSmalltalk: [ourCursor := Cursor extent: extentX @ extentY fromArray: ((1 to: 16) collect: [:i | ((self fetchLong32: i-1 ofObject: bitsObj) >> 16) bitAnd: 16rFFFF]) offset: offsetX @ offsetY]]]. argumentCount = 1 ifTrue: [ self success: ((self isPointers: maskObj) and: [(self lengthOf: maskObj) >= 5]). successFlag ifTrue: [ bitsObj := self fetchPointer: 0 ofObject: maskObj. extentX := self fetchInteger: 1 ofObject: maskObj. extentY := self fetchInteger: 2 ofObject: maskObj. depth := self fetchInteger: 3 ofObject: maskObj]. successFlag ifTrue: [ self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]). self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]). + maskBitsIndex := bitsObj + self baseHeaderSize]]. - maskBitsIndex := bitsObj + BaseHeaderSize]]. successFlag ifTrue: [ argumentCount = 0 ifTrue: [ depth = 32 ifTrue: [(self cCode: 'ioSetCursorARGB(cursorBitsIndex, extentX, extentY, offsetX, offsetY)' inSmalltalk: [ourCursor show. Cursor currentCursor == ourCursor]) ifFalse: [^self success: false]] ifFalse: [self cCode: 'ioSetCursor(cursorBitsIndex, offsetX, offsetY)' inSmalltalk: [ourCursor show]]] ifFalse: [self cCode: 'ioSetCursorWithMask(cursorBitsIndex, maskBitsIndex, offsetX, offsetY)' inSmalltalk: [cursorBitsIndex == maskBitsIndex. "placate compiler" ourCursor show]]. self pop: argumentCount]! Item was changed: ----- Method: Interpreter>>primitiveIntegerAt (in category 'array primitives') ----- primitiveIntegerAt "Return the 32bit signed integer contents of a words receiver" | index rcvr sz addr value intValue | self var: #intValue type: 'int'. index := self stackIntegerValue: 0. rcvr := self stackValue: 1. (self isIntegerObject: rcvr) ifTrue: [^self success: false]. (self isWords: rcvr) ifFalse: [^self success: false]. sz := self lengthOf: rcvr. "number of fields" self success: ((index >= 1) and: [index <= sz]). successFlag ifTrue: [ + addr := rcvr + self baseHeaderSize - 4 "for zero indexing" + (index * 4). - addr := rcvr + BaseHeaderSize - 4 "for zero indexing" + (index * 4). value := self intAt: addr. self pop: 2. "pop rcvr, index" "push element value" (self isIntegerValue: value) ifTrue: [self pushInteger: value] ifFalse: [ intValue := value. "32 bit int may have been stored in 32 or 64 bit sqInt" self push: (self signed32BitIntegerFor: intValue)]. "intValue may be sign extended to 64 bit sqInt" ].! Item was added: + ----- Method: InterpreterSimulator>>ioMicroSecondClock (in category 'I/O primitives support') ----- + ioMicroSecondClock + "Answer the value of the high-resolution millisecond clock." + + ^ self ioMicroMSecs * 1000 + ! Item was changed: ----- 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" + ^ self longAt: oop + self baseHeaderSize + (fieldIndex << self shiftForWord)! - ^ self longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord)! Item was changed: ----- Method: ObjectMemory>>fwdTableInit: (in category 'gc -- compaction') ----- fwdTableInit: blkSize "Set the limits for a table of two- or three-word forwarding blocks above the last used oop. The pointer fwdTableNext moves up to fwdTableLast. Used for compaction of memory and become-ing objects. Returns the number of forwarding blocks available." | | self inline: false. "set endOfMemory to just after a minimum-sized free block" + self setSizeOfFree: freeBlock to: self baseHeaderSize. + endOfMemory := freeBlock + self baseHeaderSize. - self setSizeOfFree: freeBlock to: BaseHeaderSize. - endOfMemory := freeBlock + BaseHeaderSize. "make a fake free chunk at endOfMemory for use as a sentinal in memory scans" + self setSizeOfFree: endOfMemory to: self baseHeaderSize. - self setSizeOfFree: endOfMemory to: BaseHeaderSize. "use all memory free between freeBlock and memoryLimit for forwarding table" "Note: Forward blocks must be quadword aligned." + fwdTableNext := (endOfMemory + self baseHeaderSize + 7) bitAnd: self wordMask - 7. - fwdTableNext := (endOfMemory + BaseHeaderSize + 7) bitAnd: WordMask-7. self flag: #Dan. "Above line does not do what it says (quadword is 16 or 32 bytes)" fwdTableLast := memoryLimit - blkSize. "last forwarding table entry" "return the number of forwarding blocks available" ^ (fwdTableLast - fwdTableNext) // blkSize "round down"! 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 | self var: #vScale type: 'double '. self 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 byteLengthOf: bitsArray. self success: (bitsArraySize = (wordsPerLine * h * 4))] ifFalse: [self success: false]]. successFlag ifTrue: [ + self bytesPerWord = 8 - BytesPerWord = 8 ifTrue: [ok := self cCode: 'ioFormPrint(bitsArray + 8, w, h, depth, hScale, vScale, landscapeFlag)'] ifFalse: [ok := self cCode: 'ioFormPrint(bitsArray + 4, 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>>restoreHeadersFrom:to:from:and:to:from: (in category 'image segment in/out') ----- restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut "Restore headers smashed by forwarding links" | tablePtr oop header | tablePtr := firstIn. [self oop: tablePtr isLessThanOrEqualTo: lastIn] whileTrue: [oop := self longAt: tablePtr. header := self longAt: hdrBaseIn + (tablePtr-firstIn). self longAt: oop put: header. + tablePtr := tablePtr + self bytesPerWord]. - tablePtr := tablePtr + BytesPerWord]. tablePtr := firstOut. [self oop: tablePtr isLessThanOrEqualTo: lastOut] whileTrue: [oop := self longAt: tablePtr. header := self longAt: hdrBaseOut + (tablePtr-firstOut). self longAt: oop put: header. + tablePtr := tablePtr + self bytesPerWord]. - tablePtr := tablePtr + BytesPerWord]. "Clear all mark bits" oop := self firstObject. [self oop: oop isLessThan: endOfMemory] whileTrue: [(self isFreeObject: oop) ifFalse: + [self longAt: oop put: ((self longAt: oop) bitAnd: self allButMarkBit)]. - [self longAt: oop put: ((self longAt: oop) bitAnd: AllButMarkBit)]. oop := self objectAfter: oop]. ! Item was changed: ----- Method: Interpreter>>fetchIntegerOrTruncFloat:ofObject: (in category 'utilities') ----- fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer "Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers." "Note: May be called by translated primitive code." | intOrFloat floatVal frac trunc | self inline: false. self var: #floatVal type: 'double '. self var: #frac type: 'double '. self var: #trunc type: 'double '. intOrFloat := self fetchPointer: fieldIndex ofObject: objectPointer. (self isIntegerObject: intOrFloat) ifTrue: [^ self integerValueOf: intOrFloat]. self assertClassOf: intOrFloat is: (self splObj: ClassFloat). successFlag ifTrue: [ self cCode: '' inSmalltalk: [floatVal := Float new: 2]. + self fetchFloatAt: intOrFloat + self baseHeaderSize into: floatVal. - self fetchFloatAt: intOrFloat + BaseHeaderSize into: floatVal. self cCode: 'frac = modf(floatVal, &trunc)'. "the following range check is for C ints, with range -2^31..2^31-1" self flag: #Dan. "The ranges are INCORRECT if SmallIntegers are wider than 31 bits." self cCode: 'success((-2147483648.0 <= trunc) && (trunc <= 2147483647.0))'.]. successFlag ifTrue: [^ self cCode: '((sqInt) trunc)' inSmalltalk: [floatVal truncated]] ifFalse: [^ 0]. ! Item was changed: ----- Method: ObjectMemory>>containOnlyOops:and: (in category 'become') ----- containOnlyOops: array1 and: array2 "Return true if neither array contains a small integer. You can't become: integers!!" | fieldOffset | fieldOffset := self lastPointerOf: array1. "same size as array2" + [fieldOffset >= self baseHeaderSize] - [fieldOffset >= BaseHeaderSize] whileTrue: [(self isIntegerObject: (self longAt: array1 + fieldOffset)) ifTrue: [^ false]. (self isIntegerObject: (self longAt: array2 + fieldOffset)) ifTrue: [^ false]. + fieldOffset := fieldOffset - self bytesPerWord]. - fieldOffset := fieldOffset - BytesPerWord]. ^ true! Item was added: + ----- Method: ObjectMemory>>baseHeaderSize (in category 'constants') ----- + baseHeaderSize + "Answer the size of an object memory header word in bytes." + "Class variable shadows the cpp macro definition in generated code." + + self inline: true. + ^self cCode: 'BASE_HEADER_SIZE' inSmalltalk: [BaseHeaderSize] + ! Item was changed: ----- Method: ObjectMemory>>storeLong32:ofObject:withValue: (in category 'interpreter access') ----- storeLong32: fieldIndex ofObject: oop withValue: valueWord + ^ self long32At: oop + self baseHeaderSize + (fieldIndex << 2) - ^ self long32At: oop + BaseHeaderSize + (fieldIndex << 2) put: valueWord! Item was added: + ----- Method: InterpreterSimulator>>signalSemaphoreWithIndex: (in category 'memory access') ----- + signalSemaphoreWithIndex: index + "Record the given semaphore index in the double buffer semaphores array to be signaled at the next convenient moment. Force a real interrupt check as soon as possible." + + ^ index ifNotNil: [super signalSemaphoreWithIndex: index]! Item was added: + ----- Method: ObjectMemory>>rootBit (in category 'constants') ----- + rootBit + "Next-to-Top bit" + + self inline: true. + ^self + cCode: 'ROOT_BIT' + inSmalltalk: [1 bitShift: BytesPerWord*8 - 2] + ! Item was added: + ----- Method: ObjectMemory>>allButMarkBitAndTypeMask (in category 'constants') ----- + allButMarkBitAndTypeMask + + self inline: true. + ^self + cCode: 'ALL_BUT_MARK_BIT_AND_TYPE_MASK' + inSmalltalk: [self allButTypeMask - self markBit] + ! Item was added: + ----- Method: ObjectMemory>>sizeMask (in category 'constants') ----- + sizeMask + "One of the base header word bit fields. For 64-bit word size, lose the 4 bit + in temp 64-bit chunk format. See size4Bit, which restores the 4 bit ST size. + Note SizeMask + Size4Bit gives the mask needed for size fits of format word in classes. + This is used in instantiateClass:indexableSize: " + + self inline: true. + ^self + cCode: 'SIZE_MASK' + inSmalltalk: [self bytesPerWord = 4 + ifTrue: [16rFC] + ifFalse: [16rF8 "Lose the 4 bit in temp 64-bit chunk format"]] + ! Item was changed: ----- Method: Interpreter>>closureNumArgs:instructionPointer:numCopiedValues: (in category 'control primitives') ----- closureNumArgs: numArgs instructionPointer: initialIP numCopiedValues: numCopied | newClosure | self inline: true. newClosure := self instantiateSmallClass: (self splObj: ClassBlockClosure) + sizeInBytes: (self bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + self baseHeaderSize. - sizeInBytes: (BytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + BaseHeaderSize. "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores." self storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (self integerObjectOf: initialIP). self storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (self integerObjectOf: numArgs). "It is up to the caller to store the outer context and copiedValues." ^newClosure! Item was changed: ----- Method: Interpreter>>primitiveStoreStackp (in category 'object access primitives') ----- primitiveStoreStackp "Atomic store into context stackPointer. Also ensures that any newly accessible cells are initialized to nil " | ctxt newStackp stackp | ctxt := self stackValue: 1. newStackp := self stackIntegerValue: 0. self success: (self oop: newStackp isGreaterThanOrEqualTo: 0). + self success: (self oop: newStackp isLessThanOrEqualTo: (self largeContextSize - self baseHeaderSize // self bytesPerWord - CtxtTempFrameStart)). - self success: (self oop: newStackp isLessThanOrEqualTo: (LargeContextSize - BaseHeaderSize // BytesPerWord - CtxtTempFrameStart)). successFlag ifFalse: [^ self primitiveFail]. stackp := self fetchStackPointerOf: ctxt. (self oop: newStackp isGreaterThan: stackp) ifTrue: ["Nil any newly accessible cells" stackp + 1 to: newStackp do: [:i | self storePointer: i + CtxtTempFrameStart - 1 ofObject: ctxt withValue: nilObj]]. self storeStackPointerValue: newStackp inContext: ctxt. self pop: 1! Item was changed: ----- Method: Interpreter>>primitiveBlockCopy (in category 'control primitives') ----- primitiveBlockCopy | context methodContext contextSize newContext initialIP | context := self stackValue: 1. (self isIntegerObject: (self fetchPointer: MethodIndex ofObject: context)) ifTrue: ["context is a block; get the context of its enclosing method" methodContext := self fetchPointer: HomeIndex ofObject: context] ifFalse: [methodContext := context]. contextSize := self sizeBitsOf: methodContext. "in bytes, including header" context := nil. "context is no longer needed and is not preserved across allocation" "remap methodContext in case GC happens during allocation" self pushRemappableOop: methodContext. newContext := self instantiateContext: (self splObj: ClassBlockContext) sizeInBytes: contextSize. methodContext := self popRemappableOop. + initialIP := self integerObjectOf: (instructionPointer+1+3) - (method + self baseHeaderSize). - initialIP := self integerObjectOf: (instructionPointer+1+3) - (method+BaseHeaderSize). "Was instructionPointer + 3, but now it's greater by 1 due to preIncrement" "Assume: have just allocated a new context; it must be young. Thus, can use uncheck stores. See the comment in fetchContextRegisters." self storePointerUnchecked: InitialIPIndex ofObject: newContext withValue: initialIP. self storePointerUnchecked: InstructionPointerIndex ofObject: newContext withValue: initialIP. self storeStackPointerValue: 0 inContext: newContext. self storePointerUnchecked: BlockArgumentCountIndex ofObject: newContext withValue: (self stackValue: 0). self storePointerUnchecked: HomeIndex ofObject: newContext withValue: methodContext. self storePointerUnchecked: SenderIndex ofObject: newContext withValue: nilObj. self pop: 2 thenPush: newContext.! Item was changed: ----- Method: Interpreter>>internalFetchContextRegisters: (in category 'contexts') ----- internalFetchContextRegisters: activeCntx "Inlined into return bytecodes. The only difference between this method and fetchContextRegisters: is that this method sets the local IP and SP." | tmp | self inline: true. tmp := self fetchPointer: MethodIndex ofObject: activeCntx. (self isIntegerObject: tmp) ifTrue: [ "if the MethodIndex field is an integer, activeCntx is a block context" tmp := self fetchPointer: HomeIndex ofObject: activeCntx. (self oop: tmp isLessThan: youngStart) ifTrue: [ self beRootIfOld: tmp ]. ] ifFalse: [ "otherwise, it is a method context and is its own home context" tmp := activeCntx. ]. localHomeContext := tmp. receiver := self fetchPointer: ReceiverIndex ofObject: tmp. method := self fetchPointer: MethodIndex ofObject: tmp. "the instruction pointer is a pointer variable equal to + method oop + ip + self baseHeaderSize - method oop + ip + BaseHeaderSize -1 for 0-based addressing of fetchByte -1 because it gets incremented BEFORE fetching currentByte" tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx. + localIP := self pointerForOop: method + tmp + self baseHeaderSize - 2. - localIP := self pointerForOop: method + tmp + BaseHeaderSize - 2. "the stack pointer is a pointer variable also..." tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx. + localSP := self pointerForOop: activeCntx + self baseHeaderSize + ((TempFrameStart + tmp - 1) * self bytesPerWord)! - localSP := self pointerForOop: activeCntx + BaseHeaderSize + ((TempFrameStart + tmp - 1) * BytesPerWord)! Item was changed: ----- Method: Interpreter>>primitiveGetAttribute (in category 'system control primitives') ----- primitiveGetAttribute "Fetch the system attribute with the given integer ID. The result is a string, which will be empty if the attribute is not defined." | attr sz s | attr := self stackIntegerValue: 0. successFlag ifTrue: [sz := self attributeSize: attr]. successFlag ifTrue: [s := self instantiateClass: (self splObj: ClassString) indexableSize: sz. self getAttribute: attr + Into: s + self baseHeaderSize - Into: s + BaseHeaderSize Length: sz. self pop: 2 thenPush: s]! Item was changed: ----- Method: ObjectMemory>>fetchClassOfNonInt: (in category 'interpreter access') ----- fetchClassOfNonInt: oop | ccIndex | self inline: true. ccIndex := (self baseHeader: oop) >> 12 bitAnd: 31. ccIndex = 0 ifTrue: [^ (self classHeader: oop) + bitAnd: self allButTypeMask] - bitAnd: AllButTypeMask] ifFalse: ["look up compact class" ^ self fetchPointer: ccIndex - 1 ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop)]! 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 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 + self baseHeaderSize. + self longAt: where + (SenderIndex << self shiftForWord) - where := newContext + BaseHeaderSize. - self longAt: where + (SenderIndex << ShiftForWord) put: activeContext. + self longAt: where + (InstructionPointerIndex << self shiftForWord) - self longAt: where + (InstructionPointerIndex << ShiftForWord) put: (self fetchPointer: ClosureStartPCIndex ofObject: theBlockClosure). + self longAt: where + (StackPointerIndex << self shiftForWord) - self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: argumentCount + numCopied). + self longAt: where + (MethodIndex << self shiftForWord) - self longAt: where + (MethodIndex << ShiftForWord) put: (self fetchPointer: MethodIndex ofObject: outerContext). + self longAt: where + (ClosureIndex << self shiftForWord) - self longAt: where + (ClosureIndex << ShiftForWord) put: theBlockClosure. + self longAt: where + (ReceiverIndex << self shiftForWord) - self longAt: where + (ReceiverIndex << ShiftForWord) put: (self fetchPointer: ReceiverIndex ofObject: outerContext). "Copy the arguments..." 1 to: argumentCount do: + [:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord) - [:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord) put: (self stackValue: argumentCount-i)]. "Copy the copied values..." + where := newContext + self baseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << self shiftForWord). - where := newContext + BaseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << ShiftForWord). 0 to: numCopied - 1 do: + [:i| self longAt: where + (i << self shiftForWord) - [: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>>primitiveIsRoot (in category 'memory space primitives') ----- primitiveIsRoot "Primitive. Answer whether the argument to the primitive is a root for young space" | oop | self export: true. oop := self stackObjectValue: 0. successFlag ifTrue:[ self pop: argumentCount + 1. + self pushBool: ((self baseHeader: oop) bitAnd: self rootBit). - self pushBool: ((self baseHeader: oop) bitAnd: RootBit). ].! Item was changed: ----- Method: ObjectMemory>>noteAsRoot:headerLoc: (in category 'garbage collection') ----- noteAsRoot: oop headerLoc: headerLoc "Record that the given oop in the old object area points to an object in the young area. HeaderLoc is usually = oop, but may be an addr in a forwarding block." | header | self inline: true. header := self longAt: headerLoc. + (header bitAnd: self rootBit) = 0 - (header bitAnd: RootBit) = 0 ifTrue: ["record oop as root only if not already recorded" rootTableCount < RootTableRedZone ifTrue: ["record root if there is enough room in the roots table " rootTableCount := rootTableCount + 1. rootTable at: rootTableCount put: oop. + self longAt: headerLoc put: (header bitOr: self rootBit)] - self longAt: headerLoc put: (header bitOr: RootBit)] ifFalse: ["we're getting in the red zone" rootTableCount < RootTableSize ifTrue: ["but there's still space to record it" rootTableCount := rootTableCount + 1. rootTable at: rootTableCount put: oop. + self longAt: headerLoc put: (header bitOr: self rootBit). - self longAt: headerLoc put: (header bitOr: RootBit). "but force an IGC on the next allocation" allocationCount := allocationsBetweenGCs + 1]]]! Item was changed: ----- Method: Interpreter>>transfer:from:to: (in category 'utilities') ----- transfer: count from: src to: dst | in out lastIn | self flag: #Dan. "Need to check all senders before converting this for 64 bits" self inline: true. + in := src - self bytesPerWord. + lastIn := in + (count * self bytesPerWord). + out := dst - self bytesPerWord. - in := src - BytesPerWord. - lastIn := in + (count * BytesPerWord). - out := dst - BytesPerWord. [self oop: in isLessThan: lastIn] whileTrue: [self + longAt: (out := out + self bytesPerWord) + put: (self longAt: (in := in + self bytesPerWord))]! - longAt: (out := out + BytesPerWord) - put: (self longAt: (in := in + BytesPerWord))]! Item was changed: ----- Method: CCodeGenerator>>generateBaseHeaderSize:on:indent: (in category 'C translation') ----- generateBaseHeaderSize: msgNode on: aStream indent: level "Generate the C code for this message onto the given stream." + aStream nextPutAll: 'BASE_HEADER_SIZE' + - aStream nextPutAll: ' ', ObjectMemory baseHeaderSize asString ! Item was changed: ----- Method: Interpreter>>fetchContextRegisters: (in category 'contexts') ----- fetchContextRegisters: activeCntx "Note: internalFetchContextRegisters: should track changes to this method." | tmp | self inline: true. tmp := self fetchPointer: MethodIndex ofObject: activeCntx. (self isIntegerObject: tmp) ifTrue: ["if the MethodIndex field is an integer, activeCntx is a block context" tmp := self fetchPointer: HomeIndex ofObject: activeCntx. (self oop: tmp isLessThan: youngStart) ifTrue: [self beRootIfOld: tmp]] ifFalse: ["otherwise, it is a method context and is its own home context " tmp := activeCntx]. theHomeContext := tmp. receiver := self fetchPointer: ReceiverIndex ofObject: tmp. method := self fetchPointer: MethodIndex ofObject: tmp. "the instruction pointer is a pointer variable equal to + method oop + ip + self baseHeaderSize - method oop + ip + BaseHeaderSize -1 for 0-based addressing of fetchByte -1 because it gets incremented BEFORE fetching currentByte " tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx. + instructionPointer := method + tmp + self baseHeaderSize - 2. - instructionPointer := method + tmp + BaseHeaderSize - 2. "the stack pointer is a pointer variable also..." tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx. + stackPointer := activeCntx + self baseHeaderSize + (TempFrameStart + tmp - 1 * self bytesPerWord)! - stackPointer := activeCntx + BaseHeaderSize + (TempFrameStart + tmp - 1 * BytesPerWord)! Item was changed: ----- Method: InterpreterSimulator>>dumpHeader: (in category 'debug support') ----- dumpHeader: hdr | cc | ^ String streamContents: [:strm | cc := (hdr bitAnd: CompactClassMask) >> 12. strm nextPutAll: '<cc=', cc hex. cc > 0 ifTrue: [strm nextPutAll: ':' , (self nameOfClass: (self compactClassAt: cc))]. strm nextPutAll: '>'. strm nextPutAll: '<ft=', ((hdr bitShift: -8) bitAnd: 16rF) hex , '>'. + strm nextPutAll: '<sz=', (hdr bitAnd: self sizeMask) hex , '>'. - strm nextPutAll: '<sz=', (hdr bitAnd: SizeMask) hex , '>'. strm nextPutAll: '<hdr=', (#(big class gcMark short) at: (hdr bitAnd: 3) +1) , '>'] ! Item was changed: ----- Method: Interpreter>>stackIntegerValue: (in category 'contexts') ----- stackIntegerValue: offset | integerPointer | + integerPointer := self longAt: stackPointer - (offset * self bytesPerWord). - integerPointer := self longAt: stackPointer - (offset*BytesPerWord). ^self checkedIntegerValueOf: integerPointer! Item was changed: ----- Method: Interpreter>>primitiveNewMethod (in category 'compiled methods') ----- primitiveNewMethod | header bytecodeCount class size theMethod literalCount | header := self popStack. bytecodeCount := self popInteger. self success: (self isIntegerObject: header). successFlag ifFalse: [self unPop: 2. ^nil]. class := self popStack. + size := (self literalCountOfHeader: header) + 1 * self bytesPerWord + bytecodeCount. - size := (self literalCountOfHeader: header) + 1 * BytesPerWord + bytecodeCount. theMethod := self instantiateClass: class indexableSize: size. self storePointerUnchecked: HeaderIndex ofObject: theMethod withValue: header. literalCount := self literalCountOfHeader: header. 1 to: literalCount do: [:i | self storePointer: i ofObject: theMethod withValue: nilObj]. self push: theMethod! Item was changed: ----- Method: Interpreter>>primitiveImageName (in category 'other primitives') ----- primitiveImageName "When called with a single string argument, record the string as the current image file name. When called with zero arguments, return a string containing the current image file name." | s sz sCRIfn okToRename | self var: #sCRIfn type: 'void *'. argumentCount = 1 ifTrue: [ "If the security plugin can be loaded, use it to check for rename permission. If not, assume it's ok" sCRIfn := self ioLoadFunction: 'secCanRenameImage' From: 'SecurityPlugin'. sCRIfn ~= 0 ifTrue:[okToRename := self cCode:' ((sqInt (*)(void))sCRIfn)()'. okToRename ifFalse:[^self primitiveFail]]. s := self stackTop. self assertClassOf: s is: (self splObj: ClassString). successFlag ifTrue: [ sz := self stSizeOf: s. + self imageNamePut: (s + self baseHeaderSize) Length: sz. - self imageNamePut: (s + BaseHeaderSize) Length: sz. self pop: 1. "pop s, leave rcvr on stack" ]. ] ifFalse: [ sz := self imageNameSize. s := self instantiateClass: (self splObj: ClassString) indexableSize: sz. + self imageNameGet: (s + self baseHeaderSize) Length: sz. - self imageNameGet: (s + BaseHeaderSize) Length: sz. self pop: 1. "rcvr" self push: s. ]. ! Item was changed: ----- Method: Interpreter>>snapshotCleanUp (in category 'image save/restore') ----- snapshotCleanUp "Clean up right before saving an image, sweeping memory and: * nilling out all fields of contexts above the stack pointer. * flushing external primitives * clearing the root bit of any object in the root table " | oop header fmt sz | oop := self firstObject. [self oop: oop isLessThan: endOfMemory] whileTrue: [(self isFreeObject: oop) ifFalse: [header := self longAt: oop. fmt := header >> 8 bitAnd: 15. "Clean out context" (fmt = 3 and: [self isContextHeader: header]) ifTrue: [sz := self sizeBitsOf: oop. + (self lastPointerOf: oop) + self bytesPerWord + to: sz - self baseHeaderSize by: self bytesPerWord - (self lastPointerOf: oop) + BytesPerWord - to: sz - BaseHeaderSize by: BytesPerWord do: [:i | self longAt: oop + i put: nilObj]]. "Clean out external functions" fmt >= 12 ifTrue: ["This is a compiled method" (self primitiveIndexOf: oop) = PrimitiveExternalCallIndex ifTrue: ["It's primitiveExternalCall" self flushExternalPrimitiveOf: oop]]]. oop := self objectAfter: oop]. self clearRootsTable! Item was changed: ----- Method: ObjectMemory>>rightType: (in category 'header access') ----- rightType: headerWord "Compute the correct header type for an object based on the size and compact class fields of the given base header word, rather than its type bits. This is used during marking, when the header type bits are used to record the state of tracing." + (headerWord bitAnd: self sizeMask) = 0 "zero size field in header word" - (headerWord bitAnd: SizeMask) = 0 "zero size field in header word" ifTrue: [ ^HeaderTypeSizeAndClass ] ifFalse: [ (headerWord bitAnd: CompactClassMask) = 0 ifTrue: [ ^HeaderTypeClass ] ifFalse: [ ^HeaderTypeShort ]].! Item was changed: ----- Method: Interpreter>>firstIndexableField: (in category 'plugin support') ----- firstIndexableField: oop "NOTE: copied in InterpreterSimulator, so please duplicate any changes" | hdr fmt totalLength fixedFields | self returnTypeC: 'char *'. hdr := self baseHeader: oop. fmt := (hdr >> 8) bitAnd: 16rF. totalLength := self lengthOf: oop baseHeader: hdr format: fmt. fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength. fmt < 8 ifTrue: [fmt = 6 ifTrue: ["32 bit field objects" + ^ self pointerForOop: oop + self baseHeaderSize + (fixedFields << 2)]. - ^ self pointerForOop: oop + BaseHeaderSize + (fixedFields << 2)]. "full word objects (pointer or bits)" + ^ self pointerForOop: oop + self baseHeaderSize + (fixedFields << self shiftForWord)] - ^ self pointerForOop: oop + BaseHeaderSize + (fixedFields << ShiftForWord)] ifFalse: ["Byte objects" + ^ self pointerForOop: oop + self baseHeaderSize + fixedFields]! - ^ self pointerForOop: oop + BaseHeaderSize + fixedFields]! Item was changed: ----- Method: Interpreter>>primitiveShortAt (in category 'array 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 sz addr value | index := self stackIntegerValue: 0. rcvr := self stackValue: 1. self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]). successFlag ifFalse: [ ^ nil ]. + sz := ((self sizeBitsOf: rcvr) - self baseHeaderSize) // 2. "number of 16-bit fields" - sz := ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2. "number of 16-bit fields" self success: ((index >= 1) and: [index <= sz]). successFlag ifTrue: [ + addr := rcvr + self baseHeaderSize + (2 * (index - 1)). - addr := rcvr + BaseHeaderSize + (2 * (index - 1)). value := self shortAt: addr. self pop: 2 thenPushInteger: value. ]! Item was changed: ----- Method: Interpreter>>sendInvokeCallback:Stack:Registers:Jmpbuf: (in category 'alien support') ----- sendInvokeCallback: thunkPtr Stack: stackPtr Registers: regsPtr Jmpbuf: jmpBufPtr "Send the 4 argument callback message invokeCallback:stack:registers:jmpbuf: to Alien class with the supplied args. The arguments are raw C addresses and are converted to integer objects on the way." | where | self export: true. self pushRemappableOop: (self positive32BitIntegerFor: jmpBufPtr). self pushRemappableOop: (self positive32BitIntegerFor: regsPtr). self pushRemappableOop: (self positive32BitIntegerFor: stackPtr). self pushRemappableOop: (self positive32BitIntegerFor: thunkPtr). receiver := self splObj: ClassAlien. lkupClass := self fetchClassOfNonInt: receiver. messageSelector := self splObj: InvokeCallbackSelector. (self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse: [(self lookupMethodNoMNUEtcInClass: lkupClass) ifFalse: [^false]]. primitiveIndex ~= 0 ifTrue: [^false]. self storeContextRegisters: activeContext. self internalJustActivateNewMethod. + where := activeContext + self baseHeaderSize + (ReceiverIndex << self shiftForWord). + self longAt: where + (1 << self shiftForWord) put: self popRemappableOop. + self longAt: where + (2 << self shiftForWord) put: self popRemappableOop. + self longAt: where + (3 << self shiftForWord) put: self popRemappableOop. + self longAt: where + (4 << self shiftForWord) put: self popRemappableOop. - where := activeContext + BaseHeaderSize + (ReceiverIndex << ShiftForWord). - self longAt: where + (1 << ShiftForWord) put: self popRemappableOop. - self longAt: where + (2 << ShiftForWord) put: self popRemappableOop. - self longAt: where + (3 << ShiftForWord) put: self popRemappableOop. - self longAt: where + (4 << ShiftForWord) put: self popRemappableOop. self fetchContextRegisters: activeContext. self callInterpreter. "not reached" ^true! Item was changed: ----- Method: ObjectMemory>>initializeMemoryFirstFree: (in category 'initialization') ----- initializeMemoryFirstFree: firstFree "Initialize endOfMemory to the top of oop storage space, reserving some space for forwarding blocks, and create the freeBlock from which space is allocated. Also create a fake free chunk at endOfMemory to act as a sentinal for memory scans. " "Note: The amount of space reserved for forwarding blocks should be chosen to ensure that incremental compactions can usually be done in a single pass. However, there should be enough forwarding blocks so a full compaction can be done in a reasonable number of passes, say ten. (A full compaction requires N object-moving passes, where N = number of non-garbage objects / number of forwarding blocks). di 11/18/2000 Re totalObjectCount: Provide a margin of one byte per object to be used for forwarding pointers at GC time. Since fwd blocks are 8 bytes, this means an absolute worst case of 8 passes to compact memory. In most cases it will be adequate to do compaction in a single pass. " | fwdBlockBytes | self var: #firstFree type: 'usqInt'. self var: #fwdBlockBytes type: 'usqInt'. "reserve space for forwarding blocks" + fwdBlockBytes := totalObjectCount bitAnd: self wordMask - self bytesPerWord + 1. + (self oop: memoryLimit - fwdBlockBytes isGreaterThanOrEqualTo: firstFree + self baseHeaderSize) - fwdBlockBytes := totalObjectCount bitAnd: WordMask - BytesPerWord + 1. - (self oop: memoryLimit - fwdBlockBytes isGreaterThanOrEqualTo: firstFree + BaseHeaderSize) ifFalse: ["reserve enough space for a minimal free block of BaseHeaderSize bytes" + fwdBlockBytes := memoryLimit - (firstFree + self baseHeaderSize)]. - fwdBlockBytes := memoryLimit - (firstFree + BaseHeaderSize)]. "set endOfMemory and initialize freeBlock" endOfMemory := memoryLimit - fwdBlockBytes. freeBlock := firstFree. self setSizeOfFree: freeBlock to: endOfMemory - firstFree. "bytes available for oops" "make a fake free chunk at endOfMemory for use as a sentinel in memory scans" + self setSizeOfFree: endOfMemory to: self baseHeaderSize. - self setSizeOfFree: endOfMemory to: BaseHeaderSize. DoAssertionChecks ifTrue: [(freeBlock < endOfMemory and: [endOfMemory < memoryLimit]) ifFalse: [self error: 'error in free space computation']. (self oopFromChunk: endOfMemory) = endOfMemory ifFalse: [self error: 'header format must have changed']. (self objectAfter: freeBlock) = endOfMemory ifFalse: [self error: 'free block not properly initialized']]! Item was changed: ----- Method: Interpreter>>internalPop: (in category 'contexts') ----- internalPop: nItems + localSP := localSP - (nItems * self bytesPerWord).! - localSP := localSP - (nItems * BytesPerWord).! Item was changed: ----- Method: ObjectMemory>>sizeHeader: (in category 'header access') ----- sizeHeader: oop + ^ self longAt: oop - (self bytesPerWord * 2)! - ^ self longAt: oop - (BytesPerWord*2)! Item was changed: ----- Method: InterpreterSimulator>>validateOopsIn: (in category 'testing') ----- validateOopsIn: object | fieldPtr limit former header | "for each oop in me see if it is legal" fieldPtr := object + BaseHeaderSize. "first field" limit := object + (self lastPointerOf: object). "a good field" [fieldPtr > limit] whileFalse: [ former := self longAt: fieldPtr. (self validOop: former) ifFalse: [self error: 'invalid oop in pointers object']. fieldPtr := fieldPtr + BytesPerWord]. "class" header := self baseHeader: object. (header bitAnd: CompactClassMask) = 0 ifTrue: [ + former := (self classHeader: object) bitAnd: self allButTypeMask. - former := (self classHeader: object) bitAnd: AllButTypeMask. (self validOop: former) ifFalse: [self halt]].! Item was added: + ----- Method: ArrayedCollection>>swapBytesFrom:to: (in category '*VMMaker-simulated image growing') ----- + swapBytesFrom: start to: stop + "Perform a bigEndian/littleEndian byte reversal of my words. + We only intend this for non-pointer arrays. Do nothing if I contain pointers." + | hack blt | + + self class isPointers | self class isWords not ifTrue: [^ self]. + + "The implementation is a hack, but fast for large ranges" + hack := Form new hackBits: self. + blt := (BitBlt toForm: hack) sourceForm: hack. + blt combinationRule: Form reverse. "XOR" + blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 1. + blt sourceX: 0; destX: 3; copyBits. "Exchange bytes 0 and 3" + blt sourceX: 3; destX: 0; copyBits. + blt sourceX: 0; destX: 3; copyBits. + blt sourceX: 1; destX: 2; copyBits. "Exchange bytes 1 and 2" + blt sourceX: 2; destX: 1; copyBits. + blt sourceX: 1; destX: 2; copyBits. + ! Item was changed: ----- Method: Interpreter>>changeClassOf:to: (in category 'object access primitives') ----- changeClassOf: rcvr to: argClass "Change the class of the receiver into the class specified by the argument given that the format of the receiver matches the format of the argument. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have." | classHdr sizeHiBits byteSize argFormat rcvrFormat 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. + byteSize := (classHdr bitAnd: self sizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0" - byteSize := (classHdr bitAnd: SizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0" "Check the receiver's format against that of the class" argFormat := (classHdr >> 8) bitAnd: 16rF. rcvrFormat := self formatOf: rcvr. argFormat = rcvrFormat ifFalse:[^self primitiveFail]. "no way" "For fixed field classes, the sizes must match. Note: byteSize-4 because base header is included in class size." + argFormat < 2 ifTrue:[(byteSize - self baseHeaderSize) = (self byteSizeOf: rcvr) ifFalse:[^self primitiveFail]]. - argFormat < 2 ifTrue:[(byteSize - BaseHeaderSize) = (self byteSizeOf: rcvr) ifFalse:[^self primitiveFail]]. (self headerType: rcvr) = HeaderTypeShort ifTrue:[ "Compact classes. Check if the arg's class is compact and exchange ccIndex" ccIndex := classHdr bitAnd: CompactClassMask. ccIndex = 0 ifTrue:[^self primitiveFail]. "class is not compact" self longAt: rcvr put: (((self longAt: rcvr) bitAnd: CompactClassMask bitInvert32) bitOr: ccIndex)] ifFalse:["Exchange the class pointer, which could make rcvr a root for argClass" + self longAt: rcvr - self baseHeaderSize put: (argClass bitOr: (self headerType: rcvr)). - self longAt: rcvr-BaseHeaderSize put: (argClass bitOr: (self headerType: rcvr)). (self oop: rcvr isLessThan: youngStart) ifTrue: [self possibleRootStoreInto: rcvr value: argClass]]. "Flush cache because rcvr's class has changed" self flushMethodCache. ! Item was added: + ----- Method: ObjectMemory>>markBit (in category 'constants') ----- + markBit + "Top bit" + + self inline: true. + ^self + cCode: 'MARK_BIT' + inSmalltalk: [1 bitShift: self bytesPerWord*8 - 1] + ! Item was changed: ----- Method: Interpreter>>imageFormatBackwardCompatibilityVersion (in category 'image save/restore') ----- imageFormatBackwardCompatibilityVersion "This VM is backwards-compatible with the immediately preceeding pre-closure version, and will allow loading images (or image segments) of that version." + self bytesPerWord == 4 - BytesPerWord == 4 ifTrue: [^6502] ifFalse: [^68000]! Item was changed: ----- Method: ObjectMemory class>>initializeObjectHeaderConstants (in category 'initialization') ----- initializeObjectHeaderConstants BytesPerWord ifNil: [BytesPerWord := 4]. "May get called on fileIn, so supply default" BaseHeaderSize := BytesPerWord. - WordMask := (1 bitShift: BytesPerWord*8) - 1. "masks for type field" TypeMask := 3. - AllButTypeMask := WordMask - TypeMask. "type field values" HeaderTypeSizeAndClass := 0. HeaderTypeClass := 1. HeaderTypeFree := 2. HeaderTypeShort := 3. "type field values used during the mark phase of GC" HeaderTypeGC := 2. GCTopMarker := 3. "neither an oop, nor an oop+1, this value signals that we have crawled back up to the top of the marking phase." "Base header word bit fields" HashBits := 16r1FFE0000. - AllButHashBits := WordMask - HashBits. HashBitsOffset := 17. - SizeMask := 16rFC. - Size4Bit := 0. - BytesPerWord = 8 ifTrue: - [SizeMask := 16rF8. "Lose the 4 bit in temp 64-bit chunk format" - Size4Bit := 4]. "But need it for ST size" - "Note SizeMask + Size4Bit gives the mask needed for size fits of format word in classes. - This is used in instantiateClass:indexableSize: " - LongSizeMask := WordMask - 16rFF + SizeMask. - CompactClassMask := 16r1F000. + CompactClassMask := 16r1F000 + ! - "masks for root and mark bits" - MarkBit := 1 bitShift: BytesPerWord*8 - 1. "Top bit" - RootBit := 1 bitShift: BytesPerWord*8 - 2. "Next-to-Top bit" - AllButMarkBit := WordMask - MarkBit. - AllButRootBit := WordMask - RootBit. - - AllButMarkBitAndTypeMask := AllButTypeMask - MarkBit.! Item was added: + ----- Method: ObjectMemory>>longSizeMask (in category 'constants') ----- + longSizeMask + "One of the base header word bit fields. For 64-bit word size, lose + the 4 bit in temp 64-bit chunk format." + + self inline: true. + ^self + cCode: 'LONG_SIZE_MASK' + inSmalltalk: [self wordMask - 16rFF + self sizeMask] + ! Item was added: + ----- Method: ObjectMemory>>size4Bit (in category 'constants') ----- + size4Bit + "One of the base header word bit fields. The 4 bit is excluded from sizeMask for + 64-bit object memory, but need it for ST size. + Note SizeMask + Size4Bit gives the mask needed for size fits of format word in classes. + This is used in instantiateClass:indexableSize: " + + self inline: true. + ^self + cCode: 'SIZE_4_BIT' + inSmalltalk: [self bytesPerWord = 4 + ifTrue: [0] + ifFalse: [4]] + ! Item was changed: ----- Method: InterpreterSimulator>>firstIndexableField: (in category 'memory access') ----- firstIndexableField: oop "NOTE: overridden from Interpreter to add coercion to CArray" | hdr fmt totalLength fixedFields | self returnTypeC: 'void *'. hdr := self baseHeader: oop. fmt := (hdr >> 8) bitAnd: 16rF. totalLength := self lengthOf: oop baseHeader: hdr format: fmt. fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength. fmt < 8 ifTrue: [fmt = 6 ifTrue: ["32 bit field objects" ^ self cCoerce: (self pointerForOop: oop + BaseHeaderSize + (fixedFields << 2)) to: 'int *']. "full word objects (pointer or bits)" + ^ self cCoerce: (self pointerForOop: oop + BaseHeaderSize + (fixedFields << self shiftForWord)) to: 'oop *'] - ^ self cCoerce: (self pointerForOop: oop + BaseHeaderSize + (fixedFields << ShiftForWord)) to: 'oop *'] ifFalse: ["Byte objects" ^ self cCoerce: (self pointerForOop: oop + BaseHeaderSize + fixedFields) to: 'char *']! Item was changed: ----- Method: ObjectMemory>>objectAfterWhileForwarding: (in category 'gc -- compaction') ----- objectAfterWhileForwarding: oop "Return the oop of the object after the given oop when the actual header of the oop may be in the forwarding table." | header fwdBlock realHeader sz | self inline: true. header := self longAt: oop. + (header bitAnd: self markBit) = 0 ifTrue: [ ^ self objectAfter: oop ]. "oop not forwarded" - (header bitAnd: MarkBit) = 0 ifTrue: [ ^ self objectAfter: oop ]. "oop not forwarded" "Assume: mark bit cannot be set on a free chunk, so if we get here, oop is not free and it has a forwarding table entry" + fwdBlock := (header bitAnd: self allButMarkBitAndTypeMask) << 1. - fwdBlock := (header bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ]. + realHeader := self longAt: fwdBlock + self bytesPerWord. - realHeader := self longAt: fwdBlock + BytesPerWord. "following code is like sizeBitsOf:" (realHeader bitAnd: TypeMask) = HeaderTypeSizeAndClass + ifTrue: [ sz := (self sizeHeader: oop) bitAnd: self longSizeMask ] + ifFalse: [ sz := realHeader bitAnd: self sizeMask ]. - ifTrue: [ sz := (self sizeHeader: oop) bitAnd: LongSizeMask ] - ifFalse: [ sz := realHeader bitAnd: SizeMask ]. ^ self oopFromChunk: (oop + sz)! Item was changed: ----- Method: Interpreter>>floatObjectOf: (in category 'object format') ----- floatObjectOf: aFloat | newFloatObj | self flag: #Dan. self var: #aFloat type: 'double '. + newFloatObj := self instantiateSmallClass: (self splObj: ClassFloat) sizeInBytes: 8 + self baseHeaderSize. + self storeFloatAt: newFloatObj + self baseHeaderSize from: aFloat. - newFloatObj := self instantiateSmallClass: (self splObj: ClassFloat) sizeInBytes: 8+BaseHeaderSize. - self storeFloatAt: newFloatObj + BaseHeaderSize from: aFloat. ^ newFloatObj. ! Item was changed: ----- Method: Interpreter>>internalJustActivateNewMethod (in category 'message sending') ----- internalJustActivateNewMethod "Activate the new method but *do not* copy receiver or argumernts from activeContext." | methodHeader initialIP newContext tempCount needsLarge where | self inline: true. methodHeader := self headerOf: newMethod. needsLarge := methodHeader bitAnd: LargeContextBit. (needsLarge = 0 and: [freeContexts ~= NilContext]) ifTrue: [newContext := freeContexts. freeContexts := self fetchPointer: 0 ofObject: newContext] ifFalse: ["Slower call for large contexts or empty free list" newContext := self allocateOrRecycleContext: needsLarge]. + initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * self bytesPerWord) + 1. - initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * BytesPerWord) + 1. tempCount := (methodHeader >> 19) bitAnd: 16r3F. "Assume: newContext will be recorded as a root if necessary by the call to newActiveContext: below, so we can use unchecked stores." + where := newContext + self baseHeaderSize. + self longAt: where + (SenderIndex << self shiftForWord) put: activeContext. + self longAt: where + (InstructionPointerIndex << self shiftForWord) put: (self integerObjectOf: initialIP). + self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount). + self longAt: where + (MethodIndex << self shiftForWord) put: newMethod. - where := newContext + BaseHeaderSize. - self longAt: where + (SenderIndex << ShiftForWord) put: activeContext. - self longAt: where + (InstructionPointerIndex << ShiftForWord) put: (self integerObjectOf: initialIP). - self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: tempCount). - self longAt: where + (MethodIndex << ShiftForWord) put: newMethod. "Set the receiver..." + self longAt: where + (ReceiverIndex << self shiftForWord) put: receiver. - self longAt: where + (ReceiverIndex << ShiftForWord) put: receiver. "clear all args and temps to nil in case it has been recycled" needsLarge := nilObj. "needsLarge here used just as faster (register?) temp" ReceiverIndex + 1 to: tempCount + ReceiverIndex do: + [:i | self longAt: where + (i << self shiftForWord) put: needsLarge]. - [:i | self longAt: where + (i << ShiftForWord) put: needsLarge]. reclaimableContextCount := reclaimableContextCount + 1. activeContext := newContext.! Item was changed: ----- Method: Interpreter>>primitiveInvokeObjectAsMethod (in category 'control primitives') ----- primitiveInvokeObjectAsMethod "Primitive. 'Invoke' an object like a function, sending the special message run: originalSelector with: arguments in: aReceiver. " | runSelector runReceiver runArgs newReceiver lookupClass | runArgs := self instantiateClass: (self splObj: ClassArray) indexableSize: argumentCount. self beRootIfOld: runArgs. "do we really need this?" + self transfer: argumentCount from: stackPointer - ((argumentCount - 1) * self bytesPerWord) to: runArgs + self baseHeaderSize. - self transfer: argumentCount from: stackPointer - ((argumentCount - 1) * BytesPerWord) to: runArgs + BaseHeaderSize. runSelector := messageSelector. runReceiver := self stackValue: argumentCount. self pop: argumentCount+1. "stack is clean here" newReceiver := newMethod. messageSelector := self splObj: SelectorRunWithIn. argumentCount := 3. self push: newReceiver. self push: runSelector. self push: runArgs. self push: runReceiver. lookupClass := self fetchClassOf: newReceiver. self findNewMethodInClass: lookupClass. self executeNewMethodFromCache. "Recursive xeq affects successFlag" successFlag := true. ! Item was changed: ----- Method: ObjectMemory>>fetchByte:ofObject: (in category 'interpreter access') ----- fetchByte: byteIndex ofObject: oop + ^ self byteAt: oop + self baseHeaderSize + byteIndex! - ^ self byteAt: oop + BaseHeaderSize + byteIndex! Item was changed: ----- Method: ObjectMemory>>incCompMakeFwd (in category 'gc -- compaction') ----- incCompMakeFwd "Create and initialize forwarding blocks for all non-free objects following compStart. If the supply of forwarding blocks is exhausted, set compEnd to the first chunk above the area to be compacted; otherwise, set it to endOfMemory. Return the number of bytes to be freed." | bytesFreed oop fwdBlock newOop | self inline: false. bytesFreed := 0. oop := self oopFromChunk: compStart. [self oop: oop isLessThan: endOfMemory] whileTrue: [ statMkFwdCount := statMkFwdCount + 1. (self isFreeObject: oop) ifTrue: [bytesFreed := bytesFreed + (self sizeOfFree: oop)] ifFalse: ["create a forwarding block for oop" + fwdBlock := self fwdBlockGet: self bytesPerWord * 2. - fwdBlock := self fwdBlockGet: BytesPerWord*2. "Two-word block" fwdBlock = nil ifTrue: ["stop; we have used all available forwarding blocks" compEnd := self chunkFromOop: oop. ^ bytesFreed]. newOop := oop - bytesFreed. self initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: false]. oop := self objectAfterWhileForwarding: oop]. compEnd := endOfMemory. ^ bytesFreed! Item was changed: ----- Method: Interpreter>>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. (self isBytes: s) ifFalse: [^ self primitiveFail]. successFlag ifTrue: [sz := self stSizeOf: s. + self clipboardWrite: sz From: s + self baseHeaderSize At: 0. - self clipboardWrite: sz From: s + BaseHeaderSize At: 0. self pop: 1]] ifFalse: [sz := self clipboardSize. (self sufficientSpaceToAllocate: sz) ifFalse:[^self primitiveFail]. s := self instantiateClass: (self splObj: ClassString) indexableSize: sz. + self clipboardRead: sz Into: s + self baseHeaderSize At: 0. - self clipboardRead: sz Into: s + BaseHeaderSize At: 0. self pop: 1 thenPush: s]! Item was changed: ----- Method: Interpreter>>primitiveConstantFill (in category 'array primitives') ----- primitiveConstantFill "Fill the receiver, which must be an indexable bytes or words objects, with the given integer value." | fillValue rcvr rcvrIsBytes end i | self var: #end type: 'usqInt'. self var: #i type: 'usqInt'. fillValue := self positive32BitValueOf: self stackTop. rcvr := self stackValue: 1. self success: (self isWordsOrBytes: rcvr). rcvrIsBytes := self isBytes: rcvr. rcvrIsBytes ifTrue: [self success: (fillValue >= 0 and: [fillValue <= 255])]. successFlag ifTrue: [end := rcvr + (self sizeBitsOf: rcvr). + i := rcvr + self baseHeaderSize. - i := rcvr + BaseHeaderSize. rcvrIsBytes ifTrue: [[i < end] whileTrue: [self byteAt: i put: fillValue. i := i + 1]] ifFalse: [[i < end] whileTrue: [self long32At: i put: fillValue. i := i + 4]]. self pop: 1]! Item was changed: ----- Method: ObjectMemory>>upward (in category 'gc -- mark and sweep') ----- upward "Return from marking an object below. Incoming: field = oop we just worked on, needs to be put away parentField = where to put it in our object NOTE: Type field of object below has already been restored!!!!!! " | type header | self inline: true. (parentField bitAnd: 1) = 1 ifTrue: [parentField = GCTopMarker ifTrue: ["top of the chain" + header := (self longAt: field) bitAnd: self allButTypeMask. - header := (self longAt: field) bitAnd: AllButTypeMask. type := self rightType: header. self longAt: field put: (header bitOr: type). "install type on class oop" ^ Done] ifFalse: ["was working on the extended class word" child := field. "oop of class" field := parentField - 1. "class word, ** clear the low bit **" parentField := self longAt: field. + header := self longAt: field + self bytesPerWord. "base header word" - header := self longAt: field + BytesPerWord. "base header word" type := self rightType: header. self longAt: field put: (child bitOr: type). "install type on class oop" + field := field + self bytesPerWord. "point at header" - field := field + BytesPerWord. "point at header" "restore type bits" + header := header bitAnd: self allButTypeMask. - header := header bitAnd: AllButTypeMask. self longAt: field put: (header bitOr: type). ^ Upward]] ifFalse: ["normal" child := field. "who we worked on below" field := parentField. "where to put it" parentField := self longAt: field. self longAt: field put: child. + field := field - self bytesPerWord. "point at header" - field := field - BytesPerWord. "point at header" ^ StartField]! Item was changed: ----- Method: Interpreter>>displayBitsOf:Left:Top:Right:Bottom: (in category 'I/O primitives') ----- displayBitsOf: aForm Left: l Top: t Right: r Bottom: b "Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object." | displayObj dispBits w h dispBitsIndex d left right top bottom surfaceHandle | displayObj := self splObj: TheDisplay. aForm = displayObj ifFalse: [^ nil]. self success: ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]). successFlag ifTrue: [ dispBits := self fetchPointer: 0 ofObject: displayObj. w := self fetchInteger: 1 ofObject: displayObj. h := self fetchInteger: 2 ofObject: displayObj. d := self fetchInteger: 3 ofObject: displayObj. ]. l < 0 ifTrue:[left := 0] ifFalse: [left := l]. r > w ifTrue: [right := w] ifFalse: [right := r]. t < 0 ifTrue: [top := 0] ifFalse: [top := t]. b > h ifTrue: [bottom := h] ifFalse: [bottom := b]. ((left <= right) and: [top <= bottom]) ifFalse: [^nil]. successFlag ifTrue: [ (self isIntegerObject: dispBits) ifTrue: [ surfaceHandle := self integerValueOf: dispBits. showSurfaceFn = 0 ifTrue: [ showSurfaceFn := self ioLoadFunction: 'ioShowSurface' From: 'SurfacePlugin'. showSurfaceFn = 0 ifTrue: [^self success: false]]. self cCode:'((sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt))showSurfaceFn)(surfaceHandle, left, top, right-left, bottom-top)'. ] ifFalse: [ + dispBitsIndex := dispBits + self baseHeaderSize. "index in memory byte array" - dispBitsIndex := dispBits + BaseHeaderSize. "index in memory byte array" self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, left, right, top, bottom)' inSmalltalk: [self showDisplayBits: dispBitsIndex w: w h: h d: d left: left right: right top: top bottom: bottom] ]. ].! Item was changed: ----- Method: Interpreter>>internalStackValue: (in category 'contexts') ----- internalStackValue: offset + ^ self longAtPointer: localSP - (offset * self bytesPerWord)! - ^ self longAtPointer: localSP - (offset * BytesPerWord)! Item was changed: ----- Method: Interpreter>>lengthOf:baseHeader:format: (in category 'array primitive support') ----- lengthOf: oop baseHeader: hdr format: fmt "Return the number of indexable bytes or words 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 | self inline: true. (hdr bitAnd: TypeMask) = HeaderTypeSizeAndClass + ifTrue: [ sz := (self sizeHeader: oop) bitAnd: self longSizeMask ] + ifFalse: [ sz := (hdr bitAnd: self sizeMask)]. + sz := sz - (hdr bitAnd: self size4Bit). - ifTrue: [ sz := (self sizeHeader: oop) bitAnd: LongSizeMask ] - ifFalse: [ sz := (hdr bitAnd: SizeMask)]. - sz := sz - (hdr bitAnd: Size4Bit). fmt <= 4 + ifTrue: [ ^ (sz - self baseHeaderSize) >> self shiftForWord "words"]. - ifTrue: [ ^ (sz - BaseHeaderSize) >> ShiftForWord "words"]. fmt < 8 + ifTrue: [ ^ (sz - self baseHeaderSize) >> 2 "32-bit longs"] + ifFalse: [ ^ (sz - self baseHeaderSize) - (fmt bitAnd: 3) "bytes"]! - ifTrue: [ ^ (sz - BaseHeaderSize) >> 2 "32-bit longs"] - ifFalse: [ ^ (sz - BaseHeaderSize) - (fmt bitAnd: 3) "bytes"]! Item was changed: ----- Method: ObjectMemory>>sufficientSpaceToAllocate: (in category 'allocation') ----- sufficientSpaceToAllocate: bytes "Return true if there is enough space to allocate the given number of bytes, perhaps after doing a garbage collection. Sender is responsible for ensuring that requested size does result in arithmetic overflow, see note below." | minFree | self inline: true. self var: #bytes type: 'usqInt'. self var: #minFree type: 'usqInt'. "Note: Arithmetic overflow may occur in calculation of minFree (indicated by minFree < bytes after calculation of minFree). The check is performed by sender to avoid redundant test here." + minFree := lowSpaceThreshold + bytes + self baseHeaderSize. - minFree := lowSpaceThreshold + bytes + BaseHeaderSize. "check for low-space" (self oop: (self sizeOfFree: freeBlock) isGreaterThanOrEqualTo: minFree) ifTrue: [^true] ifFalse: [^self sufficientSpaceAfterGC: minFree].! Item was changed: ----- 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." + ^ self longAt: oop + self baseHeaderSize + (fieldIndex << self shiftForWord) - ^ self longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord) put: valuePointer ! Item was changed: ----- Method: Interpreter>>imageFormatForwardCompatibilityVersion (in category 'image save/restore') ----- imageFormatForwardCompatibilityVersion "This VM is forwards-compatible with the immediately following closure version, and will write the new version number in snapshots if the closure creation bytecode is used." + self bytesPerWord == 4 - BytesPerWord == 4 ifTrue: [^6504] ifFalse: [^68002]! Item was changed: ----- Method: Interpreter>>arrayValueOf: (in category 'utilities') ----- arrayValueOf: arrayOop "Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object." "Note: May be called by translated primitive code." self returnTypeC: 'void *'. ((self isIntegerObject: arrayOop) not and: [self isWordsOrBytes: arrayOop]) + ifTrue: [^ self pointerForOop: (arrayOop + self baseHeaderSize)]. - ifTrue: [^ self pointerForOop: (arrayOop + BaseHeaderSize)]. self primitiveFail. ! Item was changed: ----- Method: ObjectMemory>>sizeOfFree: (in category 'header access') ----- sizeOfFree: oop "Return the size of the given chunk in bytes. Argument MUST be a free chunk." self returnTypeC: 'usqInt'. + ^ (self longAt: oop) bitAnd: self allButTypeMask! - ^ (self longAt: oop) bitAnd: AllButTypeMask! Item was changed: ----- Method: ObjectMemory>>fetchLong32LengthOf: (in category 'interpreter access') ----- fetchLong32LengthOf: objectPointer "Gives size appropriate for, eg, fetchLong32" | sz | sz := self sizeBitsOf: objectPointer. + ^ (sz - self baseHeaderSize) >> 2! - ^ (sz - BaseHeaderSize) >> 2! Item was changed: ----- Method: Interpreter>>reverseBytesFrom:to: (in category 'image save/restore') ----- reverseBytesFrom: startAddr to: stopAddr "Byte-swap the given range of memory (not inclusive of stopAddr!!)." | addr | self flag: #Dan. addr := startAddr. [self oop: addr isLessThan: stopAddr] whileTrue: [self longAt: addr put: (self byteSwapped: (self longAt: addr)). + addr := addr + self bytesPerWord].! - addr := addr + BytesPerWord].! Item was changed: ----- Method: Interpreter>>reverseDisplayFrom:to: (in category 'I/O primitive support') ----- reverseDisplayFrom: startIndex to: endIndex "Reverse the given range of Display words (at different bit depths, this will reverse different numbers of pixels). Used to give feedback during VM activities such as garbage collection when debugging. It is assumed that the given word range falls entirely within the first line of the Display." | displayObj dispBitsPtr w reversed | displayObj := self splObj: TheDisplay. ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifFalse: [^ nil]. w := self fetchInteger: 1 ofObject: displayObj. dispBitsPtr := self fetchPointer: 0 ofObject: displayObj. (self isIntegerObject: dispBitsPtr) ifTrue: [^ nil]. + dispBitsPtr := dispBitsPtr + self baseHeaderSize. - dispBitsPtr := dispBitsPtr + BaseHeaderSize. dispBitsPtr + (startIndex * 4) to: dispBitsPtr + (endIndex * 4) by: 4 do: [:ptr | reversed := (self long32At: ptr) bitXor: 4294967295. self longAt: ptr put: reversed]. successFlag := true. self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: 1. self ioForceDisplayUpdate! Item was changed: ----- Method: ObjectMemory>>allocateOrRecycleContext: (in category 'allocation') ----- allocateOrRecycleContext: needsLarge "Return a recycled context or a newly allocated one if none is available for recycling." | cntxt | needsLarge = 0 ifTrue: [freeContexts ~= NilContext ifTrue: [cntxt := freeContexts. freeContexts := self fetchPointer: 0 ofObject: cntxt. ^ cntxt]] ifFalse: [freeLargeContexts ~= NilContext ifTrue: [cntxt := freeLargeContexts. freeLargeContexts := self fetchPointer: 0 ofObject: cntxt. ^ cntxt]]. needsLarge = 0 ifTrue: [cntxt := self instantiateContext: (self splObj: ClassMethodContext) + sizeInBytes: self smallContextSize] - sizeInBytes: SmallContextSize] ifFalse: [cntxt := self instantiateContext: (self splObj: ClassMethodContext) + sizeInBytes: self largeContextSize]. - sizeInBytes: LargeContextSize]. "Required init -- above does not fill w/nil. All others get written." self storePointerUnchecked: 4 "InitialIPIndex" ofObject: cntxt withValue: nilObj. ^ cntxt ! Item was changed: ----- Method: ObjectMemory>>lastPointerWhileForwarding: (in category 'gc -- compaction') ----- lastPointerWhileForwarding: oop "The given object may have its header word in a forwarding block. Find the offset of the last pointer in the object in spite of this obstacle. " | header fwdBlock fmt size methodHeader contextSize | self inline: true. header := self longAt: oop. + (header bitAnd: self markBit) ~= 0 - (header bitAnd: MarkBit) ~= 0 ifTrue: ["oop is forwarded; get its real header from its forwarding table entry" + fwdBlock := (header bitAnd: self allButMarkBitAndTypeMask) << 1. - fwdBlock := (header bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks ifTrue: [self fwdBlockValidate: fwdBlock]. + header := self longAt: fwdBlock + self bytesPerWord]. - header := self longAt: fwdBlock + BytesPerWord]. fmt := header >> 8 bitAnd: 15. fmt <= 4 ifTrue: [(fmt = 3 and: [self isContextHeader: header]) ifTrue: ["contexts end at the stack pointer" contextSize := self fetchStackPointerOf: oop. + ^ CtxtTempFrameStart + contextSize * self bytesPerWord]. - ^ CtxtTempFrameStart + contextSize * BytesPerWord]. "do sizeBitsOf: using the header we obtained" (header bitAnd: TypeMask) = HeaderTypeSizeAndClass + ifTrue: [size := (self sizeHeader: oop) bitAnd: self allButTypeMask] + ifFalse: [size := header bitAnd: self sizeMask]. + ^ size - self baseHeaderSize]. - ifTrue: [size := (self sizeHeader: oop) bitAnd: AllButTypeMask] - ifFalse: [size := header bitAnd: SizeMask]. - ^ size - BaseHeaderSize]. fmt < 12 ifTrue: [^ 0]. "no pointers" + methodHeader := self longAt: oop + self baseHeaderSize. + ^ (methodHeader >> 10 bitAnd: 255) * self bytesPerWord + self baseHeaderSize! - methodHeader := self longAt: oop + BaseHeaderSize. - ^ (methodHeader >> 10 bitAnd: 255) * BytesPerWord + BaseHeaderSize! Item was changed: ----- Method: ObjectMemory>>allYoung:and: (in category 'become') ----- allYoung: array1 and: array2 "Return true if all the oops in both arrays, and the arrays themselves, are in the young object space." | fieldOffset | (self oop: array1 isLessThan: youngStart) ifTrue: [^ false]. (self oop: array2 isLessThan: youngStart) ifTrue: [^ false]. fieldOffset := self lastPointerOf: array1. "same size as array2" + [fieldOffset >= self baseHeaderSize] whileTrue: - [fieldOffset >= BaseHeaderSize] whileTrue: [(self oop: (self longAt: array1 + fieldOffset) isLessThan: youngStart) ifTrue: [^ false]. (self oop: (self longAt: array2 + fieldOffset) isLessThan: youngStart) ifTrue: [^ false]. + fieldOffset := fieldOffset - self bytesPerWord]. - fieldOffset := fieldOffset - BytesPerWord]. ^ true! Item was changed: ----- Method: ObjectMemory>>initForwardBlock:mapping:to:withBackPtr: (in category 'gc -- compaction') ----- initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: backFlag "Initialize the given forwarding block to map oop to newOop, and replace oop's header with a pointer to the fowarding block. " "Details: The mark bit is used to indicate that an oop is forwarded. When an oop is forwarded, its header (minus the mark bit) contains the address of its forwarding block. (The forwarding block address is actually shifted right by one bit so that its top-most bit does not conflict with the header's mark bit; since fowarding blocks are stored on word boundaries, the low two bits of the address are always zero.) The first word of the forwarding block is the new oop; the second word is the oop's orginal header. In the case of a forward become, a four-word block is used, with the third field being a backpointer to the old oop (for header fixup), and the fourth word is unused. The type bits of the forwarding header are the same as those of the original header. " | originalHeader originalHeaderType | self inline: true. originalHeader := self longAt: oop. DoAssertionChecks ifTrue: [fwdBlock = nil ifTrue: [self error: 'ran out of forwarding blocks in become']. + (originalHeader bitAnd: self markBit) ~= 0 - (originalHeader bitAnd: MarkBit) ~= 0 ifTrue: [self error: 'object already has a forwarding table entry']]. originalHeaderType := originalHeader bitAnd: TypeMask. self longAt: fwdBlock put: newOop. + self longAt: fwdBlock + self bytesPerWord put: originalHeader. + backFlag ifTrue: [self longAt: fwdBlock + (self bytesPerWord * 2) put: oop]. + self longAt: oop put: (fwdBlock >> 1 bitOr: (self markBit bitOr: originalHeaderType))! - self longAt: fwdBlock + BytesPerWord put: originalHeader. - backFlag ifTrue: [self longAt: fwdBlock + (BytesPerWord*2) put: oop]. - self longAt: oop put: (fwdBlock >> 1 bitOr: (MarkBit bitOr: originalHeaderType))! Item was added: + ----- Method: ObjectMemory>>allButTypeMask (in category 'constants') ----- + allButTypeMask + "Mask for type field" + + self inline: true. + ^self + cCode: 'ALL_BUT_TYPE_MASK' + inSmalltalk: [self wordMask - TypeMask] + ! Item was changed: ----- Method: ObjectMemory>>beRootWhileForwarding: (in category 'gc -- compaction') ----- beRootWhileForwarding: oop "Record that the given oop in the old object area points to an object in the young area when oop may be forwarded." "Warning: No young objects should be recorded as roots. Callers are responsible for ensuring this constraint is not violated." | header fwdBlock | header := self longAt: oop. + (header bitAnd: self markBit) ~= 0 - (header bitAnd: MarkBit) ~= 0 ifTrue: ["This oop is forwarded" + fwdBlock := (header bitAnd: self allButMarkBitAndTypeMask) << 1. - fwdBlock := (header bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ]. + self noteAsRoot: oop headerLoc: fwdBlock + self bytesPerWord] - self noteAsRoot: oop headerLoc: fwdBlock + BytesPerWord] ifFalse: ["Normal -- no forwarding" self noteAsRoot: oop headerLoc: oop]! Item was changed: ----- Method: ObjectMemory>>storeByte:ofObject:withValue: (in category 'interpreter access') ----- storeByte: byteIndex ofObject: oop withValue: valueByte + ^ self byteAt: oop + self baseHeaderSize + byteIndex - ^ self byteAt: oop + BaseHeaderSize + byteIndex put: valueByte! Item was added: + ----- Method: ObjectMemory>>allButHashBits (in category 'constants') ----- + allButHashBits + "Base header word bit fields" + + self inline: true. + ^self + cCode: 'ALL_BUT_HASH_BITS' + inSmalltalk: [self wordMask - HashBits] + ! Item was changed: ----- Method: CCodeGenerator>>emitDefineBytesPerWord:on: (in category 'C code generator') ----- emitDefineBytesPerWord: bytesPerWord on: aStream + "Define word size dependent constants. These are mirrored by class + variables in ObjectMemory. The macro definitions here are used at compile + time to permit building a VM for either 32-bit or 64-bit object memory from + a single generated code base. + + If SQ_VI_BYTES_PER_WORD is defined as 8 (e.g. in config.h), then a VM for + 64-bit image will be built. Otherwise, a VM for 32-bit image is built." + + aStream cr; + nextPutAll: '/*'; cr; + nextPutAll: ' * define SQ_VI_BYTES_PER_WORD 8 for a 64-bit word size VM'; cr; + nextPutAll: ' * and default to SQ_VI_BYTES_PER_WORD 4 for a 32-bit word size VM'; cr; + nextPutAll: ' */'; cr; + nextPutAll: '#ifndef SQ_VI_BYTES_PER_WORD'; cr; + nextPutAll: '# define SQ_VI_BYTES_PER_WORD '; + print: bytesPerWord; cr; + nextPutAll: '#endif'; cr; cr; + nextPutAll: '#define BYTES_PER_WORD SQ_VI_BYTES_PER_WORD'; cr; + nextPutAll: '#define BASE_HEADER_SIZE SQ_VI_BYTES_PER_WORD'; cr; + + "Define various constants that depend on BytesPerWord" + nextPutAll: '#if (BYTES_PER_WORD == 4) // 32-bit object memory'; cr; + nextPutAll: '# define WORD_MASK 0xffffffff'; cr; "(1 bitShift: BytesPerWord*8) - 1" + nextPutAll: '# define SHIFT_FOR_WORD 2'; cr; "(BytesPerWord log: 2) rounded" + nextPutAll: '# define SMALL_CONTEXT_SIZE 92'; cr; "ContextFixedSizePlusHeader + 16 * BytesPerWord" + "Large contexts have 56 indexable fileds. Max with single header word." + "However note that in 64 bits, for now, large contexts have 3-word headers" + nextPutAll: '# define LARGE_CONTEXT_SIZE 252'; cr; "ContextFixedSizePlusHeader + 56 * BytesPerWord." + nextPutAll: '# define SIZE_MASK 0xfc'; cr; "Base header word bit field" + nextPutAll: '# define LONG_SIZE_MASK 0xfffffffc'; cr; "Base header word bit field" + nextPutAll: '# define SIZE_4_BIT 0'; cr; + nextPutAll: '# define MARK_BIT 0x80000000'; cr; "Top bit, 1 bitShift: BytesPerWord*8 - 1" + nextPutAll: '# define ROOT_BIT 0x40000000'; cr; "Next-to-top bit, 1 bitShift: BytesPerWord*8 - 2" + nextPutAll: '# define ALL_BUT_MARK_BIT 0x7fffffff'; cr; "WordMask - MarkBit." + nextPutAll: '# define ALL_BUT_ROOT_BIT 0xbfffffff'; cr; "WordMask - RootBit" + nextPutAll: '# define ALL_BUT_TYPE_MASK 0xfffffffc'; cr; "WordMask - TypeMask" + nextPutAll: '# define ALL_BUT_MARK_BIT_AND_TYPE_MASK 0x7ffffffc'; cr; "AllButTypeMask - MarkBit" + nextPutAll: '# define ALL_BUT_HASH_BITS 0xe001ffff'; cr; + + nextPutAll: '#else // 64-bit object memory'; cr; + nextPutAll: '# define WORD_MASK 0xffffffffffffffff'; cr; + nextPutAll: '# define SHIFT_FOR_WORD 3'; cr; + nextPutAll: '# define SMALL_CONTEXT_SIZE 184'; cr; + nextPutAll: '# define LARGE_CONTEXT_SIZE 504'; cr; + nextPutAll: '# define SIZE_MASK 0xf8'; cr; "Lose the 4 bit in temp 64-bit chunk format" + nextPutAll: '# define LONG_SIZE_MASK 0xfffffffffffffff8'; cr; + "The 4 bit is excluded from SIZE_MASK for 64-bit object memory, but need it" + "for ST size, so define SIZE_4_BIT." + nextPutAll: '# define SIZE_4_BIT 4'; cr; + nextPutAll: '# define MARK_BIT 0x8000000000000000'; cr; + nextPutAll: '# define ROOT_BIT 0x4000000000000000'; cr; + nextPutAll: '# define ALL_BUT_MARK_BIT 0x7fffffffffffffff'; cr; + nextPutAll: '# define ALL_BUT_ROOT_BIT 0xbfffffffffffffff'; cr; + nextPutAll: '# define ALL_BUT_TYPE_MASK 0xfffffffffffffffc'; cr; + nextPutAll: '# define ALL_BUT_MARK_BIT_AND_TYPE_MASK 0x7ffffffffffffffc'; cr; + nextPutAll: '# define ALL_BUT_HASH_BITS 0xffffffffe001ffff'; cr; + nextPutAll: '#endif // (BYTES_PER_WORD == 4)'; cr + + ! - aStream - nextPutAll: '#define SQ_VI_BYTES_PER_WORD '; - print: bytesPerWord; - cr! Item was changed: ----- Method: ObjectMemory>>fetchClassOf: (in category 'interpreter access') ----- fetchClassOf: oop | ccIndex | self inline: true. (self isIntegerObject: oop) ifTrue: [^ self splObj: ClassInteger]. ccIndex := (self baseHeader: oop) >> 12 bitAnd: 31. ccIndex = 0 ifTrue: [^ (self classHeader: oop) + bitAnd: self allButTypeMask] - bitAnd: AllButTypeMask] ifFalse: ["look up compact class" ^ self fetchPointer: ccIndex - 1 ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop)]! Item was changed: ----- Method: ObjectMemory>>markAndTrace: (in category 'gc -- mark and sweep') ----- markAndTrace: oop "Mark all objects reachable from the given one. Trace from the given object even if it is old. Do not trace if it is already marked. Mark it only if it is a young object." "Tracer state variables: child object being examined field next field of child to examine parentField field where child was stored in its referencing object" | header lastFieldOffset action statMarkCountLocal | header := self longAt: oop. + (header bitAnd: self markBit) = 0 ifFalse: [^ 0 "already marked"]. - (header bitAnd: MarkBit) = 0 ifFalse: [^ 0 "already marked"]. "record tracing status in object's header" + header := (header bitAnd: self allButTypeMask) bitOr: HeaderTypeGC. - header := (header bitAnd: AllButTypeMask) bitOr: HeaderTypeGC. (self oop: oop isGreaterThanOrEqualTo: youngStart) + ifTrue: [ header := header bitOr: self markBit ]. "mark only if young" - ifTrue: [ header := header bitOr: MarkBit ]. "mark only if young" self longAt: oop put: header. "initialize the tracer state machine" parentField := GCTopMarker. child := oop. (self isWeakNonInt: oop) ifTrue: [ "Set lastFieldOffset before the weak fields in the receiver" + lastFieldOffset := (self nonWeakFieldsOf: oop) << self shiftForWord. - lastFieldOffset := (self nonWeakFieldsOf: oop) << ShiftForWord. "And remember as weak root" weakRootCount := weakRootCount + 1. weakRoots at: weakRootCount put: oop. ] ifFalse: [ "Do it the usual way" lastFieldOffset := self lastPointerOf: oop. ]. field := oop + lastFieldOffset. action := StartField. youngStartLocal := youngStart. statMarkCountLocal := statMarkCount. "run the tracer state machine until all objects reachable from oop are marked" [action = Done] whileFalse: [ statMarkCountLocal := statMarkCountLocal + 1. action = StartField ifTrue: [ action := self startField ]. action = StartObj ifTrue: [ action := self startObj ]. action = Upward ifTrue: [ action := self upward ]. ]. statMarkCount := statMarkCountLocal.! Item was changed: ----- Method: Interpreter>>pop:thenPushInteger: (in category 'contexts') ----- pop: nItems thenPushInteger: integerVal "lots of places pop a few items off the stack and then push an integer. MAke it convenient" | sp | + self longAt: (sp := stackPointer - ((nItems - 1) * self bytesPerWord)) put:(self integerObjectOf: integerVal). - self longAt: (sp := stackPointer - ((nItems - 1) * BytesPerWord)) put:(self integerObjectOf: integerVal). stackPointer := sp. ! Item was changed: ----- Method: Interpreter>>popFloat (in category 'stack bytecodes') ----- popFloat "Note: May be called by translated primitive code." | top result | self returnTypeC: 'double'. self var: #result type: 'double '. top := self popStack. self assertClassOf: top is: (self splObj: ClassFloat). successFlag ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2]. + self fetchFloatAt: top + self baseHeaderSize into: result]. - self fetchFloatAt: top + BaseHeaderSize into: result]. ^ result! Item was changed: ----- Method: Interpreter>>internalPush: (in category 'contexts') ----- internalPush: object + self longAtPointer: (localSP := localSP + self bytesPerWord) put: object.! - self longAtPointer: (localSP := localSP + BytesPerWord) put: object.! Item was changed: ----- Method: ObjectMemory>>sweepPhase (in category 'gc -- mark and sweep') ----- sweepPhase "Sweep memory from youngStart through the end of memory. Free all inaccessible objects and coalesce adjacent free chunks. Clear the mark bits of accessible objects. Compute the starting point for the first pass of incremental compaction (compStart). Return the number of surviving objects. " "Details: Each time a non-free object is encountered, decrement the number of available forward table entries. If all entries are spoken for (i.e., entriesAvailable reaches zero), set compStart to the last free chunk before that object or, if there is no free chunk before the given object, the first free chunk after it. Thus, at the end of the sweep phase, compStart through compEnd spans the highest collection of non-free objects that can be accomodated by the forwarding table. This information is used by the first pass of incremental compaction to ensure that space is initially freed at the end of memory. Note that there should always be at least one free chunk--the one at the end of the heap." | entriesAvailable survivors freeChunk firstFree oop oopHeader oopHeaderType hdrBytes oopSize freeChunkSize endOfMemoryLocal | self inline: false. self var: #oop type: 'usqInt'. self var: #endOfMemoryLocal type: 'usqInt'. + entriesAvailable := self fwdTableInit: self bytesPerWord * 2. - entriesAvailable := self fwdTableInit: BytesPerWord*2. survivors := 0. freeChunk := nil. firstFree := nil. "will be updated later" endOfMemoryLocal := endOfMemory. oop := self oopFromChunk: youngStart. [oop < endOfMemoryLocal] whileTrue: ["get oop's header, header type, size, and header size" statSweepCount := statSweepCount + 1. oopHeader := self baseHeader: oop. oopHeaderType := oopHeader bitAnd: TypeMask. hdrBytes := headerTypeBytes at: oopHeaderType. (oopHeaderType bitAnd: 1) = 1 + ifTrue: [oopSize := oopHeader bitAnd: self sizeMask] - ifTrue: [oopSize := oopHeader bitAnd: SizeMask] ifFalse: [oopHeaderType = HeaderTypeSizeAndClass + ifTrue: [oopSize := (self sizeHeader: oop) bitAnd: self longSizeMask] + ifFalse: ["free chunk" oopSize := oopHeader bitAnd: self longSizeMask]]. + (oopHeader bitAnd: self markBit) = 0 - ifTrue: [oopSize := (self sizeHeader: oop) bitAnd: LongSizeMask] - ifFalse: ["free chunk" oopSize := oopHeader bitAnd: LongSizeMask]]. - (oopHeader bitAnd: MarkBit) = 0 ifTrue: ["object is not marked; free it" "<-- Finalization support: We need to mark each oop chunk as free -->" self longAt: oop - hdrBytes put: HeaderTypeFree. freeChunk ~= nil ifTrue: ["enlarge current free chunk to include this oop" freeChunkSize := freeChunkSize + oopSize + hdrBytes] ifFalse: ["start a new free chunk" freeChunk := oop - hdrBytes. "chunk may start 4 or 8 bytes before oop" freeChunkSize := oopSize + (oop - freeChunk). "adjust size for possible extra header bytes" firstFree = nil ifTrue: [firstFree := freeChunk]]] ifFalse: ["object is marked; clear its mark bit and possibly adjust the compaction start" + self longAt: oop put: (oopHeader bitAnd: self allButMarkBit). - self longAt: oop put: (oopHeader bitAnd: AllButMarkBit). "<-- Finalization support: Check if we're running about a weak class -->" (self isWeakNonInt: oop) ifTrue: [self finalizeReference: oop]. entriesAvailable > 0 ifTrue: [entriesAvailable := entriesAvailable - 1] ifFalse: ["start compaction at the last free chunk before this object" firstFree := freeChunk]. freeChunk ~= nil ifTrue: ["record the size of the last free chunk" + self longAt: freeChunk put: ((freeChunkSize bitAnd: self longSizeMask) bitOr: HeaderTypeFree). - self longAt: freeChunk put: ((freeChunkSize bitAnd: LongSizeMask) bitOr: HeaderTypeFree). freeChunk := nil]. survivors := survivors + 1]. oop := self oopFromChunk: oop + oopSize]. freeChunk ~= nil ifTrue: ["record size of final free chunk" + self longAt: freeChunk put: ((freeChunkSize bitAnd: self longSizeMask) bitOr: HeaderTypeFree)]. - self longAt: freeChunk put: ((freeChunkSize bitAnd: LongSizeMask) bitOr: HeaderTypeFree)]. oop = endOfMemory ifFalse: [self error: 'sweep failed to find exact end of memory']. firstFree = nil ifTrue: [self error: 'expected to find at least one free object'] ifFalse: [compStart := firstFree]. ^ survivors! Item was changed: ----- Method: ObjectMemory>>restoreHeadersAfterForwardBecome: (in category 'become') ----- restoreHeadersAfterForwardBecome: copyHashFlag "Forward become leaves us with no original oops in the mutated object list, so we must enumerate the (four-word) forwarding blocks where we have stored backpointers." "This loop start is copied from fwdTableInit:" | oop1 fwdBlock oop2 hdr1 hdr2 | + fwdBlock := endOfMemory + self baseHeaderSize + 7 bitAnd: self wordMask - 7. - fwdBlock := endOfMemory + BaseHeaderSize + 7 bitAnd: WordMask - 7. self flag: #Dan. "See flag comment in fwdTableInit: (dtl)" + fwdBlock := fwdBlock + (self bytesPerWord * 4). - fwdBlock := fwdBlock + (BytesPerWord*4). "fwdBlockGet: did a pre-increment" [self oop: fwdBlock isLessThanOrEqualTo: fwdTableNext "fwdTableNext points to the last active block"] + whileTrue: [oop1 := self longAt: fwdBlock + (self bytesPerWord * 2). - whileTrue: [oop1 := self longAt: fwdBlock + (BytesPerWord*2). "Backpointer to mutated object." oop2 := self longAt: fwdBlock. self restoreHeaderOf: oop1. copyHashFlag ifTrue: ["Change the hash of the new oop (oop2) to be that of the old (oop1) so mutated objects in hash structures will be happy after the change." hdr1 := self longAt: oop1. hdr2 := self longAt: oop2. + self longAt: oop2 put: ((hdr2 bitAnd: self allButHashBits) bitOr: (hdr1 bitAnd: HashBits))]. + fwdBlock := fwdBlock + (self bytesPerWord * 4)]! - self longAt: oop2 put: ((hdr2 bitAnd: AllButHashBits) bitOr: (hdr1 bitAnd: HashBits))]. - fwdBlock := fwdBlock + (BytesPerWord*4)]! Item was added: + ----- Method: ObjectMemory>>allButRootBit (in category 'constants') ----- + allButRootBit + "Mask for root bit" + + self inline: true. + ^self + cCode: 'ALL_BUT_ROOT_BIT' + inSmalltalk: [self wordMask - self rootBit] + ! Item was changed: ----- Method: Interpreter>>firstFixedField: (in category 'plugin support') ----- firstFixedField: oop self returnTypeC: 'char *'. + ^ self pointerForOop: oop + self baseHeaderSize! - ^ self pointerForOop: oop + BaseHeaderSize! Item was added: + ----- Method: ArrayedCollection>>coerceTo:sim: (in category '*VMMaker-simulated image growing') ----- + coerceTo: cTypeString sim: interpreterSimulator + + ^ self! 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" | methodArgument argCnt argumentArray | methodArgument := self popStack. argumentArray := self popStack. ((self isNonIntegerObject: methodArgument) and: [(self isCompiledMethod: newMethod) and: [self isArray: argumentArray]]) ifFalse: [self unPop: 2. ^self primitiveFail]. argCnt := self argumentCountOf: methodArgument. argCnt = (self fetchWordLengthOf: argumentArray) ifFalse: [self unPop: 2. ^self primitiveFail]. + self transfer: argCnt from: argumentArray + self baseHeaderSize to: stackPointer + self bytesPerWord. - self transfer: argCnt from: argumentArray + BaseHeaderSize to: stackPointer + BytesPerWord. self unPop: argCnt. newMethod := methodArgument. primitiveIndex := self primitiveIndexOf: newMethod. argumentCount := argCnt. self executeNewMethod. "Recursive xeq affects successFlag" successFlag := true! Item was changed: ----- Method: ObjectMemory>>setSizeOfFree:to: (in category 'header access') ----- setSizeOfFree: chunk to: byteSize "Set the header of the given chunk to make it be a free chunk of the given size." + self longAt: chunk put: ((byteSize bitAnd: self allButTypeMask) bitOr: HeaderTypeFree).! - self longAt: chunk put: ((byteSize bitAnd: AllButTypeMask) bitOr: HeaderTypeFree).! Item was changed: ----- Method: ObjectMemory>>isObjectForwarded: (in category 'gc -- compaction') ----- isObjectForwarded: oop "Return true if the given object has a forwarding table entry during a compaction or become operation." + ^ (oop bitAnd: 1) = 0 and: ["(isIntegerObject: oop) not" ((self longAt: oop) bitAnd: self markBit) ~= 0]! - ^ (oop bitAnd: 1) = 0 and: ["(isIntegerObject: oop) not" ((self longAt: oop) bitAnd: MarkBit) ~= 0]! Item was changed: ----- Method: Interpreter>>stackPointerIndex (in category 'contexts') ----- stackPointerIndex "Return the 0-based index rel to the current context. (This is what stackPointer used to be before conversion to pointer" + ^ (stackPointer - activeContext - self baseHeaderSize) >> self shiftForWord! - ^ (stackPointer - activeContext - BaseHeaderSize) >> ShiftForWord! Item was changed: ----- Method: Interpreter>>sizeOfSTArrayFromCPrimitive: (in category 'utilities') ----- sizeOfSTArrayFromCPrimitive: cPtr "Return the number of indexable fields of the given object. This method is to be called from an automatically generated C primitive. The argument is assumed to be a pointer to the first indexable field of a words or bytes object; the object header starts 4 bytes before that." "Note: Only called by translated primitive code." | oop | self var: #cPtr type: 'void *'. + oop := (self oopForPointer: (self cCoerce: cPtr to: 'char *')) - self baseHeaderSize. - oop := (self oopForPointer: (self cCoerce: cPtr to: 'char *')) - BaseHeaderSize. (self isWordsOrBytes: oop) ifFalse: [ self primitiveFail. ^0]. ^self lengthOf: oop ! Item was changed: ----- Method: Interpreter>>createActualMessageTo: (in category 'message sending') ----- createActualMessageTo: aClass "Bundle up the selector, arguments and lookupClass into a Message object. In the process it pops the arguments off the stack, and pushes the message object. This can then be presented as the argument of e.g. #doesNotUnderstand:. ikp 11/20/1999 03:59 -- added hook for external runtime compilers." "remap lookupClass in case GC happens during allocation" | argumentArray message lookupClass | self pushRemappableOop: aClass. argumentArray := self instantiateClass: (self splObj: ClassArray) indexableSize: argumentCount. "remap argumentArray in case GC happens during allocation" self pushRemappableOop: argumentArray. message := self instantiateClass: (self splObj: ClassMessage) indexableSize: 0. argumentArray := self popRemappableOop. lookupClass := self popRemappableOop. self beRootIfOld: argumentArray. compilerInitialized ifTrue: [self compilerCreateActualMessage: message storingArgs: argumentArray] + ifFalse: [self transfer: argumentCount from: stackPointer - (argumentCount - 1 * self bytesPerWord) to: argumentArray + self baseHeaderSize. - ifFalse: [self transfer: argumentCount from: stackPointer - (argumentCount - 1 * BytesPerWord) to: argumentArray + BaseHeaderSize. self pop: argumentCount thenPush: message]. argumentCount := 1. self storePointer: MessageSelectorIndex ofObject: message withValue: messageSelector. self storePointer: MessageArgumentsIndex ofObject: message withValue: argumentArray. + (self lastPointerOf: message) >= (MessageLookupClassIndex * self bytesPerWord + self baseHeaderSize) - (self lastPointerOf: message) >= (MessageLookupClassIndex * BytesPerWord + BaseHeaderSize) ifTrue: ["Only store lookupClass if message has 3 fields (old images don't)" self storePointer: MessageLookupClassIndex ofObject: message withValue: lookupClass]! Item was added: + ----- Method: ObjectMemory>>wordMask (in category 'constants') ----- + wordMask + "Answer a bit mask for an object word, either 32 or 64 bits." + + self inline: true. + ^self + cCode: 'WORD_MASK' + inSmalltalk: [(1 bitShift: self bytesPerWord * 8) - 1] + ! Item was changed: ----- Method: Interpreter>>internalStoreContextRegisters: (in category 'contexts') ----- internalStoreContextRegisters: activeCntx "The only difference between this method and fetchContextRegisters: is that this method stores from the local IP and SP." "InstructionPointer is a pointer variable equal to + method oop + ip + self baseHeaderSize - method oop + ip + BaseHeaderSize -1 for 0-based addressing of fetchByte -1 because it gets incremented BEFORE fetching currentByte" self inline: true. self storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx withValue: (self integerObjectOf: + ((self oopForPointer: localIP) + 2 - (method + self baseHeaderSize))). - ((self oopForPointer: localIP) + 2 - (method + BaseHeaderSize))). self storePointerUnchecked: StackPointerIndex ofObject: activeCntx withValue: (self integerObjectOf: + ((((self oopForPointer: localSP) - (activeCntx + self baseHeaderSize)) >> self shiftForWord) - TempFrameStart + 1)). - ((((self oopForPointer: localSP) - (activeCntx + BaseHeaderSize)) >> ShiftForWord) - TempFrameStart + 1)). ! Item was changed: ----- Method: ObjectMemory>>restoreHeadersAfterBecoming:with: (in category 'become') ----- restoreHeadersAfterBecoming: list1 with: list2 "Restore the headers of all oops in both lists. Exchange their hash bits so becoming objects in identity sets and dictionaries doesn't change their hash value." "See also prepareForwardingTableForBecoming:with:woWay: for notes regarding the case of oop1 = oop2" | fieldOffset oop1 oop2 hdr1 hdr2 | fieldOffset := self lastPointerOf: list1. + [fieldOffset >= self baseHeaderSize] - [fieldOffset >= BaseHeaderSize] whileTrue: [oop1 := self longAt: list1 + fieldOffset. oop2 := self longAt: list2 + fieldOffset. oop1 = oop2 ifFalse: [self restoreHeaderOf: oop1. self restoreHeaderOf: oop2. "Exchange hash bits of the two objects." hdr1 := self longAt: oop1. hdr2 := self longAt: oop2. self longAt: oop1 + put: ((hdr1 bitAnd: self allButHashBits) bitOr: (hdr2 bitAnd: HashBits)). - put: ((hdr1 bitAnd: AllButHashBits) bitOr: (hdr2 bitAnd: HashBits)). self longAt: oop2 + put: ((hdr2 bitAnd: self allButHashBits) bitOr: (hdr1 bitAnd: HashBits))]. + fieldOffset := fieldOffset - self bytesPerWord]! - put: ((hdr2 bitAnd: AllButHashBits) bitOr: (hdr1 bitAnd: HashBits))]. - fieldOffset := fieldOffset - BytesPerWord]! Item was changed: ----- Method: Interpreter>>stackObjectValue: (in category 'contexts') ----- stackObjectValue: offset "Ensures that the given object is a real object, not a SmallInteger." | oop | + oop := self longAt: stackPointer - (offset * self bytesPerWord). - oop := self longAt: stackPointer - (offset * BytesPerWord). (self isIntegerObject: oop) ifTrue: [self primitiveFail. ^ nil]. ^ oop ! Item was changed: ----- Method: Interpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') ----- readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory." "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command." "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!" | swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift heapSize | self var: #f type: 'sqImageFile '. self var: #desiredHeapSize type: 'usqInt'. self var: #headerStart type: 'squeakFileOffsetType '. self var: #dataSize type: 'size_t '. self var: #imageOffset type: 'squeakFileOffsetType '. swapBytes := self checkImageVersionFrom: f startingAt: imageOffset. + headerStart := (self sqImageFilePosition: f) - self bytesPerWord. "record header start position" - headerStart := (self sqImageFilePosition: f) - BytesPerWord. "record header start position" headerSize := self getLongFromFile: f swap: swapBytes. dataSize := self getLongFromFile: f swap: swapBytes. oldBaseAddr := self getLongFromFile: f swap: swapBytes. specialObjectsOop := self getLongFromFile: f swap: swapBytes. lastHash := self getLongFromFile: f swap: swapBytes. savedWindowSize := self getLongFromFile: f swap: swapBytes. fullScreenFlag := self getLongFromFile: f swap: swapBytes. extraVMMemory := self getLongFromFile: f swap: swapBytes. lastHash = 0 ifTrue: [ "lastHash wasn't stored (e.g. by the cloner); use 999 as the seed" lastHash := 999]. "decrease Squeak object heap to leave extra memory for the VM" heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'. "compare memory requirements with availability". minimumMemory := dataSize + 100000. "need at least 100K of breathing room" heapSize < minimumMemory ifTrue: [ self insufficientMemorySpecifiedError]. "allocate a contiguous block of memory for the Squeak heap" memory := self allocateMemory: heapSize minimum: minimumMemory imageFile: f headerSize: headerSize. memory = nil ifTrue: [self insufficientMemoryAvailableError]. memStart := self startOfMemory. memoryLimit := (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety" endOfMemory := memStart + dataSize. "position file after the header" self sqImageFile: f Seek: headerStart + headerSize. "read in the image in bulk, then swap the bytes if necessary" bytesRead := self sqImage: (self pointerForOop: memory) read: f size: (self cCode: 'sizeof(unsigned char)') length: dataSize. bytesRead ~= dataSize ifTrue: [self unableToReadImageError]. + headerTypeBytes at: 0 put: self bytesPerWord * 2. "3-word header (type 0)" + headerTypeBytes at: 1 put: self bytesPerWord. "2-word header (type 1)" - headerTypeBytes at: 0 put: BytesPerWord * 2. "3-word header (type 0)" - headerTypeBytes at: 1 put: BytesPerWord. "2-word header (type 1)" headerTypeBytes at: 2 put: 0. "free chunk (type 2)" headerTypeBytes at: 3 put: 0. "1-word header (type 3)" swapBytes ifTrue: [self reverseBytesInImage]. "compute difference between old and new memory base addresses" bytesToShift := memStart - oldBaseAddr. self initializeInterpreter: bytesToShift. "adjusts all oops to new location" self isBigEnder. "work out the machine endianness and cache the answer" ^ dataSize ! Item was changed: ----- Method: Interpreter>>transfer:fromIndex:ofObject:toIndex:ofObject: (in category 'utilities') ----- transfer: count fromIndex: firstFrom ofObject: fromOop toIndex: firstTo ofObject: toOop "Transfer the specified fullword fields, as from calling context to called context" "Assume: beRootIfOld: will be called on toOop." | fromIndex toIndex lastFrom | self flag: #Dan. "Need to check all senders before converting this for 64 bits" self inline: true. + fromIndex := fromOop + (firstFrom * self bytesPerWord). + toIndex := toOop + (firstTo * self bytesPerWord). + lastFrom := fromIndex + (count * self bytesPerWord). - fromIndex := fromOop + (firstFrom * BytesPerWord). - toIndex := toOop + (firstTo * BytesPerWord). - lastFrom := fromIndex + (count * BytesPerWord). [self oop: fromIndex isLessThan: lastFrom] + whileTrue: [fromIndex := fromIndex + self bytesPerWord. + toIndex := toIndex + self bytesPerWord. - whileTrue: [fromIndex := fromIndex + BytesPerWord. - toIndex := toIndex + BytesPerWord. self longAt: toIndex put: (self longAt: fromIndex)]! Item was changed: (excessive method size, no diff calculated) Item was changed: ----- Method: Interpreter>>printNameOfClass:count: (in category 'debug printing') ----- printNameOfClass: classOop count: cnt "Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object." cnt <= 0 ifTrue: [ ^ self print: 'bad class' ]. + (self sizeBitsOf: classOop) = (7 * self bytesPerWord) "(Metaclass instSize+1 * 4)" - (self sizeBitsOf: classOop) = (7 * BytesPerWord) "(Metaclass instSize+1 * 4)" ifTrue: [self printNameOfClass: (self fetchPointer: 5 "thisClass" ofObject: classOop) count: cnt - 1. self print: ' class'] ifFalse: [self printStringOf: (self fetchPointer: 6 "name" ofObject: classOop)]! Item was changed: ----- Method: Interpreter>>primitiveIntegerAtPut (in category 'array primitives') ----- primitiveIntegerAtPut "Return the 32bit signed integer contents of a words receiver" | index rcvr sz addr value valueOop | valueOop := self stackValue: 0. index := self stackIntegerValue: 1. rcvr := self stackValue: 2. (self isIntegerObject: rcvr) ifTrue:[^self success: false]. (self isWords: rcvr) ifFalse:[^self success: false]. sz := self lengthOf: rcvr. "number of fields" ((index >= 1) and: [index <= sz]) ifFalse:[^self success: false]. (self isIntegerObject: valueOop) ifTrue:[value := self integerValueOf: valueOop] ifFalse:[value := self signed32BitValueOf: valueOop]. successFlag ifTrue:[ + addr := rcvr + self baseHeaderSize - 4 "for zero indexing" + (index * 4). - addr := rcvr + BaseHeaderSize - 4 "for zero indexing" + (index * 4). value := self intAt: addr put: value. self pop: 3 thenPush: valueOop. "pop all; return value" ]. ! Item was changed: ----- Method: Interpreter>>popStack (in category 'contexts') ----- popStack | top | top := self longAt: stackPointer. + stackPointer := stackPointer - self bytesPerWord. - stackPointer := stackPointer - BytesPerWord. ^ top! Item was changed: ----- Method: Interpreter>>imageSegmentVersion (in category 'image segment in/out') ----- imageSegmentVersion | wholeWord | "a more complex version that tells both the word reversal and the endianness of the machine it came from. Low half of word is 6502. Top byte is top byte of #doesNotUnderstand: on this machine. ($d on the Mac or $s on the PC)" + wholeWord := self longAt: (self splObj: SelectorDoesNotUnderstand) + self baseHeaderSize. - wholeWord := self longAt: (self splObj: SelectorDoesNotUnderstand) + BaseHeaderSize. "first data word, 'does' " ^ self imageFormatVersion bitOr: (wholeWord bitAnd: 16rFF000000)! Item was changed: ----- Method: Interpreter>>floatValueOf: (in category 'utilities') ----- floatValueOf: oop "Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float." "Note: May be called by translated primitive code." | result | self flag: #Dan. "None of the float stuff has been converted for 64 bits" self returnTypeC: 'double'. self var: #result type: 'double '. self assertClassOf: oop is: (self splObj: ClassFloat). successFlag ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2]. + self fetchFloatAt: oop + self baseHeaderSize into: result] - self fetchFloatAt: oop + BaseHeaderSize into: result] ifFalse: [result := 0.0]. ^ result! Item was changed: ----- Method: ObjectMemory>>fwdTableSize: (in category 'gc -- compaction') ----- fwdTableSize: blkSize "Estimate the number of forwarding blocks available for compaction" | eom fwdFirst fwdLast | self inline: false. + eom := freeBlock + self baseHeaderSize. - eom := freeBlock + BaseHeaderSize. "use all memory free between freeBlock and memoryLimit for forwarding table" "Note: Forward blocks must be quadword aligned." + fwdFirst := (eom + self baseHeaderSize + 7) bitAnd: self wordMask - 7. - fwdFirst := (eom + BaseHeaderSize + 7) bitAnd: WordMask-7. self flag: #Dan. "Above line does not do what it says (quadword is 16 or 32 bytes)" fwdLast := memoryLimit - blkSize. "last forwarding table entry" "return the number of forwarding blocks available" ^ (fwdLast - fwdFirst) // blkSize "round down"! Item was changed: ----- Method: ObjectMemory>>finalizeReference: (in category 'finalization') ----- finalizeReference: oop "During sweep phase we have encountered a weak reference. Check if its object has gone away (or is about to) and if so, signal a semaphore. " "Do *not* inline this in sweepPhase - it is quite an unlikely case to run into a weak reference" | weakOop oopGone chunk firstField lastField | self inline: false. self var: #oop type: 'usqInt'. self var: #weakOop type: 'usqInt'. + firstField := self baseHeaderSize + ((self nonWeakFieldsOf: oop) << self shiftForWord). - firstField := BaseHeaderSize + ((self nonWeakFieldsOf: oop) << ShiftForWord). lastField := self lastPointerOf: oop. + firstField to: lastField by: self bytesPerWord do: [:i | - firstField to: lastField by: BytesPerWord do: [:i | weakOop := self longAt: oop + i. "ar 1/18/2005: Added oop < youngStart test to make sure we're not testing objects in non-GCable region. This could lead to a forward reference in old space with the oop pointed to not being marked and thus treated as free." (weakOop == nilObj or: [(self isIntegerObject: weakOop) or:[weakOop < youngStart]]) ifFalse: ["Check if the object is being collected. If the weak reference points * backward: check if the weakOops chunk is free * forward: check if the weakOoop has been marked by GC" weakOop < oop ifTrue: [chunk := self chunkFromOop: weakOop. oopGone := ((self longAt: chunk) bitAnd: TypeMask) = HeaderTypeFree] + ifFalse: [oopGone := ((self baseHeader: weakOop) bitAnd: self markBit) = 0]. - ifFalse: [oopGone := ((self baseHeader: weakOop) bitAnd: MarkBit) = 0]. oopGone ifTrue: ["Store nil in the pointer and signal the interpreter " self longAt: oop + i put: nilObj. self signalFinalization: oop]]]! Item was changed: ----- Method: ObjectMemory>>startObj (in category 'gc -- mark and sweep') ----- startObj "Start tracing the object 'child' and answer the next action. The object may be anywhere in the middle of being swept itself. See comment in markAndTrace for explanation of tracer state variables." | oop header lastFieldOffset | self inline: true. oop := child. (self oop: oop isLessThan: youngStartLocal) ifTrue: ["old object; skip it" field := oop. ^ Upward]. header := self longAt: oop. + (header bitAnd: self markBit) = 0 - (header bitAnd: MarkBit) = 0 ifTrue: ["unmarked; mark and trace" "Do not trace the object's indexed fields if it's a weak class " (self isWeakNonInt: oop) ifTrue: ["Set lastFieldOffset before the weak fields in the receiver " + lastFieldOffset := (self nonWeakFieldsOf: oop) << self shiftForWord] - lastFieldOffset := (self nonWeakFieldsOf: oop) << ShiftForWord] ifFalse: ["Do it the usual way" lastFieldOffset := self lastPointerOf: oop]. + header := header bitAnd: self allButTypeMask. + header := (header bitOr: self markBit) bitOr: HeaderTypeGC. - header := header bitAnd: AllButTypeMask. - header := (header bitOr: MarkBit) bitOr: HeaderTypeGC. self longAt: oop put: header. field := oop + lastFieldOffset. ^ StartField "trace its fields and class"] ifFalse: ["already marked; skip it" field := oop. ^ Upward]! Item was changed: ----- Method: Interpreter>>storeContextRegisters: (in category 'contexts') ----- storeContextRegisters: activeCntx "Note: internalStoreContextRegisters: should track changes to this method." "InstructionPointer is a pointer variable equal to + method oop + ip + self baseHeaderSize - method oop + ip + BaseHeaderSize -1 for 0-based addressing of fetchByte -1 because it gets incremented BEFORE fetching currentByte" self inline: true. self storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx + withValue: (self integerObjectOf: (instructionPointer - method - (self baseHeaderSize - 2))). - withValue: (self integerObjectOf: (instructionPointer - method - (BaseHeaderSize - 2))). self storePointerUnchecked: StackPointerIndex ofObject: activeCntx withValue: (self integerObjectOf: (self stackPointerIndex - TempFrameStart + 1)). ! Item was changed: ----- 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 + self baseHeaderSize + (fieldIndex << self shiftForWord) - ^ self longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord) put: valuePointer! Item was changed: ----- Method: Interpreter>>assertClassOf:is: (in category 'utilities') ----- assertClassOf: oop is: classOop "Succeed if the given (non-integer) object is an instance of the given class. Fail if the object is an integer." | ccIndex cl | self inline: true. (self isIntegerObject: oop) ifTrue: [ successFlag := false. ^ nil ]. ccIndex := ((self baseHeader: oop) >> 12) bitAnd: 16r1F. ccIndex = 0 + ifTrue: [ cl := ((self classHeader: oop) bitAnd: self allButTypeMask) ] - ifTrue: [ cl := ((self classHeader: oop) bitAnd: AllButTypeMask) ] ifFalse: [ "look up compact class" cl := (self fetchPointer: (ccIndex - 1) ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop))]. self success: cl = classOop. ! Item was added: + ----- Method: ObjectMemory>>allButMarkBit (in category 'constants') ----- + allButMarkBit + "Mask for mark bit" + + self inline: true. + ^self + cCode: 'ALL_BUT_MARK_BIT' + inSmalltalk: [self wordMask - self markBit] + ! Item was added: + ----- Method: ObjectMemory>>smallContextSize (in category 'constants') ----- + smallContextSize + "16 indexable fields, calculated as ContextFixedSizePlusHeader + 16 * BytesPerWord" + + self inline: true. + ^self + cCode: 'SMALL_CONTEXT_SIZE' + inSmalltalk: [ContextFixedSizePlusHeader + 16 * self bytesPerWord] + ! Item was changed: ----- Method: ObjectMemory>>startField (in category 'gc -- mark and sweep') ----- startField "Examine and possibly trace the next field of the object being traced. See comment in markAndTrace for explanation of tracer state variables." | typeBits childType | self inline: true. child := self longAt: field. typeBits := child bitAnd: TypeMask. (typeBits bitAnd: 1) = 1 ifTrue: ["field contains a SmallInteger; skip it" + field := field - self bytesPerWord. - field := field - BytesPerWord. ^ StartField]. typeBits = 0 ifTrue: ["normal oop, go down" self longAt: field put: parentField. parentField := field. ^ StartObj]. typeBits = 2 ifTrue: ["reached the header; do we need to process the class word? " (child bitAnd: CompactClassMask) ~= 0 ifTrue: ["object's class is compact; we're done" "restore the header type bits" + child := child bitAnd: self allButTypeMask. - child := child bitAnd: AllButTypeMask. childType := self rightType: child. self longAt: field put: (child bitOr: childType). ^ Upward] ifFalse: ["object has a full class word; process that class" + child := self longAt: field - self bytesPerWord. "class word" + child := child bitAnd: self allButTypeMask. "clear type bits" + self longAt: field - self bytesPerWord put: parentField. + parentField := field - self bytesPerWord bitOr: 1. - child := self longAt: field - BytesPerWord. "class word" - child := child bitAnd: AllButTypeMask. "clear type bits" - self longAt: field - BytesPerWord put: parentField. - parentField := field - BytesPerWord bitOr: 1. "point at class word; mark as working on the class. " ^ StartObj]]! Item was changed: ----- Method: Interpreter>>balancedStack:afterPrimitive:withArgs: (in category 'debug support') ----- balancedStack: delta afterPrimitive: primIdx withArgs: nArgs "Return true if the stack is still balanced after executing primitive primIndex with nArgs args. Delta is 'stackPointer - activeContext' which is a relative measure for the stack pointer (so we don't have to relocate it during the primitive)" (primIdx >= 81 and:[primIdx <= 88]) ifTrue:[^true]. "81-88 are control primitives after which the stack may look unbalanced" successFlag ifTrue:[ "Successful prim, stack must have exactly nArgs arguments popped off" + ^(stackPointer - activeContext + (nArgs * self bytesPerWord)) = delta - ^(stackPointer - activeContext + (nArgs * BytesPerWord)) = delta ]. "Failed prim must leave stack intact" ^(stackPointer - activeContext) = delta ! Item was changed: ----- Method: ObjectMemory>>clone: (in category 'allocation') ----- clone: oop "Return a shallow copy of the given object. May cause GC" "Assume: Oop is a real object, not a small integer." | extraHdrBytes bytes newChunk remappedOop fromIndex toIndex lastFrom newOop header hash | self inline: false. self var: #lastFrom type: 'usqInt'. self var: #fromIndex type: 'usqInt'. extraHdrBytes := self extraHeaderBytes: oop. bytes := self sizeBitsOf: oop. bytes := bytes + extraHdrBytes. "allocate space for the copy, remapping oop in case of a GC" self pushRemappableOop: oop. "check it is safe to allocate this much memory. Return 0 if not" (self sufficientSpaceToAllocate: 2500 + bytes) ifFalse:[^0]. newChunk := self allocateChunk: bytes. remappedOop := self popRemappableOop. "copy old to new including all header words" + toIndex := newChunk - self bytesPerWord. "loop below uses pre-increment" + fromIndex := (remappedOop - extraHdrBytes) - self bytesPerWord. - toIndex := newChunk - BytesPerWord. "loop below uses pre-increment" - fromIndex := (remappedOop - extraHdrBytes) - BytesPerWord. lastFrom := fromIndex + bytes. [fromIndex < lastFrom] whileTrue: [ + self longAt: (toIndex := toIndex + self bytesPerWord) put: (self longAt: (fromIndex := fromIndex + self bytesPerWord))]. - self longAt: (toIndex := toIndex + BytesPerWord) put: (self longAt: (fromIndex := fromIndex + BytesPerWord))]. newOop := newChunk + extraHdrBytes. "convert from chunk to oop" "fix base header: compute new hash and clear Mark and Root bits" hash := self newObjectHash. header := (self longAt: newOop) bitAnd: 16r1FFFF. "use old ccIndex, format, size, and header-type fields" header := header bitOr: ((hash << 17) bitAnd: 16r1FFE0000). self longAt: newOop put: header. ^newOop ! Item was changed: ----- Method: ObjectMemory>>classHeader: (in category 'header access') ----- classHeader: oop + ^ self longAt: oop - self baseHeaderSize! - ^ self longAt: oop - BaseHeaderSize! Item was changed: ----- Method: Interpreter>>byteSwapped: (in category 'image save/restore') ----- byteSwapped: w "Answer the given integer with its bytes in the reverse order." self inline: true. + self isDefinedTrueExpression: 'BYTES_PER_WORD == 4' + inSmalltalk: [self bytesPerWord = 4] - self isDefinedTrueExpression: 'SQ_VI_BYTES_PER_WORD == 4' - inSmalltalk: [BytesPerWord = 4] comment: 'swap bytes in an object word' ifTrue: [^ ((w bitShift: Byte3ShiftNegated) bitAnd: Byte0Mask) + ((w bitShift: Byte1ShiftNegated) bitAnd: Byte1Mask) + ((w bitShift: Byte1Shift ) bitAnd: Byte2Mask) + ((w bitShift: Byte3Shift ) bitAnd: Byte3Mask)] ifFalse: [^ ((w bitShift: Byte7ShiftNegated) bitAnd: Byte0Mask) + ((w bitShift: Byte5ShiftNegated) bitAnd: Byte1Mask) + ((w bitShift: Byte3ShiftNegated) bitAnd: Byte2Mask) + ((w bitShift: Byte1ShiftNegated) bitAnd: Byte3Mask) + ((w bitShift: Byte1Shift ) bitAnd: Byte4Mask) + ((w bitShift: Byte3Shift ) bitAnd: Byte5Mask) + ((w bitShift: Byte5Shift ) bitAnd: Byte6Mask) + ((w bitShift: Byte7Shift ) bitAnd: Byte7Mask)]! Item was changed: ----- Method: Interpreter>>internalActivateNewMethod (in category 'message sending') ----- internalActivateNewMethod | methodHeader newContext tempCount argCount2 needsLarge where | self inline: true. methodHeader := self headerOf: newMethod. needsLarge := methodHeader bitAnd: LargeContextBit. (needsLarge = 0 and: [freeContexts ~= NilContext]) ifTrue: [newContext := freeContexts. freeContexts := self fetchPointer: 0 ofObject: newContext] ifFalse: ["Slower call for large contexts or empty free list" self externalizeIPandSP. newContext := self allocateOrRecycleContext: needsLarge. self internalizeIPandSP]. tempCount := (methodHeader >> 19) bitAnd: 16r3F. "Assume: newContext will be recorded as a root if necessary by the call to newActiveContext: below, so we can use unchecked stores." + where := newContext + self baseHeaderSize. + self longAt: where + (SenderIndex << self shiftForWord) put: activeContext. + self longAt: where + (InstructionPointerIndex << self shiftForWord) + put: (self integerObjectOf: (((LiteralStart + (self literalCountOfHeader: methodHeader)) * self bytesPerWord) + 1)). + self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount). + self longAt: where + (MethodIndex << self shiftForWord) put: newMethod. + self longAt: where + (ClosureIndex << self shiftForWord) put: nilObj. - where := newContext + BaseHeaderSize. - self longAt: where + (SenderIndex << ShiftForWord) put: activeContext. - self longAt: where + (InstructionPointerIndex << ShiftForWord) - put: (self integerObjectOf: (((LiteralStart + (self literalCountOfHeader: methodHeader)) * BytesPerWord) + 1)). - self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: tempCount). - self longAt: where + (MethodIndex << ShiftForWord) put: newMethod. - self longAt: where + (ClosureIndex << ShiftForWord) put: nilObj. "Copy the receiver and arguments..." argCount2 := argumentCount. 0 to: argCount2 do: + [:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord) put: (self internalStackValue: argCount2-i)]. - [:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord) put: (self internalStackValue: argCount2-i)]. "clear remaining temps to nil in case it has been recycled" methodHeader := nilObj. "methodHeader here used just as faster (register?) temp" argCount2+1+ReceiverIndex to: tempCount+ReceiverIndex do: + [:i | self longAt: where + (i << self shiftForWord) put: methodHeader]. - [:i | self longAt: where + (i << ShiftForWord) put: methodHeader]. self internalPop: argCount2 + 1. reclaimableContextCount := reclaimableContextCount + 1. self internalNewActiveContext: newContext. ! Item was changed: ----- Method: ObjectMemory>>adjustFieldsAndClassOf:by: (in category 'initialization') ----- adjustFieldsAndClassOf: oop by: offsetBytes "Adjust all pointers in this object by the given offset." | fieldAddr fieldOop classHeader newClassOop | self inline: true. offsetBytes = 0 ifTrue: [^nil]. fieldAddr := oop + (self lastPointerOf: oop). [self oop: fieldAddr isGreaterThan: oop] whileTrue: [fieldOop := self longAt: fieldAddr. (self isIntegerObject: fieldOop) ifFalse: [self longAt: fieldAddr put: fieldOop + offsetBytes]. + fieldAddr := fieldAddr - self bytesPerWord]. - fieldAddr := fieldAddr - BytesPerWord]. (self headerType: oop) ~= HeaderTypeShort ifTrue: ["adjust class header if not a compact class" + classHeader := self longAt: oop - self bytesPerWord. + newClassOop := (classHeader bitAnd: self allButTypeMask) + offsetBytes. + self longAt: oop - self bytesPerWord put: (newClassOop bitOr: (classHeader bitAnd: TypeMask))]! - classHeader := self longAt: oop - BytesPerWord. - newClassOop := (classHeader bitAnd: AllButTypeMask) + offsetBytes. - self longAt: oop - BytesPerWord put: (newClassOop bitOr: (classHeader bitAnd: TypeMask))]! Item was changed: ----- 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: self longSizeMask ] + ifFalse: [ ^ header bitAnd: self sizeMask ].! - ifTrue: [ ^ (self sizeHeader: oop) bitAnd: LongSizeMask ] - ifFalse: [ ^ header bitAnd: SizeMask ].! Item was changed: ----- Method: Interpreter>>roomToPushNArgs: (in category 'primitive support') ----- roomToPushNArgs: n "Answer if there is room to push n arguments onto the current stack. There may be room in this stackPage but there may not be room if the frame were converted into a context." | cntxSize | ((self headerOf: method) bitAnd: LargeContextBit) ~= 0 + ifTrue: [cntxSize := self largeContextSize / self bytesPerWord - ReceiverIndex] + ifFalse: [cntxSize := self smallContextSize / self bytesPerWord - ReceiverIndex]. - ifTrue: [cntxSize := LargeContextSize / BytesPerWord - ReceiverIndex] - ifFalse: [cntxSize := SmallContextSize / BytesPerWord - ReceiverIndex]. ^self stackPointerIndex + n <= cntxSize! Item was changed: ----- Method: CCodeGenerator>>generateBytesPerWord:on:indent: (in category 'C translation') ----- generateBytesPerWord: msgNode on: aStream indent: level "Generate the C code for this message onto the given stream." + aStream nextPutAll: 'BYTES_PER_WORD' - aStream nextPutAll: ' ', ObjectMemory bytesPerWord asString ! Item was changed: ----- Method: Interpreter>>makePointwithxValue:yValue: (in category 'utilities') ----- makePointwithxValue: xValue yValue: yValue "make a Point xValue@yValue. We know both will be integers so no value nor root checking is needed" | pointResult | + pointResult := self instantiateSmallClass: (self splObj: ClassPoint) sizeInBytes: 3 * self bytesPerWord. - pointResult := self instantiateSmallClass: (self splObj: ClassPoint) sizeInBytes: 3*BytesPerWord. self storePointerUnchecked: XIndex ofObject: pointResult withValue: (self integerObjectOf: xValue). self storePointerUnchecked: YIndex ofObject: pointResult withValue: (self integerObjectOf: yValue). ^ pointResult! Item was changed: ----- 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: self allButTypeMask ] + ifFalse: [ ^ header bitAnd: self sizeMask ].! - ifTrue: [ ^ (self sizeHeader: oop) bitAnd: AllButTypeMask ] - ifFalse: [ ^ header bitAnd: SizeMask ].! Item was added: + ----- Method: ObjectMemory>>largeContextSize (in category 'constants') ----- + largeContextSize + "Large contexts have 56 indexable fields. Max with single header word. + However note that in 64 bits, for now, large contexts have 3-word headers" + + self inline: true. + ^self + cCode: 'LARGE_CONTEXT_SIZE' + inSmalltalk: [ContextFixedSizePlusHeader + 56 * self bytesPerWord] + ! Item was changed: ----- Method: ObjectMemory>>allocateChunk: (in category 'allocation') ----- allocateChunk: byteSize "Allocate a chunk of the given size. Sender must be sure that the requested size includes enough space for the header word(s). " "Details: To limit the time per incremental GC, do one every so many allocations. The number is settable via primitiveVMParameter to tune your memory system" | enoughSpace newFreeSize newChunk | self inline: true. allocationCount >= allocationsBetweenGCs ifTrue: ["do an incremental GC every so many allocations to keep pauses short" self incrementalGC]. enoughSpace := self sufficientSpaceToAllocate: byteSize. enoughSpace ifFalse: ["signal that space is running low, but proceed with allocation if possible" signalLowSpace := true. lowSpaceThreshold := 0. "disable additional interrupts until lowSpaceThreshold is reset by image" self saveProcessSignalingLowSpace. self forceInterruptCheck]. + (self oop: (self sizeOfFree: freeBlock) isLessThan: byteSize + self baseHeaderSize) - (self oop: (self sizeOfFree: freeBlock) isLessThan: byteSize + BaseHeaderSize) ifTrue: [self error: 'out of memory']. "if we get here, there is enough space for allocation to succeed " newFreeSize := (self sizeOfFree: freeBlock) - byteSize. newChunk := freeBlock. freeBlock := freeBlock + byteSize. "Assume: client will initialize object header of free chunk, so following is not needed:" "self setSizeOfFree: newChunk to: byteSize." self setSizeOfFree: freeBlock to: newFreeSize. allocationCount := allocationCount + 1. ^newChunk! Item was changed: ----- 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 + self baseHeaderSize + (fieldIndex << 2)! - ^ self long32At: oop + BaseHeaderSize + (fieldIndex << 2)! Item was changed: ----- Method: ObjectMemory>>remap: (in category 'gc -- compaction') ----- remap: oop "Map the given oop to its new value during a compaction or become: operation. If it has no forwarding table entry, return the oop itself." | fwdBlock | self inline: false. (self isObjectForwarded: oop) ifTrue: ["get the new value for oop from its forwarding block" + fwdBlock := ((self longAt: oop) bitAnd: self allButMarkBitAndTypeMask) << 1. - fwdBlock := ((self longAt: oop) bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks ifTrue: [self fwdBlockValidate: fwdBlock]. ^ self longAt: fwdBlock]. ^ oop! Item was changed: ----- Method: ObjectMemory>>lastPointerOf: (in category 'object enumeration') ----- lastPointerOf: oop "Return the byte offset of the last pointer field of the given object. Works with CompiledMethods, as well as ordinary objects. Can be used even when the type bits are not correct." | fmt sz methodHeader header contextSize | self inline: true. header := self baseHeader: oop. fmt := header >> 8 bitAnd: 15. fmt <= 4 ifTrue: [(fmt = 3 and: [self isContextHeader: header]) ifTrue: ["contexts end at the stack pointer" contextSize := self fetchStackPointerOf: oop. + ^ CtxtTempFrameStart + contextSize * self bytesPerWord]. - ^ CtxtTempFrameStart + contextSize * BytesPerWord]. sz := self sizeBitsOfSafe: oop. + ^ sz - self baseHeaderSize "all pointers"]. - ^ sz - BaseHeaderSize "all pointers"]. fmt < 12 ifTrue: [^ 0]. "no pointers" "CompiledMethod: contains both pointers and bytes:" + methodHeader := self longAt: oop + self baseHeaderSize. + ^ (methodHeader >> 10 bitAnd: 255) * self bytesPerWord + self baseHeaderSize! - methodHeader := self longAt: oop + BaseHeaderSize. - ^ (methodHeader >> 10 bitAnd: 255) * BytesPerWord + BaseHeaderSize! Item was changed: (excessive method size, no diff calculated) Item was changed: ----- Method: Interpreter>>stackFloatValue: (in category 'contexts') ----- stackFloatValue: offset "Note: May be called by translated primitive code." | result floatPointer | self returnTypeC: 'double'. self var: #result type: 'double '. + floatPointer := self longAt: stackPointer - (offset * self bytesPerWord). - floatPointer := self longAt: stackPointer - (offset*BytesPerWord). (self fetchClassOf: floatPointer) = (self splObj: ClassFloat) ifFalse:[self primitiveFail. ^0.0]. self cCode: '' inSmalltalk: [result := Float new: 2]. + self fetchFloatAt: floatPointer + self baseHeaderSize into: result. - self fetchFloatAt: floatPointer + BaseHeaderSize into: result. ^ result! Item was changed: ----- Method: ObjectMemory>>instantiateClass:indexableSize: (in category 'interpreter access') ----- instantiateClass: classPointer indexableSize: size "NOTE: This method supports the backward-compatible split instSize field of the class format word. The sizeHiBits will go away and other shifts change by 2 when the split fields get merged in an (incompatible) image change." | hash header1 header2 cClass byteSize format binc header3 hdrSize fillWord newObj sizeHiBits bm1 classFormat | self inline: false. DoAssertionChecks ifTrue: [size < 0 ifTrue: [self error: 'cannot have a negative indexable field count']]. hash := self newObjectHash. classFormat := self formatOfClass: classPointer. "Low 2 bits are 0" header1 := (classFormat bitAnd: 16r1FF00) bitOr: (hash << HashBitsOffset bitAnd: HashBits). header2 := classPointer. header3 := 0. sizeHiBits := (classFormat bitAnd: 16r60000) >> 9. cClass := header1 bitAnd: CompactClassMask. "compact class field from format word" + byteSize := (classFormat bitAnd: self sizeMask + self size4Bit) + sizeHiBits. - byteSize := (classFormat bitAnd: SizeMask + Size4Bit) + sizeHiBits. "size in bytes -- low 2 bits are 0" "Note this byteSize comes from the format word of the class which is pre-shifted to 4 bytes per field. Need another shift for 8 bytes per word..." + byteSize := byteSize << (self shiftForWord - 2). - byteSize := byteSize << (ShiftForWord-2). format := classFormat >> 8 bitAnd: 15. self flag: #sizeLowBits. format < 8 ifTrue: [format = 6 ifTrue: ["long32 bitmaps" + bm1 := self bytesPerWord - 1. + byteSize := byteSize + (size * 4) + bm1 bitAnd: self longSizeMask. "round up" - bm1 := BytesPerWord-1. - byteSize := byteSize + (size * 4) + bm1 bitAnd: LongSizeMask. "round up" binc := bm1 - ((size * 4) + bm1 bitAnd: bm1). "odd bytes" "extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)" header1 := header1 bitOr: (binc bitAnd: 4)] + ifFalse: [byteSize := byteSize + (size * self bytesPerWord) "Arrays and 64-bit bitmaps"] - ifFalse: [byteSize := byteSize + (size * BytesPerWord) "Arrays and 64-bit bitmaps"] ] ifFalse: ["Strings and Methods" + bm1 := self bytesPerWord - 1. + byteSize := byteSize + size + bm1 bitAnd: self longSizeMask. "round up" - bm1 := BytesPerWord-1. - byteSize := byteSize + size + bm1 bitAnd: LongSizeMask. "round up" binc := bm1 - (size + bm1 bitAnd: bm1). "odd bytes" "low bits of byte size go in format field" header1 := header1 bitOr: (binc bitAnd: 3) << 8. "extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)" header1 := header1 bitOr: (binc bitAnd: 4)]. byteSize > 255 ifTrue: ["requires size header word" header3 := byteSize. header1 := header1] ifFalse: [header1 := header1 bitOr: byteSize]. header3 > 0 ifTrue: ["requires full header" hdrSize := 3] ifFalse: [cClass = 0 ifTrue: [hdrSize := 2] ifFalse: [hdrSize := 1]]. format <= 4 ifTrue: ["if pointers, fill with nil oop" fillWord := nilObj] ifFalse: [fillWord := 0]. newObj := self allocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3 doFill: true with: fillWord. ^ newObj! Item was changed: ----- Method: Interpreter>>verifyCleanHeaders (in category 'debug support') ----- verifyCleanHeaders | oop | oop := self firstObject. [self oop: oop isLessThan: endOfMemory] whileTrue: [(self isFreeObject: oop) ifTrue: ["There should only be one free block at end of memory." (self objectAfter: oop) = endOfMemory ifFalse: [self error: 'Invalid obj with HeaderTypeBits = Free.']] + ifFalse: [((self longAt: oop) bitAnd: self markBit) = 0 - ifFalse: [((self longAt: oop) bitAnd: MarkBit) = 0 ifFalse: [self error: 'Invalid obj with MarkBit set.']]. oop := self objectAfter: oop]! Item was changed: (excessive method size, no diff calculated) Item was changed: ----- Method: Interpreter>>internalPop:thenPush: (in category 'contexts') ----- internalPop: nItems thenPush: oop + self longAtPointer: (localSP := localSP - ((nItems - 1) * self bytesPerWord)) put: oop. - self longAtPointer: (localSP := localSP - ((nItems - 1) * BytesPerWord)) put: oop. ! Item was changed: ----- Method: Interpreter>>stackValue: (in category 'contexts') ----- stackValue: offset + ^ self longAt: stackPointer - (offset * self bytesPerWord)! - ^ self longAt: stackPointer - (offset*BytesPerWord)! Item was changed: ----- Method: Interpreter>>initialCleanup (in category 'initialization') ----- initialCleanup "Images written by VMs earlier than 3.6/3.7 will wrongly have the root bit set on the active context. Besides clearing the root bit, we treat this as a marker that these images also lack a cleanup of external primitives (which has been introduced at the same time when the root bit problem was fixed). In this case, we merely flush them from here." + ((self longAt: activeContext) bitAnd: self rootBit) = 0 ifTrue:[^nil]. "root bit is clean" - ((self longAt: activeContext) bitAnd: RootBit) = 0 ifTrue:[^nil]. "root bit is clean" "Clean root bit of activeContext" + self longAt: activeContext put: ((self longAt: activeContext) bitAnd: self allButRootBit). - self longAt: activeContext put: ((self longAt: activeContext) bitAnd: AllButRootBit). "Clean external primitives" self flushExternalPrimitives.! Item was changed: ----- Method: InterpreterSimulator>>validate: (in category 'testing') ----- validate: oop | header type cc sz fmt nextChunk | header := self longAt: oop. type := header bitAnd: 3. type = 2 ifFalse: [type = (self rightType: header) ifFalse: [self halt]]. + sz := (header bitAnd: self sizeMask) >> 2. - sz := (header bitAnd: SizeMask) >> 2. (self isFreeObject: oop) ifTrue: [ nextChunk := oop + (self sizeOfFree: oop) ] ifFalse: [ nextChunk := oop + (self sizeBitsOf: oop) ]. nextChunk > endOfMemory ifTrue: [oop = endOfMemory ifFalse: [self halt]]. (self headerType: nextChunk) = 0 ifTrue: [ (self headerType: (nextChunk + (BytesPerWord*2))) = 0 ifFalse: [self halt]]. (self headerType: nextChunk) = 1 ifTrue: [ (self headerType: (nextChunk + BytesPerWord)) = 1 ifFalse: [self halt]]. type = 2 ifTrue: ["free block" ^ self]. fmt := (header >> 8) bitAnd: 16rF. cc := (header >> 12) bitAnd: 31. cc > 16 ifTrue: [self halt]. "up to 32 are legal, but not used" type = 0 ifTrue: ["three-word header" ((self longAt: oop-BytesPerWord) bitAnd: 3) = type ifFalse: [self halt]. ((self longAt: oop-(BytesPerWord*2)) bitAnd: 3) = type ifFalse: [self halt]. ((self longAt: oop-BytesPerWord) = type) ifTrue: [self halt]. "Class word is 0" sz = 0 ifFalse: [self halt]]. type = 1 ifTrue: ["two-word header" ((self longAt: oop-BytesPerWord) bitAnd: 3) = type ifFalse: [self halt]. cc > 0 ifTrue: [sz = 1 ifFalse: [self halt]]. sz = 0 ifTrue: [self halt]]. type = 3 ifTrue: ["one-word header" cc = 0 ifTrue: [self halt]]. fmt = 5 ifTrue: [self halt]. fmt = 7 ifTrue: [self halt]. fmt >= 12 ifTrue: ["CompiledMethod -- check for integer header" (self isIntegerObject: (self longAt: oop + BytesPerWord)) ifFalse: [self halt]].! Item was changed: ----- Method: Interpreter>>oopHasAcceptableClass: (in category 'image segment in/out') ----- oopHasAcceptableClass: signedOop "Similar to oopHasOkayClass:, except that it only returns true or false." | oopClass formatMask behaviorFormatBits oopFormatBits oop | (self isIntegerObject: signedOop) ifTrue: [^ true]. self var: #oop type: 'usqInt'. self var: #oopClass type: 'usqInt'. oop := self cCoerce: signedOop to: 'usqInt'. oop < endOfMemory ifFalse: [^ false]. + ((oop \\ self bytesPerWord) = 0) ifFalse: [^ false]. - ((oop \\ BytesPerWord) = 0) ifFalse: [^ false]. (oop + (self sizeBitsOf: oop)) < endOfMemory ifFalse: [^ false]. oopClass := self cCoerce: (self fetchClassOf: oop) to: 'usqInt'. (self isIntegerObject: oopClass) ifTrue: [^ false]. (oopClass < endOfMemory) ifFalse: [^ false]. + ((oopClass \\ self bytesPerWord) = 0) ifFalse: [^ false]. - ((oopClass \\ BytesPerWord) = 0) ifFalse: [^ false]. (oopClass + (self sizeBitsOf: oopClass)) < endOfMemory ifFalse: [^ false]. ((self isPointers: oopClass) and: [(self lengthOf: oopClass) >= 3]) ifFalse: [^ false]. (self isBytes: oop) ifTrue: [ formatMask := 16rC00 ] "ignore extra bytes size bits" ifFalse: [ formatMask := 16rF00 ]. behaviorFormatBits := (self formatOfClass: oopClass) bitAnd: formatMask. oopFormatBits := (self baseHeader: oop) bitAnd: formatMask. behaviorFormatBits = oopFormatBits ifFalse: [^ false]. ^ true! Item was changed: ----- Method: ObjectMemory>>incCompBody (in category 'gc -- compaction') ----- incCompBody "Move objects to consolidate free space into one big chunk. Return the newly created free chunk." | bytesFreed | self inline: false. "reserve memory for forwarding table" + self fwdTableInit: self bytesPerWord * 2. "Two-word blocks" - self fwdTableInit: BytesPerWord*2. "Two-word blocks" "assign new oop locations, reverse their headers, and initialize forwarding blocks" bytesFreed := self incCompMakeFwd. "update pointers to point at new oops" self mapPointersInObjectsFrom: youngStart to: endOfMemory. "move the objects and restore their original headers; return the new free chunk" ^ self incCompMove: bytesFreed! Item was changed: ----- Method: ObjectMemory>>remapFieldsAndClassOf: (in category 'gc -- compaction') ----- remapFieldsAndClassOf: oop "Replace all forwarded pointers in this object with their new oops, using the forwarding table. Remap its class as well, if necessary. " "Note: The given oop may be forwarded itself, which means that its real header is in its forwarding table entry." | fieldOffset fieldOop fwdBlock newOop | self inline: true. fieldOffset := self lastPointerWhileForwarding: oop. + [fieldOffset >= self baseHeaderSize] - [fieldOffset >= BaseHeaderSize] whileTrue: [fieldOop := self longAt: oop + fieldOffset. (self isObjectForwarded: fieldOop) ifTrue: ["update this oop from its forwarding block" + fwdBlock := ((self longAt: fieldOop) bitAnd: self allButMarkBitAndTypeMask) << 1. - fwdBlock := ((self longAt: fieldOop) bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks ifTrue: [self fwdBlockValidate: fwdBlock]. newOop := self longAt: fwdBlock. self longAt: oop + fieldOffset put: newOop. "The following ensures that become: into old object makes it a root. It does nothing during either incremental or full compaction because oop will never be < youngStart." ((self oop: oop isLessThan: youngStart) and: [self oop: newOop isGreaterThanOrEqualTo: youngStart]) ifTrue: [self beRootWhileForwarding: oop]]. + fieldOffset := fieldOffset - self bytesPerWord]. - fieldOffset := fieldOffset - BytesPerWord]. self remapClassOf: oop! Item was changed: ----- Method: Interpreter>>primitiveFailAfterCleanup: (in category 'image segment in/out') ----- primitiveFailAfterCleanup: outPointerArray "If the storeSegment primitive fails, it must clean up first." | i lastAddr | "Store nils throughout the outPointer array." lastAddr := outPointerArray + (self lastPointerOf: outPointerArray). + i := outPointerArray + self baseHeaderSize. - i := outPointerArray + BaseHeaderSize. [i <= lastAddr] whileTrue: [self longAt: i put: nilObj. + i := i + self bytesPerWord]. - i := i + BytesPerWord]. DoAssertionChecks ifTrue: [self verifyCleanHeaders]. self primitiveFail! Item was changed: ----- Method: Interpreter>>copyObj:toSegment:addr:stopAt:saveOopAt:headerAt: (in category 'image segment in/out') ----- copyObj: oop toSegment: segmentWordArray addr: lastSeg stopAt: stopAddr saveOopAt: oopPtr headerAt: hdrPtr "Copy this object into the segment beginning at lastSeg. Install a forwarding pointer, and save oop and header. Fail if out of space. Return the next segmentAddr if successful." "Copy the object..." | extraSize bodySize hdrAddr | self flag: #Dan. "None of the imageSegment stuff has been updated for 64 bits" successFlag ifFalse: [^ lastSeg]. extraSize := self extraHeaderBytes: oop. bodySize := self sizeBitsOf: oop. (self oop: (lastSeg + extraSize + bodySize) isGreaterThanOrEqualTo: stopAddr) ifTrue: [^ self primitiveFail]. + self transfer: extraSize + bodySize // self bytesPerWord "wordCount" - self transfer: extraSize + bodySize // BytesPerWord "wordCount" from: oop - extraSize + to: lastSeg + self bytesPerWord. - to: lastSeg+BytesPerWord. "Clear root and mark bits of all headers copied into the segment" + hdrAddr := lastSeg + self bytesPerWord + extraSize. + self longAt: hdrAddr put: ((self longAt: hdrAddr) bitAnd: self allButRootBit - self markBit). - hdrAddr := lastSeg+BytesPerWord + extraSize. - self longAt: hdrAddr put: ((self longAt: hdrAddr) bitAnd: AllButRootBit - MarkBit). + self forward: oop to: (lastSeg + self bytesPerWord + extraSize - segmentWordArray) - self forward: oop to: (lastSeg+BytesPerWord + extraSize - segmentWordArray) savingOopAt: oopPtr andHeaderAt: hdrPtr. "Return new end of segment" ^ lastSeg + extraSize + bodySize! Item was changed: + ----- Method: ObjectMemory>>bytesPerWord (in category 'constants') ----- - ----- Method: ObjectMemory>>bytesPerWord (in category 'initialization') ----- bytesPerWord "Answer the size of an object memory word in bytes." + "Class variable shadows the cpp macro definition in generated code." + self inline: true. + ^self cCode: 'BYTES_PER_WORD' inSmalltalk: [BytesPerWord] + ! - ^BytesPerWord! Item was changed: ----- Method: ObjectMemory>>allocate:headerSize:h1:h2:h3:doFill:with: (in category 'allocation') ----- allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill with: fillWord "Allocate a new object of the given size and number of header words. (Note: byteSize already includes space for the base header word.) Initialize the header fields of the new object and fill the remainder of the object with the given value. May cause a GC" | newObj remappedClassOop end i | self inline: true. self var: #i type: 'usqInt'. self var: #end type: 'usqInt'. "remap classOop in case GC happens during allocation" hdrSize > 1 ifTrue: [self pushRemappableOop: classOop]. + newObj := self allocateChunk: byteSize + (hdrSize - 1 * self bytesPerWord). - newObj := self allocateChunk: byteSize + (hdrSize - 1 * BytesPerWord). hdrSize > 1 ifTrue: [remappedClassOop := self popRemappableOop]. hdrSize = 3 ifTrue: [self longAt: newObj put: (extendedSize bitOr: HeaderTypeSizeAndClass). + self longAt: newObj + self bytesPerWord put: (remappedClassOop bitOr: HeaderTypeSizeAndClass). + self longAt: newObj + (self bytesPerWord*2) put: (baseHeader bitOr: HeaderTypeSizeAndClass). + newObj := newObj + (self bytesPerWord*2)]. - self longAt: newObj + BytesPerWord put: (remappedClassOop bitOr: HeaderTypeSizeAndClass). - self longAt: newObj + (BytesPerWord*2) put: (baseHeader bitOr: HeaderTypeSizeAndClass). - newObj := newObj + (BytesPerWord*2)]. hdrSize = 2 ifTrue: [self longAt: newObj put: (remappedClassOop bitOr: HeaderTypeClass). + self longAt: newObj + self bytesPerWord put: (baseHeader bitOr: HeaderTypeClass). + newObj := newObj + self bytesPerWord]. - self longAt: newObj + BytesPerWord put: (baseHeader bitOr: HeaderTypeClass). - newObj := newObj + BytesPerWord]. hdrSize = 1 ifTrue: [self longAt: newObj put: (baseHeader bitOr: HeaderTypeShort)]. "clear new object" doFill ifTrue: [end := newObj + byteSize. + i := newObj + self bytesPerWord. - i := newObj + BytesPerWord. [i < end] whileTrue: [self longAt: i put: fillWord. + i := i + self bytesPerWord]]. - i := i + BytesPerWord]]. DoAssertionChecks ifTrue: [self okayOop: newObj. self oopHasOkayClass: newObj. (self objectAfter: newObj) = freeBlock ifFalse: [self error: 'allocate bug: did not set header of new oop correctly']. (self objectAfter: freeBlock) = endOfMemory ifFalse: [self error: 'allocate bug: did not set header of freeBlock correctly']]. ^newObj! Item was changed: ----- Method: ObjectMemory>>instantiateContext:sizeInBytes: (in category 'interpreter access') ----- instantiateContext: classPointer sizeInBytes: sizeInBytes "This version of instantiateClass assumes that the total object size is under 256 bytes, the limit for objects with only one or two header words. Note that the size is specified in bytes and should include four bytes for the base header word." | hash header1 header2 hdrSize | hash := self newObjectHash. header1 := (hash << HashBitsOffset bitAnd: HashBits) bitOr: (self formatOfClass: classPointer). header2 := classPointer. (header1 bitAnd: CompactClassMask) > 0 "are contexts compact?" ifTrue: [hdrSize := 1] ifFalse: [hdrSize := 2]. + sizeInBytes <= self sizeMask - sizeInBytes <= SizeMask ifTrue: ["OR size into header1. Must not do this if size > SizeMask" + header1 := header1 + (sizeInBytes - (header1 bitAnd: self sizeMask))] - header1 := header1 + (sizeInBytes - (header1 bitAnd: SizeMask))] ifFalse: [hdrSize := 3. "Zero the size field of header1 if large" + header1 := header1 - (header1 bitAnd: self sizeMask)]. - header1 := header1 - (header1 bitAnd: SizeMask)]. self flag: #Dan. "Check details of context sizes" + ^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: self largeContextSize doFill: false with: 0! - ^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: LargeContextSize doFill: false with: 0! Item was changed: ----- Method: ObjectMemory>>instantiateSmallClass:sizeInBytes: (in category 'interpreter access') ----- instantiateSmallClass: classPointer sizeInBytes: sizeInBytes "This version of instantiateClass assumes that the total object size is under 256 bytes, the limit for objects with only one or two header words. Note that the size is specified in bytes and should include 4 or 8 bytes for the base header word. NOTE this code will only work for sizes that are an integral number of words (like not a 32-bit LargeInteger in a 64-bit system). May cause a GC. Note that the created small object IS NOT FILLED and must be completed before returning it to Squeak. Since this call is used in routines that do jsut that we are safe. Break this rule and die." | hash header1 header2 hdrSize | + (sizeInBytes bitAnd: (self bytesPerWord - 1)) = 0 ifFalse: - (sizeInBytes bitAnd: (BytesPerWord-1)) = 0 ifFalse: [self error: 'size must be integral number of words']. hash := self newObjectHash. header1 := (hash << HashBitsOffset bitAnd: HashBits) bitOr: (self formatOfClass: classPointer). header2 := classPointer. (header1 bitAnd: CompactClassMask) > 0 "is this a compact class" ifTrue: [hdrSize := 1] ifFalse: [hdrSize := 2]. + header1 := header1 + (sizeInBytes - (header1 bitAnd: self sizeMask + self size4Bit)). - header1 := header1 + (sizeInBytes - (header1 bitAnd: SizeMask+Size4Bit)). ^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: 0 doFill: false with: 0! Item was changed: ----- Method: Interpreter>>reverseWordsFrom:to: (in category 'image save/restore') ----- reverseWordsFrom: startAddr to: stopAddr "Word-swap the given range of memory, excluding stopAddr." | addr | addr := startAddr. [self oop: addr isLessThan: stopAddr] whileTrue: [self longAt: addr put: (self wordSwapped: (self longAt: addr)). + addr := addr + self bytesPerWord].! - addr := addr + BytesPerWord].! Item was changed: ----- Method: ObjectMemory>>clearRootsTable (in category 'garbage collection') ----- clearRootsTable "Clear the root bits of the current roots, then empty the roots table. " "Caution: This should only be done when the young object space is empty." "reset the roots table (after this, all objects are old so there are no roots)" | oop | 1 to: rootTableCount do: [:i | "clear root bits of current root table entries" oop := rootTable at: i. + self longAt: oop put: ((self longAt: oop) bitAnd: self allButRootBit). - self longAt: oop put: ((self longAt: oop) bitAnd: AllButRootBit). rootTable at: i put: 0]. rootTableCount := 0! Item was changed: ----- Method: VMMaker class>>versionString (in category 'version testing') ----- versionString "VMMaker versionString" + ^'4.2.0'! - ^'4.1.1'! Item was changed: ----- Method: ObjectMemory>>validateRoots (in category 'memory access') ----- validateRoots "Verify that every old object that points to a new object has its root bit set, and appears in the rootTable. This method should not be called if the rootTable is full, because roots are no longer recorded, and incremental collections are not attempted. If DoAssertionChecks is true, this routine will halt on an unmarked root. Otherwise, this routine will merely return true in that case." | oop fieldAddr fieldOop header badRoot | self var: #oop type: 'usqInt'. self var: #fieldAddr type: 'usqInt'. self var: #fieldOop type: 'usqInt'. badRoot := false. oop := self firstObject. [oop < youngStart] whileTrue: [(self isFreeObject: oop) ifFalse: [fieldAddr := oop + (self lastPointerOf: oop). [fieldAddr > oop] whileTrue: [fieldOop := self longAt: fieldAddr. (fieldOop >= youngStart and: [(self isIntegerObject: fieldOop) not]) ifTrue: ["fieldOop is a pointer to a young object" header := self longAt: oop. + (header bitAnd: self rootBit) = 0 - (header bitAnd: RootBit) = 0 ifTrue: ["Forbidden: points to young obj but root bit not set." DoAssertionChecks ifTrue: [self error: 'root bit not set']. badRoot := true] ifFalse: ["Root bit is set" "Extreme test -- validate that oop was entered in rootTable too..." "Disabled for now... found := false. 1 to: rootTableCount do: [:i | oop = (rootTable at: i) ifTrue: [found := true]]. found ifFalse: [DoAssertionChecks ifTrue: [self error: 'root table not set']. badRoot := true]. ..." ]]. + fieldAddr := fieldAddr - self bytesPerWord]]. - fieldAddr := fieldAddr - BytesPerWord]]. oop := self objectAfter: oop]. ^ badRoot! Item was removed: - ----- Method: Array>>coerceTo:sim: (in category '*VMMaker-interpreter simulator') ----- - coerceTo: cTypeString sim: interpreterSimulator - - ^ self!

1 0

Compile VM for 32-bit or 64-bit image from one code base (was: VM Maker: VMMaker-dtl.173.mcz)
by David T. Lewis 20 May '10

20 May '10

This really belongs in the VMMaker inbox, but we don't have one of those so I uploaded it to SqS/VMMaker. If it causes problems, I appreciate if someone can do an update from VMMaker-dtl.172 and make this VMMaker-dtl.173 a branch. I may be out of town for a few days, so don't ask my permission. The purpose of this change is to move all of the BytesPerWord dependent stuff out to compile-time macros, enabling a single generated code base to produce VMs for either 32-bit or 64-bit image formats. Dave On Wed, May 19, 2010 at 11:42:19PM +0000, squeak-dev-noreply(a)lists.squeakfoundation.org wrote: > Dave Lewis uploaded a new version of VMMaker to project VM Maker: > http://www.squeaksource.com/VMMaker/VMMaker-dtl.173.mcz > > ==================== Summary ==================== > > Name: VMMaker-dtl.173 > Author: dtl > Time: 19 May 2010, 5:26:58 am > UUID: bbb194b8-b409-4b48-a757-7d9466006019 > Ancestors: VMMaker-dtl.172 > > VMMaker 4.2.0 > > EXPERIMENTAL - Includes numerous code changes that may cause problems for other VM projects that rely on a stable VMMaker code base. > > Compile a VM for either 32-bit or 64-bit image from a single generated code base. Eliminates need for separate src32 and src64 code generation from VMMaker. > > Various word-size dependent class variables are removed from ObjectMemory. C preprocessor macros are written to src/vm/interp.h to handle all compile-time size dependencies. The interpreter simulator uses a mix of class variables and instance methods to implement the corresponding calculations in Smalltalk. > > To compile a VM for 64-bit images, define the following in config.h or equivalent: > > #define SQ_VI_BYTES_PER_WORD 8 > > =============== Diff against VMMaker-dtl.172 =============== >

2 1

Re: [Pharo-project] UUID on ubuntu 10.04
by David T. Lewis 19 May '10

19 May '10

Thanks, I marked the issue as resolved and summarized the status here: http://bugs.squeak.org/view.php?id=7358 Dave On Wed, May 19, 2010 at 09:42:28AM +0200, St?phane Ducasse wrote: > Apparently the student reinstalled her ubuntu from scratch (no incremental installation) and the vm did not crash > anymore. > > Stef > > On May 17, 2010, at 9:16 PM, St?phane Ducasse wrote: > > > I asked the student to try. > > > > Stef > > > > On May 17, 2010, at 9:06 PM, laurent laffont wrote: > > > >> On ArchLinux I have the problem when UUID is built external. Official 4.0.3.2202 Unix VM binaries on http://squeakvm.org/unix/ works well for me (UUID is internal). > >> > >> Can you try with this one click image I made once (uses 4.0.3.2202 binaries) http://lolgzs.free.fr/pharo/Pharo-1.0-OneClick.zip > >> > >> Laurent Laffont > >> > >> http://pharocasts.blogspot.com/ > >> http://magaloma.blogspot.com/ > >> > >> > >> On Mon, May 17, 2010 at 8:24 PM, St?phane Ducasse <stephane.ducasse(a)inria.fr> wrote: > >> I can confirm that this is exactly the same trace than the one reported by laurent (no debug file). > >> > >> Stef > >> On May 17, 2010, at 7:51 PM, David T. Lewis wrote: > >> > >>> On Mon, May 17, 2010 at 07:38:59PM +0200, St?phane Ducasse wrote: > >>>> Hi guys > >>>> > >>>> I took seaside the latest one click image and when I have to save a MC package > >>>> I get a core dump with UUID new:... > >>>> I checke the so.UUIDplugin is there and I do not understand. > >>>> Can somebody with a Ubuntu give a try to save something using MC and the latest seaside one click. > >>> > >>> Hi Stef, > >>> > >>> This issue is being tracked here: http://bugs.squeak.org/view.php?id=7358 > >>> > >>> It is not clear to me if the issue is resolved in the Ian's latest VM > >>> build, so if you or anyone else can confirm the UUID crash happening > >>> with this VM, that would be helpful to clarify. > >>> > >>> Dave

1 0

Re: [Pharo-project] how to change the default size of the Pharo host windows?
by Eliot Miranda 19 May '10

19 May '10

On Tue, May 18, 2010 at 11:52 AM, Stéphane Ducasse < stephane.ducasse(a)inria.fr> wrote: > cool we could turn them into nice query methods with semantics revealing > names :) > I would just use a SHaredPool with class variables appropriately named, e.g. SharedPool subclass: #VMParameterNames instanceVariableNames: '' classVariableNames: '... ImageFormatVersion ...' VMParameterNames class methods for initialization initialize ... ImageFormatVersion := 41 ... then a client would use things like Smalltalk image vmParameterAt: ImageFormatVersion These are for very special uses and I don't really like the idea of making access to them too easy. > On May 18, 2010, at 7:21 PM, Eliot Miranda wrote: > > > > > > > On Mon, May 17, 2010 at 9:04 PM, Igor Stasenko <siguctua(a)gmail.com> > wrote: > > 2010/5/17 Eliot Miranda <eliot.miranda(a)gmail.com>: > > > > > > > > > On Mon, May 17, 2010 at 11:30 AM, Stéphane Ducasse > > > <stephane.ducasse(a)inria.fr> wrote: > > >> > > >> On Ma > > >> > > > >> > bytes 28 to 31: image flags, conventional VMs use only bit 0, Cog > also > > >> > uses bits 1 through 4 > > >> > bit 0: 1 => open full screen, 0 => open using width & > > >> > height > > >> > bit 1: 1 => image floats are in little-endian format, > 0=> > > >> > image floats are in big-endian format > > >> > bit 2: 1 => Process's 4th inst var (after myList) is > > >> > threadId to be used by the VM for overlapped calls > > >> > > > >> > bit 3: 1 => set the flag bit on methods that the VM > will > > >> > only interpret (because they're considered too big to JIT) > > >> > bit 4: 1 => preempting a process does not put it to > the > > >> > back of its run queue > > >> > > >> > > >> I was not clear how to read > > >> bit 3: 1 > > >> this information is not in the compiledMethods? > > > > > > For the Cog JIT I want to measure which methods get interpreted to > determine > > > the threshold at which to decide to JIT methods. It makes little sense > to > > > JIT methods that are large and only executed once, typically class > > > initialization methods. A simple criterion is to set a limit on the > number > > > of literals in a method. But I still need to know whether my threshold > is > > > affecting frequently used methods. So I added the option of setting > the > > > flag bit in any method which the JIT refuses to compile because it has > too > > > many literals. Since I need to see which methods are interpreted on > > > start-up putting a flag in the image header was convenient. The effect > is > > > that the JIT will set the flag bit on any method it refuses to JIT. I > can > > > then browse these in the image and decide whether any are important and > > > adjust the threshold accordingly. Arguably this should be a command > line > > > argument, not an image header flag. > > > > Eliot, i beg you, instead of using an obscure flags in image header, > > just add (or reserve unused) splObject indice and read/write whatever > > you want from there. > > > > SOme times it isn't appropriate to put flags in the special objects > array. Further, changing the specialObjectsArray isn't only a VM change, > its also a change to SystemDictionary>>recreateSpecialObjectsArray. For all > the flags which can be set in the header I provide access through > vmParameterAt:[put:]. > > > > > > I guess that Cog having substantial changes all around places, so > > adding a convenient API for VM flags > > and removing a bit fiddling from image header, would make things > > transparent and easy to use from language side. > > > > Ah, ok. That exists in vmParameterAt:[put:]. i.e. here's what's > different in vmParameterAt:put: at Teleplace: > > VM parameters are numbered as follows: > > ... > > 4 allocationCount (read-only; nil in Cog VMs) > > 5 allocations between GCs (read-write; nil in Cog > VMs) > > ... > > 41 imageFormatVersion for the VM > > 42 number of stack pages in use (Cog Stack VM only, > otherwise nil) > > 43 desired number of stack pages (stored in image file > header, max 65535; Cog VMs only, otherwise nil) > > 44 size of eden, in bytes (Cog VMs only, otherwise > nil) > > 45 desired size of eden, in bytes (stored in image > file header; Cog VMs only, otherwise nil) > > 46 size of machine code zone, in bytes (stored in > image file header; Cog JIT VM only, otherwise nil) > > 47 desired size of machine code zone, in bytes > (applies at startup only, stored in image file header; Cog JIT VM only) > > 48 various properties of the Cog VM as an integer > encoding an array of bit flags. > > Bit 0: implies the image's Process class has > threadId as its 3rd inst var (zero relative) > > Bit 1: if set, methods that are interpreted will > have the flag bit set in their header > > Bit 2: if set, implies preempting a process does > not put it to the back of its run queue > > 49-55 reserved for VM parameters that persist in the image > (such as eden above) > > 56 number of process switches since startup > (read-only) > > 57 number of ioProcessEvents calls since startup > (read-only) > > 58 number of ForceInterruptCheck (Cog VMs) or > quickCheckInterruptCalls (non-Cog VMs) calls since startup (read-only) > > 59 number of check event calls since startup > (read-only) > > 60 number of stack page overflows since startup > (read-only; Cog VMs only) > > 61 number of stack page divorces since startup > (read-only; Cog VMs only) > > 62 compiled code compactions since startup (read-only; > Cog only; otherwise nil) > > 63 total milliseconds in compiled code compactions > since startup (read-only; Cog only; otherwise nil) > > > > > > > > > > > > >> > > >> Stef > > >> > > >> > > >> _______________________________________________ > > >> Pharo-project mailing list > > >> Pharo-project(a)lists.gforge.inria.fr > > >> http://lists.gforge.inria.fr/cgi-bin/mailman/listinfo/pharo-project > > > > > > > > > _______________________________________________ > > > Pharo-project mailing list > > > Pharo-project(a)lists.gforge.inria.fr > > > http://lists.gforge.inria.fr/cgi-bin/mailman/listinfo/pharo-project > > > > > > > > > > > -- > > Best regards, > > Igor Stasenko AKA sig. > > > > _______________________________________________ > > Pharo-project mailing list > > Pharo-project(a)lists.gforge.inria.fr > > http://lists.gforge.inria.fr/cgi-bin/mailman/listinfo/pharo-project > > > > _______________________________________________ > > Pharo-project mailing list > > Pharo-project(a)lists.gforge.inria.fr > > http://lists.gforge.inria.fr/cgi-bin/mailman/listinfo/pharo-project > > > _______________________________________________ > Pharo-project mailing list > Pharo-project(a)lists.gforge.inria.fr > http://lists.gforge.inria.fr/cgi-bin/mailman/listinfo/pharo-project >

4 12

Re: [Pharo-project] how to change the default size of the Pharo host windows?
by Eliot Miranda 18 May '10

18 May '10

On Mon, May 17, 2010 at 9:04 PM, Igor Stasenko <siguctua(a)gmail.com> wrote: > 2010/5/17 Eliot Miranda <eliot.miranda(a)gmail.com>: > > > > > > On Mon, May 17, 2010 at 11:30 AM, Stéphane Ducasse > > <stephane.ducasse(a)inria.fr> wrote: > >> > >> On Ma > >> > > >> > bytes 28 to 31: image flags, conventional VMs use only bit 0, Cog also > >> > uses bits 1 through 4 > >> > bit 0: 1 => open full screen, 0 => open using width & > >> > height > >> > bit 1: 1 => image floats are in little-endian format, > 0=> > >> > image floats are in big-endian format > >> > bit 2: 1 => Process's 4th inst var (after myList) is > >> > threadId to be used by the VM for overlapped calls > >> > > >> > bit 3: 1 => set the flag bit on methods that the VM will > >> > only interpret (because they're considered too big to JIT) > >> > bit 4: 1 => preempting a process does not put it to the > >> > back of its run queue > >> > >> > >> I was not clear how to read > >> bit 3: 1 > >> this information is not in the compiledMethods? > > > > For the Cog JIT I want to measure which methods get interpreted to > determine > > the threshold at which to decide to JIT methods. It makes little sense > to > > JIT methods that are large and only executed once, typically class > > initialization methods. A simple criterion is to set a limit on the > number > > of literals in a method. But I still need to know whether my threshold > is > > affecting frequently used methods. So I added the option of setting the > > flag bit in any method which the JIT refuses to compile because it has > too > > many literals. Since I need to see which methods are interpreted on > > start-up putting a flag in the image header was convenient. The effect > is > > that the JIT will set the flag bit on any method it refuses to JIT. I > can > > then browse these in the image and decide whether any are important and > > adjust the threshold accordingly. Arguably this should be a command line > > argument, not an image header flag. > > Eliot, i beg you, instead of using an obscure flags in image header, > just add (or reserve unused) splObject indice and read/write whatever > you want from there. > SOme times it isn't appropriate to put flags in the special objects array. Further, changing the specialObjectsArray isn't only a VM change, its also a change to SystemDictionary>>recreateSpecialObjectsArray. For all the flags which can be set in the header I provide access through vmParameterAt:[put:]. > I guess that Cog having substantial changes all around places, so > adding a convenient API for VM flags > and removing a bit fiddling from image header, would make things > transparent and easy to use from language side. > Ah, ok. That exists in vmParameterAt:[put:]. i.e. here's what's different in vmParameterAt:put: at Teleplace: VM parameters are numbered as follows: ... 4 allocationCount (read-only; nil in Cog VMs) 5 allocations between GCs (read-write; nil in Cog VMs) ... 41 imageFormatVersion for the VM 42 number of stack pages in use (Cog Stack VM only, otherwise nil) 43 desired number of stack pages (stored in image file header, max 65535; Cog VMs only, otherwise nil) 44 size of eden, in bytes (Cog VMs only, otherwise nil) 45 desired size of eden, in bytes (stored in image file header; Cog VMs only, otherwise nil) 46 size of machine code zone, in bytes (stored in image file header; Cog JIT VM only, otherwise nil) 47 desired size of machine code zone, in bytes (applies at startup only, stored in image file header; Cog JIT VM only) 48 various properties of the Cog VM as an integer encoding an array of bit flags. Bit 0: implies the image's Process class has threadId as its 3rd inst var (zero relative) Bit 1: if set, methods that are interpreted will have the flag bit set in their header Bit 2: if set, implies preempting a process does not put it to the back of its run queue 49-55 reserved for VM parameters that persist in the image (such as eden above) 56 number of process switches since startup (read-only) 57 number of ioProcessEvents calls since startup (read-only) 58 number of ForceInterruptCheck (Cog VMs) or quickCheckInterruptCalls (non-Cog VMs) calls since startup (read-only) 59 number of check event calls since startup (read-only) 60 number of stack page overflows since startup (read-only; Cog VMs only) 61 number of stack page divorces since startup (read-only; Cog VMs only) 62 compiled code compactions since startup (read-only; Cog only; otherwise nil) 63 total milliseconds in compiled code compactions since startup (read-only; Cog only; otherwise nil) > >> > >> Stef > >> > >> > >> _______________________________________________ > >> Pharo-project mailing list > >> Pharo-project(a)lists.gforge.inria.fr > >> http://lists.gforge.inria.fr/cgi-bin/mailman/listinfo/pharo-project > > > > > > _______________________________________________ > > Pharo-project mailing list > > Pharo-project(a)lists.gforge.inria.fr > > http://lists.gforge.inria.fr/cgi-bin/mailman/listinfo/pharo-project > > > > > > -- > Best regards, > Igor Stasenko AKA sig. > > _______________________________________________ > Pharo-project mailing list > Pharo-project(a)lists.gforge.inria.fr > http://lists.gforge.inria.fr/cgi-bin/mailman/listinfo/pharo-project >

1 0

VM Maker: VMMaker-dtl.172.mcz
by squeak-dev-noreply＠lists.squeakfoundation.org 18 May '10

18 May '10

Dave Lewis uploaded a new version of VMMaker to project VM Maker: http://www.squeaksource.com/VMMaker/VMMaker-dtl.172.mcz ==================== Summary ==================== Name: VMMaker-dtl.172 Author: dtl Time: 17 May 2010, 10:12:18 am UUID: e6a86f05-ca60-4902-9c60-dca29ab45915 Ancestors: VMMaker-dtl.171 VMMaker 4.1.1 Reduce dependency on constants defined at slang code generation time in preparation for compile-time definition of BytesPerWord. Add #if #else #endif generator for slang to support #if (BytesPerWord == 8) Change #byteSwapped: and #wordSwapped: to use cpp macro rather than test for BytesPerWord variable. Remove BytesPerWord test from ObjectMemory class>>initBytesPerWord: because #byteSwapped: and #wordSwapped: no longer require different settings for class variables. =============== Diff against VMMaker-dtl.171 =============== Item was changed: ----- Method: ObjectMemory class>>initBytesPerWord: (in category 'initialization') ----- initBytesPerWord: nBytes BytesPerWord := nBytes. ShiftForWord := (BytesPerWord log: 2) rounded. + Byte0Shift := 0. + Byte1Shift := 8. + Byte2Shift := 16. + Byte3Shift := 24. + Byte4Shift := 32. + Byte5Shift := 40. + Byte6Shift := 48. + Byte7Shift := 56. + + Byte0Mask := 16r00000000000000FF. + Byte1Mask := 16r000000000000FF00. + Byte2Mask := 16r0000000000FF0000. + Byte3Mask := 16r00000000FF000000. + Byte4Mask := 16r000000FF00000000. + Byte5Mask := 16r0000FF0000000000. + Byte6Mask := 16r00FF000000000000. + Byte7Mask := 16rFF00000000000000. + Bytes3to0Mask := 16r00000000FFFFFFFF. + Bytes7to4Mask := 16rFFFFFFFF00000000. + - "The following is necessary to avoid confusing the compiler with shifts that are larger than the width of the type on which they operate. In gcc, such shifts cause incorrect code to be generated." - BytesPerWord = 8 - ifTrue: "64-bit VM" - [Byte0Mask := 16r00000000000000FF. Byte0Shift := 0. - Byte1Mask := 16r000000000000FF00. Byte1Shift := 8. - Byte2Mask := 16r0000000000FF0000. Byte2Shift := 16. - Byte3Mask := 16r00000000FF000000. Byte3Shift := 24. - Byte4Mask := 16r000000FF00000000. Byte4Shift := 32. - Byte5Mask := 16r0000FF0000000000. Byte5Shift := 40. - Byte6Mask := 16r00FF000000000000. Byte6Shift := 48. - Byte7Mask := 16rFF00000000000000. Byte7Shift := 56. - Bytes3to0Mask := 16r00000000FFFFFFFF. - Bytes7to4Mask := 16rFFFFFFFF00000000] - ifFalse: "32-bit VM" - [Byte0Mask := 16r00000000000000FF. Byte0Shift := 0. - Byte1Mask := 16r000000000000FF00. Byte1Shift := 8. - Byte2Mask := 16r0000000000FF0000. Byte2Shift := 16. - Byte3Mask := 16r00000000FF000000. Byte3Shift := 24. - Byte4Mask := 16r0000000000000000. Byte4Shift := 0. "unused" - Byte5Mask := 16r0000000000000000. Byte5Shift := 0. "unused" - Byte6Mask := 16r0000000000000000. Byte6Shift := 0. "unused" - Byte7Mask := 16r0000000000000000. Byte7Shift := 0. "unused" - Bytes3to0Mask := 16r0000000000000000. "unused" - Bytes7to4Mask := 16r0000000000000000 "unused"]. Byte1ShiftNegated := Byte1Shift negated. Byte3ShiftNegated := Byte3Shift negated. Byte4ShiftNegated := Byte4Shift negated. Byte5ShiftNegated := Byte5Shift negated. + Byte7ShiftNegated := Byte7Shift negated! - Byte7ShiftNegated := Byte7Shift negated.! Item was changed: ----- Method: Interpreter>>wordSwapped: (in category 'image save/restore') ----- wordSwapped: w "Return the given 64-bit integer with its halves in the reverse order." + self inline: true. + self isDefinedTrueExpression: 'SQ_VI_BYTES_PER_WORD == 8' + inSmalltalk: [BytesPerWord = 8] + comment: 'swap 32-bit ends of a 64-bit object word' + ifTrue: [^ ((w bitShift: Byte4ShiftNegated) bitAnd: Bytes3to0Mask) + + ((w bitShift: Byte4Shift) bitAnd: Bytes7to4Mask)] + ifFalse: [self error: 'This cannot happen.'] - BytesPerWord = 8 ifFalse: [self error: 'This cannot happen.']. - ^ ((w bitShift: Byte4ShiftNegated) bitAnd: Bytes3to0Mask) - + ((w bitShift: Byte4Shift ) bitAnd: Bytes7to4Mask) ! Item was changed: ----- Method: TSendNode>>isDirective (in category 'as yet unclassified') ----- isDirective "Preprocessor directive, e.g. a cpp macro" ^ { #preprocessorExpression: . #isDefined:inSmalltalk:comment:ifTrue:ifFalse: . + #isDefined:inSmalltalk:comment:ifTrue: . + #isDefinedTrueExpression:inSmalltalk:comment:ifTrue:ifFalse: - #isDefined:inSmalltalk:comment:ifTrue: } identityIncludes: selector! Item was changed: InterpreterPlugin subclass: #InflatePlugin instanceVariableNames: 'zipCollection zipReadLimit zipPosition zipState zipBitBuf zipBitPos zipSource zipSourcePos zipSourceLimit zipLitTable zipDistTable zipCollectionSize zipLitTableSize zipDistTableSize' + classVariableNames: 'MaxBits StateNoMoreData' - classVariableNames: 'StateNoMoreData MaxBits' poolDictionaries: '' category: 'VMMaker-Plugins'! !InflatePlugin commentStamp: '<historical>' prior: 0! This plugin implements the one crucial function for efficiently decompressing streams.! Item was changed: InterpreterPlugin subclass: #KlattSynthesizerPlugin instanceVariableNames: 'resonators frame pitch t0 nper nopen nmod a1 a2 x1 x2 b1 c1 glast vlast nlast periodCount samplesCount seed cascade samplesPerFrame samplingRate' + classVariableNames: 'A1v A2f A2v A3f A3v A4f A4v A5f A6f Anv Aspiration Atv B1 B2 B2f B3 B3f B4 B4f B5 B5f B6 B6f Bnp Bnz Btp Btz Bypass Db1 Df1 Diplophonia Epsilon F0 F1 F2 F3 F4 F5 F6 Flutter Fnp Fnz Friction Ftp Ftz Gain Jitter PI Ra Rk Ro Shimmer Turbulence Voicing' - classVariableNames: 'Bypass B3f Db1 B2 F2 A4f Epsilon Df1 Ftp Voicing Flutter B5 Btp A3v F5 Atv Ftz Diplophonia PI Aspiration Btz B4f B1 A5f F1 B4 Jitter A4v F4 Fnp A2f B5f A6f Bnp Anv Shimmer F0 Fnz A1v Ra Bnz Ro B3 B2f F3 Rk B6f A3f B6 Turbulence F6 Gain A2v Friction' poolDictionaries: 'KlattResonatorIndices' category: 'VMMaker-Plugins'! !KlattSynthesizerPlugin commentStamp: '<historical>' prior: 0! This is a pluggable primitive implementation of the KlattSynthesizer.! Item was changed: InterpreterPlugin subclass: #BalloonEngineBase instanceVariableNames: 'workBuffer objBuffer getBuffer aetBuffer spanBuffer engine formArray engineStopped geProfileTime dispatchedValue dispatchReturnValue objUsed doProfileStats copyBitsFn loadBBFn bbPluginName' + classVariableNames: 'EdgeInitTable EdgeStepTable FillTable WideLineFillTable WideLineWidthTable' - classVariableNames: 'FillTable EdgeStepTable EdgeInitTable WideLineWidthTable WideLineFillTable' poolDictionaries: 'BalloonEngineConstants' category: 'VMMaker-Plugins'! !BalloonEngineBase commentStamp: 'tpr 5/5/2003 11:45' prior: 0! This is the main class for the Balloon graphics Engine. BalloonEnginePlugin should be translated but its superclass should not since it is incorporated within that class's translation process. Nor should the simulation subclass be translated! Item was added: + ----- Method: Object>>isDefinedTrueExpression:inSmalltalk:comment:ifTrue:ifFalse: (in category '*VMMaker-translation support') ----- + isDefinedTrueExpression: condition inSmalltalk: conditionBlock comment: commentStringOrNil ifTrue: trueExpressionOrBlock ifFalse: falseExpressionOrBlockOrNil + "When translated, produces #if (condition) #else #endif CPP directives. + Example usage: + + self isDefinedTrueExpression: 'BytesPerWord == 8' + inSmalltalk: [BytesPerWord = 8] + comment: 'conditional on object word size' + ifTrue: [self doSomethingFor64BitWord] + ifFalse: [self doSomethingFor32BitWord]" + + ^ conditionBlock value + ifTrue: [trueExpressionOrBlock value] + ifFalse: [falseExpressionOrBlockOrNil value] + ! Item was changed: InterpreterPlugin subclass: #FilePlugin instanceVariableNames: 'sCCPfn sCDPfn sCGFTfn sCLPfn sCSFTfn sDFAfn sCDFfn sCOFfn sCRFfn sHFAfn' + classVariableNames: 'DirBadPath DirEntryFound DirNoMoreEntries' - classVariableNames: 'DirEntryFound DirNoMoreEntries DirBadPath' poolDictionaries: '' category: 'VMMaker-Plugins'! !FilePlugin commentStamp: 'tpr 5/5/2003 12:01' prior: 0! Provide access to the host machine file system. Requires both the Cross platform support files from platforms - Cross - plugins - FilePlugin (or some suitable replacement) and the platform specific fils from platforms - {your platform} - plugins - FilePlugin.! Item was changed: ----- Method: CCodeGenerator>>initializeCTranslationDictionary (in category 'C translation') ----- initializeCTranslationDictionary "Initialize the dictionary mapping message names to actions for C code generation." | pairs | translationDict := Dictionary new: 200. pairs := #( #& #generateAnd:on:indent: #| #generateOr:on:indent: #and: #generateSequentialAnd:on:indent: #or: #generateSequentialOr:on:indent: #not #generateNot:on:indent: #+ #generatePlus:on:indent: #- #generateMinus:on:indent: #* #generateTimes:on:indent: #/ #generateDivide:on:indent: #// #generateDivide:on:indent: #\\ #generateModulo:on:indent: #<< #generateShiftLeft:on:indent: #>> #generateShiftRight:on:indent: #min: #generateMin:on:indent: #max: #generateMax:on:indent: #bitAnd: #generateBitAnd:on:indent: #bitOr: #generateBitOr:on:indent: #bitXor: #generateBitXor:on:indent: #bitShift: #generateBitShift:on:indent: #bitInvert32 #generateBitInvert32:on:indent: #< #generateLessThan:on:indent: #<= #generateLessThanOrEqual:on:indent: #= #generateEqual:on:indent: #> #generateGreaterThan:on:indent: #>= #generateGreaterThanOrEqual:on:indent: #~= #generateNotEqual:on:indent: #== #generateEqual:on:indent: #~~ #generateNotEqual:on:indent: #isNil #generateIsNil:on:indent: #notNil #generateNotNil:on:indent: #whileTrue: #generateWhileTrue:on:indent: #whileFalse: #generateWhileFalse:on:indent: #whileTrue #generateDoWhileTrue:on:indent: #whileFalse #generateDoWhileFalse:on:indent: #to:do: #generateToDo:on:indent: #to:by:do: #generateToByDo:on:indent: #ifTrue: #generateIfTrue:on:indent: #ifFalse: #generateIfFalse:on:indent: #ifTrue:ifFalse: #generateIfTrueIfFalse:on:indent: #ifFalse:ifTrue: #generateIfFalseIfTrue:on:indent: #at: #generateAt:on:indent: #at:put: #generateAtPut:on:indent: #basicAt: #generateAt:on:indent: #basicAt:put: #generateAtPut:on:indent: #integerValueOf: #generateIntegerValueOf:on:indent: #integerObjectOf: #generateIntegerObjectOf:on:indent: #isIntegerObject: #generateIsIntegerObject:on:indent: #cCode: #generateInlineCCode:on:indent: #cCode:inSmalltalk: #generateInlineCCode:on:indent: #cCoerce:to: #generateCCoercion:on:indent: #preprocessorExpression: #generateInlineCppDirective:on:indent: #isDefined:inSmalltalk:comment:ifTrue: #generateInlineCppIfDef:on:indent: #isDefined:inSmalltalk:comment:ifTrue:ifFalse: #generateInlineCppIfDefElse:on:indent: + #isDefinedTrueExpression:inSmalltalk:comment:ifTrue:ifFalse: #generateInlineCppIfElse:on:indent: #preIncrement #generatePreIncrement:on:indent: #preDecrement #generatePreDecrement:on:indent: #inline: #generateInlineDirective:on:indent: #sharedCodeNamed:inCase: #generateSharedCodeDirective:on:indent: #asFloat #generateAsFloat:on:indent: #asInteger #generateAsInteger:on:indent: #anyMask: #generateBitAnd:on:indent: #raisedTo: #generateRaisedTo:on:indent: #touch: #generateTouch:on:indent: #bytesPerWord #generateBytesPerWord:on:indent: #baseHeaderSize #generateBaseHeaderSize:on:indent: #perform: #generatePerform:on:indent: #perform:with: #generatePerform:on:indent: #perform:with:with: #generatePerform:on:indent: #perform:with:with:with: #generatePerform:on:indent: #perform:with:with:with:with: #generatePerform:on:indent: ). 1 to: pairs size by: 2 do: [:i | translationDict at: (pairs at: i) put: (pairs at: i + 1)]. ! Item was changed: InterpreterPlugin subclass: #BitBltSimulation instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight sourceWidth sourceHeight sourceDepth sourcePitch sourceBits sourcePPW sourceMSB destWidth destHeight destDepth destPitch destBits destPPW destMSB bitCount skew mask1 mask2 preload nWords destMask hDir vDir sourceIndex sourceDelta destIndex destDelta sx sy dx dy bbW bbH halftoneHeight noSource noHalftone halftoneBase sourceAlpha srcBitShift dstBitShift bitBltOop affectedL affectedR affectedT affectedB opTable maskTable ditherMatrix4x4 ditherThresholds16 ditherValues16 hasSurfaceLock warpSrcShift warpSrcMask warpAlignShift warpAlignMask warpBitShiftTable querySurfaceFn lockSurfaceFn unlockSurfaceFn isWarping cmFlags cmMask cmShiftTable cmMaskTable cmLookupTable cmBitsPerColor dither8Lookup' + classVariableNames: 'AllOnes AlphaIndex BBClipHeightIndex BBClipWidthIndex BBClipXIndex BBClipYIndex BBColorMapIndex BBDestFormIndex BBDestXIndex BBDestYIndex BBHalftoneFormIndex BBHeightIndex BBLastIndex BBRuleIndex BBSourceFormIndex BBSourceXIndex BBSourceYIndex BBWarpBase BBWidthIndex BBXTableIndex BinaryPoint BlueIndex ColorMapFixedPart ColorMapIndexedPart ColorMapNewStyle ColorMapPresent CrossedX EndOfRun FixedPt1 FormBitsIndex FormDepthIndex FormHeightIndex FormWidthIndex GreenIndex JitBltHookSize OpTable OpTableSize RedIndex' - classVariableNames: 'CrossedX FormWidthIndex BBXTableIndex FormHeightIndex BBSourceYIndex BBSourceXIndex BBRuleIndex BBWarpBase BBColorMapIndex OpTable BBClipHeightIndex BBHalftoneFormIndex EndOfRun JitBltHookSize BBDestFormIndex GreenIndex BBClipYIndex ColorMapNewStyle FixedPt1 FormBitsIndex RedIndex BBClipXIndex BlueIndex AlphaIndex BinaryPoint BBLastIndex ColorMapIndexedPart BBHeightIndex BBSourceFormIndex BBWidthIndex FormDepthIndex OpTableSize BBClipWidthIndex BBDestYIndex AllOnes BBDestXIndex ColorMapFixedPart ColorMapPresent' poolDictionaries: '' category: 'VMMaker-Interpreter'! !BitBltSimulation commentStamp: '<historical>' prior: 0! This class implements BitBlt, much as specified in the Blue Book spec. Performance has been enhanced through the use of pointer variables such as sourceIndex and destIndex, and by separating several special cases of the inner loop. Operation has been extended to color, with support for 1, 2, 4, 8, 16, and 32-bit pixel sizes. Conversion between different pixel sizes is facilitated by accepting an optional color map. In addition to the original 16 combination rules, this BitBlt supports 16 fail (for old paint mode) 17 fail (for old mask mode) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord 21 rgbSub: sourceWord with: destinationWord 22 OLDrgbDiff: sourceWord with: destinationWord 23 OLDtallyIntoMap: destinationWord -- old vers doesn't clip to bit boundary 24 alphaBlend: sourceWord with: destinationWord 25 pixPaint: sourceWord with: destinationWord 26 pixMask: sourceWord with: destinationWord 27 rgbMax: sourceWord with: destinationWord 28 rgbMin: sourceWord with: destinationWord 29 rgbMin: sourceWord bitInvert32 with: destinationWord 30 alphaBlendConst: sourceWord with: destinationWord -- alpha passed as an arg 31 alphaPaintConst: sourceWord with: destinationWord -- alpha passed as an arg 32 rgbDiff: sourceWord with: destinationWord 33 tallyIntoMap: destinationWord 34 alphaBlendScaled: sourceWord with: destinationWord This implementation has also been fitted with an experimental "warp drive" that allows abritrary scaling and rotation (and even limited affine deformations) with all BitBlt storage modes supported. To add a new rule to BitBlt... 1. add the new rule method or methods in the category 'combination rules' of BBSim 2. describe it in the class comment of BBSim and in the class comment for BitBlt 3. add refs to initializeRuleTable in proper positions 4. add refs to initBBOpTable, following the pattern ! Item was changed: InterpreterPlugin subclass: #JPEGReaderPlugin instanceVariableNames: 'yComponent crComponent cbComponent ySampleStream crSampleStream cbSampleStream yBlocks crBlocks cbBlocks residuals ditherMask jpegBits jpegBitsSize jpegNaturalOrder jsCollection jsPosition jsReadLimit jsBitBuffer jsBitCount acTable dcTable acTableSize dcTableSize' + classVariableNames: 'BlockWidthIndex BlueIndex ConstBits CurrentXIndex CurrentYIndex DCTSize DCTSize2 FIXn0n298631336 FIXn0n34414 FIXn0n390180644 FIXn0n541196100 FIXn0n71414 FIXn0n765366865 FIXn0n899976223 FIXn1n175875602 FIXn1n40200 FIXn1n501321110 FIXn1n77200 FIXn1n847759065 FIXn1n961570560 FIXn2n053119869 FIXn2n562915447 FIXn3n072711026 GreenIndex HScaleIndex LookaheadBitsIndex LookaheadSymbolIndex MCUBlockIndex MCUWidthIndex MaxBits MaxMCUBlocks MaxSample MaxcodeIndex MinComponentSize Pass1Bits Pass1Div Pass2Div PriorDCValueIndex RedIndex SampleOffset VScaleIndex' - classVariableNames: 'FIXn0n765366865 PriorDCValueIndex FIXn1n77200 MaxBits Pass1Div DCTSize FIXn0n390180644 BlockWidthIndex Pass1Bits MCUWidthIndex Pass2Div FIXn1n175875602 CurrentXIndex FIXn0n71414 CurrentYIndex FIXn0n34414 RedIndex FIXn2n562915447 FIXn0n899976223 FIXn1n847759065 LookaheadSymbolIndex FIXn1n501321110 FIXn0n298631336 MaxSample FIXn1n40200 BlueIndex FIXn3n072711026 MinComponentSize FIXn0n541196100 LookaheadBitsIndex HScaleIndex MaxcodeIndex SampleOffset MCUBlockIndex DCTSize2 GreenIndex ConstBits FIXn1n961570560 VScaleIndex FIXn2n053119869 MaxMCUBlocks' poolDictionaries: '' category: 'VMMaker-Plugins'! !JPEGReaderPlugin commentStamp: 'tpr 5/5/2003 12:10' prior: 0! This is another JPEG reader plugin, this time not requiring jpeglib support. ! Item was changed: (excessive method size, no diff calculated) Item was added: + ----- Method: CCodeGenerator>>generateInlineCppIfElse:on:indent: (in category 'C translation') ----- + generateInlineCppIfElse: msgNode on: aStream indent: level + "Generate the C code for this message onto the given stream." + + | comment alternateBlock alternateBlockIsNil | + aStream cr; nextPutAll: '# if (', msgNode args first value, ')'. + comment := msgNode args third value. + (comment isKindOf: String) + ifTrue: [aStream nextPutAll: ' // ', comment] + ifFalse: ["nil argument, ignore it"]. + aStream cr. + msgNode isExpression + ifTrue: + [aStream tab: level + 1; nextPut: $(. + msgNode args fourth asExpression + emitCCodeOn: aStream level: level + 1 generator: self. + aStream nextPut: $); cr] + ifFalse: + [msgNode args fourth + emitCCodeOn: aStream level: level generator: self]. + alternateBlock := msgNode args fifth. + alternateBlockIsNil := true. "check for nil #else clause" + alternateBlock nodesDo: [:n | + (n ~= alternateBlock and: [n name ~= 'nil']) + ifTrue: [alternateBlockIsNil := false ]]. + (alternateBlockIsNil) ifFalse: + [aStream nextPutAll: '# else'; cr. + msgNode isExpression + ifTrue: + [aStream tab: level + 1; nextPut: $(. + alternateBlock asExpression + emitCCodeOn: aStream level: level + 1 generator: self. + aStream nextPut: $); cr] + ifFalse: + [alternateBlock + emitCCodeOn: aStream level: level generator: self]]. + aStream nextPutAll: '# endif // ', msgNode args first value; cr; tab: level + ! Item was changed: ----- Method: Interpreter>>byteSwapped: (in category 'image save/restore') ----- byteSwapped: w "Answer the given integer with its bytes in the reverse order." + self inline: true. + self isDefinedTrueExpression: 'SQ_VI_BYTES_PER_WORD == 4' + inSmalltalk: [BytesPerWord = 4] + comment: 'swap bytes in an object word' - BytesPerWord = 4 ifTrue: [^ ((w bitShift: Byte3ShiftNegated) bitAnd: Byte0Mask) + ((w bitShift: Byte1ShiftNegated) bitAnd: Byte1Mask) + ((w bitShift: Byte1Shift ) bitAnd: Byte2Mask) + ((w bitShift: Byte3Shift ) bitAnd: Byte3Mask)] ifFalse: [^ ((w bitShift: Byte7ShiftNegated) bitAnd: Byte0Mask) + ((w bitShift: Byte5ShiftNegated) bitAnd: Byte1Mask) + ((w bitShift: Byte3ShiftNegated) bitAnd: Byte2Mask) + ((w bitShift: Byte1ShiftNegated) bitAnd: Byte3Mask) + ((w bitShift: Byte1Shift ) bitAnd: Byte4Mask) + ((w bitShift: Byte3Shift ) bitAnd: Byte5Mask) + ((w bitShift: Byte5Shift ) bitAnd: Byte6Mask) + ((w bitShift: Byte7Shift ) bitAnd: Byte7Mask)]! Item was changed: (excessive method size, no diff calculated) Item was changed: InflatePlugin subclass: #DeflatePlugin instanceVariableNames: 'zipHashHead zipHashTail zipHashValue zipBlockPos zipBlockStart zipLiterals zipDistances zipLiteralFreq zipDistanceFreq zipLiteralCount zipLiteralSize zipMatchCount zipMatchLengthCodes zipDistanceCodes zipCrcTable zipExtraLengthBits zipExtraDistanceBits zipBaseLength zipBaseDistance' + classVariableNames: 'DeflateHashBits DeflateHashMask DeflateHashShift DeflateHashTableSize DeflateMaxDistance DeflateMaxDistanceCodes DeflateMaxLiteralCodes DeflateMaxMatch DeflateMinMatch DeflateWindowMask DeflateWindowSize' - classVariableNames: 'DeflateHashShift DeflateHashTableSize DeflateMaxDistanceCodes DeflateMaxMatch DeflateWindowSize DeflateWindowMask DeflateMaxLiteralCodes DeflateMinMatch DeflateHashBits DeflateHashMask DeflateMaxDistance' poolDictionaries: '' category: 'VMMaker-Plugins'! !DeflatePlugin commentStamp: 'tpr 5/5/2003 11:52' prior: 0! This adds Zip deflating support. InflatePlugin should not be translated but this subclass should since it is incorporated within that class's translation process! Item was changed: (excessive method size, no diff calculated) Item was changed: ----- Method: VMMaker class>>versionString (in category 'version testing') ----- versionString "VMMaker versionString" + ^'4.1.1'! - ^'4.1.0'!

3 2

VM Maker: VMMaker-dtl.171.mcz
by squeak-dev-noreply＠lists.squeakfoundation.org 18 May '10

18 May '10

Dave Lewis uploaded a new version of VMMaker to project VM Maker: http://www.squeaksource.com/VMMaker/VMMaker-dtl.171.mcz ==================== Summary ==================== Name: VMMaker-dtl.171 Author: dtl Time: 17 May 2010, 8:56:16 pm UUID: a2e00bbb-042c-44ba-a035-2393562a8afe Ancestors: VMMaker-dtl.170 Revert change from VMMaker-dtl.155. Byte size of a Bitmap must be 4 per pixel, not #bytesPerWord. http://lists.squeakfoundation.org/pipermail/vm-dev/2010-January/003635.html http://lists.squeakfoundation.org/pipermail/vm-dev/2010-January/003635.html =============== Diff against VMMaker-dtl.170 =============== Item was changed: InterpreterPlugin subclass: #InflatePlugin instanceVariableNames: 'zipCollection zipReadLimit zipPosition zipState zipBitBuf zipBitPos zipSource zipSourcePos zipSourceLimit zipLitTable zipDistTable zipCollectionSize zipLitTableSize zipDistTableSize' + classVariableNames: 'StateNoMoreData MaxBits' - classVariableNames: 'MaxBits StateNoMoreData' poolDictionaries: '' category: 'VMMaker-Plugins'! !InflatePlugin commentStamp: '<historical>' prior: 0! This plugin implements the one crucial function for efficiently decompressing streams.! Item was changed: InterpreterPlugin subclass: #KlattSynthesizerPlugin instanceVariableNames: 'resonators frame pitch t0 nper nopen nmod a1 a2 x1 x2 b1 c1 glast vlast nlast periodCount samplesCount seed cascade samplesPerFrame samplingRate' + classVariableNames: 'Bypass B3f Db1 B2 F2 A4f Epsilon Df1 Ftp Voicing Flutter B5 Btp A3v F5 Atv Ftz Diplophonia PI Aspiration Btz B4f B1 A5f F1 B4 Jitter A4v F4 Fnp A2f B5f A6f Bnp Anv Shimmer F0 Fnz A1v Ra Bnz Ro B3 B2f F3 Rk B6f A3f B6 Turbulence F6 Gain A2v Friction' - classVariableNames: 'A1v A2f A2v A3f A3v A4f A4v A5f A6f Anv Aspiration Atv B1 B2 B2f B3 B3f B4 B4f B5 B5f B6 B6f Bnp Bnz Btp Btz Bypass Db1 Df1 Diplophonia Epsilon F0 F1 F2 F3 F4 F5 F6 Flutter Fnp Fnz Friction Ftp Ftz Gain Jitter PI Ra Rk Ro Shimmer Turbulence Voicing' poolDictionaries: 'KlattResonatorIndices' category: 'VMMaker-Plugins'! !KlattSynthesizerPlugin commentStamp: '<historical>' prior: 0! This is a pluggable primitive implementation of the KlattSynthesizer.! Item was changed: InterpreterPlugin subclass: #BalloonEngineBase instanceVariableNames: 'workBuffer objBuffer getBuffer aetBuffer spanBuffer engine formArray engineStopped geProfileTime dispatchedValue dispatchReturnValue objUsed doProfileStats copyBitsFn loadBBFn bbPluginName' + classVariableNames: 'FillTable EdgeStepTable EdgeInitTable WideLineWidthTable WideLineFillTable' - classVariableNames: 'EdgeInitTable EdgeStepTable FillTable WideLineFillTable WideLineWidthTable' poolDictionaries: 'BalloonEngineConstants' category: 'VMMaker-Plugins'! !BalloonEngineBase commentStamp: 'tpr 5/5/2003 11:45' prior: 0! This is the main class for the Balloon graphics Engine. BalloonEnginePlugin should be translated but its superclass should not since it is incorporated within that class's translation process. Nor should the simulation subclass be translated! Item was changed: InterpreterPlugin subclass: #FilePlugin instanceVariableNames: 'sCCPfn sCDPfn sCGFTfn sCLPfn sCSFTfn sDFAfn sCDFfn sCOFfn sCRFfn sHFAfn' + classVariableNames: 'DirEntryFound DirNoMoreEntries DirBadPath' - classVariableNames: 'DirBadPath DirEntryFound DirNoMoreEntries' poolDictionaries: '' category: 'VMMaker-Plugins'! !FilePlugin commentStamp: 'tpr 5/5/2003 12:01' prior: 0! Provide access to the host machine file system. Requires both the Cross platform support files from platforms - Cross - plugins - FilePlugin (or some suitable replacement) and the platform specific fils from platforms - {your platform} - plugins - FilePlugin.! Item was changed: InterpreterPlugin subclass: #BitBltSimulation instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight sourceWidth sourceHeight sourceDepth sourcePitch sourceBits sourcePPW sourceMSB destWidth destHeight destDepth destPitch destBits destPPW destMSB bitCount skew mask1 mask2 preload nWords destMask hDir vDir sourceIndex sourceDelta destIndex destDelta sx sy dx dy bbW bbH halftoneHeight noSource noHalftone halftoneBase sourceAlpha srcBitShift dstBitShift bitBltOop affectedL affectedR affectedT affectedB opTable maskTable ditherMatrix4x4 ditherThresholds16 ditherValues16 hasSurfaceLock warpSrcShift warpSrcMask warpAlignShift warpAlignMask warpBitShiftTable querySurfaceFn lockSurfaceFn unlockSurfaceFn isWarping cmFlags cmMask cmShiftTable cmMaskTable cmLookupTable cmBitsPerColor dither8Lookup' + classVariableNames: 'CrossedX FormWidthIndex BBXTableIndex FormHeightIndex BBSourceYIndex BBSourceXIndex BBRuleIndex BBWarpBase BBColorMapIndex OpTable BBClipHeightIndex BBHalftoneFormIndex EndOfRun JitBltHookSize BBDestFormIndex GreenIndex BBClipYIndex ColorMapNewStyle FixedPt1 FormBitsIndex RedIndex BBClipXIndex BlueIndex AlphaIndex BinaryPoint BBLastIndex ColorMapIndexedPart BBHeightIndex BBSourceFormIndex BBWidthIndex FormDepthIndex OpTableSize BBClipWidthIndex BBDestYIndex AllOnes BBDestXIndex ColorMapFixedPart ColorMapPresent' - classVariableNames: 'AllOnes AlphaIndex BBClipHeightIndex BBClipWidthIndex BBClipXIndex BBClipYIndex BBColorMapIndex BBDestFormIndex BBDestXIndex BBDestYIndex BBHalftoneFormIndex BBHeightIndex BBLastIndex BBRuleIndex BBSourceFormIndex BBSourceXIndex BBSourceYIndex BBWarpBase BBWidthIndex BBXTableIndex BinaryPoint BlueIndex ColorMapFixedPart ColorMapIndexedPart ColorMapNewStyle ColorMapPresent CrossedX EndOfRun FixedPt1 FormBitsIndex FormDepthIndex FormHeightIndex FormWidthIndex GreenIndex JitBltHookSize OpTable OpTableSize RedIndex' poolDictionaries: '' category: 'VMMaker-Interpreter'! !BitBltSimulation commentStamp: '<historical>' prior: 0! This class implements BitBlt, much as specified in the Blue Book spec. Performance has been enhanced through the use of pointer variables such as sourceIndex and destIndex, and by separating several special cases of the inner loop. Operation has been extended to color, with support for 1, 2, 4, 8, 16, and 32-bit pixel sizes. Conversion between different pixel sizes is facilitated by accepting an optional color map. In addition to the original 16 combination rules, this BitBlt supports 16 fail (for old paint mode) 17 fail (for old mask mode) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord 21 rgbSub: sourceWord with: destinationWord 22 OLDrgbDiff: sourceWord with: destinationWord 23 OLDtallyIntoMap: destinationWord -- old vers doesn't clip to bit boundary 24 alphaBlend: sourceWord with: destinationWord 25 pixPaint: sourceWord with: destinationWord 26 pixMask: sourceWord with: destinationWord 27 rgbMax: sourceWord with: destinationWord 28 rgbMin: sourceWord with: destinationWord 29 rgbMin: sourceWord bitInvert32 with: destinationWord 30 alphaBlendConst: sourceWord with: destinationWord -- alpha passed as an arg 31 alphaPaintConst: sourceWord with: destinationWord -- alpha passed as an arg 32 rgbDiff: sourceWord with: destinationWord 33 tallyIntoMap: destinationWord 34 alphaBlendScaled: sourceWord with: destinationWord This implementation has also been fitted with an experimental "warp drive" that allows abritrary scaling and rotation (and even limited affine deformations) with all BitBlt storage modes supported. To add a new rule to BitBlt... 1. add the new rule method or methods in the category 'combination rules' of BBSim 2. describe it in the class comment of BBSim and in the class comment for BitBlt 3. add refs to initializeRuleTable in proper positions 4. add refs to initBBOpTable, following the pattern ! Item was changed: InterpreterPlugin subclass: #JPEGReaderPlugin instanceVariableNames: 'yComponent crComponent cbComponent ySampleStream crSampleStream cbSampleStream yBlocks crBlocks cbBlocks residuals ditherMask jpegBits jpegBitsSize jpegNaturalOrder jsCollection jsPosition jsReadLimit jsBitBuffer jsBitCount acTable dcTable acTableSize dcTableSize' + classVariableNames: 'FIXn0n765366865 PriorDCValueIndex FIXn1n77200 MaxBits Pass1Div DCTSize FIXn0n390180644 BlockWidthIndex Pass1Bits MCUWidthIndex Pass2Div FIXn1n175875602 CurrentXIndex FIXn0n71414 CurrentYIndex FIXn0n34414 RedIndex FIXn2n562915447 FIXn0n899976223 FIXn1n847759065 LookaheadSymbolIndex FIXn1n501321110 FIXn0n298631336 MaxSample FIXn1n40200 BlueIndex FIXn3n072711026 MinComponentSize FIXn0n541196100 LookaheadBitsIndex HScaleIndex MaxcodeIndex SampleOffset MCUBlockIndex DCTSize2 GreenIndex ConstBits FIXn1n961570560 VScaleIndex FIXn2n053119869 MaxMCUBlocks' - classVariableNames: 'BlockWidthIndex BlueIndex ConstBits CurrentXIndex CurrentYIndex DCTSize DCTSize2 FIXn0n298631336 FIXn0n34414 FIXn0n390180644 FIXn0n541196100 FIXn0n71414 FIXn0n765366865 FIXn0n899976223 FIXn1n175875602 FIXn1n40200 FIXn1n501321110 FIXn1n77200 FIXn1n847759065 FIXn1n961570560 FIXn2n053119869 FIXn2n562915447 FIXn3n072711026 GreenIndex HScaleIndex LookaheadBitsIndex LookaheadSymbolIndex MCUBlockIndex MCUWidthIndex MaxBits MaxMCUBlocks MaxSample MaxcodeIndex MinComponentSize Pass1Bits Pass1Div Pass2Div PriorDCValueIndex RedIndex SampleOffset VScaleIndex' poolDictionaries: '' category: 'VMMaker-Plugins'! !JPEGReaderPlugin commentStamp: 'tpr 5/5/2003 12:10' prior: 0! This is another JPEG reader plugin, this time not requiring jpeglib support. ! Item was changed: (excessive method size, no diff calculated) Item was changed: (excessive method size, no diff calculated) Item was changed: ----- Method: Interpreter>>byteSizeOf: (in category 'object format') ----- byteSizeOf: oop | slots | self flag: #Dan. (self isIntegerObject: oop) ifTrue:[^0]. slots := self slotSizeOf: oop. (self isBytesNonInt: oop) ifTrue:[^slots] + ifFalse:[^slots * 4]! - ifFalse:[^slots * self bytesPerWord]! Item was changed: InflatePlugin subclass: #DeflatePlugin instanceVariableNames: 'zipHashHead zipHashTail zipHashValue zipBlockPos zipBlockStart zipLiterals zipDistances zipLiteralFreq zipDistanceFreq zipLiteralCount zipLiteralSize zipMatchCount zipMatchLengthCodes zipDistanceCodes zipCrcTable zipExtraLengthBits zipExtraDistanceBits zipBaseLength zipBaseDistance' + classVariableNames: 'DeflateHashShift DeflateHashTableSize DeflateMaxDistanceCodes DeflateMaxMatch DeflateWindowSize DeflateWindowMask DeflateMaxLiteralCodes DeflateMinMatch DeflateHashBits DeflateHashMask DeflateMaxDistance' - classVariableNames: 'DeflateHashBits DeflateHashMask DeflateHashShift DeflateHashTableSize DeflateMaxDistance DeflateMaxDistanceCodes DeflateMaxLiteralCodes DeflateMaxMatch DeflateMinMatch DeflateWindowMask DeflateWindowSize' poolDictionaries: '' category: 'VMMaker-Plugins'! !DeflatePlugin commentStamp: 'tpr 5/5/2003 11:52' prior: 0! This adds Zip deflating support. InflatePlugin should not be translated but this subclass should since it is incorporated within that class's translation process! Item was changed: (excessive method size, no diff calculated)

1 0

CMake for Windows?
by Geoffroy Couprie 17 May '10

17 May '10

Hello, I have been trying to adapt the Unix CMake files for the Windows port, but I have difficulties understanding the sources layout. I understand at least the difference between internal and external plugins, but what is in vm/intplugins? It seems that CMake looks for sources in a lot of directories, and that some of them are not used anymore. I have these directory layouts: platforms \-Cross \-plugins \-pluginA \-pluginB \-vm \-specificplatform \-plugins \-pluginA \-pluginB \-vm And for the generated sources directory: src \-pluginA \-pluginB \-vm Is that the definitive sources layout? Also, if you're interested in using CMake for Windows, should I assemble Unix and Windows instructions in the same files? Best regards, Geoffroy Couprie

7 18

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Vm-dev May 2010