Packages January 2015

packages@lists.squeakfoundation.org

1 participants
240 discussions

The Trunk: Kernel.spur-eem.894.mcz
by commits＠source.squeak.org 29 Jan '15

29 Jan '15

Eliot Miranda uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel.spur-eem.894.mcz ==================== Summary ==================== Name: Kernel.spur-eem.894 Author: eem Time: 29 January 2015, 11:35:31.857 am UUID: 53a4a0c2-a1a6-4f4c-a91f-4345a302fbf2 Ancestors: Kernel-eem.894, Kernel.spur-ul.893 Kernel-eem.894 patched for Spur by SpurBootstrapMonticelloPackagePatcher Cog-eem.237 Access a process's environment from effectiveProcess to provide correct environment access when debugging. =============== Diff against Kernel-eem.894 =============== Item was changed: ----- Method: Behavior>>allInstances (in category 'accessing instances and variables') ----- + allInstances + "Answer all instances of the receiver." + <primitive: 177> + "The primitive can fail because memory is low. If so, fall back on the old + enumeration code, which gives the system a chance to GC and/or grow. + Because aBlock might change the class of inst (for example, using become:), + it is essential to compute next before aBlock value: inst." + | inst insts next | + insts := WriteStream on: (Array new: 64). + inst := self someInstance. + [inst == nil] whileFalse: + [next := inst nextInstance. + (inst == insts or: [inst == insts originalContents]) ifFalse: [insts nextPut: inst]. + inst := next]. + ^insts contents! - allInstances - "Answer a collection of all current instances of the receiver." - - | all | - all := OrderedCollection new. - self allInstancesDo: [:x | x == all ifFalse: [all add: x]]. - ^ all asArray - ! Item was changed: ----- Method: Behavior>>allInstancesDo: (in category 'enumerating') ----- + allInstancesDo: aBlock + "Evaluate aBlock with each of the current instances of the receiver." + | instances inst next | + instances := self allInstancesOrNil. + instances ifNotNil: + [instances do: aBlock. + ^self]. + "allInstancesOrNil can fail because memory is low. If so, fall back on the old + enumeration code. Because aBlock might change the class of inst (for example, + using become:), it is essential to compute next before aBlock value: inst." - allInstancesDo: aBlock - "Evaluate the argument, aBlock, for each of the current instances of the - receiver. - - Because aBlock might change the class of inst (for example, using become:), - it is essential to compute next before aBlock value: inst." - | inst next | inst := self someInstance. + [inst == nil] whileFalse: + [next := inst nextInstance. + aBlock value: inst. + inst := next]! - [inst == nil] - whileFalse: - [ - next := inst nextInstance. - aBlock value: inst. - inst := next]! Item was added: + ----- Method: Behavior>>allInstancesOrNil (in category 'enumerating') ----- + allInstancesOrNil + "Answer all instances of the receiver, or nil if the primitive + fails, which it may be due to being out of memory." + <primitive: 177> + ^nil! Item was changed: ----- Method: Behavior>>basicNew (in category 'instance creation') ----- basicNew "Primitive. Answer an instance of the receiver (which is a class) with no + indexable variables. Fail if the class is indexable. Essential. See Object + documentation whatIsAPrimitive. + + If the primitive fails because space is low then the scavenger will run + before the method is activated. Check that space was low and retry + via handleFailingBasicNew if so." - indexable variables. Fail if the class is indexable. Essential. See Object - documentation whatIsAPrimitive." + <primitive: 70 error: ec> + ec == #'insufficient object memory' ifTrue: + [^self handleFailingBasicNew]. + self isVariable ifTrue: [^self basicNew: 0]. + self primitiveFailed! - <primitive: 70> - self isVariable ifTrue: [ ^ self basicNew: 0 ]. - "space must be low" - OutOfMemory signal. - ^ self basicNew "retry if user proceeds" - ! Item was changed: ----- Method: Behavior>>basicNew: (in category 'instance creation') ----- + basicNew: sizeRequested + "Primitive. Answer an instance of this class with the number of indexable + variables specified by the argument, sizeRequested. Fail if this class is not + indexable or if the argument is not a positive Integer, or if there is not + enough memory available. Essential. See Object documentation whatIsAPrimitive. + + If the primitive fails because space is low then the scavenger will run before the + method is activated. Check args and retry via handleFailingBasicNew: if they're OK." - basicNew: sizeRequested - "Primitive. Answer an instance of this class with the number - of indexable variables specified by the argument, sizeRequested. - Fail if this class is not indexable or if the argument is not a - positive Integer, or if there is not enough memory available. - Essential. See Object documentation whatIsAPrimitive." + <primitive: 71 error: ec> + ec == #'insufficient object memory' ifTrue: + [^self handleFailingBasicNew: sizeRequested]. - <primitive: 71> self isVariable ifFalse: [self error: self printString, ' cannot have variable sized instances']. - (sizeRequested isInteger and: [sizeRequested >= 0]) ifTrue: - ["arg okay; space must be low." - OutOfMemory signal. - ^ self basicNew: sizeRequested "retry if user proceeds"]. self primitiveFailed! Item was added: + ----- Method: Behavior>>byteSizeOfInstance (in category 'accessing instances and variables') ----- + byteSizeOfInstance + "Answer the total memory size of an instance of the receiver." + + <primitive: 181 error: ec> + self isVariable ifTrue: + [^self byteSizeOfInstanceOfSize: 0]. + self primitiveFailed! Item was added: + ----- Method: Behavior>>byteSizeOfInstanceOfSize: (in category 'accessing instances and variables') ----- + byteSizeOfInstanceOfSize: basicSize + "Answer the total memory size of an instance of the receiver + with the given number of indexable instance variables." + + <primitive: 181 error: ec> + self isVariable + ifTrue: "If the primitive overflowed answer a close approximation" + [(basicSize isInteger + and: [basicSize >= 16r1000000]) ifTrue: + [^2 * (self byteSizeOfInstanceOfSize: basicSize + 1 // 2) + - (self byteSizeOfInstanceOfSize: 0)]] + ifFalse: + [basicSize = 0 ifTrue: + [^self byteSizeOfInstance]]. + self primitiveFailed! Item was added: + ----- Method: Behavior>>elementSize (in category 'accessing instances and variables') ----- + elementSize + "Answer the size in bytes of an element in the receiver. The formats are + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6 = unused + 7 = immediates (SmallInteger, Character) + 8 = unused + 9 = 64-bit indexable + 10-11 = 32-bit indexable (Bitmap) + 12-15 = 16-bit indexable + 16-23 = 8-bit indexable + 24-31 = compiled methods (CompiledMethod)" + | instSpec | + instSpec := self instSpec. + instSpec < 9 ifTrue: [^Smalltalk wordSize]. + instSpec >= 16 ifTrue: [^1]. + instSpec >= 12 ifTrue: [^2]. + instSpec >= 10 ifTrue: [^4]. + ^8! Item was added: + ----- Method: Behavior>>handleFailingBasicNew (in category 'private') ----- + handleFailingBasicNew + "handleFailingBasicNew gets sent after basicNew has failed and allowed + a scavenging garbage collection to occur. The scavenging collection + will have happened as the VM is activating the (failing) basicNew. If + handleFailingBasicNew fails then the scavenge failed to reclaim sufficient + space and a global garbage collection is required. Retry after garbage + collecting and growing memory if necessary. + + Primitive. Answer an instance of this class with the number of indexable + variables specified by the argument, sizeRequested. Fail if this class is not + indexable or if the argument is not a positive Integer, or if there is not + enough memory available. Essential. See Object documentation whatIsAPrimitive." + + <primitive: 70> + Smalltalk garbageCollect < 1048576 ifTrue: + [Smalltalk growMemoryByAtLeast: 1048576]. + ^self handleFailingFailingBasicNew "retry after global garbage collect"! Item was added: + ----- Method: Behavior>>handleFailingBasicNew: (in category 'private') ----- + handleFailingBasicNew: sizeRequested + "handleFailingBasicNew: gets sent after basicNew: has failed and allowed + a scavenging garbage collection to occur. The scavenging collection + will have happened as the VM is activating the (failing) basicNew:. If + handleFailingBasicNew: fails then the scavenge failed to reclaim sufficient + space and a global garbage collection is required. Retry after garbage + collecting and growing memory if necessary. + + Primitive. Answer an instance of this class with the number of indexable + variables specified by the argument, sizeRequested. Fail if this class is not + indexable or if the argument is not a positive Integer, or if there is not + enough memory available. Essential. See Object documentation whatIsAPrimitive." + + <primitive: 71> + | bytesRequested | + bytesRequested := self byteSizeOfInstanceOfSize: sizeRequested. + Smalltalk garbageCollect < bytesRequested ifTrue: + [Smalltalk growMemoryByAtLeast: bytesRequested]. + "retry after global garbage collect and possible grow" + ^self handleFailingFailingBasicNew: sizeRequested! Item was added: + ----- Method: Behavior>>handleFailingFailingBasicNew (in category 'private') ----- + handleFailingFailingBasicNew + "This basicNew gets sent after handleFailingBasicNew: has done a full + garbage collection and possibly grown memory. If this basicNew fails + then the system really is low on space, so raise the OutOfMemory signal. + + Primitive. Answer an instance of this class with the number of indexable + variables specified by the argument, sizeRequested. Fail if this class is not + indexable or if the argument is not a positive Integer, or if there is not + enough memory available. Essential. See Object documentation whatIsAPrimitive." + + <primitive: 70> + "space must be low" + OutOfMemory signal. + ^self basicNew "retry if user proceeds"! Item was added: + ----- Method: Behavior>>handleFailingFailingBasicNew: (in category 'private') ----- + handleFailingFailingBasicNew: sizeRequested + "This basicNew: gets sent after handleFailingBasicNew: has done a full + garbage collection and possibly grown memory. If this basicNew: fails + then the system really is low on space, so raise the OutOfMemory signal. + + Primitive. Answer an instance of this class with the number of indexable + variables specified by the argument, sizeRequested. Fail if this class is not + indexable or if the argument is not a positive Integer, or if there is not + enough memory available. Essential. See Object documentation whatIsAPrimitive." + + <primitive: 71> + "space must be low." + OutOfMemory signal. + ^self basicNew: sizeRequested "retry if user proceeds"! Item was added: + ----- Method: Behavior>>identityHash (in category 'comparing') ----- + identityHash + "Answer a SmallInteger whose value is related to the receiver's identity. + Behavior implements identityHash to allow the VM to use an object representation which + does not include a direct reference to an object's class in an object. If the VM is using + this implementation then classes are held in a class table and instances contain the index + of their class in the table. A class's class table index is its identityHash so that an instance + can be created without searching the table for a class's index. The VM uses this primitive + to enter the class into the class table, assigning its identityHash with an as yet unused + class table index. If this primitive fails it means that the class table is full. In Spur as of + 2014 there are 22 bits of classTable index and 22 bits of identityHash per object. + + Primitive. Essential. Do not override. See Object documentation whatIsAPrimitive." + + <primitive: 175> + self primitiveFailed! Item was changed: ----- Method: Behavior>>indexIfCompact (in category 'private') ----- indexIfCompact + "Backward compatibility with the Squeak V3 object format. + Spur does not have a distinction between compact and non-compact classes." + ^0! - "If these 5 bits are non-zero, then instances of this class - will be compact. It is crucial that there be an entry in - Smalltalk compactClassesArray for any class so optimized. - See the msgs becomeCompact and becomeUncompact." - ^ (format bitShift: -11) bitAnd: 16r1F - " - Smalltalk compactClassesArray doWithIndex: - [:c :i | c == nil ifFalse: - [c indexIfCompact = i ifFalse: [self halt]]] - "! Item was changed: ----- Method: Behavior>>instSize (in category 'testing') ----- instSize "Answer the number of named instance variables + (as opposed to indexed variables) of the receiver. + Above Cog Spur the class format is + <5 bits inst spec><16 bits inst size>" + ^format bitAnd: 16rFFFF! - (as opposed to indexed variables) of the receiver." - - self flag: #instSizeChange. "Smalltalk browseAllCallsOn: #instSizeChange" - " - NOTE: This code supports the backward-compatible extension to 8 bits of instSize. - When we revise the image format, it should become... - ^ ((format bitShift: -1) bitAnd: 16rFF) - 1 - Note also that every other method in this category will require - 2 bits more of right shift after the change. - " - ^ ((format bitShift: -10) bitAnd: 16rC0) + ((format bitShift: -1) bitAnd: 16r3F) - 1! Item was changed: ----- Method: Behavior>>instSpec (in category 'testing') ----- instSpec + "Answer the instance specification part of the format that defines what kind of object + an instance of the receiver is. The formats are + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6 = unused + 7 = immediates (SmallInteger, Character) + 8 = unused + 9 = 64-bit indexable + 10-11 = 32-bit indexable (Bitmap) + 12-15 = 16-bit indexable + 16-23 = 8-bit indexable + 24-31 = compiled methods (CompiledMethod)" + ^(format bitShift: -16) bitAnd: 16r1F! - ^ (format bitShift: -7) bitAnd: 16rF! Item was changed: ----- Method: Behavior>>isBits (in category 'testing') ----- isBits + "Answer whether the receiver contains just bits (not pointers). + Above Cog Spur the class format is + <5 bits inst spec><16 bits inst size> + where the 5-bit inst spec is + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6 = unused + 7 = immediates (SmallInteger, Character) + 8 = unused + 9 = 64-bit indexable + 10-11 = 32-bit indexable (Bitmap) + 12-15 = 16-bit indexable + 16-23 = 8-bit indexable + 24-31 = compiled methods (CompiledMethod)" + ^self instSpec >= 7! - "Answer whether the receiver contains just bits (not pointers)." - - ^ self instSpec >= 6! Item was changed: ----- Method: Behavior>>isBytes (in category 'testing') ----- isBytes + "Answer whether the receiver has 8-bit instance variables. + Above Cog Spur the class format is + <5 bits inst spec><16 bits inst size> + where the 5-bit inst spec is + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6 = unused + 7 = immediates (SmallInteger, Character) + 8 = unused + 9 = 64-bit indexable + 10-11 = 32-bit indexable (Bitmap) + 12-15 = 16-bit indexable + 16-23 = 8-bit indexable + 24-31 = compiled methods (CompiledMethod)" + ^self instSpec >= 16! - "Answer whether the receiver has 8-bit instance variables." - - ^ self instSpec >= 8! Item was added: + ----- Method: Behavior>>isCompiledMethodClass (in category 'as yet unclassified') ----- + isCompiledMethodClass + "Answer whether the receiver has compiled method instances that mix pointers and bytes." + ^self instSpec >= 24! Item was added: + ----- Method: Behavior>>isEphemeronClass (in category 'testing') ----- + isEphemeronClass + "Answer whether the receiver has ephemeral instance variables. The garbage collector will + fire (queue for finalization) any ephemeron whose first instance variable is not referenced + other than from the transitive closure of references from ephemerons. Hence referring to + an object from the first inst var of an ephemeron will cause the ephemeron to fire when + the rest of the system does not refer to the object and that object is ready to be collected. + Since references from the remaining inst vars of an ephemeron will not prevent the ephemeron + from firing, ephemerons may act as the associations in weak dictionaries such that the value + (e.g. properties attached to the key) will not prevent firing when the key is no longer referenced + other than from ephemerons. Ephemerons can therefore be used to implement instance-based + pre-mortem finalization." + ^self instSpec = 5! Item was added: + ----- Method: Behavior>>isImmediateClass (in category 'testing') ----- + isImmediateClass + "Answer whether the receiver has immediate instances. Immediate instances + store their value in their object pointer, not in an object body. Hence immediates + take no space and are immutable. The immediates are distinguished by tag bits + in the pointer. They include SmallIntegers and Characters. Hence in the 32-bit + system SmallIntegers are 31-bit signed integers and Characters are 30-bit + unsigned character codes." + ^self instSpec = 7! Item was changed: ----- Method: Behavior>>isVariable (in category 'testing') ----- isVariable + "Answer whether the receiver has indexable variables. + Above Cog Spur the class format is + <5 bits inst spec><16 bits inst size> + where the 5-bit inst spec is + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6 = unused + 7 = immediates (SmallInteger, Character) + 8 = unused + 9 = 64-bit indexable + 10-11 = 32-bit indexable (Bitmap) + 12-15 = 16-bit indexable + 16-23 = 8-bit indexable + 24-31 = compiled methods (CompiledMethod)" + | instSpec | + instSpec := self instSpec. + ^instSpec >= 2 and: [instSpec <= 4 or: [instSpec >= 9]]! - "Answer whether the receiver has indexable variables." - - ^ self instSpec >= 2! Item was changed: ----- Method: Behavior>>kindOfSubclass (in category 'testing class hierarchy') ----- kindOfSubclass + "Answer a String that is the keyword that describes the receiver's kind of subclass, + either a regular subclass, a variableSubclass, a variableByteSubclass, + a variableWordSubclass, a weakSubclass, an ephemeronSubclass or an immediateSubclass. + c.f. typeOfClass" + ^self isVariable + ifTrue: + [self isBits + ifTrue: + [self isBytes + ifTrue: [' variableByteSubclass: '] + ifFalse: [' variableWordSubclass: ']] + ifFalse: + [self isWeak + ifTrue: [' weakSubclass: '] + ifFalse: [' variableSubclass: ']]] + ifFalse: + [self isImmediateClass + ifTrue: [' immediateSubclass: '] + ifFalse: + [self isEphemeronClass + ifTrue: [' ephemeronSubclass: '] + ifFalse: [' subclass: ']]]! - "Answer a String that is the keyword that describes the receiver's kind - of subclass, either a regular subclass, a variableSubclass, a - variableByteSubclass, a variableWordSubclass, or a weakSubclass." - self isWeak - ifTrue: [^ ' weakSubclass: ']. - ^ self isVariable - ifTrue: [self isBits - ifTrue: [self isBytes - ifTrue: [ ' variableByteSubclass: '] - ifFalse: [ ' variableWordSubclass: ']] - ifFalse: [ ' variableSubclass: ']] - ifFalse: [ ' subclass: ']! Item was changed: ----- Method: Behavior>>shouldNotBeRedefined (in category 'testing') ----- shouldNotBeRedefined + "Answer if the receiver should not be redefined. + The assumption is that classes in Smalltalk specialObjects and + instance-specific Behaviors should not be redefined" - "Return true if the receiver should not be redefined. - The assumption is that compact classes, - classes in Smalltalk specialObjects and - Behaviors should not be redefined" + ^(Smalltalk specialObjectsArray + identityIndexOf: self + ifAbsent: [(self isKindOf: self) ifTrue: [1] ifFalse: [0]]) ~= 0! - ^(Smalltalk compactClassesArray includes: self) - or:[(Smalltalk specialObjectsArray includes: self) - or:[self isKindOf: self]]! Item was changed: ----- Method: Behavior>>typeOfClass (in category 'accessing') ----- typeOfClass + "Answer a symbol uniquely describing the type of the receiver. c.f. kindOfSubclass" + self isBytes ifTrue: + [^self instSpec = CompiledMethod instSpec + ifTrue: [#compiledMethod] "Very special!!" + ifFalse: [#bytes]]. + (self isWords and: [self isPointers not]) ifTrue: + [^self instSpec = SmallInteger instSpec + ifTrue: [#immediate] "Very special!!" + ifFalse: [#words]]. + self isWeak ifTrue: [^#weak]. + self isVariable ifTrue: [^#variable]. + self isEphemeronClass ifTrue: [^#ephemeron]. + ^#normal! - "Answer a symbol uniquely describing the type of the receiver" - self instSpec = CompiledMethod instSpec ifTrue:[^#compiledMethod]. "Very special!!" - self isBytes ifTrue:[^#bytes]. - (self isWords and:[self isPointers not]) ifTrue:[^#words]. - self isWeak ifTrue:[^#weak]. - self isVariable ifTrue:[^#variable]. - ^#normal.! Item was changed: ----- Method: BlockClosure>>simulateValueWithArguments:caller: (in category 'system simulation') ----- simulateValueWithArguments: anArray caller: aContext + "Simulate the valueWithArguments: primitive. Fail if anArray is not an array of the right arity." | newContext sz | - (anArray class ~~ Array - or: [numArgs ~= anArray size]) ifTrue: - [^ContextPart primitiveFailTokenFor: nil]. newContext := (MethodContext newForMethod: outerContext method) setSender: aContext receiver: outerContext receiver method: outerContext method closure: self startpc: startpc. + ((newContext objectClass: anArray) ~~ Array + or: [numArgs ~= anArray size]) ifTrue: + [^ContextPart primitiveFailTokenFor: nil]. sz := self basicSize. newContext stackp: sz + numArgs. 1 to: numArgs do: [:i| newContext at: i put: (anArray at: i)]. 1 to: sz do: [:i| newContext at: i + numArgs put: (self at: i)]. ^newContext! Item was added: + Float variableWordSubclass: #BoxedFloat64 + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'Kernel-Numbers'! + + !BoxedFloat64 commentStamp: 'eem 11/25/2014 07:54' prior: 0! + My instances hold 64-bit Floats in heap objects. This is the only representation on 32-bit systems. But on 64-bit systems SmallFloat64 holds a subset of the full 64-bit double-precision range in immediate objects.! Item was added: + ----- Method: BoxedFloat64 class>>basicNew (in category 'instance creation') ----- + basicNew + ^self basicNew: 2! Item was added: + ----- Method: BoxedFloat64 class>>basicNew: (in category 'instance creation') ----- + basicNew: sizeRequested + "Primitive. Answer an instance of this class with the number + of indexable variables specified by the argument, sizeRequested. + Fail if this class is not indexable or if the argument is not a + positive Integer, or if there is not enough memory available. + Essential. See Object documentation whatIsAPrimitive." + + <primitive: 71> + sizeRequested isInteger ifTrue: + [^sizeRequested = 2 + ifTrue: "arg okay; space must be low." + [OutOfMemory signal. + self basicNew: sizeRequested] "retry if user proceeds" + ifFalse: + [self error: 'a Float shall always have two slots']]. + self primitiveFailed! Item was added: + ----- Method: BoxedFloat64>>* (in category 'arithmetic') ----- + * aNumber + "Primitive. Answer the result of multiplying the receiver by aNumber. + Fail if the argument is not a Float. Essential. See Object documentation + whatIsAPrimitive." + + <primitive: 49> + ^ aNumber adaptToFloat: self andSend: #*! Item was added: + ----- Method: BoxedFloat64>>+ (in category 'arithmetic') ----- + + aNumber + "Primitive. Answer the sum of the receiver and aNumber. Essential. + Fail if the argument is not a Float. See Object documentation + whatIsAPrimitive." + + <primitive: 41> + ^ aNumber adaptToFloat: self andSend: #+! Item was added: + ----- Method: BoxedFloat64>>- (in category 'arithmetic') ----- + - aNumber + "Primitive. Answer the difference between the receiver and aNumber. + Fail if the argument is not a Float. Essential. See Object documentation + whatIsAPrimitive." + + <primitive: 42> + ^ aNumber adaptToFloat: self andSend: #-! Item was added: + ----- Method: BoxedFloat64>>/ (in category 'arithmetic') ----- + / aNumber + "Primitive. Answer the result of dividing receiver by aNumber. + Fail if the argument is not a Float. Essential. See Object documentation + whatIsAPrimitive." + + <primitive: 50> + aNumber isZero ifTrue: [^(ZeroDivide dividend: self) signal]. + ^ aNumber adaptToFloat: self andSend: #/! Item was added: + ----- Method: BoxedFloat64>>< (in category 'comparing') ----- + < aNumber + "Primitive. Compare the receiver with the argument and return true + if the receiver is less than the argument. Otherwise return false. + Fail if the argument is not a Float. Essential. See Object documentation + whatIsAPrimitive." + + <primitive: 43> + ^ aNumber adaptToFloat: self andCompare: #<! Item was added: + ----- Method: BoxedFloat64>><= (in category 'comparing') ----- + <= aNumber + "Primitive. Compare the receiver with the argument and return true + if the receiver is less than or equal to the argument. Otherwise return + false. Fail if the argument is not a Float. Optional. See Object + documentation whatIsAPrimitive." + + <primitive: 45> + ^ aNumber adaptToFloat: self andCompare: #<=! Item was added: + ----- Method: BoxedFloat64>>= (in category 'comparing') ----- + = aNumber + "Primitive. Compare the receiver with the argument and return true + if the receiver is equal to the argument. Otherwise return false. + Fail if the argument is not a Float. Essential. See Object documentation + whatIsAPrimitive." + + <primitive: 47> + aNumber isNumber ifFalse: [^ false]. + ^ aNumber adaptToFloat: self andCompare: #=! Item was added: + ----- Method: BoxedFloat64>>> (in category 'comparing') ----- + > aNumber + "Primitive. Compare the receiver with the argument and return true + if the receiver is greater than the argument. Otherwise return false. + Fail if the argument is not a Float. Essential. See Object documentation + whatIsAPrimitive." + + <primitive: 44> + ^ aNumber adaptToFloat: self andCompare: #>! Item was added: + ----- Method: BoxedFloat64>>>= (in category 'comparing') ----- + >= aNumber + "Primitive. Compare the receiver with the argument and return true + if the receiver is greater than or equal to the argument. Otherwise return + false. Fail if the argument is not a Float. Optional. See Object documentation + whatIsAPrimitive. " + + <primitive: 46> + ^ aNumber adaptToFloat: self andCompare: #>=! Item was added: + ----- Method: BoxedFloat64>>arcTan (in category 'mathematical functions') ----- + arcTan + "Answer the angle in radians. + Optional. See Object documentation whatIsAPrimitive." + + | theta eps step sinTheta cosTheta | + <primitive: 57> + + "Newton-Raphson" + self < 0.0 ifTrue: [ ^ 0.0 - (0.0 - self) arcTan ]. + + "first guess" + theta := (self * Halfpi) / (self + 1.0). + + "iterate" + eps := Halfpi * Epsilon. + step := theta. + [(step * step) > eps] whileTrue: [ + sinTheta := theta sin. + cosTheta := theta cos. + step := (sinTheta * cosTheta) - (self * cosTheta * cosTheta). + theta := theta - step]. + ^ theta! Item was added: + ----- Method: BoxedFloat64>>exp (in category 'mathematical functions') ----- + exp + "Answer E raised to the receiver power. + Optional. See Object documentation whatIsAPrimitive." + + | base fract correction delta div | + <primitive: 59> + + "Taylor series" + "check the special cases" + self < 0.0 ifTrue: [^ (self negated exp) reciprocal]. + self = 0.0 ifTrue: [^ 1]. + self abs > MaxValLn ifTrue: [self error: 'exp overflow']. + + "get first approximation by raising e to integer power" + base := E raisedToInteger: (self truncated). + + "now compute the correction with a short Taylor series" + "fract will be 0..1, so correction will be 1..E" + "in the worst case, convergance time is logarithmic with 1/Epsilon" + fract := self fractionPart. + fract = 0.0 ifTrue: [ ^ base ]. "no correction required" + + correction := 1.0 + fract. + delta := fract * fract / 2.0. + div := 2.0. + [delta > Epsilon] whileTrue: [ + correction := correction + delta. + div := div + 1.0. + delta := delta * fract / div]. + correction := correction + delta. + ^ base * correction! Item was added: + ----- Method: BoxedFloat64>>exponent (in category 'truncation and round off') ----- + exponent + "Primitive. Consider the receiver to be represented as a power of two + multiplied by a mantissa (between one and two). Answer with the + SmallInteger to whose power two is raised. Optional. See Object + documentation whatIsAPrimitive." + + <primitive: 53> + ^self exponentFromBitPattern! Item was added: + ----- Method: BoxedFloat64>>fractionPart (in category 'truncation and round off') ----- + fractionPart + "Primitive. Answer a Float whose value is the difference between the + receiver and the receiver's asInteger value. Optional. See Object + documentation whatIsAPrimitive." + + <primitive: 52> + ^self - self truncated asFloat! Item was added: + ----- Method: BoxedFloat64>>ln (in category 'mathematical functions') ----- + ln + "Answer the natural logarithm of the receiver. + Optional. See Object documentation whatIsAPrimitive." + + | expt n mant x div pow delta sum eps | + <primitive: 58> + + "Taylor series" + self <= 0.0 ifTrue: [DomainError signal: 'ln is only defined for x > 0.0']. + + "get a rough estimate from binary exponent" + expt := self exponent. + n := Ln2 * expt. + mant := self timesTwoPower: 0 - expt. + + "compute fine correction from mantinssa in Taylor series" + "mant is in the range [0..2]" + "we unroll the loop to avoid use of abs" + x := mant - 1.0. + div := 1.0. + pow := delta := sum := x. + x := x negated. "x <= 0" + eps := Epsilon * (n abs + 1.0). + [delta > eps] whileTrue: [ + "pass one: delta is positive" + div := div + 1.0. + pow := pow * x. + delta := pow / div. + sum := sum + delta. + "pass two: delta is negative" + div := div + 1.0. + pow := pow * x. + delta := pow / div. + sum := sum + delta]. + + ^ n + sum + + "2.718284 ln 1.0"! Item was added: + ----- Method: BoxedFloat64>>sin (in category 'mathematical functions') ----- + sin + "Answer the sine of the receiver taken as an angle in radians. + Optional. See Object documentation whatIsAPrimitive." + + | sum delta self2 i | + <primitive: 56> + + "Taylor series" + "normalize to the range [0..Pi/2]" + self < 0.0 ifTrue: [^ (0.0 - ((0.0 - self) sin))]. + self > Twopi ifTrue: [^ (self \\ Twopi) sin]. + self > Pi ifTrue: [^ (0.0 - (self - Pi) sin)]. + self > Halfpi ifTrue: [^ (Pi - self) sin]. + + "unroll loop to avoid use of abs" + sum := delta := self. + self2 := 0.0 - (self * self). + i := 2.0. + [delta > Epsilon] whileTrue: [ + "once" + delta := (delta * self2) / (i * (i + 1.0)). + i := i + 2.0. + sum := sum + delta. + "twice" + delta := (delta * self2) / (i * (i + 1.0)). + i := i + 2.0. + sum := sum + delta]. + ^ sum! Item was added: + ----- Method: BoxedFloat64>>sqrt (in category 'mathematical functions') ----- + sqrt + "Answer the square root of the receiver. + Optional. See Object documentation whatIsAPrimitive." + | exp guess eps delta | + <primitive: 55> + #Numeric. + "Changed 200/01/19 For ANSI <number> support." + "Newton-Raphson" + self <= 0.0 + ifTrue: [self = 0.0 + ifTrue: [^ 0.0] + ifFalse: ["v Chg" + ^ DomainError signal: 'sqrt undefined for number less than zero.']]. + "first guess is half the exponent" + exp := self exponent // 2. + guess := self timesTwoPower: 0 - exp. + "get eps value" + eps := guess * Epsilon. + eps := eps * eps. + delta := self - (guess * guess) / (guess * 2.0). + [delta * delta > eps] + whileTrue: + [guess := guess + delta. + delta := self - (guess * guess) / (guess * 2.0)]. + ^ guess! Item was added: + ----- Method: BoxedFloat64>>timesTwoPower: (in category 'mathematical functions') ----- + timesTwoPower: anInteger + "Primitive. Answer with the receiver multiplied by 2.0 raised + to the power of the argument. + Optional. See Object documentation whatIsAPrimitive." + + <primitive: 54> + + anInteger < -29 ifTrue: [^ self * (2.0 raisedToInteger: anInteger)]. + anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat]. + anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat]. + ^ self * (2.0 raisedToInteger: anInteger)! Item was added: + ----- Method: BoxedFloat64>>truncated (in category 'truncation and round off') ----- + truncated + "Answer with a SmallInteger equal to the value of the receiver without + its fractional part. The primitive fails if the truncated value cannot be + represented as a SmallInteger. In that case, the code below will compute + a LargeInteger truncated value. + Essential. See Object documentation whatIsAPrimitive. " + + <primitive: 51> + self isFinite ifFalse: [self error: 'Cannot truncate this number']. + + self abs < 2.0e16 + ifTrue: ["Fastest way when it may not be an integer" + | di df q r | + di := 1 + (SmallInteger maxVal bitShift: -1). + df := di asFloat. + q := self quo: df. + r := self - (q asFloat * df). + ^q * di + r truncated] + ifFalse: [^ self asTrueFraction. "Extract all bits of the mantissa and shift if necess"] + + + + ! Item was added: + ----- Method: BoxedFloat64>>~= (in category 'comparing') ----- + ~= aNumber + "Primitive. Compare the receiver with the argument and return true + if the receiver is not equal to the argument. Otherwise return false. + Fail if the argument is not a Float. Optional. See Object documentation + whatIsAPrimitive." + + <primitive: 48> + ^super ~= aNumber! Item was added: + ----- Method: Class>>immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'subclass creation') ----- + immediateSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat + "This is the standard initialization message for creating a new + immediate class as a subclass of an existing class (the receiver)." + ^ClassBuilder new + superclass: self + immediateSubclass: t + instanceVariableNames: f + classVariableNames: d + poolDictionaries: s + category: cat! Item was changed: ----- Method: ClassBuilder>>computeFormat:instSize:forSuper:ccIndex: (in category 'class format') ----- computeFormat: type instSize: newInstSize forSuper: newSuper ccIndex: ccIndex "Compute the new format for making oldClass a subclass of newSuper. + Answer the format or nil if there is any problem." - Return the format or nil if there is any problem." | instSize isVar isWords isPointers isWeak | type == #compiledMethod ifTrue: + [newInstSize > 0 ifTrue: + [self error: 'A compiled method class cannot have named instance variables'. + ^nil]. + ^CompiledMethod format]. - [^(CompiledMethod format - bitClear: (16r1F bitShift: 11)) - bitOr: (ccIndex bitShift: 11)]. instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]). + instSize > 65535 ifTrue: - instSize > 254 ifTrue: [self error: 'Class has too many instance variables (', instSize printString,')'. ^nil]. type == #normal ifTrue:[isVar := isWeak := false. isWords := isPointers := true]. type == #bytes ifTrue:[isVar := true. isWords := isPointers := isWeak := false]. type == #words ifTrue:[isVar := isWords := true. isPointers := isWeak := false]. type == #variable ifTrue:[isVar := isPointers := isWords := true. isWeak := false]. type == #weak ifTrue:[isVar := isWeak := isWords := isPointers := true]. + type == #ephemeron ifTrue:[isVar := false. isWeak := isWords := isPointers := true]. + type == #immediate ifTrue:[isVar := isWeak := isPointers := false. isWords := true]. + (isPointers not and: [instSize > 0]) ifTrue: + [self error: 'A non-pointer class cannot have named instance variables'. - (isPointers not and:[instSize > 0]) ifTrue: - [self error:'A non-pointer class cannot have instance variables'. ^nil]. + ^self format: instSize variable: isVar words: isWords pointers: isPointers weak: isWeak! - ^(self format: instSize - variable: isVar - words: isWords - pointers: isPointers - weak: isWeak) + (ccIndex bitShift: 11).! Item was changed: ----- Method: ClassBuilder>>format:variable:words:pointers:weak: (in category 'class format') ----- + format: nInstVars variable: isVar words: is32BitWords pointers: isPointers weak: isWeak + "Compute the format for the given instance specfication. + Above Cog Spur the class format is + <5 bits inst spec><16 bits inst size> + where the 5-bit inst spec is + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6 = unused + 7 = immediates (SmallInteger, Character) + 8 = unused + 9 = reserved for 64-bit indexable + 10-11 = 32-bit indexable (Bitmap) + 12-15 = 16-bit indexable + 16-23 = 8-bit indexable + 24-31 = compiled methods (CompiledMethod)" + | instSpec | - format: nInstVars variable: isVar words: isWords pointers: isPointers weak: isWeak - "Compute the format for the given instance specfication." - | cClass instSpec sizeHiBits fmt | - self flag: #instSizeChange. - " - Smalltalk browseAllCallsOn: #instSizeChange. - Smalltalk browseAllImplementorsOf: #fixedFieldsOf:. - Smalltalk browseAllImplementorsOf: #instantiateClass:indexableSize:. - " - " - NOTE: This code supports the backward-compatible extension to 8 bits of instSize. - For now the format word is... - <2 bits=instSize//64><5 bits=cClass><4 bits=instSpec><6 bits=instSize\\64><1 bit=0> - But when we revise the image format, it should become... - <5 bits=cClass><4 bits=instSpec><8 bits=instSize><1 bit=0> - " - sizeHiBits := (nInstVars+1) // 64. - cClass := 0. "for now" instSpec := isWeak + ifTrue: + [isVar + ifTrue: [4] + ifFalse: [5]] + ifFalse: + [isPointers + ifTrue: + [isVar + ifTrue: [nInstVars > 0 ifTrue: [3] ifFalse: [2]] + ifFalse: [nInstVars > 0 ifTrue: [1] ifFalse: [0]]] + ifFalse: + [isVar + ifTrue: [is32BitWords ifTrue: [10] ifFalse: [16]] + ifFalse: [7]]]. + ^(instSpec bitShift: 16) + nInstVars! - ifTrue:[4] - ifFalse:[isPointers - ifTrue: [isVar - ifTrue: [nInstVars>0 ifTrue: [3] ifFalse: [2]] - ifFalse: [nInstVars>0 ifTrue: [1] ifFalse: [0]]] - ifFalse: [isWords ifTrue: [6] ifFalse: [8]]]. - fmt := sizeHiBits. - fmt := (fmt bitShift: 5) + cClass. - fmt := (fmt bitShift: 4) + instSpec. - fmt := (fmt bitShift: 6) + ((nInstVars+1)\\64). "+1 since prim size field includes header" - fmt := (fmt bitShift: 1). "This shift plus integer bit lets wordSize work like byteSize" - ^fmt! Item was added: + ----- Method: ClassBuilder>>superclass:immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'public') ----- + superclass: aClass + immediateSubclass: t instanceVariableNames: f + classVariableNames: d poolDictionaries: s category: cat + "This is the standard initialization message for creating a + new immediate class as a subclass of an existing class." + | env | + aClass instSize > 0 + ifTrue: [^self error: 'cannot make an immediate subclass of a class with named fields']. + aClass isVariable + ifTrue: [^self error: 'cannot make an immediate subclass of a class with indexed instance variables']. + aClass isPointers + ifFalse: [^self error: 'cannot make an immediate subclass of a class without pointer fields']. + "Cope with pre-environment and environment versions. Simplify asap." + env := (Smalltalk classNamed: #EnvironmentRequest) + ifNil: [aClass environment] + ifNotNil: [:erc| erc signal ifNil: [aClass environment]]. + ^self + name: t + inEnvironment: env + subclassOf: aClass + type: #immediate + instanceVariableNames: f + classVariableNames: d + poolDictionaries: s + category: cat! Item was changed: ----- Method: ClassBuilder>>update:to: (in category 'class mutation') ----- update: oldClass to: newClass + "Convert oldClass, all its instances and possibly its meta class into newClass, + instances of newClass and possibly its meta class. The process is surprisingly + simple in its implementation and surprisingly complex in its nuances and potentially + bad side effects. + We can rely on two assumptions (which are critical): + #1: The method #updateInstancesFrom: will not create any lasting pointers to + 'old' instances ('old' is quote on quote since #updateInstancesFrom: will do + a become of the old vs. the new instances and therefore it will not create + pointers to *new* instances before the #become: which are *old* afterwards) + #2: The non-preemptive execution of the critical piece of code guarantees that + nobody can get a hold by 'other means' (such as process interruption and + reflection) on the old instances. + Given the above two, we know that after #updateInstancesFrom: there are no pointers + to any old instances. After the forwarding become there will be no pointers to the old + class or meta class either. + Andreas Raab, 2/27/2003 23:42" - "Convert oldClass, all its instances and possibly its meta class into newClass, instances of newClass and possibly its meta class. The process is surprisingly simple in its implementation and surprisingly complex in its nuances and potentially bad side effects. - We can rely on two assumptions (which are critical): - #1: The method #updateInstancesFrom: will not create any lasting pointers to 'old' instances ('old' is quote on quote since #updateInstancesFrom: will do a become of the old vs. the new instances and therefore it will not create pointers to *new* instances before the #become: which are *old* afterwards) - #2: The non-preemptive execution of the critical piece of code guarantees that nobody can get a hold by 'other means' (such as process interruption and reflection) on the old instances. - Given the above two, we know that after #updateInstancesFrom: there are no pointer to any old instances. After the forwarding become there will be no pointers to the old class or meta class either. Meaning that if we throw in a nice fat GC at the end of the critical block, everything will be gone (but see the comment right there). There's no need to worry. - " | meta | meta := oldClass isMeta. "Note: Everything from here on will run without the ability to get interrupted to prevent any other process to create new instances of the old class." + ["Note: The following removal may look somewhat obscure and needs an explanation. + When we mutate the class hierarchy we create new classes for any existing subclass. + So it may look as if we don't have to remove the old class from its superclass. However, + at the top of the hierarchy (the first class we reshape) that superclass itself is not newly + created so therefore it will hold both the oldClass and newClass in its (obsolete or not) + subclasses. Since the #become: below will transparently replace the pointers to oldClass + with newClass the superclass would have newClass in its subclasses TWICE. With rather + unclear effects if we consider that we may convert the meta-class hierarchy itself (which + is derived from the non-meta class hierarchy). + Due to this problem ALL classes are removed from their superclass just prior to converting + them. Here, breaking the superclass/subclass invariant really doesn't matter since we will + effectively remove the oldClass (becomeForward:) just a few lines below." - [ - "Note: The following removal may look somewhat obscure and needs an explanation. When we mutate the class hierarchy we create new classes for any existing subclass. So it may look as if we don't have to remove the old class from its superclass. However, at the top of the hierarchy (the first class we reshape) that superclass itself is not newly created so therefore it will hold both the oldClass and newClass in its (obsolete or not) subclasses. Since the #become: below will transparently replace the pointers to oldClass with newClass the superclass would have newClass in its subclasses TWICE. With rather unclear effects if we consider that we may convert the meta-class hierarchy itself (which is derived from the non-meta class hierarchy). - Due to this problem ALL classes are removed from their superclass just prior to converting them. Here, breaking the superclass/subclass invariant really doesn't matter since we will effectively remove the oldClass (become+GC) just a few lines below." oldClass superclass removeSubclass: oldClass. oldClass superclass removeObsoleteSubclass: oldClass. "make sure that the VM cache is clean" oldClass methodDict do: [:cm | cm flushCache]. "Convert the instances of oldClass into instances of newClass" newClass updateInstancesFrom: oldClass. meta ifTrue: [oldClass becomeForward: newClass. oldClass updateMethodBindingsTo: oldClass binding] ifFalse: [{oldClass. oldClass class} elementsForwardIdentityTo: {newClass. newClass class}. oldClass updateMethodBindingsTo: oldClass binding. oldClass class updateMethodBindingsTo: oldClass class binding]. + "eem 5/31/2014 07:22 At this point there used to be a garbage collect whose purpose was + to ensure no old instances existed after the becomeForward:. Without the GC it was possible + to resurrect old instances using e.g. allInstancesDo:. This was because the becomeForward: + updated references from the old objects to new objects but didn't destroy the old objects. + But as of late 2013/early 2014 becomeForward: has been modified to free all the old objects."] + valueUnpreemptively! - Smalltalk garbageCollect. - - "Warning: Read this before you even think about removing the GC. Yes, it slows us down. Quite heavily if you have a large image. However, there's no good and simple alternative here, since unfortunately, #become: does change class pointers. What happens is that after the above become all of the instances of the old class will have a class pointer identifying them as instances of newClass. If we get our hands on any of these instances we will break immediately since their expected instance layout (that of its class, e.g., newClass) will not match their actual instance layout (that of oldClass). And getting your hands on any of those instances is really simple - just reshaping one class two times in rapid succession will do it. Reflection techniques, interrupts, etc. will only add to this problem. In the case of Metaclass things get even worse since when we recompile the entire class hierarchy we will recompile both, Metaclass and its instances (and some of its instances will have the old and some the new layout). - - The only easy solution to this problem would be to 'fix up' the class pointers of the old instances to point to the old class (using primitiveChangeClassTo:). But this won't work either - as we do a one-way become we would have to search the entire object memory for the oldClass and couldn't even clearly identify it unless we give it some 'special token' which sounds quite error-prone. If you really need to get rid of the GC here are some alternatives: - - On the image level, one could create a copy of the oldClass before becoming it into the new class and, after becoming it, 'fix up' the old instances. That would certainly work but it sounds quite complex, as we need to make sure we're not breaking any of the superclass/subclass meta/non-meta class variants. - - Alternatively, fix up #becomeForward on the VM-level to 'dump the source objects' of #become. This would be quite doable (just 'convert' them into a well known special class such as bitmap) yet it has problems if (accidentally or not) one of the objects in #become: appears on 'both sides of the fence' (right now, this will work ... in a way ... even though the consequences are unclear). - - Another alternative is to provide a dedicated primitive for this (instead of using it implicitly in become) which would allow us to dump all the existing instances right here. This is equivalent to a more general primitiveChangeClassTo: and might be worthwhile but it would likely have to keep in mind the differences between bits and pointer thingies etc. - - Since all of the alternatives seem rather complex and magical compared to a straight-forward GC it seems best to stick with the GC solution for now. If someone has a real need to fix this problem, that person will likely be motivated enough to check out the alternatives. Personally I'd probably go for #1 (copy the old class and remap the instances to it) since it's a solution that could be easily reverted from within the image if there's any problem with it." - - ] valueUnpreemptively. - ! Item was changed: ----- Method: ClassDescription>>updateInstances:from:isMeta: (in category 'initialize-release') ----- updateInstances: oldInstances from: oldClass isMeta: isMeta + "Recreate any existing instances of the argument, oldClass, as instances of the receiver, + which is a newly changed class. Permute variables as necessary, and forward old instances + to new instances. Answer nil to defeat old clients that expect an array of old instances. + The old behaviour, which necessitated a global GC, exchanged identities and answered + the old instances. But no clients used the result. This way we avoid the unnecessary GC," - "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary. Return the array of old instances (none of which should be pointed to legally by anyone but the array)." - "If there are any contexts having an old instance as receiver it might crash the system because the layout has changed, and the method only knows about the old layout." | map variable instSize newInstances | + oldInstances isEmpty ifTrue: + [^nil]. "no instances to convert" + isMeta ifTrue: + [(oldInstances size = 1 + and: [self soleInstance class == self]) ifFalse: + [^self error:'Metaclasses can only have one instance']]. - oldInstances isEmpty ifTrue:[^#()]. "no instances to convert" - isMeta ifTrue: [ - oldInstances size = 1 ifFalse:[^self error:'Metaclasses can only have one instance']. - self soleInstance class == self ifTrue:[ - ^self error:'Metaclasses can only have one instance']]. map := self instVarMappingFrom: oldClass. variable := self isVariable. instSize := self instSize. newInstances := Array new: oldInstances size. + 1 to: oldInstances size do: + [:i| + newInstances + at: i + put: (self newInstanceFrom: (oldInstances at: i) variable: variable size: instSize map: map)]. - 1 to: oldInstances size do:[:i| - newInstances at: i put: ( - self newInstanceFrom: (oldInstances at: i) variable: variable size: instSize map: map)]. "Now perform a bulk mutation of old instances into new ones" + oldInstances elementsForwardIdentityTo: newInstances. + ^nil! - oldInstances elementsExchangeIdentityWith: newInstances. - ^newInstances "which are now old"! Item was changed: ----- Method: ClassDescription>>updateInstancesFrom: (in category 'initialize-release') ----- updateInstancesFrom: oldClass "Recreate any existing instances of the argument, oldClass, as instances of + the receiver, which is a newly changed class. Permute variables as necessary, + and forward old instances to new instances.. Answer nil to defeat any clients + that expected the old behaviour of answering the array of old instances." - the receiver, which is a newly changed class. Permute variables as - necessary. Return the array of old instances (none of which should be - pointed to legally by anyone but the array)." "ar 7/15/1999: The updating below is possibly dangerous. If there are any contexts having an old instance as receiver it might crash the system if the new receiver in which the context is executed has a different layout. See bottom below for a simple example:" + self updateInstances: oldClass allInstances asArray from: oldClass isMeta: self isMeta. - | oldInstances | - oldInstances := oldClass allInstances asArray. - oldInstances := self updateInstances: oldInstances from: oldClass isMeta: self isMeta. "Now fix up instances in segments that are out on the disk." + ImageSegment allSubInstancesDo: + [:seg | - ImageSegment allSubInstancesDo: [:seg | seg segUpdateInstancesOf: oldClass toBe: self isMeta: self isMeta]. + ^nil - ^oldInstances + "This attempts to crash the VM by stepping off the end of an instance. + As the doctor says, do not do this." " | crashingBlock class | class := Object subclass: #CrashTestDummy instanceVariableNames: 'instVar' classVariableNames: '' poolDictionaries: '' category: 'Crash-Test'. class compile:'instVar: value instVar := value'. class compile:'crashingBlock ^[instVar]'. crashingBlock := (class new) instVar: 42; crashingBlock. Object subclass: #CrashTestDummy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Crash-Test'. + crashingBlock value"! - crashingBlock. - crashingBlock value. - " - ! Item was changed: ByteArray variableByteSubclass: #CompiledMethod instanceVariableNames: '' classVariableNames: 'LargeFrame PrimaryBytecodeSetEncoderClass SecondaryBytecodeSetEncoderClass SmallFrame' poolDictionaries: '' category: 'Kernel-Methods'! + !CompiledMethod commentStamp: 'eem 1/22/2015 15:47' prior: 0! + CompiledMethod instances are methods suitable for interpretation by the virtual machine. Instances of CompiledMethod and its subclasses are the only objects in the system that have both indexable pointer fields and indexable 8-bit integer fields. The first part of a CompiledMethod is pointers, the second part is bytes. CompiledMethod inherits from ByteArray to avoid duplicating some of ByteArray's methods, not because a CompiledMethod is-a ByteArray. - !CompiledMethod commentStamp: 'eem 5/12/2014 18:02' prior: 0! - My instances are methods suitable for interpretation by the virtual machine. This is the only class in the system whose instances have both indexable pointer fields and indexable 8-bit integer fields. The first part of a CompiledMethod is pointers, the second part is bytes. I'm a subclass of ByteArray to avoid duplicating some of ByteArray's methods, not because a CompiledMethod is-a ByteArray. Class variables: SmallFrame - the number of stack slots in a small frame Context LargeFrame - the number of stack slots in a large frame Context PrimaryBytecodeSetEncoderClass - the encoder class that defines the primary instruction set SecondaryBytecodeSetEncoderClass - the encoder class that defines the secondary instruction set The current format of a CompiledMethod is as follows: header (4 or 8 bytes, SmallInteger) + literals (4 or 8 bytes each, Object, see "The last literal..." below) - literals (4 or 8 bytes each, Object) bytecodes (variable, bytes) trailer (variable, bytes) + The header is a SmallInteger (which in the 32-bit system has 31 bits, and in the 64-bit system, 61 bits) in the following format: - The header is a 31-bit signed integer (a SmallInteger) with one of the two following formats, selected by the sign bit: + (index 0) 15 bits: number of literals (#numLiterals) + (index 15) 1 bit: is optimized - reserved for methods that have been optimized by Sista - sign bit 0, header >= 0: - (index 0) 9 bits: main part of primitive number (#primitive) - (index 9) 8 bits: number of literals (#numLiterals) - (index 17) 1 bit: whether a large frame size is needed (#frameSize) - (index 18) 6 bits: number of temporary variables (#numTemps) - (index 24) 4 bits: number of arguments to the method (#numArgs) - (index 28) 1 bit: high-bit of primitive number (#primitive) - (index 29) 1 bit: flag bit, ignored by the VM (#flag) - (index 30/63) sign bit: 0 selects the Primary instruction set (#signFlag) - sign bit 1, header < 0: - (index 0) 16 bits: number of literals (#numLiterals) (index 16) 1 bit: has primitive + (index 17) 1 bit: whether a large frame size is needed (#frameSize => either SmallFrame or LargeFrame) - (index 17) 1 bit: whether a large frame size is needed (#frameSize) (index 18) 6 bits: number of temporary variables (#numTemps) (index 24) 4 bits: number of arguments to the method (#numArgs) + (index 28) 2 bits: reserved for an access modifier (00-unused, 01-private, 10-protected, 11-public), although accessors for bit 29 exist (see #flag). + sign bit: 1 bit: selects the instruction set, >= 0 Primary, < 0 Secondary (#signFlag) - (index 28) 2 bits: reserved for an access modifier (00-unused, 01-private, 10-protected, 11-public) - (index 30/63) sign bit: 1 selects the Secondary instruction set (e.g. NewsqueakV4) (#signFlag) - i.e. the Secondary Bytecode Set expands the number of literals to 65535 by assuming a CallPrimitive bytecode. + If the method has a primitive then the first bytecode of the method must be a callPrimitive: bytecode that encodes the primitive index. + + The trailer is an encoding of an instance of CompiledMethodTrailer. It is typically used to encode the index into the source files array of the method's source, but may be used to encode other values, e.g. tempNames, source as a string, etc. See the class CompiledMethodTrailer. + + The last literal in a CompiledMethod must be its methodClassAssociation, a binding whose value is the class the method is installed in. The methodClassAssociation is used to implement super sends. If a method contains no super send then its methodClassAssociation may be nil (as would be the case for example of methods providing a pool of inst var accessors). By convention the penultimate literal of a method is either its selector or an instance of AdditionalMethodState. AdditionalMethodState holds any pragmas and properties of a method, but may also be used to add instance variables to a method, albeit ones held in the method's AdditionalMethodState. Subclasses of CompiledMethod that want to add state should subclass AdditionalMethodState to add the state they want, and implement methodPropertiesClass on the class side of the CompiledMethod subclass to answer the specialized subclass of AdditionalMethodState.! - The trailer is an encoding of an instance of CompiledMethodTrailer. It is typically used to encode the index into the source files array of the method's source, but may be used to encode other values, e.g. tempNames, source as a string, etc. See the class CompiledMethodTrailer.! Item was added: + ----- Method: CompiledMethod class>>handleFailingFailingNewMethod:header: (in category 'private') ----- + handleFailingFailingNewMethod: numberOfBytes header: headerWord + "This newMethod:header: gets sent after handleFailingBasicNew: has done a full + garbage collection and possibly grown memory. If this basicNew: fails then the + system really is low on space, so raise the OutOfMemory signal. + + Primitive. Answer an instance of this class with the number of indexable variables + specified by the argument, headerWord, and the number of bytecodes specified + by numberOfBytes. Fail if this if the arguments are not Integers, or if numberOfBytes + is negative, or if the receiver is not a CompiledMethod class, or if there is not enough + memory available. Essential. See Object documentation whatIsAPrimitive." + + <primitive: 79> + "space must be low." + OutOfMemory signal. + "retry if user proceeds" + ^self newMethod: numberOfBytes header: headerWord! Item was added: + ----- Method: CompiledMethod class>>handleFailingNewMethod:header: (in category 'private') ----- + handleFailingNewMethod: numberOfBytes header: headerWord + "This newMethod:header: gets sent after newMethod:header: has failed + and allowed a scavenging garbage collection to occur. The scavenging + collection will have happened as the VM is activating the (failing) basicNew:. + If handleFailingBasicNew: fails then the scavenge failed to reclaim sufficient + space and a global garbage collection is required. Retry after garbage + collecting and growing memory if necessary. + + Primitive. Answer an instance of this class with the number of indexable variables + specified by the argument, headerWord, and the number of bytecodes specified + by numberOfBytes. Fail if this if the arguments are not Integers, or if numberOfBytes + is negative, or if the receiver is not a CompiledMethod class, or if there is not enough + memory available. Essential. See Object documentation whatIsAPrimitive." + + <primitive: 79> + | bytesRequested | + bytesRequested := (headerWord bitAnd: 16rFFFF) + 1 * Smalltalk wordSize + numberOfBytes + 16. + Smalltalk garbageCollect < bytesRequested ifTrue: + [Smalltalk growMemoryByAtLeast: bytesRequested]. + "retry after global garbage collect and possible grow" + ^self handleFailingFailingNewMethod: numberOfBytes header: headerWord! Item was added: + ----- Method: CompiledMethod class>>installPrimaryBytecodeSet: (in category 'class initialization') ----- + installPrimaryBytecodeSet: aBytecodeEncoderSubclass + PrimaryBytecodeSetEncoderClass == aBytecodeEncoderSubclass ifTrue: + [^self]. + (aBytecodeEncoderSubclass inheritsFrom: BytecodeEncoder) ifFalse: + [self error: 'A bytecode set encoder is expected to be a subclass of BytecodeEncoder']. + (self allSubInstances + detect: [:m| m header >= 0 and: [m encoderClass ~~ aBytecodeEncoderSubclass]] + ifNone: []) ifNotNil: + [Warning signal: 'There are existing CompiledMethods with a different encoderClass.']. + PrimaryBytecodeSetEncoderClass := aBytecodeEncoderSubclass! Item was added: + ----- Method: CompiledMethod class>>installSecondaryBytecodeSet: (in category 'class initialization') ----- + installSecondaryBytecodeSet: aBytecodeEncoderSubclass + PrimaryBytecodeSetEncoderClass == aBytecodeEncoderSubclass ifTrue: + [^self]. + (aBytecodeEncoderSubclass inheritsFrom: BytecodeEncoder) ifFalse: + [self error: 'A bytecode set encoder is expected to be a subclass of BytecodeEncoder']. + (self allSubInstances + detect: [:m| m header < 0 and: [m encoderClass ~~ aBytecodeEncoderSubclass]] + ifNone: []) ifNotNil: + [Warning signal: 'There are existing CompiledMethods with a different encoderClass.']. + SecondaryBytecodeSetEncoderClass := aBytecodeEncoderSubclass! Item was changed: ----- Method: CompiledMethod class>>newBytes:trailerBytes:nArgs:nTemps:nStack:nLits:primitive: (in category 'instance creation') ----- newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex "Answer an instance of me. The header is specified by the message arguments. The remaining parts are not as yet determined." + | method pc | + nArgs > 15 ifTrue: + [^self error: 'Cannot compile -- too many arguments']. - | largeBit primBits | nTemps > 63 ifTrue: + [^self error: 'Cannot compile -- too many temporary variables']. + nLits > 65535 ifTrue: + [^self error: 'Cannot compile -- too many literals']. - [^ self error: 'Cannot compile -- too many temporary variables']. - nLits > 255 ifTrue: - [^ self error: 'Cannot compile -- too many literals']. - largeBit := (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0]. - primBits := primitiveIndex <= 16r1FF - ifTrue: [primitiveIndex] - ifFalse: ["For now the high bit of primitive no. is in the 29th bit of header" - primitiveIndex > 16r3FF ifTrue: [self error: 'prim num too large']. - (primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r200) bitShift: 19)]. + method := trailer + createMethod: numberOfBytes + class: self + header: (nArgs bitShift: 24) + + (nTemps bitShift: 18) + + ((nTemps + stackSize) > SmallFrame ifTrue: [1 bitShift: 17] ifFalse: [0]) + + nLits + + (primitiveIndex > 0 ifTrue: [1 bitShift: 16] ifFalse: [0]). + primitiveIndex > 0 ifTrue: + [pc := method initialPC. + method + at: pc + 0 put: method encoderClass callPrimitiveCode; + at: pc + 1 put: (primitiveIndex bitAnd: 16rFF); + at: pc + 2 put: (primitiveIndex bitShift: -8)]. + ^method! - ^trailer - createMethod: numberOfBytes - class: self - header: (nArgs bitShift: 24) + - (nTemps bitShift: 18) + - (largeBit bitShift: 17) + - (nLits bitShift: 9) + - primBits! Item was changed: ----- Method: CompiledMethod class>>newBytes:trailerBytes:nArgs:nTemps:nStack:nLits:primitive:flag: (in category 'instance creation') ----- newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex flag: flag "Answer an instance of me. The header is specified by the message arguments. The remaining parts are not as yet determined." + | method pc | + nArgs > 15 ifTrue: + [^self error: 'Cannot compile -- too many arguments']. - | largeBit primBits flagBit | nTemps > 63 ifTrue: + [^self error: 'Cannot compile -- too many temporary variables']. + nLits > 65535 ifTrue: + [^self error: 'Cannot compile -- too many literals']. - [^ self error: 'Cannot compile -- too many temporary variables']. - nLits > 255 ifTrue: - [^ self error: 'Cannot compile -- too many literals']. - largeBit := (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0]. + method := trailer + createMethod: numberOfBytes + class: self + header: (nArgs bitShift: 24) + + (nTemps bitShift: 18) + + ((nTemps + stackSize) > SmallFrame ifTrue: [1 bitShift: 17] ifFalse: [0]) + + nLits + + (primitiveIndex > 0 ifTrue: [1 bitShift: 16] ifFalse: [0]) + + (flag ifTrue: [1 bitShift: 29] ifFalse: [0]). + primitiveIndex > 0 ifTrue: + [pc := method initialPC. + method + at: pc + 0 put: method encoderClass callPrimitiveCode; + at: pc + 1 put: (primitiveIndex bitAnd: 16rFF); + at: pc + 2 put: (primitiveIndex bitShift: -8)]. + ^method! - "For now the high bit of the primitive no. is in a high bit of the header" - primBits := (primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r200) bitShift: 19). - - flagBit := flag ifTrue: [ 1 ] ifFalse: [ 0 ]. - - ^trailer - createMethod: numberOfBytes - class: self - header: (nArgs bitShift: 24) + - (nTemps bitShift: 18) + - (largeBit bitShift: 17) + - (nLits bitShift: 9) + - primBits + - (flagBit bitShift: 29)! Item was changed: ----- Method: CompiledMethod class>>newMethod:header: (in category 'instance creation') ----- + newMethod: numberOfBytes header: headerWord - newMethod: numberOfBytes header: headerWord "Primitive. Answer an instance of me. The number of literals (and other + information) is specified by the headerWord (see my class comment). + The first argument specifies the number of fields for bytecodes in the + method. Fail if either argument is not a SmallInteger, or if numberOfBytes + is negative, or if memory is low. Once the header of a method is set by + this primitive, it cannot be changed to change the number of literals. + Essential. See Object documentation whatIsAPrimitive." - information) is specified the headerWord. The first argument specifies - the number of fields for bytecodes in the method. Fail if either - argument is not a SmallInteger, or if numberOfBytes is negative. Once - the header of a method is set by this primitive, it cannot be changed in - any way. Essential. See Object documentation whatIsAPrimitive." + <primitive: 79 error: ec> + ec == #'insufficient object memory' ifTrue: + [^self handleFailingNewMethod: numberOfBytes header: headerWord]. - <primitive: 79> - (numberOfBytes isInteger and: - [headerWord isInteger and: - [numberOfBytes >= 0]]) ifTrue: [ - "args okay; space must be low" - OutOfMemory signal. - "retry if user proceeds" - ^ self newMethod: numberOfBytes header: headerWord - ]. ^self primitiveFailed! Item was changed: ----- Method: CompiledMethod class>>toReturnConstant:trailerBytes: (in category 'instance creation') ----- toReturnConstant: index trailerBytes: trailer "Answer an instance of me that is a quick return of the constant indexed in (true false nil -1 0 1 2)." + ^self newBytes: 3 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256 + index! - ^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256 + index - ! Item was changed: ----- Method: CompiledMethod class>>toReturnField:trailerBytes: (in category 'instance creation') ----- toReturnField: field trailerBytes: trailer "Answer an instance of me that is a quick return of the instance variable indexed by the argument, field." + ^self newBytes: 3 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 264 + field! - ^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 264 + field - ! Item was changed: ----- Method: CompiledMethod class>>toReturnSelfTrailerBytes: (in category 'instance creation') ----- toReturnSelfTrailerBytes: trailer "Answer an instance of me that is a quick return of the instance (^self)." + ^self newBytes: 3 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256! - ^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256 - ! Item was added: + ----- Method: CompiledMethod>>bytecodeSetName (in category 'accessing') ----- + bytecodeSetName + ^self encoderClass name copyReplaceAll: 'EncoderFor' with: ''! Item was changed: ----- Method: CompiledMethod>>headerDescription (in category 'literals') ----- headerDescription + "Answer a description containing the information about the form of the + receiver and the form of the context needed to run the receiver." - "Answer a description containing the information about the form of the - receiver and the form of the context needed to run the receiver." + ^(ByteString new: 128) writeStream + print: self header; cr; + nextPutAll: '"primitive: '; print: self primitive; cr; + nextPutAll: ' numArgs: '; print: self numArgs; cr; + nextPutAll: ' numTemps: '; print: self numTemps; cr; + nextPutAll: ' numLiterals: '; print: self numLiterals; cr; + nextPutAll: ' frameSize: '; print: self frameSize; cr; + nextPutAll: ' bytecodeSet: '; nextPutAll: self bytecodeSetName; + nextPut: $"; cr; + contents! - | s | - s := '' writeStream. - self header printOn: s. - s cr; nextPutAll: '"primitive: '. - self primitive printOn: s. - s cr; nextPutAll: ' numArgs: '. - self numArgs printOn: s. - s cr; nextPutAll: ' numTemps: '. - self numTemps printOn: s. - s cr; nextPutAll: ' numLiterals: '. - self numLiterals printOn: s. - s cr; nextPutAll: ' frameSize: '. - self frameSize printOn: s. - s cr; nextPutAll: ' isClosureCompiled: '. - self isBlueBookCompiled not printOn: s. - s nextPut: $"; cr. - ^ s contents! Item was changed: ----- Method: CompiledMethod>>numLiterals (in category 'accessing') ----- numLiterals "Answer the number of literals used by the receiver." + ^self header bitAnd: 16r7FFF! - | header | - ^(header := self header) < 0 - ifTrue: [header bitAnd: 65535] - ifFalse: [(header bitShift: -9) bitAnd: 16rFF]! Item was changed: ----- Method: CompiledMethod>>primitive (in category 'accessing') ----- primitive "Answer the primitive index associated with the receiver. + Zero indicates that this is not a primitive method." + | initialPC | + ^(self header anyMask: 65536) "Is the hasPrimitive? flag set?" + ifTrue: [(self at: (initialPC := self initialPC) + 1) + ((self at: initialPC + 2) bitShift: 8)] + ifFalse: [0]! - Zero indicates that this is not a primitive method. - In the original header format we currently allow 10 bits of primitive index, but they are - in two places for backward compatibility. In the new format the primitive index is in the - last two bytes of a three byte callPrimitive: bytecode. The time to unpack is negligible, - since the derived primitive function pointer full index is stored in the method cache." - | header initialPC | - ^(header := self header) < 0 - ifTrue: - [(header anyMask: 65536) "Is the hasPrimitive? flag set?" - ifTrue: [(self at: (initialPC := self initialPC) + 1) + ((self at: initialPC + 2) bitShift: 8)] - ifFalse: [0]] - ifFalse: - [(header bitAnd: 16r1FF) + ((header bitShift: -19) bitAnd: 16r200)]! Item was changed: ----- Method: ContextPart>>activateReturn:value: (in category 'private') ----- activateReturn: aContext value: value "Activate 'aContext return: value' in place of self, so execution will return to aContext's sender" + ^MethodContext + sender: self - ^ self - activateMethod: ContextPart theReturnMethod - withArgs: {value} receiver: aContext + method: MethodContext theReturnMethod + arguments: {value}! - class: aContext class! Item was changed: ----- Method: ContextPart>>doPrimitive:method:receiver:args: (in category 'private') ----- doPrimitive: primitiveIndex method: meth receiver: receiver args: arguments + "Simulate a primitive method whose index is primitiveIndex. The simulated receiver and + arguments are given as arguments to this message. If successful, push result and return + resuming context, else ^ {errCode, PrimitiveFailToken}. Any primitive which provokes + execution needs to be intercepted and simulated to avoid execution running away." - "Simulate a primitive method whose index is primitiveIndex. The - simulated receiver and arguments are given as arguments to this message. - If successful, push result and return resuming context, else ^ PrimitiveFailToken. - Any primitive which provokes execution needs to be intercepted and simulated - to avoid execution running away." | value | "Judicious use of primitive 19 (a null primitive that doesn't do anything) prevents the debugger from entering various run-away activities such as spawning a new process, etc. Injudicious use results in the debugger not being able to debug + interesting code, such as the debugger itself. hence use primitive 19 with care :-)" - interesting code, such as the debugger itself. hence use primtiive 19 with care :-)" "SystemNavigation new browseAllSelect: [:m| m primitive = 19]" primitiveIndex = 19 ifTrue: [ToolSet debugContext: self label:'Code simulation error' contents: nil]. + ((primitiveIndex between: 201 and: 222) + and: [(self objectClass: receiver) includesBehavior: BlockClosure]) ifTrue: + [((primitiveIndex between: 201 and: 205) "BlockClosure>>value[:value:...]" + or: [primitiveIndex between: 221 and: 222]) ifTrue: "BlockClosure>>valueNoContextSwitch[:]" + [^receiver simulateValueWithArguments: arguments caller: self]. + primitiveIndex = 206 ifTrue: "BlockClosure>>valueWithArguments:" + [^receiver simulateValueWithArguments: arguments first caller: self]]. - "ContextPart>>blockCopy:; simulated to get startpc right" - (primitiveIndex = 80 and: [(self objectClass: receiver) includesBehavior: ContextPart]) - ifTrue: [^self push: ((BlockContext newForMethod: receiver method) - home: receiver home - startpc: pc + 2 - nargs: (arguments at: 1))]. - (primitiveIndex = 81 and: [(self objectClass: receiver) == BlockContext]) "BlockContext>>value[:value:...]" - ifTrue: [^receiver pushArgs: arguments from: self]. - (primitiveIndex = 82 and: [(self objectClass: receiver) == BlockContext]) "BlockContext>>valueWithArguments:" - ifTrue: [^receiver pushArgs: arguments first from: self]. - primitiveIndex = 83 "afr 9/11/1998 19:50" "Object>>perform:[with:...]" - ifTrue: [^self send: arguments first - to: receiver - with: arguments allButFirst - super: false]. - primitiveIndex = 84 "afr 9/11/1998 19:50 & eem 8/18/2009 17:04" "Object>>perform:withArguments:" - ifTrue: [^self send: arguments first - to: receiver - with: (arguments at: 2) - startClass: nil]. - primitiveIndex = 100 "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:" - ifTrue: [^self send: arguments first - to: receiver - with: (arguments at: 2) - startClass: (arguments at: 3)]. + primitiveIndex = 83 ifTrue: "afr 9/11/1998 19:50" "Object>>perform:[with:...]" + [^self send: arguments first to: receiver with: arguments allButFirst super: false]. + primitiveIndex = 84 ifTrue: "afr 9/11/1998 19:50 & eem 8/18/2009 17:04" "Object>>perform:withArguments:" + [^self send: arguments first to: receiver with: (arguments at: 2) lookupIn: (self objectClass: receiver)]. + primitiveIndex = 100 ifTrue: "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:" + [^self send: arguments first to: receiver with: (arguments at: 2) lookupIn: (arguments at: 3)]. + "Mutex>>primitiveEnterCriticalSection Mutex>>primitiveTestAndSetOwnershipOfCriticalSection" (primitiveIndex = 186 or: [primitiveIndex = 187]) ifTrue: [| active effective | active := Processor activeProcess. effective := active effectiveProcess. "active == effective" value := primitiveIndex = 186 ifTrue: [receiver primitiveEnterCriticalSectionOnBehalfOf: effective] ifFalse: [receiver primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: effective]. + ^(self isPrimFailToken: value) - ^((self objectClass: value) == Array - and: [value size = 2 - and: [value first == PrimitiveFailToken]]) ifTrue: [value] ifFalse: [self push: value]]. + primitiveIndex = 188 ifTrue: "eem 5/27/2008 11:10 Object>>withArgs:executeMethod:" - ((primitiveIndex = 188 or: [primitiveIndex = 189]) "eem 10/6/2014 16:14 Object>>with:*executeMethod:" - and: [arguments last isQuick not]) ifTrue: "eem 5/27/2008 11:10 Object>>withArgs:executeMethod:" [^MethodContext sender: self receiver: receiver + method: (arguments at: 2) + arguments: (arguments at: 1)]. - method: arguments last - arguments: (primitiveIndex = 188 - ifTrue: [arguments at: 1] - ifFalse: [arguments allButLast])]. "Closure primitives" (primitiveIndex = 200 and: [self == receiver]) ifTrue: "ContextPart>>closureCopy:copiedValues:; simulated to get startpc right" [^self push: (BlockClosure outerContext: receiver startpc: pc + 2 numArgs: arguments first copiedValues: arguments last)]. - ((primitiveIndex between: 201 and: 205) "BlockClosure>>value[:value:...]" - or: [primitiveIndex between: 221 and: 222]) ifTrue: "BlockClosure>>valueNoContextSwitch[:]" - [^receiver simulateValueWithArguments: arguments caller: self]. - primitiveIndex = 206 ifTrue: "BlockClosure>>valueWithArguments:" - [^receiver simulateValueWithArguments: arguments first caller: self]. primitiveIndex = 118 ifTrue: "tryPrimitive:withArgs:; avoid recursing in the VM" [(arguments size = 2 and: [arguments first isInteger and: [(self objectClass: arguments last) == Array]]) ifFalse: [^ContextPart primitiveFailTokenFor: nil]. ^self doPrimitive: arguments first method: meth receiver: receiver args: arguments last]. value := primitiveIndex = 120 "FFI method" ifTrue: [(meth literalAt: 1) tryInvokeWithArguments: arguments] ifFalse: [primitiveIndex = 117 "named primitives" ifTrue: [self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments] + ifFalse: [receiver tryPrimitive: primitiveIndex withArgs: arguments]]. + + ^(self isPrimFailToken: value) - ifFalse: - [receiver tryPrimitive: primitiveIndex withArgs: arguments]]. - ^((self objectClass: value) == Array - and: [value size = 2 - and: [value first == PrimitiveFailToken]]) ifTrue: [value] ifFalse: [self push: value]! Item was added: + ----- Method: ContextPart>>isPrimFailToken: (in category 'private') ----- + isPrimFailToken: anObject + ^(self objectClass: anObject) == Array + and: [anObject size = 2 + and: [anObject first == PrimitiveFailToken]]! Item was added: + ----- Method: ContextPart>>send:to:with:lookupIn: (in category 'controlling') ----- + send: selector to: rcvr with: arguments lookupIn: lookupClass + "Simulate the action of sending a message with selector and arguments + to rcvr. The argument, lookupClass, is the class in which to lookup the + message. This is the receiver's class for normal messages, but for super + messages it will be some specific class related to the source method." + + | meth primIndex val ctxt | + (meth := lookupClass lookupSelector: selector) ifNil: + [^self send: #doesNotUnderstand: + to: rcvr + with: {Message selector: selector arguments: arguments} + lookupIn: lookupClass]. + (primIndex := meth primitive) > 0 ifTrue: + [val := self doPrimitive: primIndex method: meth receiver: rcvr args: arguments. + (self isPrimFailToken: val) ifFalse: + [^val]]. + (selector == #doesNotUnderstand: and: [lookupClass == ProtoObject]) ifTrue: + [^self error: 'Simulated message ', arguments first selector, ' not understood']. + ctxt := MethodContext sender: self receiver: rcvr method: meth arguments: arguments. + primIndex > 0 ifTrue: + [ctxt failPrimitiveWith: val]. + ^ctxt! Item was changed: ----- Method: ContextPart>>send:to:with:super: (in category 'controlling') ----- + send: selector to: rcvr with: arguments super: superFlag + "Simulate the action of sending a message with selector arguments + to rcvr. The argument, superFlag, tells whether the receiver of the + message was specified with 'super' in the source method." - send: selector to: rcvr with: args super: superFlag - "Simulate the action of sending a message with selector, selector, and - arguments, args, to receiver. The argument, superFlag, tells whether the - receiver of the message was specified with 'super' in the source method." + ^self send: selector + to: rcvr + with: arguments + lookupIn: (superFlag + ifTrue: [self method methodClassAssociation value superclass] + ifFalse: [self objectClass: rcvr])! - | class meth val ctxt | - class := superFlag - ifTrue: [self method methodClassAssociation value superclass] - ifFalse: [self objectClass: rcvr]. - meth := class lookupSelector: selector. - meth == nil ifTrue: - [^self - send: #doesNotUnderstand: - to: rcvr - with: (Array with: (Message selector: selector arguments: args)) - super: superFlag]. - val := self tryPrimitiveFor: meth receiver: rcvr args: args. - ((self objectClass: val) == Array - and: [val size = 2 - and: [val first == PrimitiveFailToken]]) ifFalse: - [^val]. - (selector == #doesNotUnderstand: - and: [class == ProtoObject]) ifTrue: - [^self error: 'Simulated message ' , (args at: 1) selector, ' not understood']. - ctxt := self activateMethod: meth withArgs: args receiver: rcvr class: class. - ((self objectClass: val) == Array - and: [val size = 2 - and: [val first == PrimitiveFailToken - and: [val last notNil - and: [(ctxt method at: ctxt pc) = 129 "long store temp"]]]]) ifTrue: - [ctxt at: ctxt stackPtr put: val last]. - ^ctxt! Item was changed: ----- Method: ContextPart>>tryNamedPrimitiveIn:for:withArgs: (in category 'private') ----- tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments + "Invoke the named primitive for aCompiledMethod, answering its result, or, + if the primiitve fails, answering the error code." - | selector theMethod spec receiverClass | <primitive: 218 error: ec> ec ifNotNil: ["If ec is an integer other than -1 there was a problem with primitive 218, not with the external primitive itself. -1 indicates a generic failure (where ec should be nil) but ec = nil means primitive 218 is not implemented. So interpret -1 to mean the external primitive failed with a nil error code." ec isInteger ifTrue: [ec = -1 ifTrue: [ec := nil] + ifFalse: [self primitiveFailed]]]. + ^self class primitiveFailTokenFor: ec! - ifFalse: [self primitiveFailed]]. - ^{PrimitiveFailToken. ec}]. - "Assume a nil error code implies the primitive is not implemented and fall back on the old code." - "Hack. Attempt to execute the named primitive from the given compiled method" - arguments size > 8 ifTrue: - [^{PrimitiveFailToken. nil}]. - selector := #( - tryNamedPrimitive - tryNamedPrimitive: - tryNamedPrimitive:with: - tryNamedPrimitive:with:with: - tryNamedPrimitive:with:with:with: - tryNamedPrimitive:with:with:with:with: - tryNamedPrimitive:with:with:with:with:with: - tryNamedPrimitive:with:with:with:with:with:with: - tryNamedPrimitive:with:with:with:with:with:with:with:) at: arguments size+1. - receiverClass := self objectClass: aReceiver. - theMethod := receiverClass lookupSelector: selector. - theMethod == nil ifTrue: - [^{PrimitiveFailToken. nil}]. - spec := theMethod literalAt: 1. - spec replaceFrom: 1 to: spec size with: (aCompiledMethod literalAt: 1) startingAt: 1. - Smalltalk unbindExternalPrimitives. - ^self object: aReceiver perform: selector withArguments: arguments inClass: receiverClass! Item was changed: + Number subclass: #Float - Number variableWordSubclass: #Float instanceVariableNames: '' classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 ThreePi Twopi' poolDictionaries: '' category: 'Kernel-Numbers'! !Float commentStamp: '<historical>' prior: 0! My instances represent IEEE-754 floating-point double-precision numbers. They have about 16 digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Squeak Float constants. This is great for teaching about numbers, but may be confusing to the average reader: 3r20.2 --> 6.66666666666667 8r20.2 --> 16.25 If you don't have access to the definition of IEEE-754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... sign 1 bit exponent 11 bits with bias of 1023 (16r3FF) to produce an exponent in the range -1023 .. +1024 - 16r000: significand = 0: Float zero significand ~= 0: Denormalized number (exp = -1024, no hidden '1' bit) - 16r7FF: significand = 0: Infinity significand ~= 0: Not A Number (NaN) representation mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE-754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. The single-precision format is... sign 1 bit exponent 8 bits, with bias of 127, to represent -126 to +127 - 0x0 and 0xFF reserved for Float zero (mantissa is ignored) - 16r7F reserved for Float underflow/overflow (mantissa is ignored) mantissa 24 bits, but only 23 are stored This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. Thanks to Rich Harmon for asking many questions and to Tim Olson, Bruce Cohen, Rick Zaccone and others for the answers that I have collected here.! Item was changed: ----- Method: Float class>>basicNew (in category 'instance creation') ----- basicNew + ^BoxedFloat64 basicNew: 2! - ^self basicNew: 2! Item was changed: ----- Method: Float class>>basicNew: (in category 'instance creation') ----- basicNew: anInteger + ^BoxedFloat64 basicNew: 2! - anInteger = 2 ifFalse: [^self error: 'a Float shall always have two slots']. - ^super basicNew: 2! Item was changed: ----- Method: Float class>>fromIEEE32Bit: (in category 'instance creation') ----- fromIEEE32Bit: word + "Convert the given 32 bit word (which is supposed to be a positive 32-bit value) from + a 32 bit IEEE floating point representation into an actual Squeak float object (being + 64 bits wide). Should only be used for conversion in FloatArrays or likewise objects." - "Convert the given 32 bit word (which is supposed to be a positive 32bit value) from a 32bit IEEE floating point representation into an actual Squeak float object (being 64bit wide). Should only be used for conversion in FloatArrays or likewise objects." + | sign mantissa exponent delta | + word <= 0 ifTrue: + [^word negative + ifTrue: [self error: 'Cannot deal with negative numbers'] + ifFalse: [self zero]]. - | sign mantissa exponent newFloat delta | - word negative ifTrue: [^ self error:'Cannot deal with negative numbers']. - word = 0 ifTrue: [^ Float zero]. sign := word bitAnd: 16r80000000. + word = sign ifTrue: + [^self negativeZero]. - word = sign ifTrue: [^self negativeZero]. exponent := ((word bitShift: -23) bitAnd: 16rFF) - 127. mantissa := word bitAnd: 16r7FFFFF. + exponent = 128 ifTrue: "Either NAN or INF" + [^mantissa = 0 + ifTrue: + [sign = 0 + ifTrue: [self infinity] + ifFalse: [self negativeInfinity]] + ifFalse: [self nan]]. - exponent = 128 ifTrue:["Either NAN or INF" - mantissa = 0 ifFalse:[^ Float nan]. - sign = 0 - ifTrue:[^ Float infinity] - ifFalse:[^ Float negativeInfinity]]. + exponent = -127 ifTrue: - exponent = -127 ifTrue: [ "gradual underflow (denormalized number) + Remove first bit of mantissa and adjust exponent" + [delta := mantissa highBit. + mantissa := (mantissa bitAnd: (1 bitShift: delta - 1) - 1) bitShift: 24 - delta. + exponent := exponent + delta - 23]. - Remove first bit of mantissa and adjust exponent" - delta := mantissa highBit. - mantissa := (mantissa bitAnd: (1 bitShift: delta - 1) - 1) bitShift: 24 - delta. - exponent := exponent + delta - 23]. "Create new float" + ^(self basicNew: 2) + basicAt: 1 put: ((sign bitOr: (1023 + exponent bitShift: 20)) bitOr: (mantissa bitShift: -3)); + basicAt: 2 put: ((mantissa bitAnd: 7) bitShift: 29); + * 1.0 "reduce to SmallFloat64 if possible"! - newFloat := self new: 2. - newFloat basicAt: 1 put: ((sign bitOr: (1023 + exponent bitShift: 20)) bitOr: (mantissa bitShift: -3)). - newFloat basicAt: 2 put: ((mantissa bitAnd: 7) bitShift: 29). - ^newFloat! Item was removed: - ----- Method: Float>>* (in category 'arithmetic') ----- - * aNumber - "Primitive. Answer the result of multiplying the receiver by aNumber. - Fail if the argument is not a Float. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 49> - ^ aNumber adaptToFloat: self andSend: #*! Item was removed: - ----- Method: Float>>+ (in category 'arithmetic') ----- - + aNumber - "Primitive. Answer the sum of the receiver and aNumber. Essential. - Fail if the argument is not a Float. See Object documentation - whatIsAPrimitive." - - <primitive: 41> - ^ aNumber adaptToFloat: self andSend: #+! Item was removed: - ----- Method: Float>>- (in category 'arithmetic') ----- - - aNumber - "Primitive. Answer the difference between the receiver and aNumber. - Fail if the argument is not a Float. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 42> - ^ aNumber adaptToFloat: self andSend: #-! Item was removed: - ----- Method: Float>>/ (in category 'arithmetic') ----- - / aNumber - "Primitive. Answer the result of dividing receiver by aNumber. - Fail if the argument is not a Float. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 50> - aNumber isZero ifTrue: [^(ZeroDivide dividend: self) signal]. - ^ aNumber adaptToFloat: self andSend: #/! Item was removed: - ----- Method: Float>>< (in category 'comparing') ----- - < aNumber - "Primitive. Compare the receiver with the argument and return true - if the receiver is less than the argument. Otherwise return false. - Fail if the argument is not a Float. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 43> - ^ aNumber adaptToFloat: self andCompare: #<! Item was removed: - ----- Method: Float>><= (in category 'comparing') ----- - <= aNumber - "Primitive. Compare the receiver with the argument and return true - if the receiver is less than or equal to the argument. Otherwise return - false. Fail if the argument is not a Float. Optional. See Object - documentation whatIsAPrimitive." - - <primitive: 45> - ^ aNumber adaptToFloat: self andCompare: #<=! Item was removed: - ----- Method: Float>>= (in category 'comparing') ----- - = aNumber - "Primitive. Compare the receiver with the argument and return true - if the receiver is equal to the argument. Otherwise return false. - Fail if the argument is not a Float. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 47> - aNumber isNumber ifFalse: [^ false]. - ^ aNumber adaptToFloat: self andCompare: #=! Item was removed: - ----- Method: Float>>> (in category 'comparing') ----- - > aNumber - "Primitive. Compare the receiver with the argument and return true - if the receiver is greater than the argument. Otherwise return false. - Fail if the argument is not a Float. Essential. See Object documentation - whatIsAPrimitive." - - <primitive: 44> - ^ aNumber adaptToFloat: self andCompare: #>! Item was removed: - ----- Method: Float>>>= (in category 'comparing') ----- - >= aNumber - "Primitive. Compare the receiver with the argument and return true - if the receiver is greater than or equal to the argument. Otherwise return - false. Fail if the argument is not a Float. Optional. See Object documentation - whatIsAPrimitive. " - - <primitive: 46> - ^ aNumber adaptToFloat: self andCompare: #>=! Item was removed: - ----- Method: Float>>arcTan (in category 'mathematical functions') ----- - arcTan - "Answer the angle in radians. - Optional. See Object documentation whatIsAPrimitive." - - | theta eps step sinTheta cosTheta | - <primitive: 57> - - "Newton-Raphson" - self < 0.0 ifTrue: [ ^ 0.0 - (0.0 - self) arcTan ]. - - "first guess" - theta := (self * Halfpi) / (self + 1.0). - - "iterate" - eps := Halfpi * Epsilon. - step := theta. - [(step * step) > eps] whileTrue: [ - sinTheta := theta sin. - cosTheta := theta cos. - step := (sinTheta * cosTheta) - (self * cosTheta * cosTheta). - theta := theta - step]. - ^ theta! Item was removed: - ----- Method: Float>>exp (in category 'mathematical functions') ----- - exp - "Answer E raised to the receiver power. - Optional. See Object documentation whatIsAPrimitive." - - | base fract correction delta div | - <primitive: 59> - - "Taylor series" - "check the special cases" - self < 0.0 ifTrue: [^ (self negated exp) reciprocal]. - self = 0.0 ifTrue: [^ 1]. - self abs > MaxValLn ifTrue: [self error: 'exp overflow']. - - "get first approximation by raising e to integer power" - base := E raisedToInteger: (self truncated). - - "now compute the correction with a short Taylor series" - "fract will be 0..1, so correction will be 1..E" - "in the worst case, convergance time is logarithmic with 1/Epsilon" - fract := self fractionPart. - fract = 0.0 ifTrue: [ ^ base ]. "no correction required" - - correction := 1.0 + fract. - delta := fract * fract / 2.0. - div := 2.0. - [delta > Epsilon] whileTrue: [ - correction := correction + delta. - div := div + 1.0. - delta := delta * fract / div]. - correction := correction + delta. - ^ base * correction! Item was removed: - ----- Method: Float>>exponent (in category 'truncation and round off') ----- - exponent - "Primitive. Consider the receiver to be represented as a power of two - multiplied by a mantissa (between one and two). Answer with the - SmallInteger to whose power two is raised. Optional. See Object - documentation whatIsAPrimitive." - - <primitive: 53> - ^self exponentFromBitPattern! Item was removed: - ----- Method: Float>>fractionPart (in category 'truncation and round off') ----- - fractionPart - "Primitive. Answer a Float whose value is the difference between the - receiver and the receiver's asInteger value. Optional. See Object - documentation whatIsAPrimitive." - - <primitive: 52> - ^self - self truncated asFloat! Item was removed: - ----- Method: Float>>ln (in category 'mathematical functions') ----- - ln - "Answer the natural logarithm of the receiver. - Optional. See Object documentation whatIsAPrimitive." - - | expt n mant x div pow delta sum eps | - <primitive: 58> - - "Taylor series" - self <= 0.0 ifTrue: [DomainError signal: 'ln is only defined for x > 0.0']. - - "get a rough estimate from binary exponent" - expt := self exponent. - n := Ln2 * expt. - mant := self timesTwoPower: 0 - expt. - - "compute fine correction from mantinssa in Taylor series" - "mant is in the range [0..2]" - "we unroll the loop to avoid use of abs" - x := mant - 1.0. - div := 1.0. - pow := delta := sum := x. - x := x negated. "x <= 0" - eps := Epsilon * (n abs + 1.0). - [delta > eps] whileTrue: [ - "pass one: delta is positive" - div := div + 1.0. - pow := pow * x. - delta := pow / div. - sum := sum + delta. - "pass two: delta is negative" - div := div + 1.0. - pow := pow * x. - delta := pow / div. - sum := sum + delta]. - - ^ n + sum - - "2.718284 ln 1.0"! Item was removed: - ----- Method: Float>>sin (in category 'mathematical functions') ----- - sin - "Answer the sine of the receiver taken as an angle in radians. - Optional. See Object documentation whatIsAPrimitive." - - | sum delta self2 i | - <primitive: 56> - - "Taylor series" - "normalize to the range [0..Pi/2]" - self < 0.0 ifTrue: [^ (0.0 - ((0.0 - self) sin))]. - self > Twopi ifTrue: [^ (self \\ Twopi) sin]. - self > Pi ifTrue: [^ (0.0 - (self - Pi) sin)]. - self > Halfpi ifTrue: [^ (Pi - self) sin]. - - "unroll loop to avoid use of abs" - sum := delta := self. - self2 := 0.0 - (self * self). - i := 2.0. - [delta > Epsilon] whileTrue: [ - "once" - delta := (delta * self2) / (i * (i + 1.0)). - i := i + 2.0. - sum := sum + delta. - "twice" - delta := (delta * self2) / (i * (i + 1.0)). - i := i + 2.0. - sum := sum + delta]. - ^ sum! Item was removed: - ----- Method: Float>>sqrt (in category 'mathematical functions') ----- - sqrt - "Answer the square root of the receiver. - Optional. See Object documentation whatIsAPrimitive." - | exp guess eps delta | - <primitive: 55> - #Numeric. - "Changed 200/01/19 For ANSI <number> support." - "Newton-Raphson" - self <= 0.0 - ifTrue: [self = 0.0 - ifTrue: [^ 0.0] - ifFalse: ["v Chg" - ^ DomainError signal: 'sqrt undefined for number less than zero.']]. - "first guess is half the exponent" - exp := self exponent // 2. - guess := self timesTwoPower: 0 - exp. - "get eps value" - eps := guess * Epsilon. - eps := eps * eps. - delta := self - (guess * guess) / (guess * 2.0). - [delta * delta > eps] - whileTrue: - [guess := guess + delta. - delta := self - (guess * guess) / (guess * 2.0)]. - ^ guess! Item was removed: - ----- Method: Float>>timesTwoPower: (in category 'mathematical functions') ----- - timesTwoPower: anInteger - "Primitive. Answer with the receiver multiplied by 2.0 raised - to the power of the argument. - Optional. See Object documentation whatIsAPrimitive." - - <primitive: 54> - - anInteger < -29 ifTrue: [^ self * (2.0 raisedToInteger: anInteger)]. - anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat]. - anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat]. - ^ self * (2.0 raisedToInteger: anInteger)! Item was removed: - ----- Method: Float>>truncated (in category 'truncation and round off') ----- - truncated - "Answer with a SmallInteger equal to the value of the receiver without - its fractional part. The primitive fails if the truncated value cannot be - represented as a SmallInteger. In that case, the code below will compute - a LargeInteger truncated value. - Essential. See Object documentation whatIsAPrimitive. " - - <primitive: 51> - self isFinite ifFalse: [self error: 'Cannot truncate this number']. - - self abs < 2.0e16 - ifTrue: ["Fastest way when it may not be an integer" - | di df q r | - di := 1 + (SmallInteger maxVal bitShift: -1). - df := di asFloat. - q := self quo: df. - r := self - (q asFloat * df). - ^q * di + r truncated] - ifFalse: [^ self asTrueFraction. "Extract all bits of the mantissa and shift if necess"] - - - - ! Item was removed: - ----- Method: Float>>~= (in category 'comparing') ----- - ~= aNumber - "Primitive. Compare the receiver with the argument and return true - if the receiver is not equal to the argument. Otherwise return false. - Fail if the argument is not a Float. Optional. See Object documentation - whatIsAPrimitive." - - <primitive: 48> - ^super ~= aNumber! Item was added: + ----- Method: InstructionClient>>callPrimitive: (in category 'instruction decoding') ----- + callPrimitive: pimIndex + "V3PlusClosures: 139 10001011 iiiiiiii jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256) + NewsqueakV4: 249 11111001 iiiiiiii jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256) + SistaV1: 248 11111000 iiiiiiii mjjjjjjj Call Primitive #iiiiiiii + ( jjjjjjj * 256) + m=1 means inlined primitive, no hard return after execution."! Item was added: + ----- Method: InstructionPrinter>>callPrimitive: (in category 'instruction decoding') ----- + callPrimitive: index + "Print the callPrimitive." + + self print: 'callPrimtive: ' , index printString! Item was changed: ----- Method: InstructionStream>>interpretV3ClosuresExtension:in:for: (in category 'decoding - private - v3 plus closures') ----- interpretV3ClosuresExtension: offset in: method for: client | type offset2 byte2 byte3 byte4 | offset <= 6 ifTrue: ["Extended op codes 128-134" byte2 := method at: pc. pc := pc + 1. offset <= 2 ifTrue: ["128-130: extended pushes and pops" type := byte2 // 64. offset2 := byte2 \\ 64. offset = 0 ifTrue: [type = 0 ifTrue: [^client pushReceiverVariable: offset2]. type = 1 ifTrue: [^client pushTemporaryVariable: offset2]. type = 2 ifTrue: [^client pushConstant: (method literalAt: offset2 + 1)]. type = 3 ifTrue: [^client pushLiteralVariable: (method literalAt: offset2 + 1)]]. offset = 1 ifTrue: [type = 0 ifTrue: [^client storeIntoReceiverVariable: offset2]. type = 1 ifTrue: [^client storeIntoTemporaryVariable: offset2]. type = 2 ifTrue: [self error: 'illegalStore']. type = 3 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: offset2 + 1)]]. offset = 2 ifTrue: [type = 0 ifTrue: [^client popIntoReceiverVariable: offset2]. type = 1 ifTrue: [^client popIntoTemporaryVariable: offset2]. type = 2 ifTrue: [self error: 'illegalStore']. type = 3 ifTrue: [^client popIntoLiteralVariable: (method literalAt: offset2 + 1)]]]. "131-134: extended sends" offset = 3 ifTrue: "Single extended send" [^client send: (method literalAt: byte2 \\ 32 + 1) super: false numArgs: byte2 // 32]. offset = 4 ifTrue: "Double extended do-anything" [byte3 := method at: pc. pc := pc + 1. type := byte2 // 32. type = 0 ifTrue: [^client send: (method literalAt: byte3 + 1) super: false numArgs: byte2 \\ 32]. type = 1 ifTrue: [^client send: (method literalAt: byte3 + 1) super: true numArgs: byte2 \\ 32]. type = 2 ifTrue: [^client pushReceiverVariable: byte3]. type = 3 ifTrue: [^client pushConstant: (method literalAt: byte3 + 1)]. type = 4 ifTrue: [^client pushLiteralVariable: (method literalAt: byte3 + 1)]. type = 5 ifTrue: [^client storeIntoReceiverVariable: byte3]. type = 6 ifTrue: [^client popIntoReceiverVariable: byte3]. type = 7 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: byte3 + 1)]]. offset = 5 ifTrue: "Single extended send to super" [^client send: (method literalAt: byte2 \\ 32 + 1) super: true numArgs: byte2 // 32]. offset = 6 ifTrue: "Second extended send" [^client send: (method literalAt: byte2 \\ 64 + 1) super: false numArgs: byte2 // 64]]. offset = 7 ifTrue: [^client doPop]. offset = 8 ifTrue: [^client doDup]. offset = 9 ifTrue: [^client pushActiveContext]. byte2 := method at: pc. pc := pc + 1. offset = 10 ifTrue: [^byte2 < 128 ifTrue: [client pushNewArrayOfSize: byte2] ifFalse: [client pushConsArrayWithElements: byte2 - 128]]. - offset = 11 ifTrue: [^self unusedBytecode: client at: pc - 1]. byte3 := method at: pc. pc := pc + 1. + offset = 11 ifTrue: [^client callPrimitive: byte2 + (byte3 bitShift: 8)]. offset = 12 ifTrue: [^client pushRemoteTemp: byte2 inVectorAt: byte3]. offset = 13 ifTrue: [^client storeIntoRemoteTemp: byte2 inVectorAt: byte3]. offset = 14 ifTrue: [^client popIntoRemoteTemp: byte2 inVectorAt: byte3]. "offset = 15" byte4 := method at: pc. pc := pc + 1. ^client pushClosureCopyNumCopiedValues: (byte2 bitShift: -4) numArgs: (byte2 bitAnd: 16rF) blockSize: (byte3 * 256) + byte4! Item was changed: ----- Method: Integer class>>initialize (in category 'class initialization') ----- + initialize + "Integer initialize" + self initializeLowBitPerByteTable! - initialize "Integer initialize" - "Ensure we have the right compact class index" - - "LPI has been a compact class forever - just ensure basic correctness" - (LargePositiveInteger indexIfCompact = 5) ifFalse:[ - (Smalltalk compactClassesArray at: 5) - ifNil:[LargePositiveInteger becomeCompactSimplyAt: 5] - ifNotNil:[self error: 'Unexpected compact class setup']]. - - "Cog requires LNI to be compact at 4 (replacing PseudoContext)" - (LargeNegativeInteger indexIfCompact = 4) ifFalse:[ - "PseudoContext will likely get removed at some point so write this test - without introducing a hard dependency" - (Smalltalk compactClassesArray at: 4) name == #PseudoContext - ifTrue:[Smalltalk compactClassesArray at: 4 put: nil]. - (Smalltalk compactClassesArray at: 4) - ifNil:[LargeNegativeInteger becomeCompactSimplyAt: 4] - ifNotNil:[self error: 'Unexpected compact class setup']]. - - self initializeLowBitPerByteTable - ! Item was changed: ----- Method: LargeNegativeInteger>>normalize (in category 'converting') ----- normalize "Check for leading zeroes and return shortened copy if so" | sLen val len oldLen minVal | + <primitive: 'primNormalizeNegative' module: 'LargeIntegers'> - <primitive: 'primNormalizeNegative' module:'LargeIntegers'> "First establish len = significant length" len := oldLen := self digitLength. [len = 0 ifTrue: [^0]. (self digitAt: len) = 0] whileTrue: [len := len - 1]. + "Now check if in SmallInteger range. + Fast compute SmallInteger minVal digitLength" + sLen := SmallInteger minVal < -16r40000000 + ifTrue: [8] + ifFalse: [4]. - "Now check if in SmallInteger range" - sLen := 4 "SmallInteger minVal digitLength". len <= sLen ifTrue: [minVal := SmallInteger minVal. (len < sLen + or: [(self digitAt: sLen) < minVal lastDigit]) - or: [(self digitAt: sLen) < minVal lastDigit]) ifTrue: ["If high digit less, then can be small" val := 0. len to: 1 by: -1 do: [:i | val := (val *256) - (self digitAt: i)]. ^ val]. 1 to: sLen do: "If all digits same, then = minVal" [:i | (self digitAt: i) = (minVal digitAt: i) ifFalse: ["Not so; return self shortened" len < oldLen ifTrue: [^ self growto: len] ifFalse: [^ self]]]. ^ minVal]. "Return self, or a shortened copy" len < oldLen ifTrue: [^ self growto: len] ifFalse: [^ self]! Item was changed: ----- Method: LargePositiveInteger>>normalize (in category 'converting') ----- normalize "Check for leading zeroes and return shortened copy if so" | sLen val len oldLen | <primitive: 'primNormalizePositive' module:'LargeIntegers'> "First establish len = significant length" len := oldLen := self digitLength. [len = 0 ifTrue: [^0]. (self digitAt: len) = 0] whileTrue: [len := len - 1]. + "Now check if in SmallInteger range. Fast compute SmallInteger maxVal digitLength" + sLen := SmallInteger maxVal > 16r3FFFFFFF + ifTrue: [8] + ifFalse: [4]. - "Now check if in SmallInteger range" - sLen := SmallInteger maxVal digitLength. (len <= sLen + and: [(self digitAt: sLen) <= (SmallInteger maxVal digitAt: sLen)]) - and: [(self digitAt: sLen) <= (SmallInteger maxVal digitAt: sLen)]) ifTrue: ["If so, return its SmallInt value" val := 0. len to: 1 by: -1 do: [:i | val := (val *256) + (self digitAt: i)]. ^ val]. "Return self, or a shortened copy" len < oldLen ifTrue: [^ self growto: len] ifFalse: [^ self]! Item was added: + ----- Method: MethodContext class>>allInstances (in category 'enumerating') ----- + allInstances + "Answer all instances of the receiver." + <primitive: 177> + "The primitive can fail because memory is low. If so, fall back on the old + enumeration code, which gives the system a chance to GC and/or grow. + Because aBlock might change the class of inst (for example, using become:), + it is essential to compute next before aBlock value: inst. + Only count until thisContext since this context has been created only to + compute the existing instances." + | inst insts next | + insts := WriteStream on: (Array new: 64). + inst := self someInstance. + [inst == thisContext or: [inst == nil]] whileFalse: + [next := inst nextInstance. + insts nextPut: inst. + inst := next]. + ^insts contents! Item was changed: ----- Method: MethodContext class>>allInstancesDo: (in category 'private') ----- allInstancesDo: aBlock + "Evaluate aBlock with each of the current instances of the receiver." + | instances inst next | + instances := self allInstancesOrNil. + instances ifNotNil: + [instances do: aBlock. + ^self]. + "allInstancesOrNil can fail because memory is low. If so, fall back on the old + enumeration code. Because aBlock might change the class of inst (for example, + using become:), it is essential to compute next before aBlock value: inst. + Only count until thisContext since evaluation of aBlock will create new contexts." - "Only count until thisContext since evaluation of aBlock will create new contexts." - | inst next | inst := self someInstance. + [inst == thisContext or: [inst == nil]] whileFalse: + [next := inst nextInstance. + aBlock value: inst. + inst := next]! - [inst == thisContext] whileFalse:[ - next := inst nextInstance. - aBlock value: inst. - inst := next] - ! Item was added: + ----- Method: MethodContext>>failPrimitiveWith: (in category 'system simulation') ----- + failPrimitiveWith: maybePrimFailToken + "The receiver is a freshly-created context on a primitive method. Skip the callPrimitive: + bytecode and store the primitive fail code if there is one and the method consumes it." + self skipCallPrimitive. + ((self isPrimFailToken: maybePrimFailToken) + and: [method encoderClass isStoreAt: pc in: method]) ifTrue: + [self at: stackp put: maybePrimFailToken last]! Item was changed: ----- Method: Object>>clone (in category 'copying') ----- clone + "Answer a shallow copy of the receiver." + <primitive: 148 error: ec> + | class newObject | + ec == #'insufficient object memory' ifFalse: + [^self primitiveFailed]. + "If the primitive fails due to insufficient memory, instantiate via basicNew: to invoke + the garbage collector before retrying, and use copyFrom: to copy state." + newObject := (class := self class) isVariable + ifTrue: + [class isCompiledMethodClass + ifTrue: + [class newMethod: self basicSize - self initialPC + 1 header: self header] + ifFalse: + [class basicNew: self basicSize]] + ifFalse: + [class basicNew]. + ^newObject copyFrom: self! - - <primitive: 148> - self primitiveFailed! Item was changed: ----- Method: Object>>instVarAt: (in category 'system primitives') ----- + instVarAt: index + "Primitive. Answer a fixed variable in an object. The numbering of the variables + corresponds to the named instance variables, followed by the indexed instance + variables. Fail if the index is not an Integer or is not the index of a fixed variable. + Essential. See Object documentation whatIsAPrimitive." - instVarAt: index - "Primitive. Answer a fixed variable in an object. The numbering of the - variables corresponds to the named instance variables. Fail if the index - is not an Integer or is not the index of a fixed variable. Essential. See - Object documentation whatIsAPrimitive." + <primitive: 173 error: ec> + self primitiveFailed! - <primitive: 73> - "Access beyond fixed variables." - ^self basicAt: index - self class instSize ! Item was changed: ----- Method: Object>>instVarAt:put: (in category 'system primitives') ----- + instVarAt: index put: anObject + "Primitive. Store a value into a fixed variable in an object. The numbering of the + variables corresponds to the named instance variables, followed by the indexed + instance variables. Fail if the index is not an Integer or is not the index of a fixed + variable. Essential. See Object documentation whatIsAPrimitive." - instVarAt: anInteger put: anObject - "Primitive. Store a value into a fixed variable in the receiver. The - numbering of the variables corresponds to the named instance variables. - Fail if the index is not an Integer or is not the index of a fixed variable. - Answer the value stored as the result. Using this message violates the - principle that each object has sovereign control over the storing of - values into its instance variables. Essential. See Object documentation - whatIsAPrimitive." + <primitive: 174 error: ec> + self primitiveFailed! - <primitive: 74> - "Access beyond fixed fields" - ^self basicAt: anInteger - self class instSize put: anObject! Item was added: + ----- Method: Object>>isPinned (in category 'system primitives') ----- + isPinned + "Answer if the receiver is pinned. The VM's garbage collector routinely moves + objects as it reclaims and compacts memory. But it can also pin an object so + that it will not be moved, which can make it easier to pass objects out through + the FFI." + <primitive: 183 error: ec> + ^self primitiveFailed! Item was added: + ----- Method: Object>>pin (in category 'system primitives') ----- + pin + "The VM's garbage collector routinely moves objects as it reclaims and compacts + memory. But it can also pin an object so that it will not be moved, which can make + it easier to pass objects out through the FFI. Objects are unpinnned when created. + This method ensures an object is pinned, and answers whether it was already pinned." + ^self setPinned: true! Item was added: + ----- Method: Object>>setPinned: (in category 'system primitives') ----- + setPinned: aBoolean + "The VM's garbage collector routinely moves objects as it reclaims and compacts + memory. But it can also pin an object so that it will not be moved, which can make + it easier to pass objects out through the FFI. Objects are unpinnned when created. + This primitive either pins or unpins an object, and answers if it was already pinned." + <primitive: 184 error: ec> + ^self primitiveFailed! Item was added: + ----- Method: Object>>unpin (in category 'system primitives') ----- + unpin + "The VM's garbage collector routinely moves objects as it reclaims and compacts + memory. But it can also pin an object so that it will not be moved, which can make + it easier to pass objects out through the FFI. Objects are unpinnned when created. + This method ensures an object is unpinned, and answers whether it was pinned." + ^self setPinned: false! Item was changed: ----- Method: ProtoObject>>scaledIdentityHash (in category 'comparing') ----- scaledIdentityHash "For identityHash values returned by primitive 75, answer + such values times 2^8. Otherwise, match the existing + identityHash implementation" - such values times 2^18. Otherwise, match the existing - identityHash implementation" + ^self identityHash * 256 "bitShift: 8"! - ^self identityHash * 262144 "bitShift: 18"! Item was added: ==== ERROR === Error: Unrecognized class type 29 January 2015 7:38:29.248 pm VM: unix - a SmalltalkImage Image: Squeak3.11alpha [latest update: #8824] SecurityManager state: Restricted: false FileAccess: true SocketAccess: true Working Dir /home/squeaksource Trusted Dir /home/squeaksource/secure Untrusted Dir /home/squeaksource/My Squeak MCClassDefinition(Object)>>error: Receiver: a MCClassDefinition(SmallFloat64) Arguments and temporary variables: aString: 'Unrecognized class type' Receiver's instance variables: name: #SmallFloat64 superclassName: #Float variables: an OrderedCollection() category: 'Kernel-Numbers' type: #immediate comment: 'My instances represent 64-bit Floats whose exponent fits in 8 bits as...etc... commentStamp: 'eem 11/25/2014 07:54' traitComposition: nil classTraitComposition: nil MCClassDefinition>>kindOfSubclass Receiver: a MCClassDefinition(SmallFloat64) Arguments and temporary variables: Receiver's instance variables: name: #SmallFloat64 superclassName: #Float variables: an OrderedCollection() category: 'Kernel-Numbers' type: #immediate comment: 'My instances represent 64-bit Floats whose exponent fits in 8 bits as...etc... commentStamp: 'eem 11/25/2014 07:54' traitComposition: nil classTraitComposition: nil MCClassDefinition>>printDefinitionOn: Receiver: a MCClassDefinition(SmallFloat64) Arguments and temporary variables: stream: a WriteStream Receiver's instance variables: name: #SmallFloat64 superclassName: #Float variables: an OrderedCollection() category: 'Kernel-Numbers' type: #immediate comment: 'My instances represent 64-bit Floats whose exponent fits in 8 bits as...etc... commentStamp: 'eem 11/25/2014 07:54' traitComposition: nil classTraitComposition: nil [] in MCDiffyTextWriter(MCStWriter)>>writeClassDefinition: Receiver: a MCDiffyTextWriter Arguments and temporary variables: definition: a WriteStream s: a MCClassDefinition(SmallFloat64) Receiver's instance variables: stream: a WriteStream initStream: nil --- The full stack --- MCClassDefinition(Object)>>error: MCClassDefinition>>kindOfSubclass MCClassDefinition>>printDefinitionOn: [] in MCDiffyTextWriter(MCStWriter)>>writeClassDefinition: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - String class(SequenceableCollection class)>>new:streamContents: String class(SequenceableCollection class)>>streamContents: MCDiffyTextWriter(MCTextWriter)>>chunkContents: MCDiffyTextWriter(MCStWriter)>>writeClassDefinition: MCDiffyTextWriter(MCStWriter)>>visitClassDefinition: MCClassDefinition>>accept: [] in MCDiffyTextWriter(MCTextWriter)>>visitInFork: String class(SequenceableCollection class)>>new:streamContents: String class(SequenceableCollection class)>>streamContents: MCDiffyTextWriter(MCTextWriter)>>visitInFork: MCDiffyTextWriter>>writePatchFrom:to: MCDiffyTextWriter>>writeAddition: [] in MCDiffyTextWriter>>writePatch: SortedCollection(OrderedCollection)>>do: MCDiffyTextWriter>>writePatch: SSDiffyTextWriter>>writePatch: [] in SSDiffyTextWriter>>writeVersion:for: BlockClosure>>on:do: SSDiffyTextWriter>>writeVersion:for: [] in SSEMailSubscription>>versionAdded:to: BlockClosure>>on:do: SSEMailSubscription>>versionAdded:to: [] in [] in SSProject>>versionAdded: [] in BlockClosure>>newProcess

1 0

The Trunk: System.spur-eem.699.mcz
by commits＠source.squeak.org 29 Jan '15

29 Jan '15

Eliot Miranda uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System.spur-eem.699.mcz ==================== Summary ==================== Name: System.spur-eem.699 Author: eem Time: 29 January 2015, 11:35:36.303 am UUID: 66bc8fe3-a105-4f4f-8275-21235bbac975 Ancestors: System-eem.699, System.spur-eem.698 System-eem.699 patched for Spur by SpurBootstrapMonticelloPackagePatcher Cog-eem.237 Add block nesting to MessageTally. c.f. AndreasProfiler-eem.10 =============== Diff against System-eem.699 =============== Item was removed: - ----- Method: Object>>oopAge (in category '*system-support') ----- - oopAge - ^ ObjectHistory current ageOf: self! Item was removed: - ----- Method: Object>>oopTimestamp (in category '*system-support') ----- - oopTimestamp - ^ ObjectHistory current timestampOf: self! Item was removed: - Object subclass: #ObjectHistory - instanceVariableNames: 'marks markProcess' - classVariableNames: 'Current' - poolDictionaries: '' - category: 'System-Support'! - - !ObjectHistory commentStamp: 'bf 11/16/2012 12:19' prior: 0! - ObjectHistory holds ObjectHistoryMark objects which are placed in the object memory at regular intervals by its markProcess in the background. Adjacent marks (with no remaining objects inbetween) are coalesced so over time the collection does not grow unnecessarily large. - - Using these markers it is possible to determine the age of objects in memory from the time the ObjectHistory was initialized. Try e.g.: - self oopTimestamp. - self oopAge. - ObjectHistory current oopClassesByDate. - - Instance Variables - marks: SortedCollection of ObjectHistoryMark objects - markProcess: a Process running our markLoop - ! Item was removed: - ----- Method: ObjectHistory class>>current (in category 'accessing') ----- - current - ^ Current ifNil: [Current := self new]! Item was removed: - ----- Method: ObjectHistory class>>initialize (in category 'class initialization') ----- - initialize - self current. - ! Item was removed: - ----- Method: ObjectHistory class>>obsolete (in category 'class initialization') ----- - obsolete - "Kill the mark process before removing the class." - Current ifNotNil: - [:objectHistory| - objectHistory terminate]! Item was removed: - ----- Method: ObjectHistory>>ageOf: (in category 'queries') ----- - ageOf: anObject - "Age of anObject in seconds" - | timestamp | - timestamp := self timestampOf: anObject. - timestamp ifNil: [^0]. - ^(DateAndTime now - timestamp) asSeconds roundTo: self markRate! Item was removed: - ----- Method: ObjectHistory>>initialize (in category 'initializing') ----- - initialize - self restartMarkProcess. - - ! Item was removed: - ----- Method: ObjectHistory>>markLoop (in category 'marking') ----- - markLoop - [true] whileTrue: [ - self markUpdate. - (Delay forSeconds: self markRate) wait]! Item was removed: - ----- Method: ObjectHistory>>markRate (in category 'marking') ----- - markRate - "rate of creating ObjectHistoryMarks" - ^60! Item was removed: - ----- Method: ObjectHistory>>markUpdate (in category 'marking') ----- - markUpdate - "Add a new mark and compact the marks collection" - | mark prev | - "lazy init so this happens in the background process" - marks ifNil: [self reinitMarks]. - "add new mark to object memory" - mark := self newMark. - mark timestamp <= marks last timestamp ifTrue: [^self "could happen if clock is wrong"]. - marks addLast: mark. - "compact the table by removing adjacent marks" - prev := marks first. - marks removeAllSuchThat: [:each | | doDelete | - doDelete := prev objectAfter == each. - prev := each. - doDelete]. - "The loop above is O(n) in number of marks, but that number should never become so large to be an issue. Even if the number was large, this is running at system background priority so should not interfere with any user process, not even user background processes. The symptom should only be that the system is less idle. - - If we ever get to a point where the number of marks is an issue then the compacting here could be made partial: since old marks rarely get coalesced it would make sense to only check the newer ones often, and the old ones perhaps only at the system startup."! Item was removed: - ----- Method: ObjectHistory>>newMark (in category 'private') ----- - newMark - ^ ObjectHistoryMark new! Item was removed: - ----- Method: ObjectHistory>>oopClassesByAge (in category 'stats') ----- - oopClassesByAge - "Answer collection of (oopAge in seconds -> sorted counts of object classes) sorted from lowest age" - "ObjectHistory current oopClassesByAge" - - | stats prev endOfMemory now bag age obj | - endOfMemory := Object new. - stats := OrderedCollection new: 1000. - prev := nil. - now := self newMark timestamp. - marks do: [:mark | - prev ifNotNil: [ - bag := Bag new. - obj := prev objectAfter. - [obj == mark] whileFalse: [ - bag add: obj class. - obj := obj nextObject. - obj == endOfMemory ifTrue: [self error: 'should not happen']]. - age := (now - mark timestamp) asSeconds roundTo: self markRate. - stats addFirst: age -> bag sortedCounts]. - prev := mark]. - ^ stats - ! Item was removed: - ----- Method: ObjectHistory>>oopClassesByDate (in category 'stats') ----- - oopClassesByDate - "Answer collection of (Date -> sorted counts of object classes) sorted from newest date" - "ObjectHistory current oopClassesByDate" - - | stats prev endOfMemory bag date obj thisDate | - endOfMemory := Object new. - stats := OrderedCollection new: 1000. - prev := nil. - thisDate := nil. - bag := Bag new. - marks do: [:mark | - prev ifNotNil: [ - obj := prev objectAfter. - [obj == mark] whileFalse: [ - bag add: obj class. - obj := obj nextObject. - obj == endOfMemory ifTrue: [self error: 'should not happen']]. - date := mark timestamp asDate. - thisDate = date ifFalse: [ - stats addFirst: date -> bag sortedCounts. - bag := Bag new. - thisDate := date]]. - prev := mark]. - thisDate = date ifFalse: [ - stats addLast: date -> bag sortedCounts]. - ^ stats - ! Item was removed: - ----- Method: ObjectHistory>>oopCountsByAge (in category 'stats') ----- - oopCountsByAge - "Answer collection of (oopAge in seconds -> number of objects) sorted from lowest age" - "ObjectHistory current oopCountsByAge" - - | stats prev endOfMemory now n age obj | - endOfMemory := Object new. - stats := OrderedCollection new: 1000. - prev := nil. - now := self newMark timestamp. - marks do: [:mark | - prev ifNotNil: [ - n := 0. - obj := prev objectAfter. - [obj == mark] whileFalse: [ - n := n + 1. - obj := obj nextObject. - obj == endOfMemory ifTrue: [self error: 'should not happen']]. - age := (now - mark timestamp) asSeconds roundTo: self markRate. - stats addFirst: age -> n]. - prev := mark]. - ^ stats - ! Item was removed: - ----- Method: ObjectHistory>>reinitMarks (in category 'private') ----- - reinitMarks - marks := ObjectHistoryMark allInstances asOrderedCollection. - marks - ifEmpty: [marks add: self newMark] - ifNotEmpty: [ | prev | - prev := nil. - marks removeAllSuchThat: [:obj | - prev notNil and: [prev timestamp >= obj timestamp]]]. - ! Item was removed: - ----- Method: ObjectHistory>>restartMarkProcess (in category 'marking') ----- - restartMarkProcess - markProcess ifNotNil: [markProcess terminate]. - markProcess := [self markLoop] - forkAt: Processor systemBackgroundPriority - named: 'ObjectHistory''s markProcess'. - ! Item was removed: - ----- Method: ObjectHistory>>terminate (in category 'private') ----- - terminate - markProcess ifNotNil: - [markProcess terminate]! Item was removed: - ----- Method: ObjectHistory>>timestampOf: (in category 'queries') ----- - timestampOf: anObject - "Timestamp of anObject, or nil if too new" - | endOfMemory mark | - anObject class == SmallInteger ifTrue: [^nil]. - mark := anObject. - endOfMemory := Object new. - [mark class == ObjectHistoryMark] whileFalse: [ - mark := mark nextObject. - mark == endOfMemory ifTrue: [^nil]]. - ^mark timestamp! Item was removed: - Object subclass: #ObjectHistoryMark - instanceVariableNames: 'timestamp' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - - !ObjectHistoryMark commentStamp: 'bf 11/7/2012 00:12' prior: 0! - An ObjectHistoryMark is a permanent mark in the object memory. It holds a timestamp. - - While the timestamp could be used directly as mark by ObjectHistory, it's conceivable that its format might change in the future, and we do not want the mark's relative position in memory to change (which would be the case if it was migrated to a new format). So we use a distinct object instead (and we protect it against accidental become-ing by overriding those methods).! Item was removed: - ----- Method: ObjectHistoryMark>>become: (in category 'mutating') ----- - become: otherObject - ^self error: 'marks need to stay fixed in the object memory'! Item was removed: - ----- Method: ObjectHistoryMark>>becomeForward: (in category 'mutating') ----- - becomeForward: otherObject - ^self error: 'marks need to stay fixed in the object memory'! Item was removed: - ----- Method: ObjectHistoryMark>>initialize (in category 'initialization') ----- - initialize - timestamp := DateAndTime now floor. - ! Item was removed: - ----- Method: ObjectHistoryMark>>objectAfter (in category 'accessing') ----- - objectAfter - "Answer the next object in memory after me and my timestamp" - | successor | - successor := self nextObject. - successor == timestamp - ifTrue: [successor := successor nextObject]. - ^ successor! Item was removed: - ----- Method: ObjectHistoryMark>>printOn: (in category 'printing') ----- - printOn: aStream - aStream - nextPutAll: self class name; - nextPut: $(; - print: timestamp; - nextPut: $)! Item was removed: - ----- Method: ObjectHistoryMark>>timestamp (in category 'accessing') ----- - timestamp - ^timestamp - ! Item was changed: ----- Method: SmalltalkImage>>compactClassesArray (in category 'special objects') ----- compactClassesArray "Smalltalk compactClassesArray" + "Backward-compatibility support. Spur does not have compact classes." + ^{}! - "Return the array of 31 classes whose instances may be - represented compactly" - ^ self specialObjectsArray at: 29! Item was added: + ----- Method: SmalltalkImage>>growMemoryByAtLeast: (in category 'memory space') ----- + growMemoryByAtLeast: numBytes + "Grow memory by at least the requested number of bytes. + Primitive. Essential. Fail if no memory is available." + <primitive: 180> + (numBytes isInteger and: [numBytes > 0]) ifTrue: + [OutOfMemory signal]. + ^self primitiveFailed! Item was added: + ----- Method: SmalltalkImage>>maxIdentityHash (in category 'system attributes') ----- + maxIdentityHash + "Answer the maximum identityHash value supported by the VM." + <primitive: 176> + ^self primitiveFailed! Item was changed: ----- Method: SmalltalkImage>>recreateSpecialObjectsArray (in category 'special objects') ----- recreateSpecialObjectsArray "Smalltalk recreateSpecialObjectsArray" "To external package developers: **** DO NOT OVERRIDE THIS METHOD. ***** If you are writing a plugin and need additional special object(s) for your own use, use addGCRoot() function and use own, separate special objects registry " "The Special Objects Array is an array of objects used by the Squeak virtual machine. Its contents are critical and accesses to it by the VM are unchecked, so don't even think of playing here unless you know what you are doing." | newArray | + newArray := Array new: 60. - newArray := Array new: 58. "Nil false and true get used throughout the interpreter" newArray at: 1 put: nil. newArray at: 2 put: false. newArray at: 3 put: true. "This association holds the active process (a ProcessScheduler)" newArray at: 4 put: (self specialObjectsArray at: 4) "(self bindingOf: #Processor) but it answers an Alias". "Numerous classes below used for type checking and instantiation" newArray at: 5 put: Bitmap. newArray at: 6 put: SmallInteger. newArray at: 7 put: ByteString. newArray at: 8 put: Array. newArray at: 9 put: Smalltalk. + newArray at: 10 put: BoxedFloat64. + newArray at: 11 put: (self globals at: #MethodContext ifAbsent: [self globals at: #Context]). + newArray at: 12 put: nil. "was BlockContext." - newArray at: 10 put: Float. - newArray at: 11 put: MethodContext. - newArray at: 12 put: BlockContext. newArray at: 13 put: Point. newArray at: 14 put: LargePositiveInteger. newArray at: 15 put: Display. newArray at: 16 put: Message. newArray at: 17 put: CompiledMethod. + newArray at: 18 put: ((self specialObjectsArray at: 18) ifNil: [Semaphore new]). "low space Semaphore" - newArray at: 18 put: (self specialObjectsArray at: 18). - "(low space Semaphore)" newArray at: 19 put: Semaphore. newArray at: 20 put: Character. newArray at: 21 put: #doesNotUnderstand:. newArray at: 22 put: #cannotReturn:. newArray at: 23 put: nil. "This is the process signalling low space." "An array of the 32 selectors that are compiled as special bytecodes, paired alternately with the number of arguments each takes." newArray at: 24 put: #( #+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1 #* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1 #at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 #class 0 #blockCopy: 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0 ). "An array of the 255 Characters in ascii order. + Cog inlines table into machine code at: prim so do not regenerate it. + This is nil in Spur, which has immediate Characters." - Cog inlines table into machine code at: prim so do not regenerate it." newArray at: 25 put: (self specialObjectsArray at: 25). newArray at: 26 put: #mustBeBoolean. newArray at: 27 put: ByteArray. newArray at: 28 put: Process. + "An array of up to 31 classes whose instances will have compact headers; an empty array in Spur" - "An array of up to 31 classes whose instances will have compact headers" newArray at: 29 put: self compactClassesArray. + newArray at: 30 put: ((self specialObjectsArray at: 30) ifNil: [Semaphore new]). "delay Semaphore" + newArray at: 31 put: ((self specialObjectsArray at: 31) ifNil: [Semaphore new]). "user interrupt Semaphore" - newArray at: 30 put: (self specialObjectsArray at: 30). "(delay Semaphore)" - newArray at: 31 put: (self specialObjectsArray at: 31). "(user interrupt Semaphore)" "Entries 32 - 34 unreferenced. Previously these contained prototype instances to be copied for fast initialization" + newArray at: 32 put: nil. "was the prototype Float" + newArray at: 33 put: nil. "was the prototype 4-byte LargePositiveInteger" + newArray at: 34 put: nil. "was the prototype Point" - newArray at: 32 put: nil. "was (Float new: 2)" - newArray at: 33 put: nil. "was (LargePositiveInteger new: 4)" - newArray at: 34 put: nil. "was Point new" newArray at: 35 put: #cannotInterpret:. + newArray at: 36 put: nil. "was the prototype MethodContext" - "Note: This must be fixed once we start using context prototypes (yeah, right)" - "(MethodContext new: CompiledMethod fullFrameSize)." - newArray at: 36 put: (self specialObjectsArray at: 36). "Is the prototype MethodContext (unused by the VM)" newArray at: 37 put: BlockClosure. + newArray at: 38 put: nil. "was the prototype BlockContext" - "(BlockContext new: CompiledMethod fullFrameSize)." - newArray at: 38 put: (self specialObjectsArray at: 38). "Is the prototype BlockContext (unused by the VM)" "array of objects referred to by external code" + newArray at: 39 put: (self specialObjectsArray at: 39). "external semaphores" - newArray at: 39 put: (self specialObjectsArray at: 39). "preserve external semaphores" newArray at: 40 put: nil. "Reserved for Mutex in Cog VMs" + newArray at: 41 put: ((self specialObjectsArray at: 41) ifNil: [LinkedList new]). "Reserved for a LinkedList instance for overlapped calls in CogMT" + newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil: [Semaphore new]). "finalization Semaphore" - newArray at: 41 put: nil. "Reserved for a LinkedList instance for overlapped calls in CogMT" - "finalization Semaphore" - newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil: [Semaphore new]). newArray at: 43 put: LargeNegativeInteger. "External objects for callout. Note: Written so that one can actually completely remove the FFI." newArray at: 44 put: (self at: #ExternalAddress ifAbsent: []). newArray at: 45 put: (self at: #ExternalStructure ifAbsent: []). newArray at: 46 put: (self at: #ExternalData ifAbsent: []). newArray at: 47 put: (self at: #ExternalFunction ifAbsent: []). newArray at: 48 put: (self at: #ExternalLibrary ifAbsent: []). newArray at: 49 put: #aboutToReturn:through:. newArray at: 50 put: #run:with:in:. "51 reserved for immutability message" + newArray at: 51 put: #attemptToAssign:withIndex:. - "newArray at: 51 put: #attemptToAssign:withIndex:." - newArray at: 51 put: (self specialObjectsArray at: 51 ifAbsent: []). newArray at: 52 put: #(nil "nil => generic error" #'bad receiver' #'bad argument' #'bad index' #'bad number of arguments' #'inappropriate operation' #'unsupported operation' #'no modification' #'insufficient object memory' #'insufficient C memory' #'not found' #'bad method' #'internal error in named primitive machinery' #'object may move' #'resource limit exceeded' + #'object is pinned' #'primitive write beyond end of object'). - #'object is pinned'). "53 to 55 are for Alien" newArray at: 53 put: (self at: #Alien ifAbsent: []). + newArray at: 54 put: #invokeCallbackContext:. "use invokeCallback:stack:registers:jmpbuf: for old Alien callbacks." - newArray at: 54 put: #invokeCallbackContext::. "use invokeCallback:stack:registers:jmpbuf: for old Alien callbacks." newArray at: 55 put: (self at: #UnsafeAlien ifAbsent: []). + "Used to be WeakFinalizationList for WeakFinalizationList hasNewFinalization, obsoleted by ephemeron support." + newArray at: 56 put: nil. - "Weak reference finalization" - newArray at: 56 put: (self at: #WeakFinalizationList ifAbsent: []). "reserved for foreign callback process" newArray at: 57 put: (self specialObjectsArray at: 57 ifAbsent: []). newArray at: 58 put: #unusedBytecode. + "59 reserved for Sista counter tripped message" + newArray at: 59 put: #conditionalBranchCounterTrippedOn:. + "60 reserved for Sista class trap message" + newArray at: 60 put: #classTrapFor:. "Now replace the interpreter's reference in one atomic operation" + self specialObjectsArray becomeForward: newArray! - self specialObjectsArray becomeForward: newArray - ! Item was changed: ----- Method: SmalltalkImage>>setGCParameters (in category 'snapshot and quit') ----- setGCParameters + "Adjust the VM's default GC parameters to avoid too much tenuring. + Maybe this should be left to the VM?" - "Adjust the VM's default GC parameters to avoid premature tenuring." + | proportion edenSize survivorSize averageObjectSize numObjects | + proportion := 0.9. "tenure when 90% of pastSpace is full" + edenSize := SmalltalkImage current vmParameterAt: 44. + survivorSize := edenSize / 5.0. "David's paper uses 140Kb eden + 2 x 28kb survivor spaces; Spur uses the same ratios :-)" + averageObjectSize := 8 * self wordSize. "a good approximation" + numObjects := (proportion * survivorSize / averageObjectSize) rounded. + SmalltalkImage current vmParameterAt: 6 put: numObjects "tenure when more than this many objects survive the GC"! - self vmParameterAt: 5 put: 4000. "do an incremental GC after this many allocations" - self vmParameterAt: 6 put: 2000. "tenure when more than this many objects survive the GC" - ! Item was changed: ----- Method: SpaceTally>>spaceForInstancesOf: (in category 'instance size') ----- spaceForInstancesOf: aClass + "Answer a pair of the number of bytes consumed by all instances of the + given class, including their object headers, and the number of instances." - "Answer the number of bytes consumed by all instances of the given class, including their object headers and the number of instances." + | instances total | + instances := aClass allInstances. + instances isEmpty ifTrue: [^#(0 0)]. - | smallHeaderSize instVarBytes isVariable bytesPerElement total lastInstance instance instanceCount | - instance := aClass someInstance ifNil: [ ^#(0 0) ]. - smallHeaderSize := aClass isCompact ifTrue: [ 4 ] ifFalse: [ 8 ]. - instVarBytes := aClass instSize * 4. - isVariable := aClass isVariable. - bytesPerElement := isVariable - ifFalse: [ 0 ] - ifTrue: [ aClass isBytes ifTrue: [ 1 ] ifFalse: [ 4 ] ]. total := 0. + aClass isVariable + ifTrue: + [instances do: + [:i| total := total + (aClass byteSizeOfInstanceOfSize: i basicSize)]] + ifFalse: + [total := instances size * aClass byteSizeOfInstance]. + ^{ total. instances size }! - instanceCount := 0. - "A modified version of #allInstancesDo: is inlined here. It avoids an infinite loop when another process is creating new instances of aClass." - self flag: #allInstancesDo:. - lastInstance := - aClass == CompiledMethod "CompiledMethod has special format, see its class comment" - ifTrue: [aClass new] - ifFalse: [aClass basicNew]. - [ instance == lastInstance ] whileFalse: [ - | contentBytes headerBytes | - contentBytes := instVarBytes + (isVariable - ifFalse: [ 0 ] - ifTrue: [ instance basicSize * bytesPerElement ]). - headerBytes := contentBytes > 255 - ifTrue: [ 12 ] - ifFalse: [ smallHeaderSize ]. - total := total + headerBytes + (contentBytes roundUpTo: 4). - instanceCount := instanceCount + 1. - instance := instance nextInstance ]. - ^{ total. instanceCount }! Item was added: + ----- Method: SystemDictionary>>growMemoryByAtLeast: (in category 'memory space') ----- + growMemoryByAtLeast: numBytes + "Grow memory by at least the requested number of bytes. + Primitive. Fail if no memory is available. Essential." + <primitive: 180> + ^(numBytes isInteger and: [numBytes > 0]) + ifTrue: [OutOfMemory signal] + ifFalse: [self primitiveFailed]! Item was added: + ----- Method: SystemDictionary>>maxIdentityHash (in category 'system attributes') ----- + maxIdentityHash + "Answer the maximum identityHash value supported by the VM." + <primitive: 176> + ^self primitiveFailed! Item was added: + ----- Method: SystemDictionary>>setGCParameters (in category 'snapshot and quit') ----- + setGCParameters + "Adjust the VM's default GC parameters to avoid too much tenuring. + Maybe this should be left to the VM?" + + | proportion edenSize survivorSize averageObjectSize numObjects | + proportion := 0.9. "tenure when 90% of pastSpace is full" + edenSize := SmalltalkImage current vmParameterAt: 44. + survivorSize := edenSize / 5.0. "David's paper uses 140Kb eden + 2 x 28kb survivor spaces; Spur uses the same ratios :-)" + averageObjectSize := 8 * self wordSize. "a good approximation" + numObjects := (proportion * survivorSize / averageObjectSize) rounded. + SmalltalkImage current vmParameterAt: 6 put: numObjects "tenure when more than this many objects survive the GC"! Item was added: + ----- Method: SystemNavigation>>allObjects (in category 'query') ----- + allObjects + "Answer an Array of all objects in the system. Fail if + there isn't enough memory to instantiate the result." + <primitive: 178> + ^self primitiveFailed! Item was changed: ----- Method: SystemNavigation>>allObjectsDo: (in category 'query') ----- allObjectsDo: aBlock + "Evaluate the argument, aBlock, for each object in the system, excluding immediates + such as SmallInteger and Character." + self allObjectsOrNil + ifNotNil: [:allObjects| allObjects do: aBlock] + ifNil: + ["Fall back on the old single object primitive code. With closures, this needs + to use an end marker (lastObject) since activation of the block will create + new contexts and cause an infinite loop. The lastObject must be created + before calling someObject, so that the VM can settle the enumeration (e.g. + by flushing new space) as a side effect of someObject" + | object lastObject | + lastObject := Object new. + object := self someObject. + [lastObject == object or: [0 == object]] whileFalse: + [aBlock value: object. + object := object nextObject]]! - "Evaluate the argument, aBlock, for each object in the system - excluding SmallIntegers. With closures, this needs to use an end - marker (lastObject) since activation of the block will create new - contexts and cause an infinite loop." - | object lastObject | - object := self someObject. - lastObject := Object new. - [lastObject == object or: [0 == object]] - whileFalse: [aBlock value: object. - object := object nextObject]! Item was added: + ----- Method: SystemNavigation>>allObjectsOrNil (in category 'query') ----- + allObjectsOrNil + "Answer an Array of all objects in the system. Fail if there isn't + enough memory to instantiate the result and answer nil." + <primitive: 178> + ^nil!

1 0

The Trunk: System.spur-mt.697.mcz
by commits＠source.squeak.org 29 Jan '15

29 Jan '15

Eliot Miranda uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System.spur-mt.697.mcz ==================== Summary ==================== Name: System.spur-mt.697 Author: eem Time: 29 January 2015, 11:35:41.872 am UUID: c5404a70-5b08-4bdb-85d1-dcc6b9248882 Ancestors: System-mt.697, System.spur-cmm.696 System-mt.697 patched for Spur by SpurBootstrapMonticelloPackagePatcher Cog-eem.237 Let message tally ignore #home but just use #sender to handle block closures correctly. =============== Diff against System-mt.697 =============== Item was removed: - ----- Method: Object>>oopAge (in category '*system-support') ----- - oopAge - ^ ObjectHistory current ageOf: self! Item was removed: - ----- Method: Object>>oopTimestamp (in category '*system-support') ----- - oopTimestamp - ^ ObjectHistory current timestampOf: self! Item was removed: - Object subclass: #ObjectHistory - instanceVariableNames: 'marks markProcess' - classVariableNames: 'Current' - poolDictionaries: '' - category: 'System-Support'! - - !ObjectHistory commentStamp: 'bf 11/16/2012 12:19' prior: 0! - ObjectHistory holds ObjectHistoryMark objects which are placed in the object memory at regular intervals by its markProcess in the background. Adjacent marks (with no remaining objects inbetween) are coalesced so over time the collection does not grow unnecessarily large. - - Using these markers it is possible to determine the age of objects in memory from the time the ObjectHistory was initialized. Try e.g.: - self oopTimestamp. - self oopAge. - ObjectHistory current oopClassesByDate. - - Instance Variables - marks: SortedCollection of ObjectHistoryMark objects - markProcess: a Process running our markLoop - ! Item was removed: - ----- Method: ObjectHistory class>>current (in category 'accessing') ----- - current - ^ Current ifNil: [Current := self new]! Item was removed: - ----- Method: ObjectHistory class>>initialize (in category 'class initialization') ----- - initialize - self current. - ! Item was removed: - ----- Method: ObjectHistory>>ageOf: (in category 'queries') ----- - ageOf: anObject - "Age of anObject in seconds" - | timestamp | - timestamp := self timestampOf: anObject. - timestamp ifNil: [^0]. - ^(DateAndTime now - timestamp) asSeconds roundTo: self markRate! Item was removed: - ----- Method: ObjectHistory>>initialize (in category 'initializing') ----- - initialize - self restartMarkProcess. - - ! Item was removed: - ----- Method: ObjectHistory>>markLoop (in category 'marking') ----- - markLoop - [true] whileTrue: [ - self markUpdate. - (Delay forSeconds: self markRate) wait]! Item was removed: - ----- Method: ObjectHistory>>markRate (in category 'marking') ----- - markRate - "rate of creating ObjectHistoryMarks" - ^60! Item was removed: - ----- Method: ObjectHistory>>markUpdate (in category 'marking') ----- - markUpdate - "Add a new mark and compact the marks collection" - | mark prev | - "lazy init so this happens in the background process" - marks ifNil: [self reinitMarks]. - "add new mark to object memory" - mark := self newMark. - mark timestamp <= marks last timestamp ifTrue: [^self "could happen if clock is wrong"]. - marks addLast: mark. - "compact the table by removing adjacent marks" - prev := marks first. - marks removeAllSuchThat: [:each | | doDelete | - doDelete := prev objectAfter == each. - prev := each. - doDelete]. - "The loop above is O(n) in number of marks, but that number should never become so large to be an issue. Even if the number was large, this is running at system background priority so should not interfere with any user process, not even user background processes. The symptom should only be that the system is less idle. - - If we ever get to a point where the number of marks is an issue then the compacting here could be made partial: since old marks rarely get coalesced it would make sense to only check the newer ones often, and the old ones perhaps only at the system startup."! Item was removed: - ----- Method: ObjectHistory>>newMark (in category 'private') ----- - newMark - ^ ObjectHistoryMark new! Item was removed: - ----- Method: ObjectHistory>>oopClassesByAge (in category 'stats') ----- - oopClassesByAge - "Answer collection of (oopAge in seconds -> sorted counts of object classes) sorted from lowest age" - "ObjectHistory current oopClassesByAge" - - | stats prev endOfMemory now bag age obj | - endOfMemory := Object new. - stats := OrderedCollection new: 1000. - prev := nil. - now := self newMark timestamp. - marks do: [:mark | - prev ifNotNil: [ - bag := Bag new. - obj := prev objectAfter. - [obj == mark] whileFalse: [ - bag add: obj class. - obj := obj nextObject. - obj == endOfMemory ifTrue: [self error: 'should not happen']]. - age := (now - mark timestamp) asSeconds roundTo: self markRate. - stats addFirst: age -> bag sortedCounts]. - prev := mark]. - ^ stats - ! Item was removed: - ----- Method: ObjectHistory>>oopClassesByDate (in category 'stats') ----- - oopClassesByDate - "Answer collection of (Date -> sorted counts of object classes) sorted from newest date" - "ObjectHistory current oopClassesByDate" - - | stats prev endOfMemory bag date obj thisDate | - endOfMemory := Object new. - stats := OrderedCollection new: 1000. - prev := nil. - thisDate := nil. - bag := Bag new. - marks do: [:mark | - prev ifNotNil: [ - obj := prev objectAfter. - [obj == mark] whileFalse: [ - bag add: obj class. - obj := obj nextObject. - obj == endOfMemory ifTrue: [self error: 'should not happen']]. - date := mark timestamp asDate. - thisDate = date ifFalse: [ - stats addFirst: date -> bag sortedCounts. - bag := Bag new. - thisDate := date]]. - prev := mark]. - thisDate = date ifFalse: [ - stats addLast: date -> bag sortedCounts]. - ^ stats - ! Item was removed: - ----- Method: ObjectHistory>>oopCountsByAge (in category 'stats') ----- - oopCountsByAge - "Answer collection of (oopAge in seconds -> number of objects) sorted from lowest age" - "ObjectHistory current oopCountsByAge" - - | stats prev endOfMemory now n age obj | - endOfMemory := Object new. - stats := OrderedCollection new: 1000. - prev := nil. - now := self newMark timestamp. - marks do: [:mark | - prev ifNotNil: [ - n := 0. - obj := prev objectAfter. - [obj == mark] whileFalse: [ - n := n + 1. - obj := obj nextObject. - obj == endOfMemory ifTrue: [self error: 'should not happen']]. - age := (now - mark timestamp) asSeconds roundTo: self markRate. - stats addFirst: age -> n]. - prev := mark]. - ^ stats - ! Item was removed: - ----- Method: ObjectHistory>>reinitMarks (in category 'private') ----- - reinitMarks - marks := ObjectHistoryMark allInstances asOrderedCollection. - marks - ifEmpty: [marks add: self newMark] - ifNotEmpty: [ | prev | - prev := nil. - marks removeAllSuchThat: [:obj | - prev notNil and: [prev timestamp >= obj timestamp]]]. - ! Item was removed: - ----- Method: ObjectHistory>>restartMarkProcess (in category 'marking') ----- - restartMarkProcess - markProcess ifNotNil: [markProcess terminate]. - markProcess := [self markLoop] - forkAt: Processor systemBackgroundPriority - named: 'ObjectHistory''s markProcess'. - ! Item was removed: - ----- Method: ObjectHistory>>timestampOf: (in category 'queries') ----- - timestampOf: anObject - "Timestamp of anObject, or nil if too new" - | endOfMemory mark | - anObject class == SmallInteger ifTrue: [^nil]. - mark := anObject. - endOfMemory := Object new. - [mark class == ObjectHistoryMark] whileFalse: [ - mark := mark nextObject. - mark == endOfMemory ifTrue: [^nil]]. - ^mark timestamp! Item was removed: - Object subclass: #ObjectHistoryMark - instanceVariableNames: 'timestamp' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - - !ObjectHistoryMark commentStamp: 'bf 11/7/2012 00:12' prior: 0! - An ObjectHistoryMark is a permanent mark in the object memory. It holds a timestamp. - - While the timestamp could be used directly as mark by ObjectHistory, it's conceivable that its format might change in the future, and we do not want the mark's relative position in memory to change (which would be the case if it was migrated to a new format). So we use a distinct object instead (and we protect it against accidental become-ing by overriding those methods).! Item was removed: - ----- Method: ObjectHistoryMark>>become: (in category 'mutating') ----- - become: otherObject - ^self error: 'marks need to stay fixed in the object memory'! Item was removed: - ----- Method: ObjectHistoryMark>>becomeForward: (in category 'mutating') ----- - becomeForward: otherObject - ^self error: 'marks need to stay fixed in the object memory'! Item was removed: - ----- Method: ObjectHistoryMark>>initialize (in category 'initialization') ----- - initialize - timestamp := DateAndTime now floor. - ! Item was removed: - ----- Method: ObjectHistoryMark>>objectAfter (in category 'accessing') ----- - objectAfter - "Answer the next object in memory after me and my timestamp" - | successor | - successor := self nextObject. - successor == timestamp - ifTrue: [successor := successor nextObject]. - ^ successor! Item was removed: - ----- Method: ObjectHistoryMark>>printOn: (in category 'printing') ----- - printOn: aStream - aStream - nextPutAll: self class name; - nextPut: $(; - print: timestamp; - nextPut: $)! Item was removed: - ----- Method: ObjectHistoryMark>>timestamp (in category 'accessing') ----- - timestamp - ^timestamp - ! Item was changed: ----- Method: SmalltalkImage>>compactClassesArray (in category 'special objects') ----- compactClassesArray "Smalltalk compactClassesArray" + "Backward-compatibility support. Spur does not have compact classes." + ^{}! - "Return the array of 31 classes whose instances may be - represented compactly" - ^ self specialObjectsArray at: 29! Item was added: + ----- Method: SmalltalkImage>>growMemoryByAtLeast: (in category 'memory space') ----- + growMemoryByAtLeast: numBytes + "Grow memory by at least the requested number of bytes. + Primitive. Essential. Fail if no memory is available." + <primitive: 180> + (numBytes isInteger and: [numBytes > 0]) ifTrue: + [OutOfMemory signal]. + ^self primitiveFailed! Item was added: + ----- Method: SmalltalkImage>>maxIdentityHash (in category 'system attributes') ----- + maxIdentityHash + "Answer the maximum identityHash value supported by the VM." + <primitive: 176> + ^self primitiveFailed! Item was changed: ----- Method: SmalltalkImage>>recreateSpecialObjectsArray (in category 'special objects') ----- recreateSpecialObjectsArray "Smalltalk recreateSpecialObjectsArray" "To external package developers: **** DO NOT OVERRIDE THIS METHOD. ***** If you are writing a plugin and need additional special object(s) for your own use, use addGCRoot() function and use own, separate special objects registry " "The Special Objects Array is an array of objects used by the Squeak virtual machine. Its contents are critical and accesses to it by the VM are unchecked, so don't even think of playing here unless you know what you are doing." | newArray | + newArray := Array new: 60. - newArray := Array new: 58. "Nil false and true get used throughout the interpreter" newArray at: 1 put: nil. newArray at: 2 put: false. newArray at: 3 put: true. "This association holds the active process (a ProcessScheduler)" newArray at: 4 put: (self specialObjectsArray at: 4) "(self bindingOf: #Processor) but it answers an Alias". "Numerous classes below used for type checking and instantiation" newArray at: 5 put: Bitmap. newArray at: 6 put: SmallInteger. newArray at: 7 put: ByteString. newArray at: 8 put: Array. newArray at: 9 put: Smalltalk. + newArray at: 10 put: BoxedFloat64. + newArray at: 11 put: (self globals at: #MethodContext ifAbsent: [self globals at: #Context]). + newArray at: 12 put: nil. "was BlockContext." - newArray at: 10 put: Float. - newArray at: 11 put: MethodContext. - newArray at: 12 put: BlockContext. newArray at: 13 put: Point. newArray at: 14 put: LargePositiveInteger. newArray at: 15 put: Display. newArray at: 16 put: Message. newArray at: 17 put: CompiledMethod. + newArray at: 18 put: ((self specialObjectsArray at: 18) ifNil: [Semaphore new]). "low space Semaphore" - newArray at: 18 put: (self specialObjectsArray at: 18). - "(low space Semaphore)" newArray at: 19 put: Semaphore. newArray at: 20 put: Character. newArray at: 21 put: #doesNotUnderstand:. newArray at: 22 put: #cannotReturn:. newArray at: 23 put: nil. "This is the process signalling low space." "An array of the 32 selectors that are compiled as special bytecodes, paired alternately with the number of arguments each takes." newArray at: 24 put: #( #+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1 #* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1 #at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 #class 0 #blockCopy: 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0 ). "An array of the 255 Characters in ascii order. + Cog inlines table into machine code at: prim so do not regenerate it. + This is nil in Spur, which has immediate Characters." - Cog inlines table into machine code at: prim so do not regenerate it." newArray at: 25 put: (self specialObjectsArray at: 25). newArray at: 26 put: #mustBeBoolean. newArray at: 27 put: ByteArray. newArray at: 28 put: Process. + "An array of up to 31 classes whose instances will have compact headers; an empty array in Spur" - "An array of up to 31 classes whose instances will have compact headers" newArray at: 29 put: self compactClassesArray. + newArray at: 30 put: ((self specialObjectsArray at: 30) ifNil: [Semaphore new]). "delay Semaphore" + newArray at: 31 put: ((self specialObjectsArray at: 31) ifNil: [Semaphore new]). "user interrupt Semaphore" - newArray at: 30 put: (self specialObjectsArray at: 30). "(delay Semaphore)" - newArray at: 31 put: (self specialObjectsArray at: 31). "(user interrupt Semaphore)" "Entries 32 - 34 unreferenced. Previously these contained prototype instances to be copied for fast initialization" + newArray at: 32 put: nil. "was the prototype Float" + newArray at: 33 put: nil. "was the prototype 4-byte LargePositiveInteger" + newArray at: 34 put: nil. "was the prototype Point" - newArray at: 32 put: nil. "was (Float new: 2)" - newArray at: 33 put: nil. "was (LargePositiveInteger new: 4)" - newArray at: 34 put: nil. "was Point new" newArray at: 35 put: #cannotInterpret:. + newArray at: 36 put: nil. "was the prototype MethodContext" - "Note: This must be fixed once we start using context prototypes (yeah, right)" - "(MethodContext new: CompiledMethod fullFrameSize)." - newArray at: 36 put: (self specialObjectsArray at: 36). "Is the prototype MethodContext (unused by the VM)" newArray at: 37 put: BlockClosure. + newArray at: 38 put: nil. "was the prototype BlockContext" - "(BlockContext new: CompiledMethod fullFrameSize)." - newArray at: 38 put: (self specialObjectsArray at: 38). "Is the prototype BlockContext (unused by the VM)" "array of objects referred to by external code" + newArray at: 39 put: (self specialObjectsArray at: 39). "external semaphores" - newArray at: 39 put: (self specialObjectsArray at: 39). "preserve external semaphores" newArray at: 40 put: nil. "Reserved for Mutex in Cog VMs" + newArray at: 41 put: ((self specialObjectsArray at: 41) ifNil: [LinkedList new]). "Reserved for a LinkedList instance for overlapped calls in CogMT" + newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil: [Semaphore new]). "finalization Semaphore" - newArray at: 41 put: nil. "Reserved for a LinkedList instance for overlapped calls in CogMT" - "finalization Semaphore" - newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil: [Semaphore new]). newArray at: 43 put: LargeNegativeInteger. "External objects for callout. Note: Written so that one can actually completely remove the FFI." newArray at: 44 put: (self at: #ExternalAddress ifAbsent: []). newArray at: 45 put: (self at: #ExternalStructure ifAbsent: []). newArray at: 46 put: (self at: #ExternalData ifAbsent: []). newArray at: 47 put: (self at: #ExternalFunction ifAbsent: []). newArray at: 48 put: (self at: #ExternalLibrary ifAbsent: []). newArray at: 49 put: #aboutToReturn:through:. newArray at: 50 put: #run:with:in:. "51 reserved for immutability message" + newArray at: 51 put: #attemptToAssign:withIndex:. - "newArray at: 51 put: #attemptToAssign:withIndex:." - newArray at: 51 put: (self specialObjectsArray at: 51 ifAbsent: []). newArray at: 52 put: #(nil "nil => generic error" #'bad receiver' #'bad argument' #'bad index' #'bad number of arguments' #'inappropriate operation' #'unsupported operation' #'no modification' #'insufficient object memory' #'insufficient C memory' #'not found' #'bad method' #'internal error in named primitive machinery' #'object may move' #'resource limit exceeded' + #'object is pinned' #'primitive write beyond end of object'). - #'object is pinned'). "53 to 55 are for Alien" newArray at: 53 put: (self at: #Alien ifAbsent: []). + newArray at: 54 put: #invokeCallbackContext:. "use invokeCallback:stack:registers:jmpbuf: for old Alien callbacks." - newArray at: 54 put: #invokeCallbackContext::. "use invokeCallback:stack:registers:jmpbuf: for old Alien callbacks." newArray at: 55 put: (self at: #UnsafeAlien ifAbsent: []). + "Used to be WeakFinalizationList for WeakFinalizationList hasNewFinalization, obsoleted by ephemeron support." + newArray at: 56 put: nil. - "Weak reference finalization" - newArray at: 56 put: (self at: #WeakFinalizationList ifAbsent: []). "reserved for foreign callback process" newArray at: 57 put: (self specialObjectsArray at: 57 ifAbsent: []). newArray at: 58 put: #unusedBytecode. + "59 reserved for Sista counter tripped message" + newArray at: 59 put: #conditionalBranchCounterTrippedOn:. + "60 reserved for Sista class trap message" + newArray at: 60 put: #classTrapFor:. "Now replace the interpreter's reference in one atomic operation" + self specialObjectsArray becomeForward: newArray! - self specialObjectsArray becomeForward: newArray - ! Item was changed: ----- Method: SmalltalkImage>>setGCParameters (in category 'snapshot and quit') ----- setGCParameters + "Adjust the VM's default GC parameters to avoid too much tenuring. + Maybe this should be left to the VM?" - "Adjust the VM's default GC parameters to avoid premature tenuring." + | proportion edenSize survivorSize averageObjectSize numObjects | + proportion := 0.9. "tenure when 90% of pastSpace is full" + edenSize := SmalltalkImage current vmParameterAt: 44. + survivorSize := edenSize / 5.0. "David's paper uses 140Kb eden + 2 x 28kb survivor spaces; Spur uses the same ratios :-)" + averageObjectSize := 8 * self wordSize. "a good approximation" + numObjects := (proportion * survivorSize / averageObjectSize) rounded. + SmalltalkImage current vmParameterAt: 6 put: numObjects "tenure when more than this many objects survive the GC"! - self vmParameterAt: 5 put: 4000. "do an incremental GC after this many allocations" - self vmParameterAt: 6 put: 2000. "tenure when more than this many objects survive the GC" - ! Item was changed: ----- Method: SpaceTally>>spaceForInstancesOf: (in category 'instance size') ----- spaceForInstancesOf: aClass + "Answer a pair of the number of bytes consumed by all instances of the + given class, including their object headers, and the number of instances." - "Answer the number of bytes consumed by all instances of the given class, including their object headers and the number of instances." + | instances total | + instances := aClass allInstances. + instances isEmpty ifTrue: [^#(0 0)]. - | smallHeaderSize instVarBytes isVariable bytesPerElement total lastInstance instance instanceCount | - instance := aClass someInstance ifNil: [ ^#(0 0) ]. - smallHeaderSize := aClass isCompact ifTrue: [ 4 ] ifFalse: [ 8 ]. - instVarBytes := aClass instSize * 4. - isVariable := aClass isVariable. - bytesPerElement := isVariable - ifFalse: [ 0 ] - ifTrue: [ aClass isBytes ifTrue: [ 1 ] ifFalse: [ 4 ] ]. total := 0. + aClass isVariable + ifTrue: + [instances do: + [:i| total := total + (aClass byteSizeOfInstanceOfSize: i basicSize)]] + ifFalse: + [total := instances size * aClass byteSizeOfInstance]. + ^{ total. instances size }! - instanceCount := 0. - "A modified version of #allInstancesDo: is inlined here. It avoids an infinite loop when another process is creating new instances of aClass." - self flag: #allInstancesDo:. - lastInstance := - aClass == CompiledMethod "CompiledMethod has special format, see its class comment" - ifTrue: [aClass new] - ifFalse: [aClass basicNew]. - [ instance == lastInstance ] whileFalse: [ - | contentBytes headerBytes | - contentBytes := instVarBytes + (isVariable - ifFalse: [ 0 ] - ifTrue: [ instance basicSize * bytesPerElement ]). - headerBytes := contentBytes > 255 - ifTrue: [ 12 ] - ifFalse: [ smallHeaderSize ]. - total := total + headerBytes + (contentBytes roundUpTo: 4). - instanceCount := instanceCount + 1. - instance := instance nextInstance ]. - ^{ total. instanceCount }! Item was added: + ----- Method: SystemDictionary>>growMemoryByAtLeast: (in category 'memory space') ----- + growMemoryByAtLeast: numBytes + "Grow memory by at least the requested number of bytes. + Primitive. Fail if no memory is available. Essential." + <primitive: 180> + ^(numBytes isInteger and: [numBytes > 0]) + ifTrue: [OutOfMemory signal] + ifFalse: [self primitiveFailed]! Item was added: + ----- Method: SystemDictionary>>maxIdentityHash (in category 'system attributes') ----- + maxIdentityHash + "Answer the maximum identityHash value supported by the VM." + <primitive: 176> + ^self primitiveFailed! Item was added: + ----- Method: SystemDictionary>>setGCParameters (in category 'snapshot and quit') ----- + setGCParameters + "Adjust the VM's default GC parameters to avoid too much tenuring. + Maybe this should be left to the VM?" + + | proportion edenSize survivorSize averageObjectSize numObjects | + proportion := 0.9. "tenure when 90% of pastSpace is full" + edenSize := SmalltalkImage current vmParameterAt: 44. + survivorSize := edenSize / 5.0. "David's paper uses 140Kb eden + 2 x 28kb survivor spaces; Spur uses the same ratios :-)" + averageObjectSize := 8 * self wordSize. "a good approximation" + numObjects := (proportion * survivorSize / averageObjectSize) rounded. + SmalltalkImage current vmParameterAt: 6 put: numObjects "tenure when more than this many objects survive the GC"! Item was added: + ----- Method: SystemNavigation>>allObjects (in category 'query') ----- + allObjects + "Answer an Array of all objects in the system. Fail if + there isn't enough memory to instantiate the result." + <primitive: 178> + ^self primitiveFailed! Item was changed: ----- Method: SystemNavigation>>allObjectsDo: (in category 'query') ----- allObjectsDo: aBlock + "Evaluate the argument, aBlock, for each object in the system, excluding immediates + such as SmallInteger and Character." + self allObjectsOrNil + ifNotNil: [:allObjects| allObjects do: aBlock] + ifNil: + ["Fall back on the old single object primitive code. With closures, this needs + to use an end marker (lastObject) since activation of the block will create + new contexts and cause an infinite loop. The lastObject must be created + before calling someObject, so that the VM can settle the enumeration (e.g. + by flushing new space) as a side effect of someObject" + | object lastObject | + lastObject := Object new. + object := self someObject. + [lastObject == object or: [0 == object]] whileFalse: + [aBlock value: object. + object := object nextObject]]! - "Evaluate the argument, aBlock, for each object in the system - excluding SmallIntegers. With closures, this needs to use an end - marker (lastObject) since activation of the block will create new - contexts and cause an infinite loop." - | object lastObject | - object := self someObject. - lastObject := Object new. - [lastObject == object or: [0 == object]] - whileFalse: [aBlock value: object. - object := object nextObject]! Item was added: + ----- Method: SystemNavigation>>allObjectsOrNil (in category 'query') ----- + allObjectsOrNil + "Answer an Array of all objects in the system. Fail if there isn't + enough memory to instantiate the result and answer nil." + <primitive: 178> + ^nil!

1 0

The Trunk: System.spur-eem.698.mcz
by commits＠source.squeak.org 29 Jan '15

29 Jan '15

Eliot Miranda uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System.spur-eem.698.mcz ==================== Summary ==================== Name: System.spur-eem.698 Author: eem Time: 29 January 2015, 11:35:33.911 am UUID: 46cbb32d-d5af-43bb-945b-d8b66adc67eb Ancestors: System-eem.698 System-eem.698 patched for Spur by SpurBootstrapMonticelloPackagePatcher Cog-eem.237 Provide an obsolete method for ObjectHistory that kills the current ObjectHistory's mark process if the class is removed. This allows Spur to easily remove ObjectHistory, which it does not support. =============== Diff against System-eem.698 =============== Item was removed: - ----- Method: Object>>oopAge (in category '*system-support') ----- - oopAge - ^ ObjectHistory current ageOf: self! Item was removed: - ----- Method: Object>>oopTimestamp (in category '*system-support') ----- - oopTimestamp - ^ ObjectHistory current timestampOf: self! Item was removed: - Object subclass: #ObjectHistory - instanceVariableNames: 'marks markProcess' - classVariableNames: 'Current' - poolDictionaries: '' - category: 'System-Support'! - - !ObjectHistory commentStamp: 'bf 11/16/2012 12:19' prior: 0! - ObjectHistory holds ObjectHistoryMark objects which are placed in the object memory at regular intervals by its markProcess in the background. Adjacent marks (with no remaining objects inbetween) are coalesced so over time the collection does not grow unnecessarily large. - - Using these markers it is possible to determine the age of objects in memory from the time the ObjectHistory was initialized. Try e.g.: - self oopTimestamp. - self oopAge. - ObjectHistory current oopClassesByDate. - - Instance Variables - marks: SortedCollection of ObjectHistoryMark objects - markProcess: a Process running our markLoop - ! Item was removed: - ----- Method: ObjectHistory class>>current (in category 'accessing') ----- - current - ^ Current ifNil: [Current := self new]! Item was removed: - ----- Method: ObjectHistory class>>initialize (in category 'class initialization') ----- - initialize - self current. - ! Item was removed: - ----- Method: ObjectHistory class>>obsolete (in category 'class initialization') ----- - obsolete - "Kill the mark process before removing the class." - Current ifNotNil: - [:objectHistory| - objectHistory terminate]! Item was removed: - ----- Method: ObjectHistory>>ageOf: (in category 'queries') ----- - ageOf: anObject - "Age of anObject in seconds" - | timestamp | - timestamp := self timestampOf: anObject. - timestamp ifNil: [^0]. - ^(DateAndTime now - timestamp) asSeconds roundTo: self markRate! Item was removed: - ----- Method: ObjectHistory>>initialize (in category 'initializing') ----- - initialize - self restartMarkProcess. - - ! Item was removed: - ----- Method: ObjectHistory>>markLoop (in category 'marking') ----- - markLoop - [true] whileTrue: [ - self markUpdate. - (Delay forSeconds: self markRate) wait]! Item was removed: - ----- Method: ObjectHistory>>markRate (in category 'marking') ----- - markRate - "rate of creating ObjectHistoryMarks" - ^60! Item was removed: - ----- Method: ObjectHistory>>markUpdate (in category 'marking') ----- - markUpdate - "Add a new mark and compact the marks collection" - | mark prev | - "lazy init so this happens in the background process" - marks ifNil: [self reinitMarks]. - "add new mark to object memory" - mark := self newMark. - mark timestamp <= marks last timestamp ifTrue: [^self "could happen if clock is wrong"]. - marks addLast: mark. - "compact the table by removing adjacent marks" - prev := marks first. - marks removeAllSuchThat: [:each | | doDelete | - doDelete := prev objectAfter == each. - prev := each. - doDelete]. - "The loop above is O(n) in number of marks, but that number should never become so large to be an issue. Even if the number was large, this is running at system background priority so should not interfere with any user process, not even user background processes. The symptom should only be that the system is less idle. - - If we ever get to a point where the number of marks is an issue then the compacting here could be made partial: since old marks rarely get coalesced it would make sense to only check the newer ones often, and the old ones perhaps only at the system startup."! Item was removed: - ----- Method: ObjectHistory>>newMark (in category 'private') ----- - newMark - ^ ObjectHistoryMark new! Item was removed: - ----- Method: ObjectHistory>>oopClassesByAge (in category 'stats') ----- - oopClassesByAge - "Answer collection of (oopAge in seconds -> sorted counts of object classes) sorted from lowest age" - "ObjectHistory current oopClassesByAge" - - | stats prev endOfMemory now bag age obj | - endOfMemory := Object new. - stats := OrderedCollection new: 1000. - prev := nil. - now := self newMark timestamp. - marks do: [:mark | - prev ifNotNil: [ - bag := Bag new. - obj := prev objectAfter. - [obj == mark] whileFalse: [ - bag add: obj class. - obj := obj nextObject. - obj == endOfMemory ifTrue: [self error: 'should not happen']]. - age := (now - mark timestamp) asSeconds roundTo: self markRate. - stats addFirst: age -> bag sortedCounts]. - prev := mark]. - ^ stats - ! Item was removed: - ----- Method: ObjectHistory>>oopClassesByDate (in category 'stats') ----- - oopClassesByDate - "Answer collection of (Date -> sorted counts of object classes) sorted from newest date" - "ObjectHistory current oopClassesByDate" - - | stats prev endOfMemory bag date obj thisDate | - endOfMemory := Object new. - stats := OrderedCollection new: 1000. - prev := nil. - thisDate := nil. - bag := Bag new. - marks do: [:mark | - prev ifNotNil: [ - obj := prev objectAfter. - [obj == mark] whileFalse: [ - bag add: obj class. - obj := obj nextObject. - obj == endOfMemory ifTrue: [self error: 'should not happen']]. - date := mark timestamp asDate. - thisDate = date ifFalse: [ - stats addFirst: date -> bag sortedCounts. - bag := Bag new. - thisDate := date]]. - prev := mark]. - thisDate = date ifFalse: [ - stats addLast: date -> bag sortedCounts]. - ^ stats - ! Item was removed: - ----- Method: ObjectHistory>>oopCountsByAge (in category 'stats') ----- - oopCountsByAge - "Answer collection of (oopAge in seconds -> number of objects) sorted from lowest age" - "ObjectHistory current oopCountsByAge" - - | stats prev endOfMemory now n age obj | - endOfMemory := Object new. - stats := OrderedCollection new: 1000. - prev := nil. - now := self newMark timestamp. - marks do: [:mark | - prev ifNotNil: [ - n := 0. - obj := prev objectAfter. - [obj == mark] whileFalse: [ - n := n + 1. - obj := obj nextObject. - obj == endOfMemory ifTrue: [self error: 'should not happen']]. - age := (now - mark timestamp) asSeconds roundTo: self markRate. - stats addFirst: age -> n]. - prev := mark]. - ^ stats - ! Item was removed: - ----- Method: ObjectHistory>>reinitMarks (in category 'private') ----- - reinitMarks - marks := ObjectHistoryMark allInstances asOrderedCollection. - marks - ifEmpty: [marks add: self newMark] - ifNotEmpty: [ | prev | - prev := nil. - marks removeAllSuchThat: [:obj | - prev notNil and: [prev timestamp >= obj timestamp]]]. - ! Item was removed: - ----- Method: ObjectHistory>>restartMarkProcess (in category 'marking') ----- - restartMarkProcess - markProcess ifNotNil: [markProcess terminate]. - markProcess := [self markLoop] - forkAt: Processor systemBackgroundPriority - named: 'ObjectHistory''s markProcess'. - ! Item was removed: - ----- Method: ObjectHistory>>terminate (in category 'private') ----- - terminate - markProcess ifNotNil: - [markProcess terminate]! Item was removed: - ----- Method: ObjectHistory>>timestampOf: (in category 'queries') ----- - timestampOf: anObject - "Timestamp of anObject, or nil if too new" - | endOfMemory mark | - anObject class == SmallInteger ifTrue: [^nil]. - mark := anObject. - endOfMemory := Object new. - [mark class == ObjectHistoryMark] whileFalse: [ - mark := mark nextObject. - mark == endOfMemory ifTrue: [^nil]]. - ^mark timestamp! Item was removed: - Object subclass: #ObjectHistoryMark - instanceVariableNames: 'timestamp' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - - !ObjectHistoryMark commentStamp: 'bf 11/7/2012 00:12' prior: 0! - An ObjectHistoryMark is a permanent mark in the object memory. It holds a timestamp. - - While the timestamp could be used directly as mark by ObjectHistory, it's conceivable that its format might change in the future, and we do not want the mark's relative position in memory to change (which would be the case if it was migrated to a new format). So we use a distinct object instead (and we protect it against accidental become-ing by overriding those methods).! Item was removed: - ----- Method: ObjectHistoryMark>>become: (in category 'mutating') ----- - become: otherObject - ^self error: 'marks need to stay fixed in the object memory'! Item was removed: - ----- Method: ObjectHistoryMark>>becomeForward: (in category 'mutating') ----- - becomeForward: otherObject - ^self error: 'marks need to stay fixed in the object memory'! Item was removed: - ----- Method: ObjectHistoryMark>>initialize (in category 'initialization') ----- - initialize - timestamp := DateAndTime now floor. - ! Item was removed: - ----- Method: ObjectHistoryMark>>objectAfter (in category 'accessing') ----- - objectAfter - "Answer the next object in memory after me and my timestamp" - | successor | - successor := self nextObject. - successor == timestamp - ifTrue: [successor := successor nextObject]. - ^ successor! Item was removed: - ----- Method: ObjectHistoryMark>>printOn: (in category 'printing') ----- - printOn: aStream - aStream - nextPutAll: self class name; - nextPut: $(; - print: timestamp; - nextPut: $)! Item was removed: - ----- Method: ObjectHistoryMark>>timestamp (in category 'accessing') ----- - timestamp - ^timestamp - ! Item was changed: ----- Method: SmalltalkImage>>compactClassesArray (in category 'special objects') ----- compactClassesArray "Smalltalk compactClassesArray" + "Backward-compatibility support. Spur does not have compact classes." + ^{}! - "Return the array of 31 classes whose instances may be - represented compactly" - ^ self specialObjectsArray at: 29! Item was added: + ----- Method: SmalltalkImage>>growMemoryByAtLeast: (in category 'memory space') ----- + growMemoryByAtLeast: numBytes + "Grow memory by at least the requested number of bytes. + Primitive. Essential. Fail if no memory is available." + <primitive: 180> + (numBytes isInteger and: [numBytes > 0]) ifTrue: + [OutOfMemory signal]. + ^self primitiveFailed! Item was added: + ----- Method: SmalltalkImage>>maxIdentityHash (in category 'system attributes') ----- + maxIdentityHash + "Answer the maximum identityHash value supported by the VM." + <primitive: 176> + ^self primitiveFailed! Item was changed: ----- Method: SmalltalkImage>>recreateSpecialObjectsArray (in category 'special objects') ----- recreateSpecialObjectsArray "Smalltalk recreateSpecialObjectsArray" "To external package developers: **** DO NOT OVERRIDE THIS METHOD. ***** If you are writing a plugin and need additional special object(s) for your own use, use addGCRoot() function and use own, separate special objects registry " "The Special Objects Array is an array of objects used by the Squeak virtual machine. Its contents are critical and accesses to it by the VM are unchecked, so don't even think of playing here unless you know what you are doing." | newArray | + newArray := Array new: 60. - newArray := Array new: 58. "Nil false and true get used throughout the interpreter" newArray at: 1 put: nil. newArray at: 2 put: false. newArray at: 3 put: true. "This association holds the active process (a ProcessScheduler)" newArray at: 4 put: (self specialObjectsArray at: 4) "(self bindingOf: #Processor) but it answers an Alias". "Numerous classes below used for type checking and instantiation" newArray at: 5 put: Bitmap. newArray at: 6 put: SmallInteger. newArray at: 7 put: ByteString. newArray at: 8 put: Array. newArray at: 9 put: Smalltalk. + newArray at: 10 put: BoxedFloat64. + newArray at: 11 put: (self globals at: #MethodContext ifAbsent: [self globals at: #Context]). + newArray at: 12 put: nil. "was BlockContext." - newArray at: 10 put: Float. - newArray at: 11 put: MethodContext. - newArray at: 12 put: BlockContext. newArray at: 13 put: Point. newArray at: 14 put: LargePositiveInteger. newArray at: 15 put: Display. newArray at: 16 put: Message. newArray at: 17 put: CompiledMethod. + newArray at: 18 put: ((self specialObjectsArray at: 18) ifNil: [Semaphore new]). "low space Semaphore" - newArray at: 18 put: (self specialObjectsArray at: 18). - "(low space Semaphore)" newArray at: 19 put: Semaphore. newArray at: 20 put: Character. newArray at: 21 put: #doesNotUnderstand:. newArray at: 22 put: #cannotReturn:. newArray at: 23 put: nil. "This is the process signalling low space." "An array of the 32 selectors that are compiled as special bytecodes, paired alternately with the number of arguments each takes." newArray at: 24 put: #( #+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1 #* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1 #at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 #class 0 #blockCopy: 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0 ). "An array of the 255 Characters in ascii order. + Cog inlines table into machine code at: prim so do not regenerate it. + This is nil in Spur, which has immediate Characters." - Cog inlines table into machine code at: prim so do not regenerate it." newArray at: 25 put: (self specialObjectsArray at: 25). newArray at: 26 put: #mustBeBoolean. newArray at: 27 put: ByteArray. newArray at: 28 put: Process. + "An array of up to 31 classes whose instances will have compact headers; an empty array in Spur" - "An array of up to 31 classes whose instances will have compact headers" newArray at: 29 put: self compactClassesArray. + newArray at: 30 put: ((self specialObjectsArray at: 30) ifNil: [Semaphore new]). "delay Semaphore" + newArray at: 31 put: ((self specialObjectsArray at: 31) ifNil: [Semaphore new]). "user interrupt Semaphore" - newArray at: 30 put: (self specialObjectsArray at: 30). "(delay Semaphore)" - newArray at: 31 put: (self specialObjectsArray at: 31). "(user interrupt Semaphore)" "Entries 32 - 34 unreferenced. Previously these contained prototype instances to be copied for fast initialization" + newArray at: 32 put: nil. "was the prototype Float" + newArray at: 33 put: nil. "was the prototype 4-byte LargePositiveInteger" + newArray at: 34 put: nil. "was the prototype Point" - newArray at: 32 put: nil. "was (Float new: 2)" - newArray at: 33 put: nil. "was (LargePositiveInteger new: 4)" - newArray at: 34 put: nil. "was Point new" newArray at: 35 put: #cannotInterpret:. + newArray at: 36 put: nil. "was the prototype MethodContext" - "Note: This must be fixed once we start using context prototypes (yeah, right)" - "(MethodContext new: CompiledMethod fullFrameSize)." - newArray at: 36 put: (self specialObjectsArray at: 36). "Is the prototype MethodContext (unused by the VM)" newArray at: 37 put: BlockClosure. + newArray at: 38 put: nil. "was the prototype BlockContext" - "(BlockContext new: CompiledMethod fullFrameSize)." - newArray at: 38 put: (self specialObjectsArray at: 38). "Is the prototype BlockContext (unused by the VM)" "array of objects referred to by external code" + newArray at: 39 put: (self specialObjectsArray at: 39). "external semaphores" - newArray at: 39 put: (self specialObjectsArray at: 39). "preserve external semaphores" newArray at: 40 put: nil. "Reserved for Mutex in Cog VMs" + newArray at: 41 put: ((self specialObjectsArray at: 41) ifNil: [LinkedList new]). "Reserved for a LinkedList instance for overlapped calls in CogMT" + newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil: [Semaphore new]). "finalization Semaphore" - newArray at: 41 put: nil. "Reserved for a LinkedList instance for overlapped calls in CogMT" - "finalization Semaphore" - newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil: [Semaphore new]). newArray at: 43 put: LargeNegativeInteger. "External objects for callout. Note: Written so that one can actually completely remove the FFI." newArray at: 44 put: (self at: #ExternalAddress ifAbsent: []). newArray at: 45 put: (self at: #ExternalStructure ifAbsent: []). newArray at: 46 put: (self at: #ExternalData ifAbsent: []). newArray at: 47 put: (self at: #ExternalFunction ifAbsent: []). newArray at: 48 put: (self at: #ExternalLibrary ifAbsent: []). newArray at: 49 put: #aboutToReturn:through:. newArray at: 50 put: #run:with:in:. "51 reserved for immutability message" + newArray at: 51 put: #attemptToAssign:withIndex:. - "newArray at: 51 put: #attemptToAssign:withIndex:." - newArray at: 51 put: (self specialObjectsArray at: 51 ifAbsent: []). newArray at: 52 put: #(nil "nil => generic error" #'bad receiver' #'bad argument' #'bad index' #'bad number of arguments' #'inappropriate operation' #'unsupported operation' #'no modification' #'insufficient object memory' #'insufficient C memory' #'not found' #'bad method' #'internal error in named primitive machinery' #'object may move' #'resource limit exceeded' + #'object is pinned' #'primitive write beyond end of object'). - #'object is pinned'). "53 to 55 are for Alien" newArray at: 53 put: (self at: #Alien ifAbsent: []). + newArray at: 54 put: #invokeCallbackContext:. "use invokeCallback:stack:registers:jmpbuf: for old Alien callbacks." - newArray at: 54 put: #invokeCallbackContext::. "use invokeCallback:stack:registers:jmpbuf: for old Alien callbacks." newArray at: 55 put: (self at: #UnsafeAlien ifAbsent: []). + "Used to be WeakFinalizationList for WeakFinalizationList hasNewFinalization, obsoleted by ephemeron support." + newArray at: 56 put: nil. - "Weak reference finalization" - newArray at: 56 put: (self at: #WeakFinalizationList ifAbsent: []). "reserved for foreign callback process" newArray at: 57 put: (self specialObjectsArray at: 57 ifAbsent: []). newArray at: 58 put: #unusedBytecode. + "59 reserved for Sista counter tripped message" + newArray at: 59 put: #conditionalBranchCounterTrippedOn:. + "60 reserved for Sista class trap message" + newArray at: 60 put: #classTrapFor:. "Now replace the interpreter's reference in one atomic operation" + self specialObjectsArray becomeForward: newArray! - self specialObjectsArray becomeForward: newArray - ! Item was changed: ----- Method: SmalltalkImage>>setGCParameters (in category 'snapshot and quit') ----- setGCParameters + "Adjust the VM's default GC parameters to avoid too much tenuring. + Maybe this should be left to the VM?" - "Adjust the VM's default GC parameters to avoid premature tenuring." + | proportion edenSize survivorSize averageObjectSize numObjects | + proportion := 0.9. "tenure when 90% of pastSpace is full" + edenSize := SmalltalkImage current vmParameterAt: 44. + survivorSize := edenSize / 5.0. "David's paper uses 140Kb eden + 2 x 28kb survivor spaces; Spur uses the same ratios :-)" + averageObjectSize := 8 * self wordSize. "a good approximation" + numObjects := (proportion * survivorSize / averageObjectSize) rounded. + SmalltalkImage current vmParameterAt: 6 put: numObjects "tenure when more than this many objects survive the GC"! - self vmParameterAt: 5 put: 4000. "do an incremental GC after this many allocations" - self vmParameterAt: 6 put: 2000. "tenure when more than this many objects survive the GC" - ! Item was changed: ----- Method: SpaceTally>>spaceForInstancesOf: (in category 'instance size') ----- spaceForInstancesOf: aClass + "Answer a pair of the number of bytes consumed by all instances of the + given class, including their object headers, and the number of instances." - "Answer the number of bytes consumed by all instances of the given class, including their object headers and the number of instances." + | instances total | + instances := aClass allInstances. + instances isEmpty ifTrue: [^#(0 0)]. - | smallHeaderSize instVarBytes isVariable bytesPerElement total lastInstance instance instanceCount | - instance := aClass someInstance ifNil: [ ^#(0 0) ]. - smallHeaderSize := aClass isCompact ifTrue: [ 4 ] ifFalse: [ 8 ]. - instVarBytes := aClass instSize * 4. - isVariable := aClass isVariable. - bytesPerElement := isVariable - ifFalse: [ 0 ] - ifTrue: [ aClass isBytes ifTrue: [ 1 ] ifFalse: [ 4 ] ]. total := 0. + aClass isVariable + ifTrue: + [instances do: + [:i| total := total + (aClass byteSizeOfInstanceOfSize: i basicSize)]] + ifFalse: + [total := instances size * aClass byteSizeOfInstance]. + ^{ total. instances size }! - instanceCount := 0. - "A modified version of #allInstancesDo: is inlined here. It avoids an infinite loop when another process is creating new instances of aClass." - self flag: #allInstancesDo:. - lastInstance := - aClass == CompiledMethod "CompiledMethod has special format, see its class comment" - ifTrue: [aClass new] - ifFalse: [aClass basicNew]. - [ instance == lastInstance ] whileFalse: [ - | contentBytes headerBytes | - contentBytes := instVarBytes + (isVariable - ifFalse: [ 0 ] - ifTrue: [ instance basicSize * bytesPerElement ]). - headerBytes := contentBytes > 255 - ifTrue: [ 12 ] - ifFalse: [ smallHeaderSize ]. - total := total + headerBytes + (contentBytes roundUpTo: 4). - instanceCount := instanceCount + 1. - instance := instance nextInstance ]. - ^{ total. instanceCount }! Item was added: + ----- Method: SystemDictionary>>growMemoryByAtLeast: (in category 'memory space') ----- + growMemoryByAtLeast: numBytes + "Grow memory by at least the requested number of bytes. + Primitive. Fail if no memory is available. Essential." + <primitive: 180> + ^(numBytes isInteger and: [numBytes > 0]) + ifTrue: [OutOfMemory signal] + ifFalse: [self primitiveFailed]! Item was added: + ----- Method: SystemDictionary>>maxIdentityHash (in category 'system attributes') ----- + maxIdentityHash + "Answer the maximum identityHash value supported by the VM." + <primitive: 176> + ^self primitiveFailed! Item was added: + ----- Method: SystemDictionary>>setGCParameters (in category 'snapshot and quit') ----- + setGCParameters + "Adjust the VM's default GC parameters to avoid too much tenuring. + Maybe this should be left to the VM?" + + | proportion edenSize survivorSize averageObjectSize numObjects | + proportion := 0.9. "tenure when 90% of pastSpace is full" + edenSize := SmalltalkImage current vmParameterAt: 44. + survivorSize := edenSize / 5.0. "David's paper uses 140Kb eden + 2 x 28kb survivor spaces; Spur uses the same ratios :-)" + averageObjectSize := 8 * self wordSize. "a good approximation" + numObjects := (proportion * survivorSize / averageObjectSize) rounded. + SmalltalkImage current vmParameterAt: 6 put: numObjects "tenure when more than this many objects survive the GC"! Item was added: + ----- Method: SystemNavigation>>allObjects (in category 'query') ----- + allObjects + "Answer an Array of all objects in the system. Fail if + there isn't enough memory to instantiate the result." + <primitive: 178> + ^self primitiveFailed! Item was changed: ----- Method: SystemNavigation>>allObjectsDo: (in category 'query') ----- allObjectsDo: aBlock + "Evaluate the argument, aBlock, for each object in the system, excluding immediates + such as SmallInteger and Character." + self allObjectsOrNil + ifNotNil: [:allObjects| allObjects do: aBlock] + ifNil: + ["Fall back on the old single object primitive code. With closures, this needs + to use an end marker (lastObject) since activation of the block will create + new contexts and cause an infinite loop. The lastObject must be created + before calling someObject, so that the VM can settle the enumeration (e.g. + by flushing new space) as a side effect of someObject" + | object lastObject | + lastObject := Object new. + object := self someObject. + [lastObject == object or: [0 == object]] whileFalse: + [aBlock value: object. + object := object nextObject]]! - "Evaluate the argument, aBlock, for each object in the system - excluding SmallIntegers. With closures, this needs to use an end - marker (lastObject) since activation of the block will create new - contexts and cause an infinite loop." - | object lastObject | - object := self someObject. - lastObject := Object new. - [lastObject == object or: [0 == object]] - whileFalse: [aBlock value: object. - object := object nextObject]! Item was added: + ----- Method: SystemNavigation>>allObjectsOrNil (in category 'query') ----- + allObjectsOrNil + "Answer an Array of all objects in the system. Fail if there isn't + enough memory to instantiate the result and answer nil." + <primitive: 178> + ^nil!

1 0

The Trunk: Kernel.spur-eem.894.mcz
by commits＠source.squeak.org 29 Jan '15

29 Jan '15

1 0

The Trunk: System.spur-eem.699.mcz
by commits＠source.squeak.org 29 Jan '15

29 Jan '15

1 0

The Trunk: Kernel-eem.894.mcz
by commits＠source.squeak.org 29 Jan '15

29 Jan '15

Eliot Miranda uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-eem.894.mcz ==================== Summary ==================== Name: Kernel-eem.894 Author: eem Time: 29 January 2015, 10:54:41.65 am UUID: 4c8074eb-6db4-4d9b-bbfe-cd8f7197b999 Ancestors: Kernel-ul.893 Access a process's environment from effectiveProcess to provide correct environment access when debugging. =============== Diff against Kernel-ul.893 =============== Item was added: + ----- Method: Process>>effectiveEnvironment (in category 'private') ----- + effectiveEnvironment + "effectiveProcess is a mechanism to allow process-faithful debugging. The debugger executes code + on behalf of processes, so unless some effort is made, the identity of Processor activeProcess is not + correctly maintained when debugging code. The debugger uses evaluate:onBehalfOf: to assign the + debugged process as the effectiveProcess of the process executing the code, preserving process + identity. By using the effectiveProcess's environment, access in the debugger is correct." + ^effectiveProcess + ifNil: [env] + ifNotNil: + [:theEffectiveProcess| + theEffectiveProcess effectiveEnvironment]! Item was changed: ----- Method: Process>>effectiveProcess (in category 'accessing') ----- effectiveProcess "effectiveProcess is a mechanism to allow process-faithful debugging. The debugger executes code + on behalf of processes, so unless some effort is made, the identity of Processor activeProcess is not - on behalf of processes, so unless some effort is made the identity of Processor activeProcess is not correctly maintained when debugging code. The debugger uses evaluate:onBehalfOf: to assign the debugged process as the effectiveProcess of the process executing the code, preserving process identity." ^effectiveProcess ifNil: [self]! Item was changed: ----- Method: Process>>environmentAt:ifAbsent: (in category 'process specific') ----- environmentAt: key ifAbsent: aBlock + ^(self effectiveEnvironment ifNil: [ ^aBlock value ]) at: key ifAbsent: aBlock.! - ^(env ifNil: [ ^aBlock value ]) at: key ifAbsent: aBlock.! Item was changed: ----- Method: Process>>environmentAt:ifAbsentPut: (in category 'process specific') ----- environmentAt: key ifAbsentPut: aBlock + ^self setEffectiveEnvironment at: key ifAbsentPut: aBlock! - ^(env ifNil: [ env := Dictionary new ]) at: key ifAbsentPut: aBlock.! Item was changed: ----- Method: Process>>environmentAt:put: (in category 'process specific') ----- environmentAt: key put: value + ^self setEffectiveEnvironment at: key put: value! - ^(env ifNil: [ env := Dictionary new ]) at: key put: value.! Item was changed: ----- Method: Process>>environmentRemoveKey:ifAbsent: (in category 'process specific') ----- environmentRemoveKey: key ifAbsent: errorBlock + ^(self effectiveEnvironment ifNil: [^errorBlock value]) + removeKey: key + ifAbsent: errorBlock! - ^(env ifNil: [ ^errorBlock value ]) removeKey: key ifAbsent: errorBlock! Item was added: + ----- Method: Process>>setEffectiveEnvironment (in category 'private') ----- + setEffectiveEnvironment + "effectiveProcess is a mechanism to allow process-faithful debugging. The debugger executes code + on behalf of processes, so unless some effort is made, the identity of Processor activeProcess is not + correctly maintained when debugging code. The debugger uses evaluate:onBehalfOf: to assign the + debugged process as the effectiveProcess of the process executing the code, preserving process + identity. By using the effectiveProcess's environment, access in the debugger is correct." + ^effectiveProcess + ifNil: [env ifNil: [env := Dictionary new]] + ifNotNil: + [:theEffectiveProcess| + theEffectiveProcess setEffectiveEnvironment]!

1 0

The Trunk: Kernel-eem.894.mcz
by commits＠source.squeak.org 29 Jan '15

29 Jan '15

1 0

The Trunk: Kernel-eem.894.mcz
by commits＠source.squeak.org 29 Jan '15

29 Jan '15

1 0

The Trunk: System-eem.699.mcz
by commits＠source.squeak.org 29 Jan '15

29 Jan '15

Eliot Miranda uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-eem.699.mcz ==================== Summary ==================== Name: System-eem.699 Author: eem Time: 28 January 2015, 4:49:52.494 pm UUID: 7aa9dbe2-e1cf-4547-bee4-c122268381d9 Ancestors: System-eem.698 Add block nesting to MessageTally. c.f. AndreasProfiler-eem.10 =============== Diff against System-eem.698 =============== Item was changed: Magnitude subclass: #MessageTally + instanceVariableNames: 'class method blockNesting process tally receivers senders time gcStats maxClassNameSize maxClassPlusSelectorSize maxTabs reportOtherProcesses time0 startTime endTime preHibernationCopy' - instanceVariableNames: 'class method process tally receivers senders time gcStats maxClassNameSize maxClassPlusSelectorSize maxTabs reportOtherProcesses time0 startTime endTime preHibernationCopy' classVariableNames: 'DefaultPollPeriod ShowProcesses Timer' poolDictionaries: '' category: 'System-Tools'! !MessageTally commentStamp: 'eem 7/16/2012 17:10' prior: 0! My instances observe and report the amount of time spent in methods. NOTE: a higher-level user interface (combining the MessageTally result tree with a method browser) is available from TimeProfileBrowser. Note that TimeProfileBrowser was not fancy with the different setting possibilities. TimeProfileBrowser spyOn: [20 timesRepeat: [Transcript show: 100 factorial printString]] Strategies ----------- MessageTally provides two different strategies available for profiling: * spyOn: and friends use a high-priority Process to interrupt the block or process being spied on at periodic intervals. The interrupted call stack is then examined for caller information. See below for an example showing different settings * tallySends: and friends use the interpreter simulator to run the block, recording every method call. The two give you different results: * spyOn: gives you a view of where the time is being spent in your program, at least on a rough statistical level (assuming you've run the block for long enough and have a high enough poll rate). If you're trying to optimize your code, start here and optimize the methods where most of the time is being spent first. * tallySends: gives you accurate counts of how many times methods get called, and by exactly which route. If you're debugging, or trying to figure out if a given method is getting called too many times, this is your tool. Q: How do you interpret MessageTally>>tallySends A: The methods #tallySends and #spyOn: measure two very different quantities, but broken down in the same who-called-who format. #spyOn: is approximate, but more indicative of real time spent, whereas #tallySends is exact and a precise record of how many times each method got executed. Examples ---------- Here you can see all the processes computation time [1000 timesRepeat: [3.14159 printString. Processor yield]] fork. [1000 timesRepeat: [30 factorial. Processor yield]] fork. [1000 timesRepeat: [30 factorial. Processor yield]] fork. MessageTally spyAllOn: [ (Delay forMilliseconds: 100) wait] This profiles across a snapshot, writing the output to {imageName}.N.profile | fn | fn := (FileDirectory baseNameFor: Smalltalk image imageName), '.profile'. [MessageTally spyOn: [Smalltalk image snapshot: true andQuit: true] toFileNamed: fn reportOtherProcesses: true] on: FileExistsException do: [:ex| ex resume: (FileStream forceNewFileNamed: (FileDirectory default nextNameFor: (FileDirectory localNameFor: (FileDirectory baseNameFor: fn)) extension: 'profile'))] Settings --------- You can change the printing format (that is, the whitespace and string compression) by using these instance methods: maxClassNameSize: maxClassPlusSelectorSize: maxTabs: You can change the default polling period (initially set to 1) by calling MessageTally defaultPollPeriod: numberOfMilliseconds To understand the difference ---------------------------------- Here we see all the processes [1000 timesRepeat: [ 100 timesRepeat: [120 factorial]. (Delay forMilliseconds: 10) wait ]] forkAt: 45 named: '45'. MessageTally spyAllOn: [10000 timesRepeat: [1.23 printString]] Here we only see the execution of the expression [10000 timesRepeat: [1.23 printString] [1000 timesRepeat: [ 100 timesRepeat: [120 factorial]. (Delay forMilliseconds: 10) wait ]] forkAt: 45 named: '45'. MessageTally spyOn: [10000 timesRepeat: [1.23 printString]] Here we only check the exact message sends: this is not a pc-sampling approach [1000 timesRepeat: [ 100 timesRepeat: [120 factorial]. (Delay forMilliseconds: 10) wait ]] forkAt: 45 named: '45'. MessageTally tallySends: [10000 timesRepeat: [1.23 printString]] ! Item was added: + ----- Method: MessageTally>>blockNesting (in category 'accessing') ----- + blockNesting + ^blockNesting! Item was added: + ----- Method: MessageTally>>blockNestingCountOf: (in category 'tallying') ----- + blockNestingCountOf: context + | count nest | + count := 0. + nest := context. + [nest closure notNil] whileTrue: + [count := count + 1. + nest := nest closure outerContext]. + ^count! Item was changed: ----- Method: MessageTally>>class:method: (in category 'private') ----- class: aClass method: aMethod class := aClass. method := aMethod. + tally := blockNesting := 0. + receivers := {}! - tally := 0. - receivers := Array new: 0! Item was added: + ----- Method: MessageTally>>class:method:nesting: (in category 'private') ----- + class: aClass method: aMethod nesting: blockNestingCount + + class := aClass. + method := aMethod. + blockNesting := blockNestingCount. + tally := 0. + receivers := {}! Item was changed: ----- Method: MessageTally>>copyWithTally: (in category 'private') ----- copyWithTally: hitCount + ^ (MessageTally new class: class method: method nesting: blockNesting) - ^ (MessageTally new class: class method: method) reportOtherProcesses: reportOtherProcesses; process: process; bump: hitCount! Item was changed: ----- Method: MessageTally>>into:fromSender: (in category 'collecting leaves') ----- into: leafDict fromSender: senderTally | leafNode | + leafNode := leafDict + at: method + ifAbsentPut: + [(self class new class: class method: method nesting: blockNesting) + process: process; + reportOtherProcesses: reportOtherProcesses]. - leafNode := leafDict at: method - ifAbsentPut: [(self class new class: class method: method) - process: process; - reportOtherProcesses: reportOtherProcesses]. leafNode bump: tally fromSender: senderTally! Item was changed: ----- Method: MessageTally>>printOn: (in category 'printing') ----- printOn: aStream | className | (class isNil or: [method isNil]) ifTrue: [^super printOn: aStream]. className := method methodClass name contractTo: self maxClassNameSize. + blockNesting ifNotNil: + [blockNesting timesRepeat: + [aStream nextPutAll: '[] in ']]. aStream nextPutAll: className; nextPutAll: ' >> '; nextPutAll: (method selector contractTo: self maxClassPlusSelectorSize - className size)! Item was changed: ----- Method: MessageTally>>printOn:total:totalTime:tallyExact: (in category 'printing') ----- printOn: aStream total: total totalTime: totalTime tallyExact: isExact | aSelector className myTally aClass percentage | isExact ifTrue: [myTally := tally. receivers == nil ifFalse: [receivers do: [:r | myTally := myTally - r tally]]. aStream print: myTally; space] ifFalse: [percentage := tally asFloat / total * 100.0. aStream nextPutAll: (percentage printShowingDecimalPlaces: 1); nextPutAll: '% {'; print: (percentage * totalTime / 100) rounded; nextPutAll: 'ms} ']. receivers == nil ifTrue: [aStream nextPutAll: 'primitives'; cr] ifFalse: [aSelector := method selector. aClass := method methodClass. className := aClass name contractTo: self maxClassNameSize. + blockNesting > 0 ifTrue: + [aStream + next: blockNesting put: $[; + next: blockNesting put: $]; + space]. aStream nextPutAll: class name; nextPutAll: (aClass = class ifTrue: ['>>'] ifFalse: ['(' , aClass name , ')>>']); nextPutAll: (aSelector contractTo: self maxClassPlusSelectorSize - className size); cr]! Item was changed: ----- Method: MessageTally>>sonsOver: (in category 'comparing') ----- sonsOver: threshold | hereTally last sons | + receivers basicSize = 0 ifTrue: [^#()]. - (receivers == nil or: [receivers size = 0]) ifTrue: [^#()]. hereTally := tally. sons := receivers select: "subtract subNode tallies for primitive hits here" [:son | hereTally := hereTally - son tally. son tally > threshold]. + hereTally > threshold ifTrue: + [last := MessageTally new class: class method: method nesting: blockNesting. + last process: process. + last reportOtherProcesses: reportOtherProcesses. + ^sons copyWith: (last primitives: hereTally)]. - hereTally > threshold - ifTrue: [ - last := MessageTally new class: class method: method. - last process: process. - last reportOtherProcesses: reportOtherProcesses. - ^sons copyWith: (last primitives: hereTally)]. ^sons! Item was changed: ----- Method: MessageTally>>tally:in:by: (in category 'tallying') ----- tally: context in: aProcess by: count "Explicitly tally the specified context and its stack." + | sender nesting | + nesting := self blockNestingCountOf: context. - | sender | "Add to this node if appropriate" + (context method == method + and: [blockNesting = nesting]) ifTrue: + [^self bumpBy: count]. - context method == method ifTrue: [^self bumpBy: count]. "No sender? Add new branch to the tree." + (sender := context sender) ifNil: + [^(self bumpBy: count) tallyPath: context in: aProcess by: count]. - (sender := context sender) ifNil: [ - ^ (self bumpBy: count) tallyPath: context in: aProcess by: count]. "Find the node for the sending context (or add it if necessary)" ^ (self tally: sender in: aProcess by: count) tallyPath: context in: aProcess by: count! Item was changed: ----- Method: MessageTally>>tallyPath:by: (in category 'tallying') ----- tallyPath: context by: count + | aMethod nesting path | - | aMethod path | aMethod := context method. + nesting := self blockNestingCountOf: context. + - "Find the correct child (if there)" + path := receivers + detect: [:oldTally | + oldTally method == aMethod + and: [oldTally blockNesting = nesting]] + ifNone: []. - receivers do: [ :oldTally | - oldTally method == aMethod ifTrue: [path := oldTally]]. "Add new child if needed" + path ifNil: + [path := MessageTally new class: context receiver class method: aMethod nesting: nesting. - path ifNil: [ - path := MessageTally new class: context receiver class method: aMethod. path reportOtherProcesses: reportOtherProcesses. receivers := receivers copyWith: path]. ^ path bumpBy: count! Item was changed: ----- Method: MessageTally>>tallyPath:in:by: (in category 'tallying') ----- tallyPath: context in: aProcess by: count + | aMethod nesting path | - | aMethod path | aMethod := context method. + nesting := self blockNestingCountOf: context. + - "Find the correct child (if there)" + path := receivers + detect: [:oldTally | + oldTally method == aMethod + and: [oldTally process == aProcess + and: [oldTally blockNesting = nesting]]] + ifNone: []. + - receivers do: [ :oldTally | - (oldTally method == aMethod and: [oldTally process == aProcess]) - ifTrue: [path := oldTally]]. - "Add new child if needed" + path ifNil: + [path := MessageTally new + class: context receiver class method: aMethod nesting: nesting; + process: aProcess; + reportOtherProcesses: reportOtherProcesses; + maxClassNameSize: maxClassNameSize; + maxClassPlusSelectorSize: maxClassPlusSelectorSize; + maxTabs: maxTabs. - path ifNil:[ - path := MessageTally new class: context receiver class method: aMethod; - process: aProcess; - reportOtherProcesses: reportOtherProcesses; - maxClassNameSize: maxClassNameSize; - maxClassPlusSelectorSize: maxClassPlusSelectorSize; - maxTabs: maxTabs. receivers := receivers copyWith: path]. + ^path bumpBy: count! - ^ path bumpBy: count!

1 0

← Newer
1
2
3
4
5
6
7
...
24
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages January 2015