[Vm-dev] VM Maker: CogAttic-eem.1.mcz
commits at source.squeak.org
commits at source.squeak.org
Mon Apr 3 16:33:32 UTC 2017
Eliot Miranda uploaded a new version of CogAttic to project VM Maker:
http://source.squeak.org/VMMaker/CogAttic-eem.1.mcz
==================== Summary ====================
Name: CogAttic-eem.1
Author: eem
Time: 3 April 2017, 9:33:17.758106 am
UUID: 51c2ce88-51e0-4384-b3e2-865d53d2cfd8
Ancestors:
Move a bunch of obsolete code to a history-preservation package to lessen Undeclared pollution of Cog.
==================== Snapshot ====================
SystemOrganization addCategory: #'CogAttic-Scripts'!
SystemOrganization addCategory: #'CogAttic-Bootstrapping'!
Object subclass: #SpurBootstrapMonticelloPackagePatcher
instanceVariableNames: 'sourceDir destDir packagesAndPatches imageTypes'
classVariableNames: ''
poolDictionaries: ''
category: 'CogAttic-Bootstrapping'!
!SpurBootstrapMonticelloPackagePatcher commentStamp: 'eem 1/15/2014 17:59' prior: 0!
A SpurBootstrapMonticelloPackagePatcher is used to construct a new set of patched Monticello packages for Spur. The use case is some bootstrap process loads a set of Monticello packages. To repeat the bootstrap with a Spur image the bootstrap must use suitably patched Monticello packages containing the new method versions on the class side of SpurBootstrap.
Instance Variables
destDir: <FileDirectory>
sourceDir: <FileDirectory>
destDir
- directory to which patched packages are to be written
sourceDir
- directory from which packages to be patched are to be read!
----- Method: SpurBootstrapMonticelloPackagePatcher class>>squeak45baseline (in category 'baselines') -----
squeak45baseline
"The base Squeak-4.5-13680 package set."
^#( name 'base-Squeak45-eem'
repository ('http://source.squeak.org/squeak45')
dependency ('Squeak-Version' 'Squeak-Version-ar.4662' '6bfece28-65a4-b147-9462-417b2e86acd0')
dependency ('311Deprecated' '311Deprecated-nice.2' '6df45c33-740a-fc4f-b3d0-45412ad7d284')
dependency ('39Deprecated' '39Deprecated-ar.19' '8da20c38-7d28-3241-9f29-da261d6f9bfe')
dependency ('45Deprecated' '45Deprecated-fbs.24' '4033c169-94c6-7741-9aee-5a7570a7ec7a')
dependency ('Balloon' 'Balloon-nice.24' '97e2ed51-707d-4da1-ab4f-35add3deee5e')
dependency ('Network' 'Network-nice.150' 'c844e5ea-c919-44fc-905e-69487b035947')
dependency ('Compression' 'Compression-fbs.40' '82b0d6e4-0239-1241-968c-461a785fb6a7')
dependency ('Graphics' 'Graphics-nice.289' 'e809bcbf-53e1-420b-846a-9e86e0dd1f06')
dependency ('Multilingual' 'Multilingual-fbs.194' '07f4a7b5-7169-3345-85fc-5a8ba04e5323')
dependency ('CollectionsTests' 'CollectionsTests-dtl.214' 'cf157d3a-2d71-46f3-86ce-450ee24e8d27')
dependency ('PackageInfo-Base' 'PackageInfo-Base-nice.68' 'b6669527-9a35-4783-a64f-8f2af97e330b')
dependency ('Compiler' 'Compiler-nice.279' '94b1b5f8-f71b-4425-b035-461d3dc94e3f')
dependency ('Environments' 'Environments-ul.46' 'cfd9e7f7-6a4b-400e-b9c7-9c6239da4752')
dependency ('Kernel' 'Kernel-dtl.836' '410e695f-7f23-43e4-9dc2-d292b9954f0d')
dependency ('MonticelloConfigurations' 'MonticelloConfigurations-fbs.123' 'b9735d10-7cf4-a746-8a64-b50fa9cf273f')
dependency ('Tools' 'Tools-cmm.519' 'dae6bdb9-8b54-491a-a2a4-0b114f02e10d')
dependency ('MorphicExtras' 'MorphicExtras-tpr.147' 'e76a71a5-6be9-4420-b71a-2c92d900c476')
dependency ('Files' 'Files-dtl.130' '8ee82071-69f7-446d-8ed7-77eafc838f03')
dependency ('System' 'System-dtl.666' '098b856a-ecc5-498a-bceb-ef3457d3511e')
dependency ('Collections' 'Collections-ul.564' '4b9a37ef-df86-40a0-a0dd-8e8b2c04d4ed')
dependency ('Monticello' 'Monticello-cmm.586' 'a4dbd656-e50a-47ba-8661-44f8c87bb3e0')
dependency ('EToys' 'EToys-cmm.117' 'c3e71dbe-17af-4b71-ad9c-c0bb2a2bc193')
dependency ('Exceptions' 'Exceptions-cmm.49' '6cede9fe-b13d-481a-b8de-bb004ece1145')
dependency ('FlexibleVocabularies' 'FlexibleVocabularies-bf.13' '55c72a72-619e-4a81-831f-303600bbd792')
dependency ('GraphicsTests' 'GraphicsTests-fbs.38' '081189cc-a44f-fa4e-965e-25438280ea93')
dependency ('Installer-Core' 'Installer-Core-cmm.392' '7cb5c040-6f68-479d-bc9e-0b264b172443')
dependency ('KernelTests' 'KernelTests-nice.259' '0f7301b0-612c-49d8-936f-775995b35e0f')
dependency ('GetText' 'GetText-nice.34' '4d432f8e-55be-428a-9138-63dd1738035e')
dependency ('Sound' 'Sound-nice.38' 'b626daf0-be23-4fb8-b2d5-04b9cd370539')
dependency ('ToolBuilder-Tests' 'ToolBuilder-Tests-cmm.1' 'e77685b9-ca09-40c0-b84e-6caee75f4075')
dependency ('Morphic' 'Morphic-cmm.720' 'e5e81c18-990b-4e35-b325-adb032b8418d')
dependency ('MorphicTests' 'MorphicTests-nice.24' 'e33a9ad3-2f39-4c19-a3a7-dc87f18177fc')
dependency ('MorphicExtrasTests' 'MorphicExtrasTests-fbs.3' '1c039763-bc92-834c-943e-d96d8820cbd7')
dependency ('MultilingualTests' 'MultilingualTests-fbs.18' '07e26018-8455-3349-9b44-9ecb4aaeefb2')
dependency ('Nebraska' 'Nebraska-nice.36' 'cc80dca4-ed72-4c39-952c-3b37886100de')
dependency ('NetworkTests' 'NetworkTests-fbs.37' '97699685-5826-fe47-af98-356971abf2fb')
dependency ('PreferenceBrowser' 'PreferenceBrowser-fbs.49' '72d30dfa-0ff5-4347-9823-eb77ae236f8f')
dependency ('Protocols' 'Protocols-nice.46' '15b63671-d541-4c1d-9ff5-72da4fc5bfe9')
dependency ('SMBase' 'SMBase-nice.132' 'a70c8bd2-3eee-4e21-b9c6-113f6b194527')
dependency ('SMLoader' 'SMLoader-fbs.79' '9f7d983e-d958-4115-94aa-21302f89ad8b')
dependency ('ST80' 'ST80-cmm.172' '47b2f84a-6951-480b-88f2-b2726dba08bd')
dependency ('ST80Tests' 'ST80Tests-nice.2' '7ee5426b-73f1-48ac-8ec4-3943dc452cb6')
dependency ('ST80Tools' 'ST80Tools-fbs.1' '108ec7bc-d1f5-dd4b-9511-e7a653a71e9f')
dependency ('SUnit' 'SUnit-fbs.99' 'a5be81dd-6e9f-8d41-a091-3c6c27a28abe')
dependency ('SUnitGUI' 'SUnitGUI-fbs.59' '0bfcf308-0d02-a749-9930-6229492cca48')
dependency ('ScriptLoader' 'ScriptLoader-cmm.338' 'adb79117-0915-40a5-a5ee-c766e4b50d42')
dependency ('Services-Base' 'Services-Base-topa.51' '94328e86-1643-4090-8f18-bc4467119161')
dependency ('SmallLand-ColorTheme' 'SmallLand-ColorTheme-fbs.6' 'a78b81e3-3b11-c24e-9c84-3bb5319e0858')
dependency ('SystemChangeNotification-Tests' 'SystemChangeNotification-Tests-nice.23' '3eed6d26-4aef-4095-a604-d9f914240281')
dependency ('Tests' 'Tests-cmm.290' 'f3fccfae-6baf-4093-ba62-e15ef110a687')
dependency ('ToolBuilder-Kernel' 'ToolBuilder-Kernel-nice.60' '86949a07-725b-4a27-a7cd-a827c74f48be')
dependency ('ToolBuilder-MVC' 'ToolBuilder-MVC-fbs.34' 'aded987d-5cd5-6f41-9635-1d38da947ddf')
dependency ('ToolBuilder-Morphic' 'ToolBuilder-Morphic-fbs.91' 'abaa076b-af43-af42-8c98-7a71482c6a30')
dependency ('ToolBuilder-SUnit' 'ToolBuilder-SUnit-fbs.19' '3e30756c-2af8-0741-836f-0d42a9d5af32')
dependency ('ToolsTests' 'ToolsTests-cmm.68' '98c1608a-6cb3-4a03-a28a-dd101e6c876b')
dependency ('MonticelloForTraits' 'MonticelloForTraits-fbs.1' '160be615-5ab7-4148-a7cb-60dd629ab085')
dependency ('Traits' 'Traits-topa.302' '58712f55-3f3f-467e-ac0e-e118c9737c53')
dependency ('TraitsTests' 'TraitsTests-fbs.13' '0429146f-6767-4a4f-8fce-37571625920a')
dependency ('TrueType' 'TrueType-nice.28' '42a74f04-e193-455b-a2c1-14ec51724234')
dependency ('Universes' 'Universes-nice.46' '805eb73f-391b-4e3f-aef9-64add79e4e8c')
dependency ('VersionNumber' 'VersionNumber-cmm.4' '68fb1f05-d3e2-4c9b-9234-20a9bed166dc')
dependency ('XML-Parser' 'XML-Parser-fbs.36' 'a2d9791a-c341-564b-9b57-a0fe9f42b66f')
dependency ('ReleaseBuilder' 'ReleaseBuilder-cmm.114' 'ea773780-69e1-48dd-a16c-e167acb9de04')
dependency ('ShoutCore' 'ShoutCore-cwp.40' '81b3e230-2e8a-42c5-9521-e54338fadb6f')
dependency ('VersionNumberTests' 'VersionNumberTests-fbs.4' '953a944c-9648-dd4b-898e-9e10e0507b91')
dependency ('HelpSystem-Core' 'HelpSystem-Core-ul.56' '6d8a0d54-5f60-da45-8c3c-d42ea8abd999')
dependency ('HelpSystem-Tests' 'HelpSystem-Tests-fbs.15' '8927a848-29a0-f54c-8c79-efb8070c4702')
dependency ('Help-Squeak-Project' 'Help-Squeak-Project-kfr.10' 'b86eb622-cc53-634d-aa65-aed2c86263f9')
dependency ('Help-Squeak-TerseGuide' 'Help-Squeak-TerseGuide-dtl.2' '8b18cab9-7183-4c5e-8cac-f79c4400da43')
dependency ('SystemReporter' 'SystemReporter-ul.21' '34c5c48c-e7cc-4dfe-8133-6dec3bc63ff7')
dependency ('BalloonTests' 'BalloonTests-egp.2' 'a8206c39-12ee-4222-a29a-caa537e037c4')
dependency ('CommandLine' 'CommandLine-fbs.2' '414e59b8-4f4a-814d-9dac-b7b9886e92a0')
dependency ('UpdateStream' 'UpdateStream-nice.4' '5fcdedce-88aa-469a-bf8b-32820f051c4f')
)!
----- Method: SpurBootstrapMonticelloPackagePatcher>>cachedNonDiffyVersionNamed:from: (in category 'patching') -----
cachedNonDiffyVersionNamed: versionName from: repo
"Make sure that the cache contains a non-diffy version of versionName and answer it."
| cacheRepo nonDiffyVersion |
self assert: (versionName endsWith: '.mcz').
cacheRepo := MCCacheRepository default.
"Make sure that at least the diffy (.mcd) version is present"
(cacheRepo directory includesKey: versionName) ifFalse:
[cacheRepo storeVersion: (repo versionNamed: versionName)].
"if after storeVersion there's still no .mcz we need to create one; sigh..."
(cacheRepo directory includesKey: versionName) ifFalse:
[| baseName diffyVersionName diffyVersion file delete |
baseName := versionName allButLast: 4. "strip .mcz"
diffyVersionName := cacheRepo directory fileNames detect: [:fn| (fn endsWith: '.mcd') and: [(fn copyUpTo: $() = baseName]].
diffyVersion := cacheRepo versionNamed: diffyVersionName.
file := cacheRepo directory newFileNamed: versionName.
delete := false.
[file binary.
[MCMczWriter fileOut: diffyVersion on: file]
on: Error
do: [:ex|
delete := true. "don't leave half-formed .mcz files around to screw things up later on..."
ex pass]]
ensure:
[file close.
delete ifTrue:
[cacheRepo directory deleteFileNamed: versionName]].
"now delete the damn diffy version that caused all the pain in the first place"
delete ifFalse:
[cacheRepo directory deleteFileNamed: diffyVersionName].
cacheRepo flushCache; cacheAllFilenames].
nonDiffyVersion := cacheRepo versionNamed: versionName.
self assert: (nonDiffyVersion fileName endsWith: '.mcz').
^nonDiffyVersion!
----- Method: SpurBootstrapMonticelloPackagePatcher>>classDefinitionFor:type:from:comment:stamp: (in category 'private-accessing') -----
classDefinitionFor: className type: typeSymbol from: definitions comment: commentString stamp: stampString
| classDef |
classDef := definitions
detect: [:d| d isClassDefinition and: [d className = className]]
ifNone:
[self assert: (#(BoxedFloat64 SmallFloat64) includes: className).
MCClassDefinition new
initializeWithName: className
superclassName: #Float
traitComposition: '{}'
classTraitComposition: '{}'
category: 'Kernel-Numbers'
instVarNames: #()
classVarNames: #()
poolDictionaryNames: #()
classInstVarNames: #()
type: typeSymbol
comment: commentString asString
commentStamp: stampString].
className == #Character ifTrue:
[classDef variables removeAllSuchThat:
[:varDef|
varDef isInstanceVariable and: [varDef name = 'value']]].
classDef instVarNamed: 'type' put: typeSymbol.
commentString ifNotNil:
[classDef
instVarNamed: 'comment' put: commentString;
instVarNamed: 'commentStamp' put: stampString].
^MCAddition of: classDef!
----- Method: SpurBootstrapMonticelloPackagePatcher>>compiledMethodClassDefinition (in category 'private-accessing') -----
compiledMethodClassDefinition
^MCAddition of:
(MCClassDefinition new
initializeWithName: #CompiledMethod
superclassName: #ByteArray
category: #'Kernel-Methods'
instVarNames: #()
classVarNames: #(LargeFrame PrimaryBytecodeSetEncoderClass SecondaryBytecodeSetEncoderClass SmallFrame)
poolDictionaryNames: #()
classInstVarNames: #()
type: #compiledMethod
comment:
'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.
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)
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:
(index 0) 15 bits: number of literals (#numLiterals)
(index 15) 1 bit: is optimized - reserved for methods that have been optimized by Sista
(index 16) 1 bit: has primitive
(index 17) 1 bit: whether a large frame size is needed (#frameSize => either SmallFrame or LargeFrame)
(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)
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.'
commentStamp: 'eem 1/22/2015 15:47')!
----- Method: SpurBootstrapMonticelloPackagePatcher>>directoryFrom: (in category 'initialization') -----
directoryFrom: dirName
^FileDirectory on: (dirName first = $/
ifTrue: [dirName]
ifFalse: [(FileDirectory default directoryNamed: dirName) fullName])!
----- Method: SpurBootstrapMonticelloPackagePatcher>>download:from: (in category 'repository population') -----
download: baseConfigurationOrArray "<MCConfiguration|Array>" from: repo
| base |
base := baseConfigurationOrArray isArray
ifTrue: [MCConfiguration fromArray: baseConfigurationOrArray]
ifFalse: [baseConfigurationOrArray].
self packagesAndPatches keysAndValuesDo:
[:package :patches| | dependency |
dependency := base dependencies detect: [:dep| dep package name = package name].
self downloadToSourceDirAllPackageVersionsStartingWith: dependency versionInfo
from: repo].!
----- Method: SpurBootstrapMonticelloPackagePatcher>>downloadToSourceDirAllPackageVersionsStartingWith:from: (in category 'repository population') -----
downloadToSourceDirAllPackageVersionsStartingWith: aMCVersionInfo from: repo
| localRepo priorName |
priorName := MCVersionName on: (aMCVersionInfo versionName
copyReplaceAll: aMCVersionInfo versionNumber asString
with: (aMCVersionInfo versionNumber - 1) asString).
localRepo := MCDirectoryRepository directory: sourceDir.
(repo possiblyNewerVersionsOfAnyOf: {priorName asMCVersionName}) do:
[:newerVersion |
(localRepo includesVersionNamed: newerVersion) ifFalse:
[localRepo storeVersion: (repo versionNamed: newerVersion)]]!
----- Method: SpurBootstrapMonticelloPackagePatcher>>filesForPackage:in: (in category 'private-accessing') -----
filesForPackage: package in: aDirectory
"Names sorted from lowest version to highest"
^((aDirectory fileNames
select:
[:fileName|
(fileName beginsWith: package name)
and: [(fileName at: package name size + 1) isLetter not
and: [(fileName copyFrom: package name size + 2 to: package name size + 5) ~= 'spur']]]
thenCollect: [:fn| {fn asMCVersionName versionNumber. fn}])
sort: [:tuple :tupolev|
tuple first < tupolev first
or: [tuple first = tupolev first
and: [tuple last < tupolev last]]])
collect: [:tuple| tuple last]!
----- Method: SpurBootstrapMonticelloPackagePatcher>>filteredDefinitionsAsPatches:patches: (in category 'private-accessing') -----
filteredDefinitionsAsPatches: modifiedDefinitions patches: existingPatches
^modifiedDefinitions
select:
[:def|
existingPatches noneSatisfy:
[:addition|
def isMethodDefinition
and: [addition definition isMethodDefinition
and: [addition definition selector = def selector
and: [addition definition className = def className
and: [addition definition classIsMeta = def classIsMeta]]]]]]
thenCollect:
[:def|
((def source includesSubString: 'DELETEME')
ifTrue: [MCRemoval]
ifFalse: [MCAddition]) of: def]!
----- Method: SpurBootstrapMonticelloPackagePatcher>>findOldestConfigurationFor:inVersionNames:repository: (in category 'configurations') -----
findOldestConfigurationFor: packageVersions inVersionNames: configurationVersionNames repository: repo
| oldest |
oldest := configurationVersionNames first.
configurationVersionNames do:
[:cfgver| | config |
config := repo versionNamed: cfgver.
(packageVersions noneSatisfy:
[:pkgver| | configVersion |
configVersion := config dependencies detect:
[:dep|
pkgver packageName = dep package name].
configVersion versionInfo versionNumber >= pkgver versionNumber]) ifTrue:
[^oldest].
oldest := cfgver].
self error: 'couldn''t find configuration newer than supplied versions'!
----- Method: SpurBootstrapMonticelloPackagePatcher>>from:to: (in category 'initialization') -----
from: sourceDirName to: destDirName
sourceDir := self directoryFrom: sourceDirName.
destDir := self directoryFrom: destDirName!
----- Method: SpurBootstrapMonticelloPackagePatcher>>imageTypes: (in category 'initialization') -----
imageTypes: typeArray
imageTypes := typeArray!
----- Method: SpurBootstrapMonticelloPackagePatcher>>modifiedCharacterDefinitionsIn: (in category 'private-accessing') -----
modifiedCharacterDefinitionsIn: definitions
| rewriter |
rewriter := RBParseTreeRewriter new.
rewriter
replace: 'value' with: 'self asInteger';
replace: 'value := ``@args' with: 'DELETEME'.
^(((definitions select: [:d| d isMethodDefinition and: [d fullClassName = #Character]])
collect: [:d| { d. self patchDefinition: d withRewriter: rewriter} ]
thenSelect: [:pair| pair first source ~= pair second source])
collect: [:pair| pair second])!
----- Method: SpurBootstrapMonticelloPackagePatcher>>modifiedFloatDefinitionsIn: (in category 'private-accessing') -----
modifiedFloatDefinitionsIn: definitions
"Delete the non-accessing primitives in Float (prims 41 through 59),
and copy them to BoxedFloat64,
and create corresponding ones in SmallFloat64 with primtiive numbers + 500."
| floatPrims |
floatPrims := definitions select:
[:d| | index |
d isMethodDefinition
and: [d fullClassName = #Float
and: [(index := d source indexOfSubCollection: '<primitive: ') > 0
and: [(Integer readFrom: (ReadStream on: d source from: index + '<primitive: ' size to: index + '<primitive: ' size + 4))
between: 41
and: 59]]]].
^(floatPrims collect:
[:d|
MCMethodDefinition new
initializeWithClassName: d className
classIsMeta: false
selector: d selector
category: d category
timeStamp: d timeStamp
source: d source, 'DELETEME']),
(floatPrims collect:
[:d|
MCMethodDefinition new
initializeWithClassName: #BoxedFloat64
classIsMeta: false
selector: d selector
category: d category
timeStamp: d timeStamp
source: d source]),
(floatPrims collect:
[:d|
MCMethodDefinition new
initializeWithClassName: #SmallFloat64
classIsMeta: false
selector: d selector
category: d category
timeStamp: 'eem 11/25/2014 07:54'
source: (d source copyReplaceAll: '<primitive: ' with: '<primitive: 5')])!
----- Method: SpurBootstrapMonticelloPackagePatcher>>packageForMissingClassNamed: (in category 'accessing') -----
packageForMissingClassNamed: className
(className = #BoxedFloat64
or: [className = #SmallFloat64]) ifTrue:
[^PackageInfo named: 'Kernel'].
self error: 'unknown missing class'!
----- Method: SpurBootstrapMonticelloPackagePatcher>>packages (in category 'private-accessing') -----
packages
"Answer the packages Spur modifies."
^self packagesAndPatches keys!
----- Method: SpurBootstrapMonticelloPackagePatcher>>packagesAndPatches (in category 'private-accessing') -----
packagesAndPatches
"SpurBootstrapMonticelloPackagePatcher new packagesAndPatches"
| spurBootstrap |
packagesAndPatches ifNotNil:
[^packagesAndPatches].
packagesAndPatches := Dictionary new.
spurBootstrap := SpurBootstrap new.
imageTypes ifNotNil:
[spurBootstrap imageTypes: imageTypes].
spurBootstrap prototypeClassNameMetaSelectorMethodDo:
[:className :isMeta :selector :method| | package category source definition |
(Smalltalk classNamed: className)
ifNil: [package := self packageForMissingClassNamed: className]
ifNotNil:
[:behavior| | class methodReference |
class := isMeta ifTrue: [behavior class] ifFalse: [behavior].
(class includesSelector: selector) ifTrue:
[methodReference := (class >> selector) methodReference.
category := methodReference category.
category first = $* ifTrue:
[category := nil]].
package := (methodReference isNil
or: [methodReference category = Categorizer default
or: [methodReference category first = $*]]) "This for Scorch's override of InstructionClient>>classPrimitive:"
ifTrue: [PackageOrganizer default packageOfClass: class]
ifFalse: [PackageOrganizer default packageOfMethod: methodReference]].
source := method getSourceFromFile asString allButFirst: method selector size - selector size.
source first ~= selector first ifTrue:
[source replaceFrom: 1 to: selector size with: selector startingAt: 1].
definition := MCAddition of: (MCMethodDefinition new
initializeWithClassName: className
classIsMeta: isMeta
selector: selector
category: (category ifNil: [SpurBootstrap
categoryForClass: className
meta: isMeta
selector: selector])
timeStamp: method timeStamp
source: source).
(method pragmaAt: #remove) ifNotNil:
[definition := definition inverse].
(packagesAndPatches at: package ifAbsentPut: [OrderedCollection new])
add: definition].
^packagesAndPatches!
----- Method: SpurBootstrapMonticelloPackagePatcher>>patch (in category 'patching') -----
patch
"(SpurBootstrapMonticelloPackagePatcher new
from: 'trunkpackages'
to: 'spurpackages')
patch"
"(SpurBootstrapMonticelloPackagePatcher new
from: '/Users/eliot/Squeak/Squeak4.5-spur/squeakv3-package-cache'
to: '/Users/eliot/Squeak/Squeak4.5-spur/package-cache')
patch"
"(SpurBootstrapMonticelloPackagePatcher new
from: '/Users/eliot/Glue/repositories/nsboot/Squeak4.3/squeak-package-cache'
to: '/Users/eliot/Glue/repositories/nsboot/Squeak4.3/package-cache')
patch"
sourceDir exists ifFalse:
[self error: 'source directory doest not exist'].
destDir assureExistence.
self packagesAndPatches keysAndValuesDo:
[:package :patches|
(self filesForPackage: package in: sourceDir) do:
[:packageFile|
self patchPackage: packageFile with: patches for: package]]!
----- Method: SpurBootstrapMonticelloPackagePatcher>>patchAndUploadAllInTrunk (in category 'patching') -----
patchAndUploadAllInTrunk
"Look for all versions in the default repository that have patched versions there-in.
Download and patch them and upload the patched versions (overwriting the older ones)."
"(SpurBootstrapMonticelloPackagePatcher new
from: 'trunkpackages'
to: 'spurpackages')
patchAndUploadAllInTrunk"
| seed trunk sourceRepo cacheRepo |
seed := 'Are you really sure you want to do this?\It should happen only once!!' withCRs.
3 timesRepeat:
[(UIManager confirm: seed) ifFalse: [^self].
seed := seed copyReplaceAll: 'really ' with: 'really, really '].
sourceDir assureExistence; deleteLocalFiles.
destDir assureExistence; deleteLocalFiles.
sourceRepo := MCDirectoryRepository directory: sourceDir.
cacheRepo := MCCacheRepository default.
(trunk := self trunk) cacheAllFileNamesDuring:
[| latestBranches latestUnbranched |
latestBranches := self packages collect:
[:package|
(trunk versionNamesForPackageNamed: package name, '.spur') detectMin: [:vn | vn asMCVersionName versionNumber]].
latestUnbranched := latestBranches collect:
[:verName|
(trunk versionNamed: (verName copyReplaceAll: '.spur' with: '') asMCVersionName) info ancestors first versionName].
((trunk possiblyNewerVersionsOfAnyOf: latestUnbranched)
reject: [:unpatched| unpatched includesSubString: '.spur'])
do: [:unpatched|
"it is claimed that whether a repository contains a .mcz or a .mcd is irrelevant. At least for the cache repository that's not true."
sourceRepo storeVersion: (self cachedNonDiffyVersionNamed: unpatched from: trunk)].
self patchAsNeeded.
self uploadFrom: (MCDirectoryRepository directory: destDir) to: trunk]!
----- Method: SpurBootstrapMonticelloPackagePatcher>>patchAndUploadNewer (in category 'patching') -----
patchAndUploadNewer
"Look for unbranched versions on the default repository that are newer than the
image''s versions. Download and patch them and upload the patched versions."
"(SpurBootstrapMonticelloPackagePatcher new
from: 'trunkpackages'
to: 'spurpackages')
patchAndUploadNewer"
| repo sourceRepo |
sourceDir deleteLocalFiles.
destDir deleteLocalFiles.
repo := self repositoryForUrl: MCMcmUpdater defaultUpdateURL.
sourceRepo := MCDirectoryRepository directory: sourceDir.
repo cacheAllFileNamesDuring:
[self packages do:
[:package| | workingCopy |
workingCopy := MCWorkingCopy allManagers detect: [:pkg| pkg packageName = package packageName].
(workingCopy possiblyNewerVersionsIn: repo) do:
[:newerVersion|
newerVersion packageAndBranchName = package packageName ifTrue: "Don't patch already patched packages!!!!"
[(sourceRepo includesVersionNamed: newerVersion) ifFalse:
[sourceRepo storeVersion: (repo versionNamed: newerVersion)]]]].
self patchAsNeeded.
self uploadFrom: (MCDirectoryRepository directory: destDir) to: repo]!
----- Method: SpurBootstrapMonticelloPackagePatcher>>patchAndUploadUnpatchedInTrunk (in category 'patching') -----
patchAndUploadUnpatchedInTrunk
"Look for unbranched versions in the default repository that are newer than the
latest patched versions there-in. Download and patch them and upload the patched
versions."
"(SpurBootstrapMonticelloPackagePatcher new
from: 'trunkpackages'
to: 'spurpackages')
patchAndUploadUnpatchedInTrunk"
| trunk sourceRepo cacheRepo |
sourceDir assureExistence; deleteLocalFiles.
destDir assureExistence; deleteLocalFiles.
sourceRepo := MCDirectoryRepository directory: sourceDir.
cacheRepo := MCCacheRepository default.
(trunk := self trunk) cacheAllFileNamesDuring:
[| latestBranches latestUnbranched |
latestBranches := self packages collect:
[:package|
(trunk versionNamesForPackageNamed: package name, '.spur') detectMax: [:vn | vn asMCVersionName versionNumber]]
thenSelect: [:branch| branch notNil].
latestUnbranched := latestBranches collect: [:verName| (verName copyReplaceAll: '.spur' with: '') asMCVersionName].
((trunk possiblyNewerVersionsOfAnyOf: latestUnbranched)
reject: [:unpatched| unpatched includesSubString: '.spur'])
do: [:unpatched|
"it is claimed that whether a repository contains a .mcz or a .mcd is irrelevant. At least for the cache repositoriy that's not true."
sourceRepo storeVersion: (self cachedNonDiffyVersionNamed: unpatched from: trunk)].
self patchAsNeeded.
self uploadFrom: (MCDirectoryRepository directory: destDir) to: trunk]!
----- Method: SpurBootstrapMonticelloPackagePatcher>>patchAsNeeded (in category 'patching') -----
patchAsNeeded
(sourceDir exists and: [destDir exists]) ifFalse:
[self error: 'one or both of the directories don''t exist'].
self packagesAndPatches keysAndValuesDo:
[:package :patches|
(self filesForPackage: package in: sourceDir) do:
[:packageFile| | spurPackageFile |
spurPackageFile := self spurBranchNameForInfo: packageFile package: package.
((destDir includesKey: packageFile) or: [destDir includesKey: spurPackageFile])
ifTrue:
[Transcript
cr; nextPutAll: destDir fullName; nextPutAll: ' contains either ';
nextPutAll: packageFile; nextPutAll: ' or '; nextPutAll: spurPackageFile;
nextPutAll: '; not saving'; flush]
ifFalse:
[self patchPackage: packageFile with: patches for: package]]]
"| patcher |
patcher := SpurBootstrapMonticelloPackagePatcher new
from: 'trunkpackages'
to: 'spurpackages'.
patcher trunk cacheAllFileNamesDuring:
[patcher patchAsNeeded]"!
----- Method: SpurBootstrapMonticelloPackagePatcher>>patchDefinition:withRewriter: (in category 'patching') -----
patchDefinition: aMCMethodDefinition withRewriter: aRBParseTreeRewriter
| parseTree |
parseTree := RBParser
parseMethod: aMCMethodDefinition source
onError: [:str :pos | self halt].
aRBParseTreeRewriter executeTree: parseTree.
^MCMethodDefinition new
initializeWithClassName: aMCMethodDefinition className
classIsMeta:aMCMethodDefinition classIsMeta
selector: aMCMethodDefinition selector
category: aMCMethodDefinition category
timeStamp: aMCMethodDefinition timeStamp
source: aRBParseTreeRewriter tree newSource!
----- Method: SpurBootstrapMonticelloPackagePatcher>>patchFile: (in category 'patching') -----
patchFile: packageFile
"(SpurBootstrapMonticelloPackagePatcher new
from: '/Users/eliot/oscogvm/image/package-cache'
to: '/Users/eliot/oscogvm/image/spurpackages')
patchFile: 'Collections-ul.573(nice.572).mcd'"
sourceDir exists ifFalse:
[self error: 'source directory doest not exist'].
destDir assureExistence.
self packagesAndPatches keysAndValuesDo:
[:package :patches|
((packageFile beginsWith: package name)
and: [(packageFile at: package name size + 1) isLetter not]) ifTrue:
[self patchPackage: packageFile with: patches for: package]]!
----- Method: SpurBootstrapMonticelloPackagePatcher>>patchPackage:with:for: (in category 'patching') -----
patchPackage: packageFileName with: patches for: package
| version newVersion |
version := self versionFor: packageFileName in: sourceDir.
newVersion := self version: version withPatches: patches for: package.
self storeVersion: newVersion!
----- Method: SpurBootstrapMonticelloPackagePatcher>>patches:forSnapshot: (in category 'patching') -----
patches: basePatches forSnapshot: snapshot
"Add modified class defs for Character, SmallInteger, Float, BoxedFloat64, SmallFloat64 and COmpiledMethod.
Remove ObjectHistory and ObjectHistoryMark (which Spur does not support)."
| patches defs |
patches := basePatches copy.
defs := snapshot definitions.
(defs anySatisfy: [:d| d isClassDefinition and: [d className == #Character]]) ifTrue:
[patches
addAll: (self filteredDefinitionsAsPatches: (self modifiedCharacterDefinitionsIn: snapshot definitions)
patches: patches);
add: (self
classDefinitionFor: #Character
type: #immediate
from: snapshot definitions
comment: 'I represent a character by storing its associated Unicode as an unsigned 30-bit value. Characters are created uniquely, so that all instances of a particular Unicode are identical. My instances are encoded in tagged pointers in the VM, so called immediates, and therefore are pure immutable values.
The code point is based on Unicode. Since Unicode is 21-bit wide character set, we have several bits available for other information. As the Unicode Standard states, a Unicode code point doesn''t carry the language information. This is going to be a problem with the languages so called CJK (Chinese, Japanese, Korean. Or often CJKV including Vietnamese). Since the characters of those languages are unified and given the same code point, it is impossible to display a bare Unicode code point in an inspector or such tools. To utilize the extra available bits, we use them for identifying the languages. Since the old implementation uses the bits to identify the character encoding, the bits are sometimes called "encoding tag" or neutrally "leading char", but the bits rigidly denotes the concept of languages.
The other languages can have the language tag if you like. This will help to break the large default font (font set) into separately loadable chunk of fonts. However, it is open to the each native speakers and writers to decide how to define the character equality, since the same Unicode code point may have different language tag thus simple #= comparison may return false.'
stamp: 'eem 8/12/2014 14:53')].
(defs anySatisfy: [:def| def isClassDefinition and: [def className == #SmallInteger]]) ifTrue:
[patches
add: (self
classDefinitionFor: #SmallInteger
type: #immediate
from: snapshot definitions
comment: 'My instances are at least 31-bit numbers, stored in twos complement form. The allowable range in 32-bits is approximately +- 10^9 (+- 1billion). In 64-bits my instances are 61-bit numbers, stored in twos complement form. The allowable range is approximately +- 10^18 (+- 1 quintillion). The actual values are computed at start-up. See SmallInteger class startUp:, minVal, maxVal.'
stamp: 'eem 11/20/2014 08:41')].
(defs anySatisfy: [:def| def isClassDefinition and: [def className == #Float]]) ifTrue:
[patches
add: (self
classDefinitionFor: #Float
type: #normal
from: snapshot definitions
comment: nil
stamp: nil);
add: (self
classDefinitionFor: #BoxedFloat64
type: #words
from: snapshot definitions
comment: '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.'
stamp: 'eem 11/25/2014 07:54');
add: (self
classDefinitionFor: #SmallFloat64
type: #immediate
from: snapshot definitions
comment: 'My instances represent 64-bit Floats whose exponent fits in 8 bits as immediate objects. This representation is only available on 64-bit systems, not 32-bit systems.'
stamp: 'eem 11/25/2014 07:54');
addAll: (self filteredDefinitionsAsPatches: (self modifiedFloatDefinitionsIn: snapshot definitions)
patches: patches)].
(defs anySatisfy: [:def| def isClassDefinition and: [def className == #CompiledMethod]]) ifTrue:
[patches
add: self compiledMethodClassDefinition].
(defs anySatisfy: [:def| def isClassDefinition and: [def className == #ObjectHistory]]) ifTrue:
[patches addAll:
(defs
select: [:def| #(ObjectHistory ObjectHistoryMark) includes: def className]
thenCollect: [:def| MCRemoval of: def])].
^MCPatch operations: patches!
----- Method: SpurBootstrapMonticelloPackagePatcher>>repositoryForUrl: (in category 'repository population') -----
repositoryForUrl: url
^MCRepositoryGroup default repositories
detect: [:r| r description = url]
ifNone: [MCHttpRepository
location: url
user: 'squeak'
password: 'squeak']!
----- Method: SpurBootstrapMonticelloPackagePatcher>>spurBranchNameForInfo:package: (in category 'patching') -----
spurBranchNameForInfo: versionInfoOrString package: package
^(versionInfoOrString isString
ifTrue: [versionInfoOrString]
ifFalse: [versionInfoOrString name]) copyReplaceAll: package name with: package name, '.spur'!
----- Method: SpurBootstrapMonticelloPackagePatcher>>spurConfigurationOf:forRepository: (in category 'configurations') -----
spurConfigurationOf: anMCConfiguration forRepository: repo
"Answer a copy of anMCConfiguration containing the matching Spur dependencies.
If no replacements could be made (because no Spur versions exist) then answer nil."
| found clone |
found := false.
clone := Array streamContents:
[:s|
s nextPut: #name; nextPut: (anMCConfiguration name copyReplaceAll: 'update-' with: 'update.spur-');
"no location accessor!!!!"
nextPut: #repository; nextPut: {anMCConfiguration repositories first locationWithTrailingSlash allButLast}.
anMCConfiguration dependencies do:
[:dep| | info pkg ver spurVersionName |
info := dep versionInfo.
((pkg := self packages
detect: [:package| package name = dep package name]
ifNone: []) notNil
and: [spurVersionName := (info name
copyReplaceAll: pkg name
with: pkg name, '.spur'), '.mcz'.
(ver := MCCacheRepository default versionNamed: spurVersionName asMCVersionName) ifNil:
[ver := repo versionNamed: spurVersionName asMCVersionName].
ver notNil])
ifTrue: [found := true. info := ver info].
(ver isNil and: [spurVersionName notNil]) ifTrue:
[Transcript nextPutAll: 'failed to get ', spurVersionName, ' in ', anMCConfiguration name; cr; flush.
self error: 'failed to get ', spurVersionName, ' in ', anMCConfiguration name].
s nextPut: #dependency; nextPut: (MCConfiguration dependencyToArray: (MCVersionDependency package: dep package info: info))]].
^found ifTrue:
[MCConfiguration fromArray: clone]!
----- Method: SpurBootstrapMonticelloPackagePatcher>>storeVersion: (in category 'patching') -----
storeVersion: newVersion
[(MCDirectoryRepository new directory: destDir) storeVersion: newVersion]
on: FileExistsException
do: [:ex| ex resume: (ex fileClass forceNewFileNamed: ex fileName)]!
----- Method: SpurBootstrapMonticelloPackagePatcher>>trunk (in category 'repository population') -----
trunk
^self repositoryForUrl: 'http://source.squeak.org/trunk'!
----- Method: SpurBootstrapMonticelloPackagePatcher>>uploadFrom:to: (in category 'repository population') -----
uploadFrom: localRepo to: uploadRepository
localRepo allVersionsDo:
[:version|
(uploadRepository includesVersionNamed: version info name) ifFalse:
[uploadRepository storeVersion: version]]!
----- Method: SpurBootstrapMonticelloPackagePatcher>>uploadNewerSpurConfigurationsInTrunk (in category 'configurations') -----
uploadNewerSpurConfigurationsInTrunk
"Make sure that update.spur configurations exist for all relevant update.* configurations."
"SpurBootstrapMonticelloPackagePatcher new uploadNewerSpurConfigurationsInTrunk"
| trunk |
trunk := self trunk.
trunk cacheAllFileNamesDuring:
[| configurations spurConfigurations oldestUpdate |
spurConfigurations := (trunk versionNamesForPackageNamed: 'update.spur') sort: [:a :b| a versionNumber > b versionNumber].
configurations := ((trunk versionNamesForPackageNamed: 'update') select: [:n| n beginsWith: 'update-']) sort: [:a :b| a versionNumber > b versionNumber].
oldestUpdate := spurConfigurations isEmpty
ifTrue:
[| earliestBranches earliestUnbranched |
earliestBranches := self packages collect:
[:package|
(trunk versionNamesForPackageNamed: package name, '.spur') detectMin:
[:vn | vn asMCVersionName versionNumber]].
earliestUnbranched := earliestBranches collect:
[:verName| (verName copyReplaceAll: '.spur' with: '') asMCVersionName].
self
findOldestConfigurationFor: earliestUnbranched
inVersionNames: configurations
repository: trunk]
ifFalse:
[spurConfigurations first copyReplaceAll: '.spur' with: ''].
Transcript nextPutAll: 'Oldest: ', oldestUpdate; cr; flush.
(configurations copyFrom: 1 to: (configurations indexOf: oldestUpdate) - 1) reverseDo:
[:configName|
"((configName beginsWith: 'update-eem.29') and: ['34' includes: (configName at: 14)]) ifTrue:
[self halt]."
(self spurConfigurationOf: (trunk versionNamed: configName) forRepository: trunk) ifNotNil:
[:edition| trunk storeVersion: edition]]]!
----- Method: SpurBootstrapMonticelloPackagePatcher>>version:withPatches:for: (in category 'patching') -----
version: version withPatches: patches for: package
| snapshot ancestry possibleSpurAncestor actualAncestor |
snapshot := MCPatcher
apply: (self patches: patches forSnapshot: version snapshot)
to: version snapshot.
ancestry := MCWorkingAncestry new addAncestor: version info.
"this is a hack; we may not be patching w.r.t. a directory or trunk"
possibleSpurAncestor := (self spurBranchNameForInfo: version info ancestors first package: package) , '.mcz'.
(destDir includesKey: possibleSpurAncestor)
ifTrue:
[actualAncestor := self versionFor: possibleSpurAncestor in: destDir]
ifFalse:
[((self trunk versionNamesForPackageNamed: package name) includes: possibleSpurAncestor) ifTrue:
[actualAncestor := self trunk versionNamed: possibleSpurAncestor]].
actualAncestor ifNotNil:
[ancestry addAncestor: actualAncestor info].
^MCVersion
package: version package
info: (ancestry
infoWithName: (self spurBranchNameForInfo: version info package: package)
message: version info name,
' patched for Spur by ',
(CCodeGenerator shortMonticelloDescriptionForClass: self class),
'\\' withCRs,
version info message)
snapshot: snapshot
dependencies: {} "punt on computing dependencies; there are't any so far"!
----- Method: SpurBootstrapMonticelloPackagePatcher>>versionFor:in: (in category 'patching') -----
versionFor: packageFileName in: directory
^directory
readOnlyFileNamed: packageFileName
do: [:fs|
((MCVersionReader readerClassForFileNamed: fs fullName)
on: fs fileName: fs fullName)
version]!
Object subclass: #SpurBootstrapNewspeakFilePatcher
instanceVariableNames: 'source substitutions'
classVariableNames: ''
poolDictionaries: ''
category: 'CogAttic-Bootstrapping'!
----- Method: SpurBootstrapNewspeakFilePatcher>>editTo: (in category 'patching') -----
editTo: dest "<FileStream>"
source reopen.
[substitutions do:
[:tuple|
[:start :end :substitution|
[source position + 1 < start] whileTrue:
[dest nextPut: source next].
dest nextPutAll: (substitution
copyReplaceAll: (String with: Character cr)
with: (String with: Character lf)).
source skip: end - start + 1] valueWithArguments: tuple].
dest nextPutAll: source upToEnd]
ensure: [source close]!
----- Method: SpurBootstrapNewspeakFilePatcher>>findClassDeclarationFor:in: (in category 'parsing') -----
findClassDeclarationFor: className in: ast "<ClassDeclarationAST>" "^(ClassDeclarationAST|nil)"
^ast instanceSide nestedClasses
detect: [:classDecl| classDecl name = className]
ifNone: []!
----- Method: SpurBootstrapNewspeakFilePatcher>>findMethodDeclarationFor:in: (in category 'parsing') -----
findMethodDeclarationFor: selector "<Symbol>" in: ast "<ClassDeclarationAST>" "^(MethodAST|nil)"
ast instanceSide categories do:
[:categoryAST|
categoryAST methods do:
[:methodAST|
methodAST pattern selector = selector ifTrue:
[^methodAST]]].
^nil!
----- Method: SpurBootstrapNewspeakFilePatcher>>initialize (in category 'initialize-release') -----
initialize
substitutions := SortedCollection sortBlock: [:tupleA :tupleB | tupleA first <= tupleB first]!
----- Method: SpurBootstrapNewspeakFilePatcher>>newspeakSourceFor:selector: (in category 'patching') -----
newspeakSourceFor: method "<CompiledMethod>" selector: selector "<Symbol>"
| source startIndex nextIndex |
source := method getSourceFromFile asString allButFirst: method selector size - selector size.
source first ~= selector first ifTrue:
[source replaceFrom: 1 to: selector size with: selector startingAt: 1].
"map comments to Newspeak format..."
startIndex := 1.
[(startIndex := source indexOf: $" startingAt: startIndex) > 0] whileTrue:
[nextIndex := source indexOf: $" startingAt: startIndex + 1.
nextIndex < startIndex ifTrue:
[self error: 'matching close comment not found'].
source := source copyReplaceFrom: nextIndex to: nextIndex with: ' *)'.
source := source copyReplaceFrom: startIndex to: startIndex with: '(* '.
startIndex := nextIndex + 5].
"map assignments to Newspeak format"
startIndex := 1.
[(startIndex := source indexOfSubCollection: ':=' startingAt: startIndex) > 0] whileTrue:
[nextIndex := startIndex.
[(source at: nextIndex - 1) isSeparator] whileTrue:
[nextIndex := nextIndex - 1].
source := source copyReplaceFrom: nextIndex to: startIndex + 1 with: '::'.
startIndex := nextIndex + 1].
"add the horror-show parentheses"
startIndex := source indexOf: Character cr.
source := source copyReplaceFrom: startIndex to: startIndex - 1 with: ' = ('.
source := source, (String with: Character cr with: $) ).
^source!
----- Method: SpurBootstrapNewspeakFilePatcher>>parse (in category 'parsing') -----
parse
| platform |
platform := BlackMarket platform.
^[(NewspeakParsing
usingPlatform: platform
grammar: (NewspeakGrammar parserLib: (CombinatorialParsing usingPlatform: platform))
asts: (NewspeakASTs usingLib: platform)) Parser new compilationUnit parse: source]
ensure: [source close]!
----- Method: SpurBootstrapNewspeakFilePatcher>>patch:inDirectory: (in category 'patching') -----
patch: className inDirectory: dir
"SpurBootstrapNewspeakFilePatcher new
patch: 'KernelForSqueak'
inDirectory: '../newspeak'"
| directory |
directory := FileDirectory default directoryNamed: dir.
source := directory oldFileNamed: className, '.ns3'.
self substitute: self parse.
self editTo: (directory forceNewFileNamed: className, '.ns3.patched')!
----- Method: SpurBootstrapNewspeakFilePatcher>>substitute: (in category 'patching') -----
substitute: ast "<ClassDeclarationAST>"
SpurBootstrap new prototypeClassNameMetaSelectorMethodDo:
[:className :isMeta :selector :method| | source |
method primitive = 0 ifTrue: "all primitives are in the VMMirror package"
[(self findClassDeclarationFor: className in: ast) ifNotNil:
[:classDecl|
(self findMethodDeclarationFor: selector in: classDecl) ifNotNil:
[:methodDecl|
source := self newspeakSourceFor: method selector: selector.
substitutions add: {methodDecl start. methodDecl end. source}]]]]!
Object subclass: #SpurBootstrapPrototypes
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogAttic-Bootstrapping'!
SpurBootstrapPrototypes subclass: #SpurBootstrapPharoPrototypes
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogAttic-Bootstrapping'!
----- Method: SpurBootstrapPharoPrototypes class>>imageType (in category 'accessing') -----
imageType
^ 'pharo'!
----- Method: SpurBootstrapPharoPrototypes>>BehaviorPROTOTYPEbasicIdentityHash (in category 'method prototypes') -----
BehaviorPROTOTYPEbasicIdentityHash
"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!
----- Method: SpurBootstrapPharoPrototypes>>BehaviorPROTOTYPElargeIdentityHash (in category 'method prototypes') -----
BehaviorPROTOTYPElargeIdentityHash
"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: 175>
self primitiveFailed!
----- Method: SpurBootstrapPharoPrototypes>>BlockClosurePHAROPROTOTYPEsimulateValueWithArguments:caller: (in category 'method prototypes') -----
BlockClosurePHAROPROTOTYPEsimulateValueWithArguments: anArray caller: aContext
<indirect>!
----- Method: SpurBootstrapPharoPrototypes>>CharacterPROTOTYPEcodePoint (in category 'method prototypes') -----
CharacterPROTOTYPEcodePoint
"Just for ANSI Compliance"
^self asciiValue!
----- Method: SpurBootstrapPharoPrototypes>>CharacterPROTOTYPEsetValue: (in category 'method prototypes') -----
CharacterPROTOTYPEsetValue: newValue
self error: 'Characters are immutable'!
----- Method: SpurBootstrapPharoPrototypes>>CharacterPROTOTYPEshallowCopy (in category 'method prototypes') -----
CharacterPROTOTYPEshallowCopy
"Answer the receiver, because Characters are unique."
^self!
----- Method: SpurBootstrapPharoPrototypes>>ContextPROTOTYPEdoPrimitive:method:receiver:args: (in category 'method prototypes') -----
ContextPROTOTYPEdoPrimitive: primitiveIndex method: meth receiver: aReceiver args: arguments
<indirect>!
----- Method: SpurBootstrapPharoPrototypes>>ContextPROTOTYPEfailPrimitiveWith: (in category 'method prototypes') -----
ContextPROTOTYPEfailPrimitiveWith: maybePrimFailToken
<indirect>!
----- Method: SpurBootstrapPharoPrototypes>>ContextPROTOTYPEisPrimFailToken: (in category 'method prototypes') -----
ContextPROTOTYPEisPrimFailToken: anObject
<indirect>
!
----- Method: SpurBootstrapPharoPrototypes>>ContextPROTOTYPEobjectClass: (in category 'method prototypes') -----
ContextPROTOTYPEobjectClass: aReceiver
<indirect>!
----- Method: SpurBootstrapPharoPrototypes>>ContextPROTOTYPEsend:to:with:lookupIn: (in category 'method prototypes') -----
ContextPROTOTYPEsend: 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 := Context sender: self receiver: rcvr method: meth arguments: arguments.
primIndex > 0 ifTrue:
[ctxt failPrimitiveWith: val].
^ctxt!
----- Method: SpurBootstrapPharoPrototypes>>ContextclassPROTOTYPEallInstances (in category 'method prototypes') -----
ContextclassPROTOTYPEallInstances
"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!
----- Method: SpurBootstrapPharoPrototypes>>ContextclassPROTOTYPEallInstancesDo: (in category 'method prototypes') -----
ContextclassPROTOTYPEallInstancesDo: 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."
inst := self someInstance.
[inst == thisContext or: [inst == nil]] whileFalse:
[next := inst nextInstance.
aBlock value: inst.
inst := next]!
----- Method: SpurBootstrapPharoPrototypes>>ProtoObjectPROTOTYPEidentityHash (in category 'method prototypes') -----
ProtoObjectPROTOTYPEidentityHash
"Answer a SmallInteger whose value is related to the receiver's identity.
This method must not be overridden, except by SmallInteger. As of
2014, the 32-bit Spur VM has 22 bits of hash and 31-bit SmallIntegers
(30 bits + 1 sign bit). Shifting by 8 will not create large integers.
Do not override."
^self basicIdentityHash bitShift: 8!
----- Method: SpurBootstrapPharoPrototypes>>SlotClassBuilderPROTOTYPEcomputeFormat:instSize:forSuper:ccIndex: (in category 'method prototypes') -----
SlotClassBuilderPROTOTYPEcomputeFormat: 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."
| 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].
instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]).
instSize > 65535 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'.
^nil].
^self format: instSize variable: isVar words: isWords pointers: isPointers weak: isWeak!
----- Method: SpurBootstrapPharoPrototypes>>SlotClassBuilderPROTOTYPEformat:variable:words:pointers:weak: (in category 'method prototypes') -----
SlotClassBuilderPROTOTYPEformat: nInstVars variable: isVar words: isWords 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 |
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: [isWords ifTrue: [12] ifFalse: [16]]
ifFalse: [7]]].
^(instSpec bitShift: 16) + nInstVars!
----- Method: SpurBootstrapPharoPrototypes>>SlotClassBuilderPROTOTYPEsuperclass:immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'method prototypes') -----
SlotClassBuilderPROTOTYPEsuperclass: 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!
----- Method: SpurBootstrapPharoPrototypes>>SlotClassBuilderPROTOTYPEupdate:to: (in category 'method prototypes') -----
SlotClassBuilderPROTOTYPEupdate: 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"
| 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."
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!
----- Method: SpurBootstrapPharoPrototypes>>SmalltalkImagePROTOTYPEnewSpecialObjectsArray (in category 'method prototypes') -----
SmalltalkImagePROTOTYPEnewSpecialObjectsArray
"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.
"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 globals associationAt: #Processor).
"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: Float.
newArray at: 11 put: (self globals at: #MethodContext ifAbsent: [self globals at: #Context]).
newArray at: 12 put: nil. "was 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 primitiveGetSpecialObjectsArray at: 18) ifNil: [Semaphore new]). "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."
newArray at: 25 put: (self primitiveGetSpecialObjectsArray 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"
newArray at: 29 put: self compactClassesArray.
newArray at: 30 put: ((self primitiveGetSpecialObjectsArray at: 30) ifNil: [Semaphore new]). "delay Semaphore"
newArray at: 31 put: ((self primitiveGetSpecialObjectsArray at: 31) ifNil: [Semaphore new]). "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: 35 put: #cannotInterpret:.
newArray at: 36 put: nil. "was the prototype MethodContext"
newArray at: 37 put: BlockClosure.
newArray at: 38 put: nil. "was the prototype BlockContext"
"array of objects referred to by external code"
newArray at: 39 put: (self primitiveGetSpecialObjectsArray at: 39). "external semaphores"
newArray at: 40 put: nil. "Reserved for Mutex in Cog VMs"
newArray at: 41 put: ((self primitiveGetSpecialObjectsArray at: 41) ifNil: [LinkedList new]). "Reserved for a LinkedList instance for overlapped calls in CogMT"
newArray at: 42 put: ((self primitiveGetSpecialObjectsArray at: 42) ifNil: [Semaphore new]). "finalization Semaphore"
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: 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').
"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: 55 put: (self at: #UnsafeAlien ifAbsent: []).
"Used to be WeakFinalizationList for WeakFinalizationList hasNewFinalization, obsoleted by ephemeron support."
newArray at: 56 put: nil.
"reserved for foreign callback process"
newArray at: 57 put: (self primitiveGetSpecialObjectsArray 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:.
^newArray!
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEallInstances (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEallInstances
"Answer all instances of the receiver."
self error: 'Traits does not have instances.'!
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEallInstancesDo: (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEallInstancesDo: aBlock
"Evaluate aBlock with each of the current instances of the receiver."
self error: 'Traits does not have instances.'!
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEinstSpec (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEinstSpec
"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)"
^(self format bitShift: -16) bitAnd: 16r1F!
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEisBits (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEisBits
"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!
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEisBytes (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEisBytes
"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!
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEisEphemeronClass (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEisEphemeronClass
"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!
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEisImmediateClass (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEisImmediateClass
"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!
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEisVariable (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEisVariable
"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]]!
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEkindOfSubclass (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEkindOfSubclass
"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: ']]]!
----- Method: SpurBootstrapPharoPrototypes>>VirtualMachinePROTOTYPEisSpur (in category 'method prototypes') -----
VirtualMachinePROTOTYPEisSpur
"this value is always true but is here for backward compatibility (non Spur images should return false)"
^ true!
----- Method: SpurBootstrapPharoPrototypes>>VirtualMachinePROTOTYPEsetGCParameters (in category 'method prototypes') -----
VirtualMachinePROTOTYPEsetGCParameters
"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 := self parameterAt: 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.
self tenuringThreshold: numObjects "tenure when more than this many objects survive the GC"!
----- Method: SpurBootstrapPrototypes class>>allMethodPrototypes (in category 'accessing method dictionary') -----
allMethodPrototypes
^(self canUnderstand: #allMethods)
ifTrue: "Pharo"
[self allMethods select:
[:each| each category = 'method prototypes']]
ifFalse: "Squeak" "%$#@*!! collect: on IdentitySet answers a *Set*, not an IdentitySet %$#@*!!"
[(self allSelectors collect: [:s| self lookupSelector: s] as: IdentitySet)
select: [:m| m protocol = 'method prototypes']]!
----- Method: SpurBootstrapPrototypes class>>imageType (in category 'accessing') -----
imageType
^ self subclassResponsibility!
----- Method: SpurBootstrapPrototypes class>>prototypeClassFor: (in category 'instance creation') -----
prototypeClassFor: type
| deepest |
deepest := nil.
self allSubclassesDo:
[:aClass | aClass imageType = type ifTrue: [deepest := aClass]].
^deepest!
----- Method: SpurBootstrapPrototypes>>ArrayPROTOTYPEelementsExchangeIdentityWith: (in category 'method prototypes') -----
ArrayPROTOTYPEelementsExchangeIdentityWith: otherArray
"This primitive performs a bulk mutation, causing all pointers to the elements of the
receiver to be replaced by pointers to the corresponding elements of otherArray.
At the same time, all pointers to the elements of otherArray are replaced by
pointers to the corresponding elements of this array. The identityHashes remain
with the pointers rather than with the objects so that objects in hashed structures
should still be properly indexed after the mutation."
<primitive: 128 error: ec>
ec == #'bad receiver' ifTrue:
[^self error: 'receiver must be of class Array'].
ec == #'bad argument' ifTrue:
[^self error: (otherArray class == Array
ifTrue: ['arg must be of class Array']
ifFalse: ['receiver and argument must have the same size'])].
ec == #'inappropriate operation' ifTrue:
[^self error: 'can''t become immediates such as SmallIntegers or Characters'].
ec == #'no modification' ifTrue:
[^self error: 'can''t become immutable objects'].
ec == #'object is pinned' ifTrue:
[^self error: 'can''t become pinned objects'].
ec == #'insufficient object memory' ifTrue:
[Smalltalk garbageCollect < 1048576 ifTrue:
[Smalltalk growMemoryByAtLeast: 1048576].
^self elementsExchangeIdentityWith: otherArray].
self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>ArrayPROTOTYPEelementsForwardIdentityTo: (in category 'method prototypes') -----
ArrayPROTOTYPEelementsForwardIdentityTo: otherArray
"This primitive performs a bulk mutation, causing all pointers to the elements of the
receiver to be replaced by pointers to the corresponding elements of otherArray.
The identityHashes remain with the pointers rather than with the objects so that
the objects in this array should still be properly indexed in any existing hashed
structures after the mutation."
<primitive: 72 error: ec>
ec == #'bad receiver' ifTrue:
[^self error: 'receiver must be of class Array'].
ec == #'bad argument' ifTrue:
[^self error: (otherArray class == Array
ifTrue: ['arg must be of class Array']
ifFalse: ['receiver and argument must have the same size'])].
ec == #'inappropriate operation' ifTrue:
[^self error: 'can''t become immediates such as SmallIntegers or Characters'].
ec == #'no modification' ifTrue:
[^self error: 'can''t become immutable objects'].
ec == #'object is pinned' ifTrue:
[^self error: 'can''t become pinned objects'].
ec == #'insufficient object memory' ifTrue:
[Smalltalk garbageCollect < 1048576 ifTrue:
[Smalltalk growMemoryByAtLeast: 1048576].
^self elementsForwardIdentityTo: otherArray].
self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>ArrayPROTOTYPEelementsForwardIdentityTo:copyHash: (in category 'method prototypes') -----
ArrayPROTOTYPEelementsForwardIdentityTo: otherArray copyHash: copyHash
"This primitive performs a bulk mutation, causing all pointers to the elements of the
receiver to be replaced by pointers to the corresponding elements of otherArray.
If copyHash is true, the identityHashes remain with the pointers rather than with the
objects so that the objects in the receiver should still be properly indexed in any
existing hashed structures after the mutation. If copyHash is false, then the hashes
of the objects in otherArray remain unchanged. If you know what you're doing this
may indeed be what you want."
<primitive: 249 error: ec>
ec == #'bad receiver' ifTrue:
[^self error: 'receiver must be of class Array'].
ec == #'bad argument' ifTrue:
[^self error: (otherArray class == Array
ifTrue: ['arg must be of class Array']
ifFalse: ['receiver and argument must have the same size'])].
ec == #'inappropriate operation' ifTrue:
[^self error: 'can''t become immediates such as SmallIntegers or Characters'].
ec == #'no modification' ifTrue:
[^self error: 'can''t become immutable objects'].
ec == #'object is pinned' ifTrue:
[^self error: 'can''t become pinned objects'].
ec == #'insufficient object memory' ifTrue:
[Smalltalk garbageCollect < 1048576 ifTrue:
[Smalltalk growMemoryByAtLeast: 1048576].
^self elementsForwardIdentityTo: otherArray copyHash: copyHash].
self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEallInstances (in category 'method prototypes') -----
BehaviorPROTOTYPEallInstances
"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!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEallInstancesDo: (in category 'method prototypes') -----
BehaviorPROTOTYPEallInstancesDo: 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."
inst := self someInstance.
[inst == nil] whileFalse:
[next := inst nextInstance.
aBlock value: inst.
inst := next]!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEallInstancesOrNil (in category 'method prototypes') -----
BehaviorPROTOTYPEallInstancesOrNil
"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!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEbasicNew (in category 'method prototypes') -----
BehaviorPROTOTYPEbasicNew
"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."
<primitive: 70 error: ec>
ec == #'insufficient object memory' ifTrue:
[^self handleFailingBasicNew].
self isVariable ifTrue: [^self basicNew: 0].
self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEbasicNew: (in category 'method prototypes') -----
BehaviorPROTOTYPEbasicNew: 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."
<primitive: 71 error: ec>
ec == #'insufficient object memory' ifTrue:
[^self handleFailingBasicNew: sizeRequested].
self isVariable ifFalse:
[self error: self printString, ' cannot have variable sized instances'].
self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEbyteSizeOfInstance (in category 'method prototypes') -----
BehaviorPROTOTYPEbyteSizeOfInstance
"Answer the total memory size of an instance of the receiver."
<primitive: 181 error: ec>
self isVariable ifTrue:
[^self byteSizeOfInstanceOfSize: 0].
self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEbyteSizeOfInstanceOfSize: (in category 'method prototypes') -----
BehaviorPROTOTYPEbyteSizeOfInstanceOfSize: 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!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEelementSize (in category 'method prototypes') -----
BehaviorPROTOTYPEelementSize
"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!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEhandleFailingBasicNew (in category 'method prototypes') -----
BehaviorPROTOTYPEhandleFailingBasicNew
"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"!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEhandleFailingBasicNew: (in category 'method prototypes') -----
BehaviorPROTOTYPEhandleFailingBasicNew: 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!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEhandleFailingFailingBasicNew (in category 'method prototypes') -----
BehaviorPROTOTYPEhandleFailingFailingBasicNew
"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"!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEhandleFailingFailingBasicNew: (in category 'method prototypes') -----
BehaviorPROTOTYPEhandleFailingFailingBasicNew: 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"!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEindexIfCompact (in category 'method prototypes') -----
BehaviorPROTOTYPEindexIfCompact
"Backward compatibility with the Squeak V3 object format.
Spur does not have a distinction between compact and non-compact classes."
^0!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEinstSize (in category 'method prototypes') -----
BehaviorPROTOTYPEinstSize
<indirect>!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEinstSpec (in category 'method prototypes') -----
BehaviorPROTOTYPEinstSpec
<indirect>!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEisBits (in category 'method prototypes') -----
BehaviorPROTOTYPEisBits
"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!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEisBytes (in category 'method prototypes') -----
BehaviorPROTOTYPEisBytes
"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!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEisCompiledMethodClass (in category 'method prototypes') -----
BehaviorPROTOTYPEisCompiledMethodClass
"Answer whether the receiver has compiled method instances that mix pointers and bytes."
^self instSpec >= 24!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEisEphemeronClass (in category 'method prototypes') -----
BehaviorPROTOTYPEisEphemeronClass
"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!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEisImmediateClass (in category 'method prototypes') -----
BehaviorPROTOTYPEisImmediateClass
"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!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEisVariable (in category 'method prototypes') -----
BehaviorPROTOTYPEisVariable
"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]]!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEkindOfSubclass (in category 'method prototypes') -----
BehaviorPROTOTYPEkindOfSubclass
"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: ']]]!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEshouldNotBeRedefined (in category 'method prototypes') -----
BehaviorPROTOTYPEshouldNotBeRedefined
"Answer if the receiver should not be redefined.
The assumption is that classes in Smalltalk specialObjects and
instance-specific Behaviors should not be redefined"
^(Smalltalk specialObjectsArray
identityIndexOf: self
ifAbsent: [(self isKindOf: self) ifTrue: [1] ifFalse: [0]]) ~= 0!
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEtypeOfClass (in category 'method prototypes') -----
BehaviorPROTOTYPEtypeOfClass
"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!
----- Method: SpurBootstrapPrototypes>>BoxedFloat64classPROTOTYPEbasicNew (in category 'method prototypes') -----
BoxedFloat64classPROTOTYPEbasicNew
^self basicNew: 2!
----- Method: SpurBootstrapPrototypes>>BoxedFloat64classPROTOTYPEbasicNew: (in category 'method prototypes') -----
BoxedFloat64classPROTOTYPEbasicNew: 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!
----- Method: SpurBootstrapPrototypes>>BytecodeEncoderPROTOTYPEcomputeMethodHeaderForNumArgs:numTemps:numLits:primitive: (in category 'method prototypes') -----
BytecodeEncoderPROTOTYPEcomputeMethodHeaderForNumArgs: numArgs numTemps: numTemps numLits: numLits primitive: primitiveIndex
numArgs > 15 ifTrue:
[^self error: 'Cannot compile -- too many arguments'].
numTemps > 63 ifTrue:
[^self error: 'Cannot compile -- too many temporary variables'].
numLits > 65535 ifTrue:
[^self error: 'Cannot compile -- too many literals'].
^(CompiledMethod headerFlagForEncoder: self)
+ (numArgs bitShift: 24)
+ (numTemps bitShift: 18)
"+ (largeBit bitShift: 17)" "largeBit gets filled in later"
+ (primitiveIndex > 0 ifTrue: [1 bitShift: 16] ifFalse: [0])
+ numLits!
----- Method: SpurBootstrapPrototypes>>BytecodeEncoderPROTOTYPEsizeCallPrimitive: (in category 'method prototypes') -----
BytecodeEncoderPROTOTYPEsizeCallPrimitive: primitiveIndex
^self sizeOpcodeSelector: #genCallPrimitive: withArguments: {primitiveIndex}!
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEDollarEquals: (in category 'method prototypes') -----
CharacterPROTOTYPEDollarEquals: aCharacter
"Primitive. Answer if the receiver and the argument are the
same object (have the same object pointer). Optional. See
Object documentation whatIsAPrimitive."
<primitive: 110>
^self == aCharacter!
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEasInteger (in category 'method prototypes') -----
CharacterPROTOTYPEasInteger
"Answer the receiver's character code."
<primitive: 171>
^self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEasciiValue (in category 'method prototypes') -----
CharacterPROTOTYPEasciiValue
"Answer the receiver's character code.
This will be ascii for characters with value <= 127,
and Unicode for those with higher values."
<primitive: 171>
^self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEcomeFullyUpOnReload: (in category 'method prototypes') -----
CharacterPROTOTYPEcomeFullyUpOnReload: smartRefStream
"Now Characters are immediates, this can be deleted."
<remove>!
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEcopy (in category 'method prototypes') -----
CharacterPROTOTYPEcopy
"Answer the receiver, because Characters are unique."
^self!
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEdeepCopy (in category 'method prototypes') -----
CharacterPROTOTYPEdeepCopy
"Answer the receiver, because Characters are unique."
^self!
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEhash (in category 'method prototypes') -----
CharacterPROTOTYPEhash
"Hash is reimplemented because = is implemented.
Answer the receiver's character code."
<primitive: 171>
^self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEidentityHash (in category 'method prototypes') -----
CharacterPROTOTYPEidentityHash
"Answer the receiver's character code."
<primitive: 171>
^self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEshallowCopy (in category 'method prototypes') -----
CharacterPROTOTYPEshallowCopy
"Answer the receiver, because Characters are unique."
^self!
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEveryDeepCopyWith: (in category 'method prototypes') -----
CharacterPROTOTYPEveryDeepCopyWith: deepCopier
"Answer the receiver, because Characters are unique."
^self!
----- Method: SpurBootstrapPrototypes>>CharacterclassPROTOTYPEdigitValue: (in category 'method prototypes') -----
CharacterclassPROTOTYPEdigitValue: x
"Answer the Character whose digit value is x. For example,
answer $9 for x=9, $0 for x=0, $A for x=10, $Z for x=35."
| n |
n := x asInteger.
^self value: (n < 10 ifTrue: [n + 48] ifFalse: [n + 55])!
----- Method: SpurBootstrapPrototypes>>CharacterclassPROTOTYPEinitialize (in category 'method prototypes') -----
CharacterclassPROTOTYPEinitialize
"Create the DigitsValues table."
"Character initialize"
self initializeDigitValues!
----- Method: SpurBootstrapPrototypes>>CharacterclassPROTOTYPEvalue: (in category 'method prototypes') -----
CharacterclassPROTOTYPEvalue: anInteger
"Answer the Character whose value is anInteger."
<primitive: 170>
^self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>ClassDescriptionPROTOTYPEupdateInstances:from:isMeta: (in category 'method prototypes') -----
ClassDescriptionPROTOTYPEupdateInstances: 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,"
| map variable instSize newInstances |
oldInstances isEmpty ifTrue:
[^nil]. "no instances to convert"
isMeta ifTrue:
[(oldInstances size = 1
and: [self soleInstance class == self
or: [self soleInstance class == oldClass]]) ifFalse:
[^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)].
"Now perform a bulk mutation of old instances into new ones"
oldInstances elementsForwardIdentityTo: newInstances.
^nil!
----- Method: SpurBootstrapPrototypes>>ClassDescriptionPROTOTYPEupdateInstancesFrom: (in category 'method prototypes') -----
ClassDescriptionPROTOTYPEupdateInstancesFrom: 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."
"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.
"Now fix up instances in segments that are out on the disk."
ImageSegment allSubInstancesDo:
[:seg |
seg segUpdateInstancesOf: oldClass toBe: self isMeta: self isMeta].
^nil
"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"!
----- Method: SpurBootstrapPrototypes>>CompiledMethodPROTOTYPEnumLiterals (in category 'method prototypes') -----
CompiledMethodPROTOTYPEnumLiterals
"Answer the number of literals used by the receiver."
^self header bitAnd: 16r7FFF!
----- Method: SpurBootstrapPrototypes>>CompiledMethodPROTOTYPEprimitive (in category 'method prototypes') -----
CompiledMethodPROTOTYPEprimitive
"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]!
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEhandleFailingFailingNewMethod:header: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEhandleFailingFailingNewMethod: 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!
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEhandleFailingNewMethod:header: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEhandleFailingNewMethod: 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!
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEheaderFlagForEncoder: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEheaderFlagForEncoder: anEncoder
<indirect>!
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEinitialize (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEinitialize "CompiledMethod initialize"
<indirect>!
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEinstallPrimaryBytecodeSet: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEinstallPrimaryBytecodeSet: aBytecodeEncoderSubclass
<indirect>!
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEinstallSecondaryBytecodeSet: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEinstallSecondaryBytecodeSet: aBytecodeEncoderSubclass
<indirect>!
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEnewBytes:trailerBytes:nArgs:nTemps:nStack:nLits:primitive: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEnewBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex
"Since this method refers to ClassVariables things are easier if it lives in the actual class."
<indirect>!
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEnewBytes:trailerBytes:nArgs:nTemps:nStack:nLits:primitive:flag: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEnewBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex flag: flag
"Since this method refers to ClassVariables things are easier if it lives in the actual class."
<indirect>!
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEnewMethod:header: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEnewMethod: 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."
<primitive: 79 error: ec>
ec == #'insufficient object memory' ifTrue:
[^self handleFailingNewMethod: numberOfBytes header: headerWord].
^self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEtoReturnConstant:trailerBytes: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEtoReturnConstant: 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!
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEtoReturnField:trailerBytes: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEtoReturnField: 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!
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEtoReturnSelfTrailerBytes: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEtoReturnSelfTrailerBytes: 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!
----- Method: SpurBootstrapPrototypes>>EncoderForV3PROTOTYPEcomputeMethodHeaderForNumArgs:numTemps:numLits:primitive: (in category 'method prototypes') -----
EncoderForV3PROTOTYPEcomputeMethodHeaderForNumArgs: numArgs numTemps: numTemps numLits: numLits primitive: primitiveIndex
<remove>!
----- Method: SpurBootstrapPrototypes>>EncoderForV3PlusClosuresPROTOTYPEgenCallPrimitive: (in category 'method prototypes') -----
EncoderForV3PlusClosuresPROTOTYPEgenCallPrimitive: primitiveIndex
"Since this method has inst var refs the prototype must live in the actual class."
<indirect>!
----- Method: SpurBootstrapPrototypes>>EncoderForV3PlusClosuresclassPROTOTYPEbytecodeSize: (in category 'method prototypes') -----
EncoderForV3PlusClosuresclassPROTOTYPEbytecodeSize: bytecode
"Answer the number of bytes in the bytecode."
bytecode <= 125 ifTrue:
[^1].
bytecode >= 176 ifTrue:
[^1].
bytecode >= 160 ifTrue: "long jumps"
[^2].
bytecode >= 144 ifTrue: "short jumps"
[^1].
"extensions"
bytecode >= 128 ifTrue:
[^#(2 2 2 2 3 2 2 1 1 1 2 3 3 3 3 4) at: bytecode - 127].
^nil!
----- Method: SpurBootstrapPrototypes>>EncoderForV3PlusClosuresclassPROTOTYPEcallPrimitiveCode (in category 'method prototypes') -----
EncoderForV3PlusClosuresclassPROTOTYPEcallPrimitiveCode
"139 11101111 iiiiiiii jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256)"
^139!
----- Method: SpurBootstrapPrototypes>>FloatclassPROTOTYPEbasicNew (in category 'method prototypes') -----
FloatclassPROTOTYPEbasicNew
^BoxedFloat64 basicNew: 2!
----- Method: SpurBootstrapPrototypes>>FloatclassPROTOTYPEbasicNew: (in category 'method prototypes') -----
FloatclassPROTOTYPEbasicNew: anInteger
^BoxedFloat64 basicNew: 2!
----- Method: SpurBootstrapPrototypes>>FloatclassPROTOTYPEfromIEEE32Bit: (in category 'method prototypes') -----
FloatclassPROTOTYPEfromIEEE32Bit: 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."
| sign mantissa exponent delta |
word <= 0 ifTrue:
[^word negative
ifTrue: [self error: 'Cannot deal with negative numbers']
ifFalse: [self zero]].
sign := word bitAnd: 16r80000000.
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 = -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].
"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"!
----- Method: SpurBootstrapPrototypes>>InstructionClientPROTOTYPEcallPrimitive: (in category 'method prototypes') -----
InstructionClientPROTOTYPEcallPrimitive: 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."!
----- Method: SpurBootstrapPrototypes>>InstructionStreamPROTOTYPEinterpretV3ClosuresExtension:in:for: (in category 'method prototypes') -----
InstructionStreamPROTOTYPEinterpretV3ClosuresExtension: offset in: method for: client
"Since this method has inst var refs the prototype must live in the actual class."
<indirect>!
----- Method: SpurBootstrapPrototypes>>LargeNegativeIntegerPROTOTYPEnormalize (in category 'method prototypes') -----
LargeNegativeIntegerPROTOTYPEnormalize
"Check for leading zeroes and return shortened copy if so"
| sLen val len oldLen minVal |
<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].
len <= sLen ifTrue:
[minVal := SmallInteger minVal.
(len < sLen
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]!
----- Method: SpurBootstrapPrototypes>>LargePositiveIntegerPROTOTYPEnormalize (in category 'method prototypes') -----
LargePositiveIntegerPROTOTYPEnormalize
"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].
(len <= 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]!
----- Method: SpurBootstrapPrototypes>>MethodNodeOLDSQUEAKPROTOTYPEgenerate: (in category 'method prototypes') -----
MethodNodeOLDSQUEAKPROTOTYPEgenerate: trailer
"The receiver is the root of a parse tree. Answer a CompiledMethod.
The argument, trailer, is arbitrary but is typically either the reference
to the source code that is stored with every CompiledMethod, or an
encoding of the method's temporary names."
^self generate: trailer using: CompiledMethod!
----- Method: SpurBootstrapPrototypes>>MethodNodePROTOTYPEgenerate:using: (in category 'method prototypes') -----
MethodNodePROTOTYPEgenerate: trailer using: aCompiledMethodClass
"Since this method has inst var refs the prototype must live in the actual class."
<indirect>!
----- Method: SpurBootstrapPrototypes>>ObjectPROTOTYPEclone (in category 'method prototypes') -----
ObjectPROTOTYPEclone
"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!
----- Method: SpurBootstrapPrototypes>>ObjectPROTOTYPEinstVarAt: (in category 'method prototypes') -----
ObjectPROTOTYPEinstVarAt: 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."
<primitive: 173 error: ec>
self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>ObjectPROTOTYPEinstVarAt:put: (in category 'method prototypes') -----
ObjectPROTOTYPEinstVarAt: 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."
<primitive: 174 error: ec>
self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>ObjectPROTOTYPEisPinned (in category 'method prototypes') -----
ObjectPROTOTYPEisPinned
"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!
----- Method: SpurBootstrapPrototypes>>ObjectPROTOTYPEoopAge (in category 'method prototypes') -----
ObjectPROTOTYPEoopAge
<remove>!
----- Method: SpurBootstrapPrototypes>>ObjectPROTOTYPEoopTimestamp (in category 'method prototypes') -----
ObjectPROTOTYPEoopTimestamp
<remove>!
----- Method: SpurBootstrapPrototypes>>ObjectPROTOTYPEpin (in category 'method prototypes') -----
ObjectPROTOTYPEpin
"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!
----- Method: SpurBootstrapPrototypes>>ObjectPROTOTYPEsetPinned: (in category 'method prototypes') -----
ObjectPROTOTYPEsetPinned: 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!
----- Method: SpurBootstrapPrototypes>>ObjectPROTOTYPEunpin (in category 'method prototypes') -----
ObjectPROTOTYPEunpin
"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!
----- Method: SpurBootstrapPrototypes>>SmallFloat64PROTOTYPEclone (in category 'method prototypes') -----
SmallFloat64PROTOTYPEclone
"Answer the receiver, because SmallFloat64s are unique."
^self!
----- Method: SpurBootstrapPrototypes>>SmallFloat64PROTOTYPEcopy (in category 'method prototypes') -----
SmallFloat64PROTOTYPEcopy
"Answer the receiver, because SmallFloat64s are unique."
^self!
----- Method: SpurBootstrapPrototypes>>SmallFloat64PROTOTYPEdeepCopy (in category 'method prototypes') -----
SmallFloat64PROTOTYPEdeepCopy
"Answer the receiver, because SmallFloat64s are unique."
^self!
----- Method: SpurBootstrapPrototypes>>SmallFloat64PROTOTYPEidentityHash (in category 'method prototypes') -----
SmallFloat64PROTOTYPEidentityHash
"Answer an integer unique to the receiver."
<primitive: 171>
^self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>SmallFloat64PROTOTYPEshallowCopy (in category 'method prototypes') -----
SmallFloat64PROTOTYPEshallowCopy
"Answer the receiver, because SmallFloat64s are unique."
^self!
----- Method: SpurBootstrapPrototypes>>SmallFloat64PROTOTYPEveryDeepCopyWith: (in category 'method prototypes') -----
SmallFloat64PROTOTYPEveryDeepCopyWith: deepCopier
"Answer the receiver, because SmallFloat64s are unique."
^self!
----- Method: SpurBootstrapPrototypes>>SmallFloat64classPROTOTYPEbasicNew (in category 'method prototypes') -----
SmallFloat64classPROTOTYPEbasicNew
self error: 'SmallFloat64s can only be created by performing arithmetic'!
----- Method: SpurBootstrapPrototypes>>SmallFloat64classPROTOTYPEbasicNew: (in category 'method prototypes') -----
SmallFloat64classPROTOTYPEbasicNew: anInteger
^self basicNew!
----- Method: SpurBootstrapPrototypes>>SmallIntegerPROTOTYPEasCharacter (in category 'method prototypes') -----
SmallIntegerPROTOTYPEasCharacter
<primitive: 170>
^self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>SmallIntegerPROTOTYPEdecimalDigitLength (in category 'method prototypes') -----
SmallIntegerPROTOTYPEdecimalDigitLength
"Answer the number of digits printed out in base 10.
Note that this only works for positive SmallIntegers up to 64-bits."
^self < 10000
ifTrue:
[self < 100
ifTrue:
[self < 10 ifTrue: [1] ifFalse: [2]]
ifFalse:
[self < 1000 ifTrue: [3] ifFalse: [4]]]
ifFalse:
[self < 100000000
ifTrue:
[self < 1000000
ifTrue: [self < 100000 ifTrue: [5] ifFalse: [6]]
ifFalse: [self < 10000000 ifTrue: [7] ifFalse: [8]]]
ifFalse:
[self < 1000000000000
ifTrue:
[self < 10000000000
ifTrue: [self < 1000000000 ifTrue: [9] ifFalse: [10]]
ifFalse: [self < 100000000000 ifTrue: [11] ifFalse: [12]]]
ifFalse:
[self < 10000000000000000
ifTrue:
[self < 100000000000000
ifTrue: [self < 10000000000000 ifTrue: [13] ifFalse: [14]]
ifFalse: [self < 1000000000000000 ifTrue: [15] ifFalse: [16]]]
ifFalse:
[self < 1000000000000000000
ifTrue: [self < 100000000000000000 ifTrue: [17] ifFalse: [18]]
ifFalse: [self < 10000000000000000000 ifTrue: [19] ifFalse: [20]]]]]]!
----- Method: SpurBootstrapPrototypes>>SmallIntegerPROTOTYPEdigitLength (in category 'method prototypes') -----
SmallIntegerPROTOTYPEdigitLength
"Answer the number of indexable fields in the receiver. This value is the
same as the largest legal subscript. Included so that a SmallInteger can
behave like a LargePositiveInteger or LargeNegativeInteger."
| value length |
length := 1.
value := self.
value >= 0
ifTrue:
[[value > 255] whileTrue:
[value := value bitShift: -8.
length := length + 1]]
ifFalse:
[[value < -255] whileTrue:
[value := value bitShift: -8.
length := length + 1]].
^length!
----- Method: SpurBootstrapPrototypes>>SmalltalkImagePROTOTYPEcompactClassesArray (in category 'method prototypes') -----
SmalltalkImagePROTOTYPEcompactClassesArray
"Smalltalk compactClassesArray"
"Backward-compatibility support. Spur does not have compact classes."
^{}!
----- Method: SpurBootstrapPrototypes>>SmalltalkImagePROTOTYPEgrowMemoryByAtLeast: (in category 'method prototypes') -----
SmalltalkImagePROTOTYPEgrowMemoryByAtLeast: 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!
----- Method: SpurBootstrapPrototypes>>SmalltalkImagePROTOTYPEmaxIdentityHash (in category 'method prototypes') -----
SmalltalkImagePROTOTYPEmaxIdentityHash
"Answer the maximum identityHash value supported by the VM."
<primitive: 176>
^self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>SmalltalkImagePROTOTYPEprimBytesLeft (in category 'method prototypes') -----
SmalltalkImagePROTOTYPEprimBytesLeft
"Primitive. Answer the number of free bytes available in old space.
Not accurate unless preceded by
Smalltalk garbageCollectMost (for reasonable accuracy), or
Smalltalk garbageCollect (for real accuracy).
See Object documentation whatIsAPrimitive."
<primitive: 112>
^0!
----- Method: SpurBootstrapPrototypes>>SmalltalkImagePROTOTYPEprimitiveGarbageCollect (in category 'method prototypes') -----
SmalltalkImagePROTOTYPEprimitiveGarbageCollect
"Primitive. Reclaims all garbage and answers the size of the largest free chunk in old space.."
<primitive: 130>
^self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>SpaceTallyPROTOTYPEspaceForInstancesOf: (in category 'method prototypes') -----
SpaceTallyPROTOTYPEspaceForInstancesOf: 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."
| instances total |
instances := aClass allInstances.
instances isEmpty ifTrue: [^#(0 0)].
total := 0.
aClass isVariable
ifTrue:
[instances do:
[:i| total := total + (aClass byteSizeOfInstanceOfSize: i basicSize)]]
ifFalse:
[total := instances size * aClass byteSizeOfInstance].
^{ total. instances size }!
----- Method: SpurBootstrapPrototypes>>SystemDictionaryPROTOTYPEgrowMemoryByAtLeast: (in category 'method prototypes') -----
SystemDictionaryPROTOTYPEgrowMemoryByAtLeast: 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]!
----- Method: SpurBootstrapPrototypes>>SystemDictionaryPROTOTYPEmaxIdentityHash (in category 'method prototypes') -----
SystemDictionaryPROTOTYPEmaxIdentityHash
"Answer the maximum identityHash value supported by the VM."
<primitive: 176>
^self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>SystemNavigationPROTOTYPEallObjects (in category 'method prototypes') -----
SystemNavigationPROTOTYPEallObjects
"Answer an Array of all objects in the system. Fail if
there isn't enough memory to instantiate the result."
<primitive: 178>
^self primitiveFailed!
----- Method: SpurBootstrapPrototypes>>SystemNavigationPROTOTYPEallObjectsDo: (in category 'method prototypes') -----
SystemNavigationPROTOTYPEallObjectsDo: 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]]!
----- Method: SpurBootstrapPrototypes>>SystemNavigationPROTOTYPEallObjectsOrNil (in category 'method prototypes') -----
SystemNavigationPROTOTYPEallObjectsOrNil
"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!
----- Method: SpurBootstrapPrototypes>>WideStringPROTOTYPEat: (in category 'method prototypes') -----
WideStringPROTOTYPEat: index
"Answer the Character stored in the field of the receiver indexed by the
argument. Primitive. Fail if the index argument is not an Integer or is out
of bounds. Essential. See Object documentation whatIsAPrimitive."
<primitive: 63>
^index isInteger
ifTrue:
[self errorSubscriptBounds: index]
ifFalse:
[index isNumber
ifTrue: [self at: index asInteger]
ifFalse: [self errorNonIntegerIndex]]!
----- Method: SpurBootstrapPrototypes>>WideStringPROTOTYPEat:put: (in category 'method prototypes') -----
WideStringPROTOTYPEat: index put: aCharacter
"Store the Character into the field of the receiver indicated by the index.
Primitive. Fail if the index is not an Integer or is out of bounds, or if the
argument is not a Character. Essential. See Object documentation whatIsAPrimitive."
<primitive: 64>
^aCharacter isCharacter
ifTrue:
[index isInteger
ifTrue: [self errorSubscriptBounds: index]
ifFalse: [self errorNonIntegerIndex]]
ifFalse:
[self errorImproperStore]!
SpurBootstrapPrototypes subclass: #SpurBootstrapSqueakFamilyPrototypes
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogAttic-Bootstrapping'!
SpurBootstrapSqueakFamilyPrototypes subclass: #SpurBootstrapCuisPrototypes
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogAttic-Bootstrapping'!
----- Method: SpurBootstrapCuisPrototypes class>>imageType (in category 'accessing') -----
imageType
^ 'cuis'!
----- Method: SpurBootstrapCuisPrototypes>>ArrayPROTOTYPEcreateMethod:class:header: (in category 'method prototypes') -----
ArrayPROTOTYPEcreateMethod: numberOfBytesForAllButTrailer class: aCompiledMethodClass header: headerWord
| meth delta |
meth := aCompiledMethodClass newMethod: numberOfBytesForAllButTrailer + self size header: headerWord.
"copy the trailer data"
delta := meth size - self size.
1 to: self size do:
[:i | meth at: delta + i put: (self at: i)].
^meth!
----- Method: SpurBootstrapCuisPrototypes>>BehaviorPROTOTYPEidentityHash (in category 'method prototypes') -----
BehaviorPROTOTYPEidentityHash
"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!
----- Method: SpurBootstrapCuisPrototypes>>BlockClosurePROTOTYPEsimulateValueWithArguments:caller: (in category 'method prototypes') -----
BlockClosurePROTOTYPEsimulateValueWithArguments: anArray caller: aContext
<indirect>!
----- Method: SpurBootstrapCuisPrototypes>>CharacterPROTOTYPEclone (in category 'method prototypes') -----
CharacterPROTOTYPEclone
"Answer the receiver, because Characters are unique."
^self!
----- Method: SpurBootstrapCuisPrototypes>>CharacterPROTOTYPEsetValue: (in category 'method prototypes') -----
CharacterPROTOTYPEsetValue: v
<remove>!
----- Method: SpurBootstrapCuisPrototypes>>CharacterPROTOTYPEvalue (in category 'method prototypes') -----
CharacterPROTOTYPEvalue
"Answer the value of the receiver that represents its ISO 8859-15 (Latin-9) encoding."
<primitive: 171>
^self primitiveFailed!
----- Method: SpurBootstrapCuisPrototypes>>CharacterclassPROTOTYPEinitialize (in category 'method prototypes') -----
CharacterclassPROTOTYPEinitialize
<ignore>!
----- Method: SpurBootstrapCuisPrototypes>>ClassDescriptionPROTOTYPEupdateInstancesFrom: (in category 'method prototypes') -----
ClassDescriptionPROTOTYPEupdateInstancesFrom: 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."
"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.
^nil
"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"!
----- Method: SpurBootstrapCuisPrototypes>>ClassDescriptionPROTOTYPEupdateMethodBindingsTo: (in category 'method prototypes') -----
ClassDescriptionPROTOTYPEupdateMethodBindingsTo: aBinding
<indirect>!
----- Method: SpurBootstrapCuisPrototypes>>ClassPROTOTYPEimmediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'method prototypes') -----
ClassPROTOTYPEimmediateSubclass: 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!
----- Method: SpurBootstrapCuisPrototypes>>CompiledMethodPROTOTYPEbytecodeSetName (in category 'method prototypes') -----
CompiledMethodPROTOTYPEbytecodeSetName
^self encoderClass name copyReplaceAll: 'EncoderFor' with: ''!
----- Method: SpurBootstrapCuisPrototypes>>CompiledMethodPROTOTYPEheaderDescription (in category 'method prototypes') -----
CompiledMethodPROTOTYPEheaderDescription
"Answer a description containing the information about the form of the
receiver and the form of the context needed to run the receiver."
^(String 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!
----- Method: SpurBootstrapCuisPrototypes>>ContextPartPROTOTYPEactivateReturn:value: (in category 'method prototypes') -----
ContextPartPROTOTYPEactivateReturn: aContext value: value
"Activate 'aContext return: value' in place of self, so execution will return to aContext's sender"
^MethodContext
sender: self
receiver: aContext
method: MethodContext theReturnMethod
arguments: {value}!
----- Method: SpurBootstrapCuisPrototypes>>ContextPartPROTOTYPEdoPrimitive:method:receiver:args: (in category 'method prototypes') -----
ContextPartPROTOTYPEdoPrimitive: 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."
| 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 :-)"
"SystemNavigation new browseAllSelect: [:m| m primitive = 19]"
primitiveIndex = 19 ifTrue:
[Debugger
openContext: 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]].
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)
ifTrue: [value]
ifFalse: [self push: value]].
primitiveIndex = 188 ifTrue: "eem 5/27/2008 11:10 Object>>withArgs:executeMethod:"
[^MethodContext
sender: self
receiver: receiver
method: (arguments at: 2)
arguments: (arguments at: 1)].
"Closure primitives"
(primitiveIndex = 200 and: [self == receiver]) ifTrue:
"ContextPart>>closureCopy:copiedValues:; simulated to get startpc right"
[^self push: (BlockClosure
outerContext: receiver
startpc: self pc + 2
numArgs: arguments first
copiedValues: arguments last)].
primitiveIndex = 118 ifTrue: "tryPrimitive:withArgs:; avoid recursing in the VM"
[(arguments size = 2
and: [arguments first isInteger
and: [(self objectClass: arguments last) == Array]]) ifFalse:
[^self class 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)
ifTrue: [value]
ifFalse: [self push: value]!
----- Method: SpurBootstrapCuisPrototypes>>ContextPartPROTOTYPEisPrimFailToken: (in category 'method prototypes') -----
ContextPartPROTOTYPEisPrimFailToken: anObject
<indirect>!
----- Method: SpurBootstrapCuisPrototypes>>ContextPartPROTOTYPEsend:to:with:lookupIn: (in category 'method prototypes') -----
ContextPartPROTOTYPEsend: 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!
----- Method: SpurBootstrapCuisPrototypes>>ContextPartPROTOTYPEsend:to:with:super: (in category 'method prototypes') -----
ContextPartPROTOTYPEsend: 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."
^self send: selector
to: rcvr
with: arguments
lookupIn: (superFlag
ifTrue: [self method methodClassAssociation value superclass]
ifFalse: [self objectClass: rcvr])!
----- Method: SpurBootstrapCuisPrototypes>>ContextPartPROTOTYPEtryNamedPrimitiveIn:for:withArgs: (in category 'method prototypes') -----
ContextPartPROTOTYPEtryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments
"Invoke the named primitive for aCompiledMethod, answering its result, or,
if the primiitve fails, answering the error code."
<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!
----- Method: SpurBootstrapCuisPrototypes>>IntegerclassPROTOTYPEinitialize (in category 'method prototypes') -----
IntegerclassPROTOTYPEinitialize
"Integer initialize"
self initializeLowBitPerByteTable!
----- Method: SpurBootstrapCuisPrototypes>>MethodContextPROTOTYPEfailPrimitiveWith: (in category 'method prototypes') -----
MethodContextPROTOTYPEfailPrimitiveWith: maybePrimFailToken
<indirect>!
----- Method: SpurBootstrapCuisPrototypes>>MethodContextclassPROTOTYPEallInstances (in category 'method prototypes') -----
MethodContextclassPROTOTYPEallInstances
"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!
----- Method: SpurBootstrapCuisPrototypes>>MethodContextclassPROTOTYPEallInstancesDo: (in category 'method prototypes') -----
MethodContextclassPROTOTYPEallInstancesDo: 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."
inst := self someInstance.
[inst == thisContext or: [inst == nil]] whileFalse:
[next := inst nextInstance.
aBlock value: inst.
inst := next]!
----- Method: SpurBootstrapCuisPrototypes>>MethodNodePROTOTYPEgenerate:using:ifQuick: (in category 'method prototypes') -----
MethodNodePROTOTYPEgenerate: trailer using: aCompiledMethodClass ifQuick: methodBlock
<indirect>!
----- Method: SpurBootstrapCuisPrototypes>>ProtoObjectPROTOTYPEscaledIdentityHash (in category 'method prototypes') -----
ProtoObjectPROTOTYPEscaledIdentityHash
"For identityHash values returned by primitive 75, answer
such values times 2^8. Otherwise, match the existing
identityHash implementation"
^self identityHash * 256 "bitShift: 8"!
----- Method: SpurBootstrapCuisPrototypes>>SmallIntegerPROTOTYPEclone (in category 'method prototypes') -----
SmallIntegerPROTOTYPEclone
"Answer the receiver, because SmallIntegers are unique."
^self!
----- Method: SpurBootstrapCuisPrototypes>>SmalltalkImagePROTOTYPErecreateSpecialObjectsArray (in category 'method prototypes') -----
SmalltalkImagePROTOTYPErecreateSpecialObjectsArray
<remove>!
----- Method: SpurBootstrapCuisPrototypes>>SmalltalkImagePROTOTYPEsetGCParameters (in category 'method prototypes') -----
SmalltalkImagePROTOTYPEsetGCParameters
"Adjust the VM's default GC parameters to avoid too much tenuring.
Maybe this should be left to the VM?"
<remove>!
----- Method: SpurBootstrapCuisPrototypes>>SystemDictionaryPROTOTYPErecreateSpecialObjectsArray (in category 'method prototypes') -----
SystemDictionaryPROTOTYPErecreateSpecialObjectsArray
"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.
"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 associationAt: #Processor).
"Numerous classes below used for type checking and instantiation"
newArray at: 5 put: Bitmap.
newArray at: 6 put: SmallInteger.
newArray at: 7 put: String.
newArray at: 8 put: Array.
newArray at: 9 put: Smalltalk.
newArray at: 10 put: BoxedFloat64.
newArray at: 11 put: MethodContext.
newArray at: 12 put: nil. "was 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: 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."
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"
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"
"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: 35 put: #cannotInterpret:.
newArray at: 36 put: nil. "was the prototype MethodContext"
newArray at: 37 put: BlockClosure.
newArray at: 38 put: nil. "was the prototype BlockContext"
"array of objects referred to by external code"
newArray at: 39 put: (self specialObjectsArray at: 39). "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: 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: 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').
"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: 55 put: (self at: #UnsafeAlien ifAbsent: []).
"Used to be WeakFinalizationList for WeakFinalizationList hasNewFinalization, obsoleted by ephemeron support."
newArray at: 56 put: nil.
"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!
----- Method: SpurBootstrapCuisPrototypes>>SystemDictionaryPROTOTYPEsetGCParameters (in category 'method prototypes') -----
SystemDictionaryPROTOTYPEsetGCParameters
"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 := Smalltalk 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.
Smalltalk vmParameterAt: 6 put: numObjects "tenure when more than this many objects survive the GC"!
----- Method: SpurBootstrapCuisPrototypes>>SystemDictionaryPROTOTYPEwordSize (in category 'method prototypes') -----
SystemDictionaryPROTOTYPEwordSize
"Answer the size in bytes of an object pointer or word in the object memory.
The value does not change for a given image, but may be modified by a SystemTracer
when converting the image to another format."
"Smalltalk wordSize"
^self vmParameterAt: 40!
SpurBootstrapSqueakFamilyPrototypes subclass: #SpurBootstrapSqueak43Prototypes
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogAttic-Bootstrapping'!
----- Method: SpurBootstrapSqueak43Prototypes class>>imageType (in category 'accessing') -----
imageType
^ 'squeak 4.3'!
----- Method: SpurBootstrapSqueak43Prototypes>>BlockClosurePROTOTYPEsimulateValueWithArguments:caller: (in category 'method prototypes') -----
BlockClosurePROTOTYPEsimulateValueWithArguments: anArray caller: aContext
<indirect>!
----- Method: SpurBootstrapSqueak43Prototypes>>CharacterPROTOTYPEshouldBePrintedAsLiteral (in category 'method prototypes') -----
CharacterPROTOTYPEshouldBePrintedAsLiteral
^(self asInteger between: 33 and: 255) and: [self asInteger ~= 127]!
----- Method: SpurBootstrapSqueak43Prototypes>>CompiledMethodPROTOTYPEencoderClass (in category 'method prototypes') -----
CompiledMethodPROTOTYPEencoderClass
<indirect>!
----- Method: SpurBootstrapSqueak43Prototypes>>DecompilerPROTOTYPEdecompile:in:method:using: (in category 'method prototypes') -----
DecompilerPROTOTYPEdecompile: aSelector in: aClass method: aMethod using: aConstructor
<indirect>!
----- Method: SpurBootstrapSqueak43Prototypes>>InstructionStreamPROTOTYPEinterpretExtension:in:for: (in category 'method prototypes') -----
InstructionStreamPROTOTYPEinterpretExtension: offset in: method for: client
^self interpretV3ClosuresExtension: offset in: method for: client!
----- Method: SpurBootstrapSqueak43Prototypes>>InstructionStreamPROTOTYPEnextPc: (in category 'method prototypes') -----
InstructionStreamPROTOTYPEnextPc: currentByte
<indirect>!
----- Method: SpurBootstrapSqueak43Prototypes>>InstructionStreamPROTOTYPEskipCallPrimitive (in category 'method prototypes') -----
InstructionStreamPROTOTYPEskipCallPrimitive
<indirect>!
----- Method: SpurBootstrapSqueak43Prototypes>>MCClassDefinitionPROTOTYPEkindOfSubclass (in category 'method prototypes') -----
MCClassDefinitionPROTOTYPEkindOfSubclass
<indirect>!
----- Method: SpurBootstrapSqueak43Prototypes>>MCMethodDefinitionPROTOTYPEinitializeWithClassName:classIsMeta:selector:category:timeStamp:source: (in category 'method prototypes') -----
MCMethodDefinitionPROTOTYPEinitializeWithClassName: classString
classIsMeta: metaBoolean
selector: selectorString
category: catString
timeStamp: timeString
source: sourceString
<indirect>!
----- Method: SpurBootstrapSqueak43Prototypes>>MethodNodePROTOTYPEprintPropertiesOn: (in category 'method prototypes') -----
MethodNodePROTOTYPEprintPropertiesOn: aStream
<indirect>!
----- Method: SpurBootstrapSqueakFamilyPrototypes class>>imageType (in category 'accessing') -----
imageType
^'squeak'!
----- Method: SpurBootstrapSqueakFamilyPrototypes>>ClassBuilderPROTOTYPEcomputeFormat:instSize:forSuper:ccIndex: (in category 'method prototypes') -----
ClassBuilderPROTOTYPEcomputeFormat: 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."
| 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].
instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]).
instSize > 65535 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'.
^nil].
^self format: instSize variable: isVar words: isWords pointers: isPointers weak: isWeak!
----- Method: SpurBootstrapSqueakFamilyPrototypes>>ClassBuilderPROTOTYPEformat:variable:words:pointers:weak: (in category 'method prototypes') -----
ClassBuilderPROTOTYPEformat: 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 |
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!
----- Method: SpurBootstrapSqueakFamilyPrototypes>>ClassBuilderPROTOTYPEsuperclass:immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'method prototypes') -----
ClassBuilderPROTOTYPEsuperclass: 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!
----- Method: SpurBootstrapSqueakFamilyPrototypes>>ClassBuilderPROTOTYPEupdate:to: (in category 'method prototypes') -----
ClassBuilderPROTOTYPEupdate: 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"
| 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."
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!
----- Method: SpurBootstrapSqueakFamilyPrototypes>>InstructionPrinterPROTOTYPEcallPrimitive: (in category 'method prototypes') -----
InstructionPrinterPROTOTYPEcallPrimitive: index
"Print the callPrimitive bytecode."
self print: 'callPrimitive: ' , index printString!
SpurBootstrapSqueakFamilyPrototypes subclass: #SpurBootstrapSqueakPrototypes
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogAttic-Bootstrapping'!
----- Method: SpurBootstrapSqueakPrototypes class>>imageType (in category 'accessing') -----
imageType
^ 'squeak'!
----- Method: SpurBootstrapSqueakPrototypes>>BehaviorPROTOTYPEidentityHash (in category 'method prototypes') -----
BehaviorPROTOTYPEidentityHash
"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!
----- Method: SpurBootstrapSqueakPrototypes>>BlockClosurePROTOTYPEsimulateValueWithArguments:caller: (in category 'method prototypes') -----
BlockClosurePROTOTYPEsimulateValueWithArguments: anArray caller: aContext
<indirect>!
----- Method: SpurBootstrapSqueakPrototypes>>CharacterPROTOTYPEclone (in category 'method prototypes') -----
CharacterPROTOTYPEclone
"Answer the receiver, because Characters are unique."
^self!
----- Method: SpurBootstrapSqueakPrototypes>>CharacterPROTOTYPEsetValue: (in category 'method prototypes') -----
CharacterPROTOTYPEsetValue: v
<remove>!
----- Method: SpurBootstrapSqueakPrototypes>>ClassDescriptionPROTOTYPEupdateMethodBindingsTo: (in category 'method prototypes') -----
ClassDescriptionPROTOTYPEupdateMethodBindingsTo: aBinding
<indirect>!
----- Method: SpurBootstrapSqueakPrototypes>>ClassPROTOTYPEimmediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'method prototypes') -----
ClassPROTOTYPEimmediateSubclass: 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!
----- Method: SpurBootstrapSqueakPrototypes>>CompiledMethodPROTOTYPEbytecodeSetName (in category 'method prototypes') -----
CompiledMethodPROTOTYPEbytecodeSetName
^self encoderClass name copyReplaceAll: 'EncoderFor' with: ''!
----- Method: SpurBootstrapSqueakPrototypes>>CompiledMethodPROTOTYPEheaderDescription (in category 'method prototypes') -----
CompiledMethodPROTOTYPEheaderDescription
"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!
----- Method: SpurBootstrapSqueakPrototypes>>ContextPartPROTOTYPEactivateReturn:value: (in category 'method prototypes') -----
ContextPartPROTOTYPEactivateReturn: aContext value: value
"Activate 'aContext return: value' in place of self, so execution will return to aContext's sender"
^MethodContext
sender: self
receiver: aContext
method: MethodContext theReturnMethod
arguments: {value}!
----- Method: SpurBootstrapSqueakPrototypes>>ContextPartPROTOTYPEdoPrimitive:method:receiver:args: (in category 'method prototypes') -----
ContextPartPROTOTYPEdoPrimitive: primitiveIndex method: meth receiver: receiver args: arguments
<indirect>!
----- Method: SpurBootstrapSqueakPrototypes>>ContextPartPROTOTYPEisPrimFailToken: (in category 'method prototypes') -----
ContextPartPROTOTYPEisPrimFailToken: anObject
<indirect>!
----- Method: SpurBootstrapSqueakPrototypes>>ContextPartPROTOTYPEsend:to:with:lookupIn: (in category 'method prototypes') -----
ContextPartPROTOTYPEsend: 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!
----- Method: SpurBootstrapSqueakPrototypes>>ContextPartPROTOTYPEsend:to:with:super: (in category 'method prototypes') -----
ContextPartPROTOTYPEsend: 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."
^self send: selector
to: rcvr
with: arguments
lookupIn: (superFlag
ifTrue: [self method methodClassAssociation value superclass]
ifFalse: [self objectClass: rcvr])!
----- Method: SpurBootstrapSqueakPrototypes>>ContextPartPROTOTYPEtryNamedPrimitiveIn:for:withArgs: (in category 'method prototypes') -----
ContextPartPROTOTYPEtryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments
"Invoke the named primitive for aCompiledMethod, answering its result, or,
if the primiitve fails, answering the error code."
<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!
----- Method: SpurBootstrapSqueakPrototypes>>IntegerclassPROTOTYPEinitialize (in category 'method prototypes') -----
IntegerclassPROTOTYPEinitialize
"Integer initialize"
self initializeLowBitPerByteTable!
----- Method: SpurBootstrapSqueakPrototypes>>MethodContextPROTOTYPEfailPrimitiveWith: (in category 'method prototypes') -----
MethodContextPROTOTYPEfailPrimitiveWith: maybePrimFailToken
<indirect>!
----- Method: SpurBootstrapSqueakPrototypes>>MethodContextclassPROTOTYPEallInstances (in category 'method prototypes') -----
MethodContextclassPROTOTYPEallInstances
"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!
----- Method: SpurBootstrapSqueakPrototypes>>MethodContextclassPROTOTYPEallInstancesDo: (in category 'method prototypes') -----
MethodContextclassPROTOTYPEallInstancesDo: 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."
inst := self someInstance.
[inst == thisContext or: [inst == nil]] whileFalse:
[next := inst nextInstance.
aBlock value: inst.
inst := next]!
----- Method: SpurBootstrapSqueakPrototypes>>ProtoObjectPROTOTYPEscaledIdentityHash (in category 'method prototypes') -----
ProtoObjectPROTOTYPEscaledIdentityHash
"For identityHash values returned by primitive 75, answer
such values times 2^8. Otherwise, match the existing
identityHash implementation"
^self identityHash * 256 "bitShift: 8"!
----- Method: SpurBootstrapSqueakPrototypes>>SmallIntegerPROTOTYPEclone (in category 'method prototypes') -----
SmallIntegerPROTOTYPEclone
"Answer the receiver, because SmallIntegers are unique."
^self!
----- Method: SpurBootstrapSqueakPrototypes>>SmalltalkImagePROTOTYPErecreateSpecialObjectsArray (in category 'method prototypes') -----
SmalltalkImagePROTOTYPErecreateSpecialObjectsArray
"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.
"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: 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: 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."
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"
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"
"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: 35 put: #cannotInterpret:.
newArray at: 36 put: nil. "was the prototype MethodContext"
newArray at: 37 put: BlockClosure.
newArray at: 38 put: nil. "was the prototype BlockContext"
"array of objects referred to by external code"
newArray at: 39 put: (self specialObjectsArray at: 39). "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: 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: 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').
"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: 55 put: (self at: #UnsafeAlien ifAbsent: []).
"Used to be WeakFinalizationList for WeakFinalizationList hasNewFinalization, obsoleted by ephemeron support."
newArray at: 56 put: nil.
"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!
----- Method: SpurBootstrapSqueakPrototypes>>SmalltalkImagePROTOTYPEsetGCParameters (in category 'method prototypes') -----
SmalltalkImagePROTOTYPEsetGCParameters
"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"!
----- Method: SpurBootstrapSqueakPrototypes>>SystemDictionaryPROTOTYPEsetGCParameters (in category 'method prototypes') -----
SystemDictionaryPROTOTYPEsetGCParameters
"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"!
Spur32BitMMLESimulator subclass: #SpurOldFormat32BitMMLESimulator
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogAttic-Bootstrapping'!
----- Method: SpurOldFormat32BitMMLESimulator>>literalCountOfMethodHeader: (in category 'method access') -----
literalCountOfMethodHeader: header
self assert: (self isIntegerObject: header).
^header >> 10 bitAnd: 16rFF!
----- Method: SpurOldFormat32BitMMLESimulator>>primitiveIndexOfMethodHeader: (in category 'method access') -----
primitiveIndexOfMethodHeader: methodHeader
| primBits |
primBits := (self integerValueOf: methodHeader) bitAnd: 16r100001FF.
^(primBits bitAnd: 16r1FF) + (primBits >> 19)!
SimulatorHarness subclass: #SpurBootstrap
instanceVariableNames: 'oldHeap newHeap oldHeapSize newHeapSize oldHeapNumObjs newHeapNumObjs map reverseMap classToIndex oldInterpreter lastClassTablePage literalMap methodClasses installedPrototypes installedMethodOops classMetaclass imageTypes classMethodContextIndex classBlockClosureIndex toBeInitialized'
classVariableNames: 'ImageHeaderFlags ImageName ImageScreenSize TransformedImage'
poolDictionaries: 'VMObjectIndices'
category: 'CogAttic-Bootstrapping'!
!SpurBootstrap commentStamp: 'eem 9/11/2013 05:45' prior: 0!
SpurBootstrap bootstraps an image in SpurMemoryManager format from a Squeak V3 + closures format.
e.g.
(SpurBootstrap32 new on: '/Users/eliot/Cog/startreader.image')
transform;
launch
Bootstrap issues:
- should it implement a deterministic Symbol identityHash? This means set a Symbol's identityHash at instance creation time
based on its string hash so that e.g. MethodDIctionary instances have a deterministic order and don't need to be rehashed on load.
- should it collapse ContextPart and MethodContext down onto Context (and perhaps eliminate BlockContext)?
Instance Variables
classToIndex: <Dictionary>
lastClassTablePage: <Integer>
map: <Dictionary>
methodClasses: <Set>
newHeap: <SpurMemoryManager>
oldHeap: <NewObjectMemory>
oldInterpreter: <StackInterpreterSimulator>
reverseMap: <Dictionary>
symbolMap: <Dictionary>
classToIndex
- oldClass to new classIndex map
lastClassTablePage
- oop in newHeap of last classTable page. U<sed in validation to filter-out class table.
methodClasses
- cache of methodClassAssociations for classes in which modified methods are installed
map
- oldObject to newObject map
newHeap
- the output, bootstrapped image
oldHeap
- the input, image
oldInterpreter
- the interpreter associated with oldHeap, needed for a hack to grab WeakArray
reverseMap
- newObject to oldObject map
symbolMap
- symbol toi symbol oop in oldHeap, used to map prototype methdos to methods in oldHeap!
----- Method: SpurBootstrap class>>bootstrapCuisImage: (in category 'utilities') -----
bootstrapCuisImage: imageFileBaseName
self bootstrapImage: imageFileBaseName type: #('squeak' 'cuis')!
----- Method: SpurBootstrap class>>bootstrapImage:type: (in category 'utilities') -----
bootstrapImage: imageFileNameOrBaseName type: typeName
"SpurBootstrap bootstrapImage: '/Users/eliot/Squeak/Squeak4.5/Squeak4.5-13680'"
| imageFileBaseName imageFormat |
imageFileBaseName := (imageFileNameOrBaseName endsWith: '.image')
ifTrue: [imageFileNameOrBaseName allButLast: 6]
ifFalse: [imageFileNameOrBaseName].
imageFormat := ImageFormat fromFile: imageFileBaseName, '.image'.
imageFormat requiresClosureSupport ifFalse:
[self error: 'Can''t bootstrap this image since Spur assumes closure support.'].
imageFormat requiresSpurSupport ifTrue:
[self error: 'This image is already in Spur format.'].
imageFormat is32Bit ifTrue:
[^SpurBootstrap32 new bootstrapImage: imageFileBaseName type: typeName].
self error: '64-bit support and 64-bit generation as-yet-unimplemented'!
----- Method: SpurBootstrap class>>bootstrapOldSqueakImage: (in category 'utilities') -----
bootstrapOldSqueakImage: imageFileBaseName
"Try asnd bootstrap a pre-CompiledMethodTrailer Squeak image."
self bootstrapImage: imageFileBaseName type: #('squeak' 'old squeak')!
----- Method: SpurBootstrap class>>bootstrapPharoImage: (in category 'utilities') -----
bootstrapPharoImage: imageFileBaseName
| oldCompilerClass oldBytecodeBackend |
oldCompilerClass := SmalltalkImage compilerClass.
oldBytecodeBackend := CompilationContext bytecodeBackend.
[
SmalltalkImage compilerClass: Compiler.
CompilationContext bytecodeBackend: IRSpurSqueakV3PlusClosuresBytecodeGenerator.
self bootstrapImage: imageFileBaseName type: 'pharo' ]
ensure: [
SmalltalkImage compilerClass: oldCompilerClass.
CompilationContext bytecodeBackend: oldBytecodeBackend ]!
----- Method: SpurBootstrap class>>bootstrapSqueakImage: (in category 'utilities') -----
bootstrapSqueakImage: imageFileBaseName
self bootstrapImage: imageFileBaseName type: 'squeak'!
----- Method: SpurBootstrap class>>categoryForClass:meta:selector: (in category 'method prototype categorization') -----
categoryForClass: className meta: isMeta selector: selector
^(isMeta
ifTrue: [{ className. #class. selector }]
ifFalse: [{ className. selector }])
caseOf: {
[#(Behavior allInstancesOrNil)] -> [#enumerating].
[#(Behavior byteSizeOfInstance)] -> [#'accessing instances and variables'].
[#(Behavior byteSizeOfInstanceOfSize:)] -> [#'accessing instances and variables'].
[#(Behavior elementSize)] -> [#'accessing instances and variables'].
[#(Behavior handleFailingBasicNew)] -> [#private].
[#(Behavior handleFailingBasicNew:)] -> [#private].
[#(Behavior handleFailingFailingBasicNew)] -> [#private].
[#(Behavior handleFailingFailingBasicNew:)] -> [#private].
[#(Behavior identityHash)] -> [#comparing].
[#(Behavior isCompiledMethodClass)] -> [#testing].
[#(Behavior isEphemeronClass)] -> [#testing].
[#(Behavior isImmediateClass)] -> [#testing].
[#(BoxedFloat64 class basicNew)] -> [#'instance creation'].
[#(BoxedFloat64 class basicNew:)] -> [#'instance creation'].
[#(Character identityHash)] -> [#comparing].
[#(Character setValue:)] -> [#accessing].
[#(Class immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:)]
-> [#'subclass creation'].
[#(ClassBuilder superclass:immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:)]
-> [#public].
[#(CompiledMethod bytecodeSetName)] -> [#accessing].
[#(CompiledMethod class handleFailingFailingNewMethod:header:)]
-> [#private].
[#(CompiledMethod class handleFailingNewMethod:header:)]
-> [#private].
[#(CompiledMethod class headerFlagForEncoder:)]
-> [#'method encoding'].
[#(CompiledMethod class installPrimaryBytecodeSet:)]
-> [#'class initialization'].
[#(CompiledMethod class installSecondaryBytecodeSet:)]
-> [#'class initialization'].
[#(Context class allInstances)] -> [#enumerating].
[#(Context class allInstancesDo:)] -> [#enumerating].
[#(Context failPrimitiveWith:)] -> [#'system simulation'].
[#(Context isPrimFailToken:)] -> [#private].
[#(Context send:to:with:lookupIn:)] -> [#controlling].
[#(ContextPart isPrimFailToken:)] -> [#private].
[#(ContextPart send:to:with:lookupIn:)] -> [#controlling].
[#(EncoderForV3 computeMethodHeaderForNumArgs:numTemps:numLits:primitive:)]
-> [#'method encoding'].
[#(EncoderForV3PlusClosures genCallPrimitive:)]
-> [#'bytecode generation'].
[#(EncoderForV3PlusClosures class callPrimitiveCode)]
-> [#'bytecode decoding'].
[#(InstructionClient callPrimitive:)] -> [#'instruction decoding'].
[#(MethodContext failPrimitiveWith:)] -> [#'system simulation'].
[#(MethodContext class allInstances)] -> [#enumerating].
[#(MethodContext class allInstancesDo:)] -> [#enumerating].
[#(Object isPinned)] -> [#'system primitives'].
[#(Object pin)] -> [#'system primitives'].
[#(Object setPinned:)] -> [#'system primitives'].
[#(Object unpin)] -> [#'system primitives'].
[#(SmallFloat64 class basicNew)] -> [#'instance creation'].
[#(SmallFloat64 class basicNew:)] -> [#'instance creation'].
[#(SmallFloat64 clone)] -> [#copying].
[#(SmallFloat64 copy)] -> [#copying].
[#(SmallFloat64 deepCopy)] -> [#copying].
[#(SmallFloat64 identityHash)] -> [#comparing].
[#(SmallFloat64 shallowCopy)] -> [#copying].
[#(SmallFloat64 veryDeepCopyWith:)] -> [#copying].
[#(SmallInteger asCharacter)] -> [#converting].
[#(SmalltalkImage growMemoryByAtLeast:)] -> [#'memory space'].
[#(SmalltalkImage maxIdentityHash)] -> [#'system attributes'].
[#(SystemDictionary growMemoryByAtLeast:)] -> [#'memory space'].
[#(SystemDictionary maxIdentityHash)] -> [#'system attributes'].
[#(SystemDictionary setGCParameters)] -> [#'snapshot and quit'].
[#(SystemNavigation allObjects)] -> [#query].
[#(SystemNavigation allObjectsOrNil)] -> [#query].
}
otherwise:
[Transcript nextPutAll: className.
isMeta ifTrue: [Transcript nextPutAll: ' class'].
Transcript nextPutAll: '>>'; store: selector; nextPutAll: ' is unclassified'; cr; flush.
^Categorizer default]!
----- Method: SpurBootstrap class>>defaultIntegerBaseInDebugger (in category 'debugger') -----
defaultIntegerBaseInDebugger
^16!
----- Method: SpurBootstrap class>>isolatedPrototypes (in category 'utilities') -----
isolatedPrototypes
"SpurBootstrap isolatedPrototypes"
| prototypes |
prototypes := (self systemNavigation allMethodsSelect:
[:m| m selector includesSubString: 'PROTOTYPE'])
collect: [:mr| mr compiledMethod].
^prototypes select:
[:m|
(m methodClass includesBehavior: SpurBootstrapPrototypes)
ifTrue:
[(m pragmaAt: #indirect) notNil
and: [prototypes noneSatisfy:
[:p|
p selector == m selector
and: [p methodClass ~~ m methodClass]]]]
ifFalse:
[prototypes noneSatisfy:
[:p|
p selector == m selector
and: [(p methodClass includesBehavior: SpurBootstrapPrototypes)
and: [(p pragmaAt: #indirect) notNil]]]]]!
----- Method: SpurBootstrap class>>testComputeFormat (in category 'tests') -----
testComputeFormat
"self testComputeFormat"
#( (normal 0)
(bytes 16)
(words 12)
(variable 2)
(weak 4)
(ephemeron 5)
(immediate 7)
(compiledMethod 24)) do:
[:tuple|
[:type :instSpec| | fmt |
fmt := [self ClassBuilderPROTOTYPEcomputeFormat: type instSize: 0 forSuper: Object ccIndex: 0]
on: MessageNotUnderstood
do: [:ex|
ex message selector ~~ #format:variable:words:pointers:weak: ifTrue:
[ex pass].
self perform: #ClassBuilderPROTOTYPEformat:variable:words:pointers:weak:
withArguments: ex message arguments].
self assert: (fmt >> 16 = instSpec
or: [type = #compiledMethod and: [fmt = CompiledMethod format]]).
] valueWithArguments: tuple]!
----- Method: SpurBootstrap>>addMissingClassVars: (in category 'bootstrap image') -----
addMissingClassVars: classVars
"Add any missing class vars given classVars, a Dictionary from nonMetaClass to binding.
Initialize any classes that get inst vars added."
| addClassVarNameSym bindingOfSym |
classVars isEmpty ifTrue:
[^self].
addClassVarNameSym := self findSymbol: #addClassVarName:.
addClassVarNameSym ifNil:
[addClassVarNameSym := self findSymbol: #addClassVarNamed:].
bindingOfSym := self findSymbol: #bindingOf:.
classVars keysAndValuesDo:
[:binding :class|
Transcript cr; nextPutAll: 'ADDING CLASS VAR '; store: binding key; nextPutAll: ' TO '; print: class; flush.
self interpreter: oldInterpreter
object: (self oldClassOopFor: class)
perform: addClassVarNameSym
withArguments: {oldHeap stringForCString: binding key}.
literalMap
at: binding
put: (self interpreter: oldInterpreter
object: (self oldClassOopFor: class)
perform: bindingOfSym
withArguments: {self findSymbol: binding key})].
toBeInitialized := classVars asSet!
----- Method: SpurBootstrap>>addNewMethods (in category 'bootstrap methods') -----
addNewMethods
"Get the simulator to add any and all missing methods immediately."
| cmaiaSym basSym |
cmaiaSym := self findSymbol: #compiledMethodAt:ifAbsent:.
basSym := self findSymbol: #basicAddSelector:withMethod:.
basSym ifNil:
[basSym := self findSymbol: #addSelectorSilently:withMethod:].
self allPrototypeClassNamesDo:
[:sym :symIsMeta|
(self findClassNamed: (literalMap at: sym))
ifNil: [Transcript
cr;
nextPutAll: 'not installing any methods for ';
nextPutAll: sym;
nextPutAll: '; class not found in image';
flush.]
ifNotNil:
[:theClass| | class |
class := symIsMeta ifTrue: [oldHeap fetchClassOfNonImm: theClass] ifFalse: [theClass].
self prototypeClassNameMetaSelectorMethodDo:
[:className :isMeta :selector :method| | methodOrNil |
(className = sym
and: [symIsMeta = isMeta
and: [(method pragmaAt: #remove) isNil]]) ifTrue:
["probe method dictionary of the class for each method, installing a dummy if not found."
"Transcript cr; nextPutAll: 'checking for '; nextPutAll: selector; flush."
methodOrNil := self interpreter: oldInterpreter
object: class
perform: cmaiaSym
withArguments: {literalMap at: selector. oldHeap nilObject}.
methodOrNil = oldHeap nilObject
ifTrue: "no method. install the real thing now"
[Transcript
cr;
nextPutAll: 'installing ';
nextPutAll: className;
nextPutAll: (isMeta ifTrue: [' class>>'] ifFalse: ['>>']);
store: selector;
flush.
self interpreter: oldInterpreter
object: class
perform: basSym
withArguments: { literalMap at: selector.
self installableMethodFor: method
selector: selector
className: className
isMeta: isMeta}.
installedPrototypes add: method selector]
ifFalse: "existing method; collect the methodClassAssociation; its needed later"
[methodClasses add: (oldInterpreter methodClassAssociationOf: methodOrNil)]]]]]!
----- Method: SpurBootstrap>>allInstancesOf: (in category 'bootstrap methods') -----
allInstancesOf: classOop
| instances |
instances := OrderedCollection new.
oldHeap allObjectsDo:
[:o|
((oldHeap isPointersNonImm: o)
and: [(oldHeap fetchClassOf: o) = classOop]) ifTrue:
[instances addLast: o]].
^instances!
----- Method: SpurBootstrap>>allMethodPrototypes (in category 'method prototypes') -----
allMethodPrototypes
"Answer all prototype selectors, including those marked <remove>"
^(imageTypes
inject: (IdentitySet withAll: SpurBootstrapPrototypes allMethodPrototypes)
into: [:allPrototypes :type | | prototypes |
prototypes := (SpurBootstrapPrototypes prototypeClassFor: type) allMethodPrototypes.
allPrototypes
removeAllSuchThat: [:existing| prototypes anySatisfy: [:new| existing selector == new selector]];
addAll: (prototypes reject: [:prototype| (prototype pragmaAt: #ignore) notNil]);
yourself])
asArray sort: [:ma :mb| ma selector <= mb selector]!
----- Method: SpurBootstrap>>allPrototypeClassNamesDo: (in category 'method prototypes') -----
allPrototypeClassNamesDo: aBlock
"self basicNew allPrototypeClassNames"
| pairs |
pairs := Set new.
self prototypeClassNameMetaSelectorMethodDo:
[:className :isMeta :selector :method |
pairs add: {className. isMeta}].
pairs do: [:pair| aBlock value: pair first value: pair last]!
----- Method: SpurBootstrap>>allPrototypeMethodSymbols (in category 'method prototypes') -----
allPrototypeMethodSymbols
"self basicNew allPrototypeMethodSymbols"
| symbols |
self assert: SpurBootstrap isolatedPrototypes isEmpty.
symbols := Set new.
self prototypeClassNameMetaSelectorMethodDo:
[:className :isMeta :selector :method | | adder |
symbols
add: className;
add: selector.
adder := [:lit|
(lit isSymbol and: [lit ~~ method selector]) ifTrue: [symbols add: lit].
lit isArray ifTrue: [lit do: adder]].
method literals do: adder].
^symbols!
----- Method: SpurBootstrap>>allocateClassTable (in category 'bootstrap image') -----
allocateClassTable
"Allocate the root of the classTable plus enough pages to accomodate all classes in
the classToIndex map. Don't fill in the entries yet; the classes have yet to be cloned."
| tableRoot page maxSize numPages |
tableRoot := newHeap
allocateSlots: newHeap classTableRootSlots + newHeap hiddenRootSlots
format: newHeap arrayFormat
classIndex: newHeap arrayClassIndexPun.
self assert: (newHeap numSlotsOf: tableRoot) = (newHeap classTableRootSlots + newHeap hiddenRootSlots).
self assert: (newHeap formatOf: tableRoot) = newHeap arrayFormat.
self assert: (newHeap classIndexOf: tableRoot) = newHeap arrayClassIndexPun.
newHeap nilFieldsOf: tableRoot.
"first page is strong"
page := newHeap
allocateSlots: newHeap classTablePageSize
format: newHeap arrayFormat
classIndex: newHeap arrayClassIndexPun.
self assert: (newHeap numSlotsOf: page) = newHeap classTablePageSize.
self assert: (newHeap formatOf: tableRoot) = newHeap arrayFormat.
self assert: (newHeap classIndexOf: tableRoot) = newHeap arrayClassIndexPun.
self assert: (newHeap objectAfter: tableRoot limit: newHeap freeStart) = page.
lastClassTablePage := page.
newHeap nilFieldsOf: page.
newHeap storePointer: 0 ofObject: tableRoot withValue: page.
newHeap setHiddenRootsObj: tableRoot.
maxSize := classToIndex inject: 0 into: [:a :b| a max: b].
numPages := (maxSize + newHeap classTableMinorIndexMask / newHeap classTablePageSize) truncated.
2 to: numPages do:
[:i|
page := newHeap
allocateSlots: newHeap classTablePageSize
format: newHeap arrayFormat
classIndex: newHeap arrayClassIndexPun.
self assert: (newHeap numSlotsOf: page) = newHeap classTablePageSize.
self assert: (newHeap formatOf: page) = newHeap arrayFormat.
self assert: (newHeap classIndexOf: page) = newHeap arrayClassIndexPun.
newHeap fillObj: page numSlots: newHeap classTablePageSize with: newHeap nilObject.
newHeap storePointer: i - 1 ofObject: tableRoot withValue: page.
self assert: (newHeap objectAfter: (newHeap fetchPointer: i - 2 ofObject: tableRoot) limit: newHeap freeStart) = page.
lastClassTablePage := page].
"and once again to recompute numClassTablePages post building the class table."
newHeap instVarNamed: 'numClassTablePages' put: nil.
newHeap setHiddenRootsObj: tableRoot!
----- Method: SpurBootstrap>>allocateFreeLists (in category 'bootstrap image') -----
allocateFreeLists
"Allocate the freeLists array."
| freeListsOop |
freeListsOop := newHeap
allocateSlots: newHeap numFreeLists
format: newHeap wordIndexableFormat
classIndex: newHeap wordSizeClassIndexPun.
self assert: (newHeap objectAfter: newHeap trueObject) = freeListsOop.
0 to: newHeap numFreeLists - 1 do:
[:i|
newHeap
storePointerUnchecked: i
ofObject: freeListsOop
withValue: 0]!
----- Method: SpurBootstrap>>bootstrapImage (in category 'bootstrap image') -----
bootstrapImage
oldHeap fullGC.
self measureOldHeapPostGC.
self initMaps.
Transcript cr; nextPutAll: 'transforming image...'; flush.
self cloneNilTrueAndFalse.
self allocateFreeLists.
self buildClassMap.
self allocateClassTable.
self cloneObjects.
self fillInObjects.
self fillInClassTable.
newHeapSize := newHeap freeStart.
newHeap initializePostBootstrap.
self measureNewHeapPostInitPostBootstrap!
----- Method: SpurBootstrap>>bootstrapImage: (in category 'public access') -----
bootstrapImage: imageName
(Smalltalk classNamed: #FileReference) ifNotNil:
[^self bootstrapImageUsingFileReference: imageName].
(Smalltalk classNamed: #FileDirectory) ifNotNil:
[^self bootstrapImageUsingFileDirectory: imageName].
self error: 'at a loss as to what file system support to use'!
----- Method: SpurBootstrap>>bootstrapImage:type: (in category 'public access') -----
bootstrapImage: imageName type: typeNameOrArrayOfTypeNames
"type can be:
- 'squeak'
- {'old squeak' 'squeak' }
- { 'cuis' 'squeak' }
- 'pharo'
- it might be 'newspeak', if needed (but is not implemented)"
imageTypes := typeNameOrArrayOfTypeNames isArray
ifTrue: [typeNameOrArrayOfTypeNames]
ifFalse: [{typeNameOrArrayOfTypeNames}].
self bootstrapImage: imageName
!
----- Method: SpurBootstrap>>bootstrapImageUsingFileDirectory: (in category 'public access') -----
bootstrapImageUsingFileDirectory: imageName
| dirName baseName dir |
dirName := FileDirectory dirPathFor: imageName.
baseName := (imageName endsWith: '.image')
ifTrue: [FileDirectory baseNameFor: imageName]
ifFalse: [FileDirectory localNameFor: imageName].
dir := dirName isEmpty ifTrue: [FileDirectory default] ifFalse: [FileDirectory default on: dirName].
self on: (dir fullNameFor: baseName, '.image').
[self transform]
on: Halt
do: [:ex|
"suppress halts from the usual suspects (development time halts)"
(#(fullGC compactImage) includes: ex signalerContext sender selector)
ifTrue: [ex resume]
ifFalse: [ex pass]].
self writeSnapshot: (dir fullNameFor: baseName, '-spur.image')
ofTransformedImage: newHeap
headerFlags: oldInterpreter getImageHeaderFlags
screenSize: oldInterpreter savedWindowSize.
dir deleteFileNamed: baseName, '-spur.changes';
copyFileNamed: baseName, '.changes' toFileNamed: baseName, '-spur.changes'!
----- Method: SpurBootstrap>>bootstrapImageUsingFileReference: (in category 'public access') -----
bootstrapImageUsingFileReference: imageName
| dirName baseName dir |
dirName := imageName asFileReference parent fullName.
baseName := (imageName endsWith: '.image')
ifTrue: [ imageName asFileReference base ]
ifFalse: [ (imageName, '.image') asFileReference base ].
dir := dirName asFileReference.
self on: (dir / (baseName, '.image')) fullName.
[self transform]
on: Halt
do: [:ex|
"suppress halts from the usual suspects (development time halts)"
(#(fullGC compactImage) includes: ex signalerContext sender selector)
ifTrue: [ex resume]
ifFalse: [ex pass]].
self writeSnapshot: (dir / (baseName, '-spur.image')) fullName
ofTransformedImage: newHeap
headerFlags: oldInterpreter getImageHeaderFlags
screenSize: oldInterpreter savedWindowSize.
(dir / (baseName, '.changes')) copyTo: (dir / (baseName, '-spur.changes'))!
----- Method: SpurBootstrap>>buildClassMap (in category 'bootstrap image') -----
buildClassMap
"enumerate all objects asking isBehavior:? (class == Metaclass or class class == Metaclass) doesn't work for Newspeak"
"Build a map from all classes in oldHeap to a class index.
ONLY DEALS WITH CLASSES THAT HAVE INSTANCES!!!! (can walk superclass chain? Can walk subclasses set? Can ask class == Metaclass or class class == Metaclass class?)"
| classes classTableIndex |
self defineKnownClassIndices.
classes := classToIndex keys asSet.
classTableIndex := classToIndex inject: 0 into: [:a :b| a max: b].
oldHeap allObjectsDo:
[:oldObj| | oldClass |
oldClass := oldHeap fetchClassOfNonImm: oldObj.
self assert: (oldHeap isPointersNonImm: oldClass).
(classes includes: oldClass) ifFalse:
[classes add: oldClass.
classToIndex at: oldClass put: (classTableIndex := classTableIndex + 1)]]!
----- Method: SpurBootstrap>>checkReshapeOf: (in category 'bootstrap image') -----
checkReshapeOf: ourMethodClasses
"Check the shape of all our method classes match the shape of those in the image to be bootstrapped.
Use the simulator to redefine any that need it. Does /not/ reshape metaclasses; these we assume are ok."
| toReshape |
toReshape := Set new.
ourMethodClasses do:
[:mc|
(literalMap at: mc binding ifAbsent: []) ifNotNil:
[:binding|
(mc ~~ Character "Character will reshape anyway"
and: [mc instSize ~= (oldHeap instanceSizeOf: (oldHeap fetchPointer: ValueIndex ofObject: binding))]) ifTrue:
[toReshape add: mc]]].
toReshape isEmpty ifTrue:
[^self].
self interpreter: oldInterpreter
object: (self oldClassOopFor: ClassBuilder)
perform: (self findSymbol: #beSilent:)
withArguments: {oldHeap trueObject}.
"Assume only one class in any subtree needs reshaping. Fast and loose but gets us there for now."
toReshape copy do:
[:class|
toReshape removeAll: (toReshape select: [:ea| ea inheritsFrom: class])].
toReshape do:
[:class|
Transcript cr; nextPutAll: 'RESHAPING '; print: class; flush.
self interpreter: oldInterpreter
object: (self oldClassOopFor: Compiler)
perform: (self findSymbol: #evaluate:)
withArguments: {oldHeap stringForCString: class definition}]!
----- Method: SpurBootstrap>>classMetaclass (in category 'bootstrap image') -----
classMetaclass
^classMetaclass ifNil:
[classMetaclass := oldHeap fetchClassOfNonImm: (oldHeap fetchClassOfNonImm: oldHeap classArray)]!
----- Method: SpurBootstrap>>classNameForPrototypeMethod: (in category 'method prototypes') -----
classNameForPrototypeMethod: protoMethod
| protoSelector |
protoSelector := protoMethod selector.
#('OLDSQUEAKPROTOTYPE' 'SQUEAKPROTOTYPE' 'PHAROPROTOTYPE' 'PROTOTYPE') do:
[:prototype| | index |
(index := protoSelector indexOfSubCollection: prototype) ~= 0 ifTrue:
[^(protoSelector first: index - 1) asSymbol]].
self error: 'really??'!
----- Method: SpurBootstrap>>classTableSize (in category 'class indices') -----
classTableSize
^newHeap classIndexMask + 1!
----- Method: SpurBootstrap>>clone:classIndex: (in category 'bootstrap image') -----
clone: oldObj classIndex: classIndex
| newObj format numBytes |
((format := oldHeap formatOf: oldObj) >= oldHeap firstLongFormat
and: [numBytes := oldHeap numBytesOf: oldObj.
format >= oldHeap firstCompiledMethodFormat
and: [(oldInterpreter primitiveIndexOf: oldObj) > 0]]) ifTrue:
[numBytes := numBytes + 3].
newObj := newHeap
allocateSlots: (format >= oldHeap firstLongFormat
ifTrue: [newHeap numSlotsForBytes: numBytes]
ifFalse: [oldHeap numSlotsOf: oldObj])
format: (self newFormatFor: oldObj numBytes: numBytes)
classIndex: classIndex.
reverseMap at: newObj put: oldObj.
^map at: oldObj put: newObj!
----- Method: SpurBootstrap>>cloneArrayLiteral: (in category 'bootstrap methods') -----
cloneArrayLiteral: anArray
"Currently serves only to clone the #(0 0) literal in SpaceTallyPROTOTYPEspaceForInstancesOf:"
| array |
array := oldHeap instantiateClass: (oldHeap splObj: ClassArray) indexableSize: anArray size.
1 to: anArray size do:
[:i| | lit |
lit := anArray at: i.
lit class caseOf: {
[SmallInteger] -> [oldHeap
storePointerUnchecked: i - 1
ofObject: array
withValue: (oldHeap integerObjectOf: lit)].
[ByteSymbol] -> [oldHeap
storePointer: i - 1
ofObject: array
withValue: (self findSymbol: lit)].
[UndefinedObject] -> [oldHeap
storePointerUnchecked: i - 1
ofObject: array
withValue: oldHeap nilObject] }].
^array
!
----- Method: SpurBootstrap>>cloneMethodProxy: (in category 'bootstrap methods') -----
cloneMethodProxy: proxy "<VMCompiledMethodProxy>"
| bytes newMethod delta |
bytes := proxy size - proxy initialPC + 1.
delta := proxy primitive > 0
ifTrue: [3]
ifFalse: [0].
newMethod := CompiledMethod
newMethod: bytes + delta
header: (self headerForOldMethodHeader: (oldHeap integerObjectOf: proxy header)).
1 to: proxy numLiterals - 1 do:
[:i| newMethod literalAt: i put: (proxy literalAt: i)].
newMethod
literalAt: proxy numLiterals
put: (Smalltalk bindingOf: #Character).
delta > 0 ifTrue:
[newMethod
at: newMethod initialPC + 0 put: 139;
at: newMethod initialPC + 1 put: (proxy primitive bitAnd: 16rFF);
at: newMethod initialPC + 2 put: (proxy primitive bitShift: -8)].
proxy initialPC to: proxy size do:
[:i| newMethod at: i + delta put: (proxy at: i)].
^newMethod!
----- Method: SpurBootstrap>>cloneNilTrueAndFalse (in category 'bootstrap image') -----
cloneNilTrueAndFalse
{ oldHeap nilObject.
oldHeap falseObject.
oldHeap trueObject. }
with: (self firstOrdinaryClassIndex to: self firstOrdinaryClassIndex + 2)
do: [:obj :classIndex|
classToIndex at: (oldHeap fetchClassOfNonImm: obj) put: classIndex.
self clone: obj classIndex: classIndex].
newHeap
nilObject: (map at: oldHeap nilObject); "needed for nilling objects etc"
falseObject: (map at: oldHeap falseObject);
trueObject: (map at: oldHeap trueObject)!
----- Method: SpurBootstrap>>cloneObjects (in category 'bootstrap image') -----
cloneObjects
| specialObjectsArray characterClass characterTable compactClasses oldObj oldClass |
specialObjectsArray := oldHeap specialObjectsOop.
characterClass := oldHeap classCharacter.
characterTable := oldHeap characterTable.
compactClasses := oldHeap splObj: CompactClasses.
self clone: specialObjectsArray
classIndex: (classToIndex at: (oldHeap fetchClassOfNonImm: specialObjectsArray)).
oldObj := oldHeap objectAfter: oldHeap trueObject.
[oldObj < oldHeap freeStart] whileTrue:
[oldClass := oldHeap fetchClassOfNonImm: oldObj.
(oldObj ~= characterTable
and: [oldObj ~= specialObjectsArray
and: [oldObj ~= compactClasses
and: [oldClass ~= characterClass]]]) ifTrue:
[self clone: oldObj classIndex: (classToIndex at: oldClass)].
oldObj := oldHeap objectAfter: oldObj].
newHeap
specialObjectsOop: (map at: oldHeap specialObjectsOop);
lastHash: oldHeap lastHash!
----- Method: SpurBootstrap>>coHeapFrom: (in category 'testing') -----
coHeapFrom: aSpur32BitMMLESimulator
| coHeap |
coHeap := Spur32BitMMLECoSimulator new.
aSpur32BitMMLESimulator class allInstVarNames do:
[:ivn|
coHeap instVarNamed: ivn put: (aSpur32BitMMLESimulator instVarNamed: ivn)].
coHeap scavenger instVarNamed: 'manager' put: coHeap.
^coHeap!
----- Method: SpurBootstrap>>compactImage (in category 'bootstrap image') -----
compactImage
| firstFree lastUsed |
newHeap allHeapEntitiesDo:
[:o|
(newHeap isFreeObject: o)
ifTrue: [firstFree ifNil: [firstFree := o]]
ifFalse: [lastUsed := o]].
lastUsed < firstFree ifTrue: "nothing to do"
[^self].
self halt!
----- Method: SpurBootstrap>>convertOldMethodHeader: (in category 'bootstrap image') -----
convertOldMethodHeader: methodHeader
^((oldInterpreter argumentCountOfMethodHeader: methodHeader) << 24)
+ ((oldInterpreter temporaryCountOfMethodHeader: methodHeader) << 18)
+ ((oldInterpreter methodHeaderIndicatesLargeFrame: methodHeader) ifTrue: [1 << 17] ifFalse: [0])
+ ((oldInterpreter methodHeaderHasPrimitive: methodHeader) ifTrue: [1 << 16] ifFalse: [0])
+ (oldHeap literalCountOfMethodHeader: methodHeader)!
----- Method: SpurBootstrap>>defineKnownClassIndices (in category 'class indices') -----
defineKnownClassIndices
"The classTable is laid out
- to make it easy to map immediates to classes; the tag pattern of an immediate is its class index.
hence there are two entries for SmallInteger
- to assign small indices to well-known classes such as Array, Message et al
- to leave plenty of room for new known classes; hence the first page contains only well-known classes
- to enable overlaps and avoid conflicts with indices in the specialObjectsArray (?really? eem)
- to provide a WeakArray pun for the pages of the table itself so that these do not show up as instances of WeakArray"
| classMethodContext classBlockClosure classMessage "no api method for these" |
classMessage := oldHeap splObj: (VMObjectIndices bindingOf: #ClassMessage) value.
classMethodContext := oldHeap splObj: (VMObjectIndices bindingOf: #ClassMethodContext) value.
classBlockClosure := oldHeap splObj: (VMObjectIndices bindingOf: #ClassBlockClosure) value.
"c.f. SpurMemoryManager class>>intializeCompactClassIndices".
classToIndex keysDo:
[:oldClass|
self assert: (oldInterpreter addressCouldBeClassObj: oldClass)].
classToIndex
at: oldHeap classSmallInteger put: 1; "N.B. must fill-in index 3 manually"
at: oldHeap classCharacter put: 2;
"at: oldHeap classSmallInteger put: 3" "N.B. must fill-in index 3 manually"
"leave room for up to 15 tagged classes"
"leave room for up to 16 puns"
at: oldHeap classLargeNegativeInteger put: 32;
at: oldHeap classLargePositiveInteger put: 33;
at: oldHeap classFloat put: 34;
at: "oldHeap" classMessage put: 35;
at: "oldHeap" classMethodContext put: (classMethodContextIndex := 36);
at: "oldHeap" classBlockClosure put: (classBlockClosureIndex := 37);
at: oldHeap classSemaphore put: 48;
"at: oldHeap classMutex put: 49; see below"
at: oldHeap classByteArray put: 50;
at: oldHeap classArray put: 51;
at: oldHeap classString put: 52;
at: oldHeap classBitmap put: 53;
at: oldHeap classPoint put: 54.
{{oldHeap classMutex. 49}.
{oldHeap classExternalAddress. 128}.
{oldHeap classExternalData. 129}.
{oldHeap classExternalFunction. 130}.
{oldHeap classExternalLibrary. 131}.
{oldHeap classExternalStructure. 132}.
{oldHeap classAlien. 133}.
{oldHeap classUnsafeAlien. 134}}
do: [:pair|
[:oop :index|
oop ~= oldHeap nilObject ifTrue:
[classToIndex at: oop put: index]] valueWithArguments: pair].
classToIndex keysDo:
[:oldClass|
self assert: (oldInterpreter addressCouldBeClassObj: oldClass)]!
----- Method: SpurBootstrap>>fileOutPrototypesFor: (in category 'public access') -----
fileOutPrototypesFor: imageTypeOrArrayOfTypes
"SpurBootstrap new fileOutPrototypesFor: 'squeak'"
| internalStream |
imageTypes := imageTypeOrArrayOfTypes isString
ifTrue: [{imageTypeOrArrayOfTypes}]
ifFalse: [imageTypeOrArrayOfTypes asArray].
internalStream := WriteStream on: (String new: 1000).
internalStream header; timeStamp.
self prototypeClassNameMetaSelectorMethodDo:
[:className :isMeta :selector :method| | classNameString class category preamble source |
class := Smalltalk classNamed: className.
isMeta
ifTrue: [class := class class. classNameString := className, ' class']
ifFalse: [classNameString := className].
(method pragmaAt: #remove)
ifNil:
[category := class ifNotNil: [class organization categoryOfElement: selector].
(category notNil and: [category first = $*]) ifTrue:
[category := nil].
category ifNil:
[category := self class categoryForClass: className meta: isMeta selector: selector].
preamble := classNameString, ' methodsFor: ' , category asString printString, ' stamp: ''', method timeStamp, ''''.
internalStream nextPut: $!!; nextChunkPut: preamble; cr.
source := method getSourceFromFile asString.
source := source copyFrom: (source indexOfSubCollection: 'PROTOTYPE') + 9 to: source size.
(self selectorForPrototypeMethod: method) isBinary ifTrue:
[source := (self selectorForPrototypeMethod: method), (source copyFrom: (source indexOf: Character space) to: source size)].
internalStream nextChunkPut: source; space; nextPut: $!!; cr; cr]
ifNotNil:
[source := classNameString, ' removeSelector: ', selector storeString.
internalStream nextChunkPut: source; cr; cr]].
internalStream trailer.
FileStream
writeSourceCodeFrom: internalStream
baseName: ('SpurBootstrapPrototypes-', (imageTypes fold: [:a :b| a, '-', b]) replaceAll: Character space with: $_)
isSt: true
useHtml: false!
----- Method: SpurBootstrap>>fillInClassTable (in category 'bootstrap image') -----
fillInClassTable
| firstPage maxIndex |
maxIndex := 0.
classToIndex keysAndValuesDo:
[:oldClass :index| | newClass page |
maxIndex := maxIndex max: index.
newClass := map at: oldClass.
self assert: (newHeap isPointersNonImm: newClass).
newHeap setHashBitsOf: newClass to: index.
page := newHeap
fetchPointer: index >> newHeap classTableMajorIndexShift
ofObject: newHeap classTableRootObj.
newHeap
storePointer: (index bitAnd: newHeap classTableMinorIndexMask)
ofObject: page
withValue: newClass.
self assert: (newHeap classAtIndex: index) = newClass].
firstPage := newHeap
fetchPointer: 0
ofObject: newHeap classTableRootObj.
newHeap
storePointer: 1
ofObject: firstPage
withValue: (map at: oldHeap classSmallInteger);
storePointer: 2
ofObject: firstPage
withValue: (map at: oldHeap classCharacter);
storePointer: 3
ofObject: firstPage
withValue: (map at: oldHeap classSmallInteger);
storePointer: newHeap arrayClassIndexPun
ofObject: firstPage
withValue: (map at: oldHeap classArray);
storePointer: newHeap arrayClassIndexPun
ofObject: firstPage
withValue: (map at: oldHeap classArray).
newHeap classTableIndex: maxIndex!
----- Method: SpurBootstrap>>fillInCompiledMethod:from: (in category 'bootstrap image') -----
fillInCompiledMethod: newObj from: oldObj
| firstByteIndex primIndex |
self fillInPointerObject: newObj from: oldObj.
"Now convert the CompiledMethod's format. First write the header in the new format"
newHeap
storePointerUnchecked: 0
ofObject: newObj
withValue: (newHeap integerObjectOf: (self convertOldMethodHeader: (oldHeap fetchPointer: 0 ofObject: oldObj))).
"Then if necessary prepend the callPrimitive: bytecode"
(primIndex := oldInterpreter primitiveIndexOf: oldObj) > 0
ifTrue:
[firstByteIndex := oldHeap lastPointerOf: oldObj.
newHeap
storeByte: firstByteIndex + 0 ofObject: newObj withValue: 139;
storeByte: firstByteIndex + 1 ofObject: newObj withValue: (primIndex bitAnd: 255);
storeByte: firstByteIndex + 2 ofObject: newObj withValue: (primIndex bitShift: -8).
firstByteIndex to: (oldHeap numBytesOfBytes: oldObj) - 1 do:
[:i|
newHeap storeByte: i + 3 ofObject: newObj withValue: (oldHeap fetchByte: i ofObject: oldObj)]]
ifFalse:
[(oldHeap lastPointerOf: oldObj) / oldHeap wordSize to: (oldHeap numSlotsOf: oldObj) - 1 do:
[:i|
newHeap storeLong32: i ofObject: newObj withValue: (oldHeap fetchLong32: i ofObject: oldObj)]]!
----- Method: SpurBootstrap>>fillInObjects (in category 'bootstrap image') -----
fillInObjects
oldHeap allObjectsDo:
[:oldObj|
(map at: oldObj ifAbsent: nil) ifNotNil:
[:newObj| | format classIndex |
format := newHeap formatOf: newObj.
(newHeap isPointersFormat: format)
ifTrue:
[((newHeap isIndexableFormat: format)
and: [(classIndex := newHeap classIndexOf: newObj) <= classBlockClosureIndex
and: [classIndex >= classMethodContextIndex]])
ifTrue: [self fillInPointerObjectWithPC: newObj from: oldObj]
ifFalse: [self fillInPointerObject: newObj from: oldObj]]
ifFalse:
[(newHeap isCompiledMethodFormat: format)
ifTrue: [self fillInCompiledMethod: newObj from: oldObj]
ifFalse: [self fillInBitsObject: newObj from: oldObj]]]]!
----- Method: SpurBootstrap>>fillInPointerObject:from: (in category 'bootstrap image') -----
fillInPointerObject: newObj from: oldObj
"Fill-in a newObj with appropriately mapped contents from oldObj.
Filter-out the character table and the compact classes array.
Map character objects to immediate characters."
0 to: (oldHeap lastPointerOf: oldObj) / oldHeap wordSize - 1 do:
[:i| | oldValue newValue |
oldValue := oldHeap fetchPointer: i ofObject: oldObj.
newValue := (oldHeap isIntegerObject: oldValue)
ifTrue: [oldValue]
ifFalse:
[map at: oldValue ifAbsent:
[(oldValue = oldHeap characterTable
or: [oldValue = (oldHeap splObj: CompactClasses)])
ifTrue: [newHeap nilObject]
ifFalse:
[self assert: (oldHeap fetchClassOfNonImm: oldValue) = oldHeap classCharacter.
newHeap characterObjectOf:
(oldHeap integerValueOf:
(oldHeap fetchPointer: CharacterValueIndex ofObject: oldValue))]]].
newHeap
storePointerUnchecked: i
ofObject: newObj
withValue: newValue].
(self isOldObjABehavior: oldObj) ifTrue:
[self mapOldBehavior: oldObj toNewBehavior: newObj]!
----- Method: SpurBootstrap>>fillInPointerObjectWithPC:from: (in category 'bootstrap image') -----
fillInPointerObjectWithPC: newObj from: oldObj
"Fill-in a newObj with appropriately mapped contents from oldObj.
If the object has a pc and its method has a primitive, increment the
pc by the size of the callPrimitive: bytecode."
| method |
self fillInPointerObject: newObj from: oldObj.
(newHeap classIndexOf: newObj) = classBlockClosureIndex ifTrue:
[method := oldHeap
fetchPointer: MethodIndex
ofObject: (oldHeap
fetchPointer: ClosureOuterContextIndex
ofObject: oldObj).
(oldInterpreter primitiveIndexOf: method) > 0 ifTrue:
[self incrementPCField: ClosureStartPCIndex ofObject: newObj by: 3]].
(newHeap classIndexOf: newObj) = classMethodContextIndex ifTrue:
[method := oldHeap
fetchPointer: MethodIndex
ofObject: oldObj.
(method ~= oldHeap nilObject
and: [(oldInterpreter primitiveIndexOf: method) > 0]) ifTrue:
[self incrementPCField: InstructionPointerIndex ofObject: newObj by: 3]].!
----- Method: SpurBootstrap>>findClassNamed: (in category 'bootstrap methods') -----
findClassNamed: symbolOop
oldHeap allObjectsDo:
[:o|
((oldHeap isPointersNonImm: o)
and: [(oldInterpreter addressCouldBeClassObj: o)
and: [(oldHeap fetchPointer: oldInterpreter classNameIndex ofObject: o) = symbolOop]]) ifTrue:
[^o]].
^nil!
----- Method: SpurBootstrap>>findLiteral:inClass: (in category 'bootstrap methods') -----
findLiteral: aLiteral inClass: classOop
| bindingOrNil |
aLiteral isString ifTrue:
[^self stringFor: aLiteral].
aLiteral isFloat ifTrue:
[^oldHeap floatObjectOf: aLiteral].
aLiteral isArray ifTrue:
[^self cloneArrayLiteral: aLiteral].
aLiteral isCharacter ifTrue:
[^oldHeap characterObjectOf: aLiteral asciiValue].
self assert: aLiteral isVariableBinding.
bindingOrNil := self interpreter: oldInterpreter
object: classOop
perform: (self findSymbol: #bindingOf:)
withArguments: {self findSymbol: aLiteral key}.
bindingOrNil ~= oldHeap nilObject ifTrue:
[^bindingOrNil].
self error: 'couldn''t find literal ', aLiteral printString!
----- Method: SpurBootstrap>>findRequiredGlobals (in category 'bootstrap image') -----
findRequiredGlobals
"Look for the necessary gobal bindings in the prototype methods in the old image.
This has to be done early by sending bindingOf: to Smalltalk. Collect the class
hierarchy of all prototypes that access inst vars (non-local prototypes) to check
their shapes. Also find out Metaclass, needed for identifying classes."
| globals ourMethodClasses classVars bindingOfSym |
globals := Set new.
ourMethodClasses := Set new.
classVars := Dictionary new.
self prototypeClassNameMetaSelectorMethodDo:
[:c :m :s :method| | allNonMetaSupers |
(Smalltalk classNamed: c) ifNotNil:
[:nonMetaClass|
allNonMetaSupers := nonMetaClass withAllSuperclasses.
(method methodClass includesBehavior: SpurBootstrapPrototypes) ifFalse:
[ourMethodClasses addAll: allNonMetaSupers.
globals addAll: (allNonMetaSupers collect: [:sc| sc binding])].
method literals do:
[:l|
(l isVariableBinding
and: [l key isSymbol
and: [SpurBootstrapPrototypes withAllSubclasses noneSatisfy: [:sbpc| sbpc name == l key]]]) ifTrue:
[((Smalltalk bindingOf: l key) == l
or: [(Undeclared bindingOf: l key) == l])
ifTrue: [globals add: l]
ifFalse:
[self assert: (nonMetaClass bindingOf: l key) == l.
classVars at: l put: nonMetaClass]]]]].
globals add: Compiler binding. "For potential reshaping in checkReshapeOf:"
bindingOfSym := self findSymbol: #bindingOf:.
self withExecutableInterpreter: oldInterpreter
do: [| toBeAdded |
globals do:
[:global| | bindingOop |
(self findSymbol: global key) ifNotNil:
[:symbolOop|
bindingOop := self interpreter: oldInterpreter
object: (oldHeap splObj: 8) "Smalltalk"
perform: bindingOfSym
withArguments: {self findSymbol: global key}.
bindingOop ~= oldHeap nilObject ifTrue:
[literalMap at: global put: bindingOop]]].
toBeAdded := Dictionary new.
classVars keysAndValuesDo:
[:var :class| | val |
(self findSymbol: var key) "New class inst vars may not yet be interned."
ifNil: [toBeAdded at: var put: class]
ifNotNil:
[:varName|
val := self interpreter: oldInterpreter
object: (self oldClassOopFor: class)
perform: bindingOfSym
withArguments: {varName}.
val ~= oldHeap nilObject
ifTrue: [literalMap at: var put: val]
ifFalse: [toBeAdded at: var put: class]]].
"May have to redefine to add missing inst vars and/or add any missing class vars."
self checkReshapeOf: ourMethodClasses.
self addMissingClassVars: toBeAdded]!
----- Method: SpurBootstrap>>findSymbol: (in category 'bootstrap methods') -----
findSymbol: aString
"Find the Symbol equal to aString in oldHeap."
| symbolClass |
(literalMap at: aString ifAbsent: nil) ifNotNil:
[:oop| ^oop].
symbolClass := self symbolClass.
oldHeap allObjectsDo:
[:obj|
(symbolClass = (oldHeap fetchClassOfNonImm: obj)
and: [(oldHeap numBytesOf: obj) = aString size
and: [aString = (oldHeap stringOf: obj)]]) ifTrue:
[aString isSymbol ifTrue:
[literalMap at: aString asSymbol put: obj].
^obj]].
Transcript cr; nextPutAll: 'Warning, could not find '; store: aString; flush.
^nil!
----- Method: SpurBootstrap>>firstOrdinaryClassIndex (in category 'class indices') -----
firstOrdinaryClassIndex
^newHeap classTablePageSize!
----- Method: SpurBootstrap>>followForwardingPointers (in category 'bootstrap image') -----
followForwardingPointers
newHeap allObjectsDo:
[:o|
(newHeap isForwarded: o) ifFalse:
[0 to: (newHeap numPointerSlotsOf: o) - 1 do:
[:i| | field |
field := newHeap fetchPointer: i ofObject: o.
(newHeap isOopForwarded: field) ifTrue:
[newHeap
storePointer: i
ofObject: o
withValue: (newHeap followForwarded: field)]]]]!
----- Method: SpurBootstrap>>freeForwarders (in category 'bootstrap image') -----
freeForwarders
"Check that all forwarders have been followed. Then free them."
| numForwarders numFreed |
numForwarders := numFreed := 0.
newHeap allObjectsDo:
[:o|
(newHeap isForwarded: o)
ifTrue: [numForwarders := numForwarders + 1]
ifFalse:
[0 to: (newHeap numPointerSlotsOf: o) - 1 do:
[:i|
self assert: (newHeap isOopForwarded: (newHeap fetchPointer: i ofObject: o)) not]]].
Transcript ensureCr; nextPutAll: 'freeing '; print: numForwarders; nextPutAll: ' forwarders'; cr; flush.
newHeap allObjectsDo:
[:o|
(newHeap isForwarded: o) ifTrue:
[numFreed := numFreed + 1.
newHeap freeObject: o]].
self assert: numFreed = numForwarders!
----- Method: SpurBootstrap>>headerForOldMethodHeader: (in category 'bootstrap image') -----
headerForOldMethodHeader: methodHeaderOop
^self isOnSpur
ifTrue: [self convertOldMethodHeader: methodHeaderOop]
ifFalse: [oldHeap integerValueOf: methodHeaderOop]!
----- Method: SpurBootstrap>>imageTypes: (in category 'bootstrap image') -----
imageTypes: anArray
imageTypes := anArray!
----- Method: SpurBootstrap>>incrementPCField:ofObject:by: (in category 'bootstrap image') -----
incrementPCField: fieldIndex ofObject: newObj by: n
| value |
value := newHeap fetchPointer: fieldIndex ofObject: newObj.
(newHeap isIntegerObject: value)
ifTrue:
[newHeap
storePointerUnchecked: fieldIndex
ofObject: newObj
withValue: (newHeap integerObjectOf: n + (newHeap integerValueOf: value))]
ifFalse:
[self assert: value = newHeap nilObject]!
----- Method: SpurBootstrap>>indexOfSelector:in: (in category 'bootstrap methods') -----
indexOfSelector: selectorOop in: methodDict
SelectorStart to: (oldHeap numSlotsOf: methodDict) - 1 do:
[:i|
(oldHeap fetchPointer: i ofObject: methodDict) = selectorOop ifTrue:
[^i]].
self error: 'could not find selector in method dict'!
----- Method: SpurBootstrap>>initMaps (in category 'initialize-release') -----
initMaps
map := Dictionary new: oldHeap memory size // 4.
reverseMap := Dictionary new: oldHeap memory size // 4.
classToIndex := Dictionary new: 1024.
literalMap := IdentityDictionary new.
methodClasses := Set new.
installedPrototypes := Set new.
installedMethodOops := Set new.
classMetaclass := nil!
----- Method: SpurBootstrap>>initialize (in category 'initialize-release') -----
initialize
super initialize.
imageTypes := {'squeak'}. "By default, image is Squeak (so Eliot does not kick me :P)"!
----- Method: SpurBootstrap>>initializeClasses (in category 'bootstrap image') -----
initializeClasses
toBeInitialized ifNil: [^self].
self withExecutableInterpreter: oldInterpreter
do: [toBeInitialized do:
[:class|
self interpreter: oldInterpreter
object: (self oldClassOopFor: class)
perform: (self findSymbol: #initialize)
withArguments: #()]]!
----- Method: SpurBootstrap>>installModifiedMethods (in category 'bootstrap methods') -----
installModifiedMethods
"Install all the methods in the class-side method prototypes protocol in the relevant classes
in the new image. First use the simulator to get the image to intern all symbols and add
dummy methods under new selectors. With that done we can manually replace the relevant
methods with the prototypes, mapping selectors and global variables as required."
self withExecutableInterpreter: oldInterpreter
do: [self internAllSymbols.
self addNewMethods.
self removeMethods.
self replaceMethods.
self modifyCharacterMethods]!
----- Method: SpurBootstrap>>installableMethodFor:selector:className:isMeta: (in category 'bootstrap methods') -----
installableMethodFor: aCompiledMethod selector: selector className: className isMeta: isMeta
"Create a sourceless method to install in the bootstrapped image. It will allow the
bootstrap to limp along until the relevant transformed Monticello package is loaded."
| compiledMethodClass methodClassBinding methodClass sourcelessMethod bytes newMethod delta initialPC |
compiledMethodClass := self findClassNamed: (self findSymbol: #CompiledMethod).
methodClassBinding := self methodClassBindingForClassName: className isMeta: isMeta.
methodClass := oldHeap fetchPointer: ValueIndex ofObject: methodClassBinding.
"the prototypes have source pointers. the Character methods to be replaced don't."
sourcelessMethod := aCompiledMethod trailer hasSourcePointer
ifTrue: [aCompiledMethod copyWithTempsFromMethodNode: aCompiledMethod methodNode]
ifFalse: [aCompiledMethod].
initialPC := sourcelessMethod initialPC.
bytes := sourcelessMethod size - initialPC + 1.
"Ugh, this is complicated. We could be running on Spur with the new method format
or on non-Spur with the old format. Make both work."
delta := (sourcelessMethod primitive > 0
and: [(sourcelessMethod at: initialPC) = sourcelessMethod encoderClass callPrimitiveCode])
ifTrue: [3]
ifFalse: [0].
newMethod := self
interpreter: oldInterpreter
object: compiledMethodClass
perform: (self findSymbol: #newMethod:header:)
withArguments: { oldHeap integerObjectOf: bytes - delta.
oldHeap integerObjectOf: (self oldFormatHeaderFor: sourcelessMethod) }.
1 to: sourcelessMethod numLiterals - 2 do:
[:i| | literal oop |
literal := sourcelessMethod literalAt: i.
oop := (literal isLiteral or: [literal isVariableBinding])
ifTrue:
[literal isInteger
ifTrue: [oldInterpreter signed64BitIntegerFor: literal]
ifFalse: [literalMap
at: literal
ifAbsent: [self findLiteral: literal
inClass: methodClass]]]
ifFalse: "should be a VMObjectProxy"
[literal oop].
oldHeap storePointer: i ofObject: newMethod withValue: oop].
oldHeap
storePointer: sourcelessMethod numLiterals - 1
ofObject: newMethod
withValue: (selector isSymbol
ifTrue: [self findSymbol: selector]
ifFalse: [selector oop]);
storePointer: sourcelessMethod numLiterals
ofObject: newMethod
withValue: methodClassBinding.
initialPC to: sourcelessMethod size - delta do:
[:i|
oldHeap storeByte: i - 1 ofObject: newMethod withValue: (sourcelessMethod byteAt: i + delta)].
installedMethodOops add: newMethod.
^newMethod!
----- Method: SpurBootstrap>>internAllSymbols (in category 'bootstrap methods') -----
internAllSymbols
"Ensure that all symbols in the method prototypes are interned so that later we can install them.
Enter them into the map, this system's symbol -> oldHeap's version.
Do this by interpreting Symbol intern: 'aSymbol' for each symbol."
| internSym all symbolClass |
internSym := self findSymbol: #intern:.
symbolClass := self symbolClass.
all := self allPrototypeMethodSymbols.
oldHeap allObjectsDo:
[:objOop| | sz |
symbolClass = (oldHeap fetchClassOfNonImm: objOop) ifTrue:
[sz := oldHeap numBytesOf: objOop.
(all detect: [:sym| sym size = sz and: [sym = (oldHeap stringOf: objOop)]]
ifNone: nil) ifNotNil:
[:sym|
literalMap at: sym put: objOop.
all remove: sym]]].
all do: [:sym|
(self findSymbol: sym)
ifNotNil: [:imageSym| literalMap at: sym put: imageSym]
ifNil:[Transcript cr; nextPutAll: 'interning '; nextPutAll: sym; flush.
"Interpret Symbol intern: sym to ... intern it :-)"
literalMap
at: sym
put: (self interpreter: oldInterpreter
object: self symbolClass
perform: internSym
withArguments: {self stringFor: sym})]].
literalMap keysAndValuesDo:
[:symOrGlobal :imageSymOrGlobal|
symOrGlobal isSymbol ifTrue:
[self assert: symOrGlobal = (oldHeap stringOf: imageSymOrGlobal)]]!
----- Method: SpurBootstrap>>isOldObjABehavior: (in category 'bootstrap image') -----
isOldObjABehavior: oldObj
| oldObjClass |
^(classToIndex includesKey: oldObj)
or: [(oldObjClass := oldHeap fetchClassOfNonImm: oldObj) = self classMetaclass
or: [(oldHeap fetchClassOfNonImm: oldObjClass) = classMetaclass]]!
----- Method: SpurBootstrap>>isOnSpur (in category 'testing') -----
isOnSpur
^$c class instSize = 0!
----- Method: SpurBootstrap>>launch (in category 'testing') -----
launch
self launch: newHeap
simulatorClass: StackInterpreterSimulator
headerFlags: oldInterpreter getImageHeaderFlags!
----- Method: SpurBootstrap>>launch:simulatorClass:headerFlags: (in category 'testing') -----
launch: heap simulatorClass: simulatorClass headerFlags: headerFlags
| sim methodCacheSize |
sim := simulatorClass onObjectMemory: heap.
heap coInterpreter: sim.
(sim class allInstVarNames includes: 'cogCodeSize')
ifTrue:
[sim initializeInterpreter: 0.
methodCacheSize := sim methodCache size * heap wordSize.
sim instVarNamed: 'heapBase' put: heap startOfMemory;
instVarNamed: 'numStackPages' put: 8;
instVarNamed: 'cogCodeSize' put: 1024*1024;
moveMethodCacheToMemoryAt: sim cogCodeSize + sim computeStackZoneSize;
movePrimTraceLogToMemoryAt: sim cogCodeSize + sim computeStackZoneSize + methodCacheSize;
"sendTrace: 1+ 2 + 8 + 16;"
initializeCodeGenerator]
ifFalse:
[sim initializeInterpreter: 0].
heap
initializeNewSpaceVariables;
bootstrapping: false;
assimilateNewSegment: (heap segmentManager segments at: 0).
sim
setImageHeaderFlagsFrom: headerFlags;
imageName: ImageName;
flushExternalPrimitives;
openAsMorph;
transcript: Transcript. "deep copy copies this"
"sim
instVarNamed: 'printSends' put: true;
instVarNamed: 'printReturns' put: true;
instVarNamed: 'methodDictLinearSearchLimit' put: SmallInteger maxVal." "for now"
heap
setCheckForLeaks: 0;
runLeakCheckerForFullGC.
sim halt; run!
----- Method: SpurBootstrap>>launchSaved (in category 'testing') -----
launchSaved
self launch: TransformedImage veryDeepCopy
simulatorClass: StackInterpreterSimulator
headerFlags: ImageHeaderFlags!
----- Method: SpurBootstrap>>launchSavedWithJIT (in category 'testing') -----
launchSavedWithJIT
self launch: (self coHeapFrom: TransformedImage veryDeepCopy)
simulatorClass: CogVMSimulator
headerFlags: ImageHeaderFlags!
----- Method: SpurBootstrap>>mapOldBehavior:toNewBehavior: (in category 'bootstrap image') -----
mapOldBehavior: oldObj toNewBehavior: newObj
"Map the old format inst var's value to the new value.
In addition, for Character, make it immediate and remove its instance variable."
newHeap
storePointerUnchecked: InstanceSpecificationIndex
ofObject: newObj
withValue: (self newClassFormatFor: oldObj).
oldObj = oldHeap classCharacter ifTrue:
[InstanceSpecificationIndex + 1 to: (oldHeap numSlotsOf: oldObj) do:
[:i| | var field |
var := oldHeap fetchPointer: i ofObject: oldObj.
((oldHeap fetchClassOf: var) = oldHeap classArray
and: [(oldHeap numSlotsOf: var) = 1
and: [field := oldHeap fetchPointer: 0 ofObject: var.
(oldHeap fetchClassOf: field) = oldHeap classString
and: [(oldHeap lengthOf: field) = 5
and: [(oldHeap str: 'value' n: (oldHeap firstIndexableField: field) cmp: 5) = 0]]]]) ifTrue:
[newHeap
storePointerUnchecked: i
ofObject: newObj
withValue: newHeap nilObject.
^self]]]!
----- Method: SpurBootstrap>>measureNewHeapPostInitPostBootstrap (in category 'stats') -----
measureNewHeapPostInitPostBootstrap
| savedEndOfMemory |
"need to hack around the fact that newHeap isn't all there yet.
In particular, it has no freeList so can't free space from
freeOldSpaceStart to endOfMemory to make oldSpace enumerable."
newHeapNumObjs := 0.
savedEndOfMemory := newHeap endOfMemory.
newHeap setEndOfMemory: newHeap freeOldSpaceStart.
newHeap allObjectsDo: [:o| newHeapNumObjs := newHeapNumObjs + 1].
newHeap setEndOfMemory: savedEndOfMemory!
----- Method: SpurBootstrap>>measureOldHeapPostGC (in category 'stats') -----
measureOldHeapPostGC
oldHeapSize := oldHeap freeStart.
oldHeapNumObjs := 0.
oldHeap allObjectsDo: [:o| oldHeapNumObjs := oldHeapNumObjs + 1]!
----- Method: SpurBootstrap>>methodClassBindingForClassName:isMeta: (in category 'bootstrap methods') -----
methodClassBindingForClassName: classNameSymbol isMeta: isMeta
| class |
class := self findClassNamed: (literalMap at: classNameSymbol).
isMeta ifTrue: [class := oldHeap fetchClassOfNonImm: class].
^self interpreter: oldInterpreter
object: class
perform: (self findSymbol: #binding)
withArguments: #()!
----- Method: SpurBootstrap>>modifyCharacterMethods (in category 'bootstrap methods') -----
modifyCharacterMethods
| cc md mda |
cc := oldHeap classCharacter.
md := oldHeap fetchPointer: MethodDictionaryIndex ofObject: cc.
mda := oldHeap fetchPointer: MethodArrayIndex ofObject: md..
0 to: (oldHeap numSlotsOf: mda) - 1 do:
[:i| | method |
method := oldHeap fetchPointer: i ofObject: mda.
method ~= oldHeap nilObject ifTrue:
[(self replacementForCharacterMethod: method) ifNotNil:
[:replacement|
Transcript
cr;
nextPutAll: 'replacing Character>>#';
nextPutAll: (oldHeap stringOf: (oldHeap fetchPointer: i + SelectorStart ofObject: md));
flush.
oldHeap
storePointer: i
ofObject: mda
withValue: replacement]]]!
----- Method: SpurBootstrap>>newClassFormatFor: (in category 'bootstrap image') -----
newClassFormatFor: oldClassObj
"OLD: <2 bits=instSize//64><5 bits=cClass><4 bits=instSpec><6 bits=instSize\\64><1 bit=0>
NEW: <5 bits inst spec><16 bits inst size>"
| oldFormat instSize newInstSpec |
((oldInterpreter classNameOf: oldClassObj Is: 'SmallInteger')
or: [(oldInterpreter classNameOf: oldClassObj Is: 'Character')
or: [oldInterpreter classNameOf: oldClassObj Is: 'SmallFloat64']]) ifTrue:
[^newHeap integerObjectOf: newHeap instSpecForImmediateClasses << 16].
oldFormat := oldHeap formatOfClass: oldClassObj. "N.B. SmallInteger with tag bit cleared"
oldFormat := oldFormat >> 1.
instSize := ((oldFormat bitShift: -10) bitAnd: 16rC0) + ((oldFormat bitShift: -1) bitAnd: 16r3F) - 1.
newInstSpec := #(0 1 2 3 4 nil 10 9 16 16 16 16 24 24 24 24) at: ((oldFormat bitShift: -7) bitAnd: 16rF) + 1.
^newHeap integerObjectOf: newInstSpec << 16 + instSize!
----- Method: SpurBootstrap>>newFormatFor:numBytes: (in category 'bootstrap image') -----
newFormatFor: oldObj numBytes: numBytesIfBits
"OLD:
0 no fields
1 fixed fields only (all containing pointers)
2 indexable fields only (all containing pointers)
3 both fixed and indexable fields (all containing pointers)
4 both fixed and indexable weak fields (all containing pointers).
5 unused
6 indexable word fields only (no pointers)
7 indexable long (64-bit) fields (only in 64-bit images)
8-11 indexable byte fields only (no pointers) (low 2 bits are low 2 bits of size)
12-15 compiled methods:
# of literal oops specified in method header,
followed by indexable bytes (same interpretation of low 2 bits as above)"
"NEW:
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 = reserved
7 = forwarder format (also immediate class format)
9 64-bit indexable
10 - 11 32-bit indexable
12 - 15 16-bit indexable
16 - 23 byte indexable
24 - 31 compiled method"
| oldFormat |
oldFormat := oldHeap formatOf: oldObj.
oldFormat <= 4 ifTrue:
[^oldFormat].
oldFormat >= 12 ifTrue: "CompiledMethod"
[^24 + (self wordSize - numBytesIfBits bitAnd: self wordSizeMask)].
oldFormat >= 8 ifTrue: "ByteArray et al"
[^16 + (self wordSize - numBytesIfBits bitAnd: self wordSizeMask)].
oldFormat = 6 ifTrue: "32-bit indexable"
[^10 + (numBytesIfBits bitAnd: self wordSizeMask) sign].
oldFormat = 7 ifTrue: "64-bit indexable"
[^9].
self error: 'illegal old format'!
----- Method: SpurBootstrap>>oldClassOopFor: (in category 'bootstrap image') -----
oldClassOopFor: aClass
^oldHeap fetchPointer: ValueIndex ofObject: (literalMap at: aClass binding).!
----- Method: SpurBootstrap>>oldFormatHeaderFor: (in category 'bootstrap methods') -----
oldFormatHeaderFor: method
| primBits primitive |
primitive := method primitive.
primBits := primitive <= 16r1FF
ifTrue: [primitive]
ifFalse: [(primitive bitAnd: 16r1FF) + ((primitive bitAnd: 16r200) bitShift: 19)].
^(method numArgs bitShift: 24)
+ (method numTemps bitShift: 18)
+ (method frameSize > method class smallFrameSize ifTrue: [1 << 17] ifFalse: [0])
+ (method numLiterals bitShift: 9)
+ primBits!
----- Method: SpurBootstrap>>on: (in category 'initialize-release') -----
on: imageName
StackInterpreter initializeWithOptions: Dictionary new.
(oldInterpreter := StackInterpreterSimulator new)
openOn: imageName extraMemory: 0;
assertValidExecutionPointersAtEachStep: false.
oldHeap := oldInterpreter objectMemory.
newHeap := Spur32BitMMLESimulator new.
newHeap
allocateMemoryOfSize: (oldHeap youngStart * 3 / 2 roundUpTo: 1024 * 1024)
newSpaceSize: 4 * 1024 * 1024
stackSize: 16 * 1024
codeSize: 0.
newHeap setCheckForLeaks: 15 - 6. "don't check become; or newSpace; soooo many rehashes in bootstrap"
newHeap bootstrapping: true.
self initMaps!
----- Method: SpurBootstrap>>prototypeClassNameMetaSelectorMethodDo: (in category 'method prototypes') -----
prototypeClassNameMetaSelectorMethodDo: quaternaryBlock
"Evaluate aBlock with class name, class is meta, method and selector.
For now find methods in class-side category #'method prototypes'.
Scheme could be extended to have different protocols for different
Squeak/Pharo versions."
self allMethodPrototypes do:
[:methodArg| | method className isMeta |
className := self classNameForPrototypeMethod: (method := methodArg).
(isMeta := className endsWith: 'class') ifTrue:
[className := (className allButLast: 5) asSymbol].
(method pragmaAt: #indirect) ifNotNil:
[method := (isMeta
ifTrue: [(Smalltalk classNamed: className) class]
ifFalse: [Smalltalk classNamed: className]) >> method selector].
quaternaryBlock
value: className
value: isMeta
value: (self selectorForPrototypeMethod: method)
value: method]!
----- Method: SpurBootstrap>>recreateSpecialObjectsArray (in category 'bootstrap image') -----
recreateSpecialObjectsArray
"This is tricky. We want to recreate the specialObjectsArray according to
the class side SmalltalkImagePROTOTYPErecreateSpecialObjectsArray.
But that version destroys the CompactClassesArray upon which the V3
image depends. The bootstrap will get rid of it later. So save it before
the recreation and restore it."
self withExecutableInterpreter: oldInterpreter
do: [| compactClassesArray |
compactClassesArray := oldHeap splObj: CompactClasses.
self
interpreter: oldInterpreter
object: (oldHeap splObj: 8)
perform: (self findSymbol: #recreateSpecialObjectsArray)
withArguments: #().
oldHeap splObj: CompactClasses put: compactClassesArray]!
----- Method: SpurBootstrap>>rehashImage (in category 'bootstrap image') -----
rehashImage
"Rehash all collections in newHeap.
Find out which classes implement rehash, entering a 1 against their classIndex in rehashFlags.
Enumerate all objects, rehashing those whose class has a bit set in rehashFlags."
| n sim rehashFlags dotDate rehashSym sizeSym |
rehashSym := map at: (self findSymbol: #rehash).
sizeSym := map at: (self findSymbol: #size).
sim := StackInterpreterSimulator
onObjectMemory: newHeap
options: #(ObjectMemory #Spur32BitMemoryManager).
sim
setImageHeaderFlagsFrom: oldInterpreter getImageHeaderFlags;
imageName: 'spur image';
assertValidExecutionPointersAtEachStep: false..
newHeap coInterpreter: sim.
sim bootstrapping: true.
sim initializeInterpreter: 0.
sim instVarNamed: 'methodDictLinearSearchLimit' put: SmallInteger maxVal.
(imageTypes includes: 'cuis') ifTrue:
[newHeap scavenger growRememberedSet]. "Rehashing a 4.2 Cuis image overflows the 768 element high tide."
sim redirectTranscriptToHost.
newHeap
setHashBitsOf: newHeap nilObject to: 1;
setHashBitsOf: newHeap falseObject to: 2;
setHashBitsOf: newHeap trueObject to: 3.
rehashFlags := ByteArray new: newHeap numClassTablePages * newHeap classTablePageSize.
n := 0.
newHeap classTableObjectsDo:
[:class| | classIndex |
sim messageSelector: rehashSym.
"Lookup rehash but don't be fooled by ProtoObject>>rehash, which is just ^self."
((sim lookupOrdinaryNoMNUEtcInClass: class) = 0
and: [(sim isQuickPrimitiveIndex: (sim primitiveIndexOf: (sim instVarNamed: 'newMethod'))) not]) ifTrue:
[n := n + 1.
classIndex := newHeap rawHashBitsOf: class.
rehashFlags
at: classIndex >> 3 + 1
put: ((rehashFlags at: classIndex >> 3 + 1)
bitOr: (1 << (classIndex bitAnd: 7)))]].
Transcript cr; print: n; nextPutAll: ' classes understand rehash. rehashing instances...'; flush.
dotDate := Time now asSeconds.
n := 0.
self withExecutableInterpreter: sim
do: [sim setBreakSelector: 'error:'.
"don't rehash twice (actually without limit), so don't rehash any new objects created."
newHeap allExistingOldSpaceObjectsDo:
[:o| | classIndex |
classIndex := newHeap classIndexOf: o.
((rehashFlags at: classIndex >> 3 + 1) anyMask: 1 << (classIndex bitAnd: 7)) ifTrue:
[Time now asSeconds > dotDate ifTrue:
[Transcript nextPut: $.; flush.
dotDate := Time now asSeconds].
"2845 = n ifTrue: [self halt]."
"Rehash an object if its size is > 0.
Symbol implements rehash, but let's not waste time rehashing it; in Squeak
up to 2013 symbols are kept in a set which will get reashed anyway..
Don't rehash empty collections; they may be large for a reason and rehashing will shrink them."
((sim addressCouldBeClassObj: o)
or: [(self interpreter: sim
object: o
perform: sizeSym
withArguments: #()) = (newHeap integerObjectOf: 0)]) ifFalse:
[self interpreter: sim
object: o
perform: rehashSym
withArguments: #()]]]]!
----- Method: SpurBootstrap>>removeMethods (in category 'bootstrap methods') -----
removeMethods
"Get the simulator to remove any methods marked with <remove>."
| removeSym |
removeSym := self findSymbol: #removeSelectorSilently:.
removeSym ifNil:
[removeSym := self findSymbol: #removeSelector:].
self prototypeClassNameMetaSelectorMethodDo:
[:className :isMeta :selector :method| | class |
(method pragmaAt: #remove) ifNotNil:
[(self findClassNamed: (literalMap at: className)) ifNotNil:
[:theClass|
class := isMeta ifTrue: [oldHeap fetchClassOfNonImm: theClass] ifFalse: [theClass].
Transcript
cr;
nextPutAll: 'removing ';
nextPutAll: className;
nextPutAll: (isMeta ifTrue: [' class>>'] ifFalse: ['>>']);
store: selector;
flush.
self interpreter: oldInterpreter
object: class
perform: removeSym
withArguments: {literalMap at: selector}]]]!
----- Method: SpurBootstrap>>replaceMethods (in category 'bootstrap methods') -----
replaceMethods
"Replace all the modified method prototypes."
self allPrototypeClassNamesDo:
[:sym :symIsMeta|
(self findClassNamed: (literalMap at: sym))
ifNil: [Transcript
cr;
nextPutAll: 'not replacing any methods for ';
nextPutAll: sym;
nextPutAll: '; class not found in image';
flush.]
ifNotNil:
[:theClass| | class |
class := symIsMeta ifTrue: [oldHeap fetchClassOfNonImm: theClass] ifFalse: [theClass].
self prototypeClassNameMetaSelectorMethodDo:
[:className :isMeta :selector :method| | replacement methodDict index |
(className = sym
and: [symIsMeta = isMeta
and: [(method pragmaAt: #remove) isNil]]) ifTrue:
[(installedPrototypes includes: method selector) ifFalse:
["probe method dictionary of the class for each method, installing a dummy if not found."
Transcript
cr;
nextPutAll: 'replacing ';
nextPutAll: className;
nextPutAll: (isMeta ifTrue: [' class>>'] ifFalse: ['>>']);
store: selector;
flush.
replacement := self installableMethodFor: method
selector: selector
className: className
isMeta: isMeta.
methodDict := oldHeap fetchPointer: MethodDictionaryIndex ofObject: class.
index := self indexOfSelector: (literalMap at: selector) in: methodDict.
oldHeap
storePointer: index - SelectorStart
ofObject: (oldHeap fetchPointer: MethodArrayIndex ofObject: methodDict)
withValue: replacement.
installedPrototypes add: method selector]]]]]!
----- Method: SpurBootstrap>>replacementForCharacterMethod: (in category 'bootstrap methods') -----
replacementForCharacterMethod: characterMethodOop
"Answer a replacement method for the argument if it refers
to Character's old inst var value. Otherwise answer nil."
| proxy asIntegerProxy clone assembly newInsts newMethod |
"(oldHeap stringOf: (oldHeap longAt: characterMethodOop + (oldHeap lastPointerOf: characterMethodOop) - 4)) = 'isOctetCharacter' ifTrue:
[self halt]."
"Don't replace something already installed."
(installedMethodOops includes: characterMethodOop) ifTrue:
[^nil].
proxy := VMCompiledMethodProxy new
for: characterMethodOop
coInterpreter: oldInterpreter
objectMemory: oldHeap.
self assert: (oldHeap literalCountOf: characterMethodOop) = proxy numLiterals.
clone := self cloneMethodProxy: proxy.
self assert: proxy numLiterals = clone numLiterals.
clone isReturnSpecial ifTrue:
[^nil].
"Quick methods accessing value should have been replaced. The halt will fire if there
is a missing prototype for such a method on the class side of SpurBootstrap. The
relevant Character prototypes there so far are Character>>asInteger, Character>>
asciiValue, Character>>hash & Character>>identityHash. Conceivably the bootstrap
could be applied to an image that has others; hence the halt."
clone isReturnField ifTrue: [self halt].
clone hasInstVarRef ifFalse:
[^nil].
clone setSourcePointer: 0.
asIntegerProxy := VMObjectProxy new
for: (literalMap at: #asInteger)
coInterpreter: oldInterpreter
objectMemory: oldHeap.
assembly := BytecodeDisassembler new disassemble: clone.
assembly literals: (assembly literals allButLast: 2), {asIntegerProxy}, (assembly literals last: 2).
"Do this by looking for index of pushReceiverVariable: and replacing it by pushSelf, send asInteger"
newInsts := (assembly instructions piecesCutWhere:
[:msgOrLabelAssoc :nextInst|
msgOrLabelAssoc isVariableBinding not
and: [msgOrLabelAssoc selector == #pushReceiverVariable:]]) fold:
[:a :b|
a allButLast,
{ Message selector: #pushReceiver.
Message
selector: #send:super:numArgs:
arguments: {asIntegerProxy. false. 0}},
b].
assembly instructions: newInsts.
newMethod := assembly assemble.
self assert: clone numLiterals + 1 = newMethod numLiterals.
^self
installableMethodFor: newMethod
selector: clone selector
className: #Character
isMeta: false!
----- Method: SpurBootstrap>>reportSizes (in category 'bootstrap image') -----
reportSizes
| change oldAvgBytes newAvgBytes |
change := newHeapSize - oldHeapSize / oldHeapSize.
oldAvgBytes := oldHeapSize asFloat / oldHeapNumObjs.
Transcript
nextPutAll: 'done.'; cr;
nextPutAll: 'old heap size: '; nextPutAll: oldHeapSize asStringWithCommas; tab;
nextPutAll: ' (avg obj bytes '; print: oldAvgBytes maxDecimalPlaces: 2; nextPutAll: ' words '; print: oldAvgBytes / self wordSize maxDecimalPlaces: 2; nextPut: $); cr;
nextPutAll: 'initial new heap size: '; nextPutAll: newHeapSize asStringWithCommas; cr;
nextPutAll: 'change: '; print: change * 100.0 maxDecimalPlaces: 2; nextPut: $%; cr;
flush.
newHeapSize := newHeap endOfMemory
- newHeap scavenger eden limit
- newHeap totalFreeListBytes.
change := newHeapSize - oldHeapSize / oldHeapSize.
newAvgBytes := newHeapSize asFloat / newHeapNumObjs.
Transcript
nextPutAll: 'final new heap size: '; nextPutAll: newHeapSize asStringWithCommas; tab;
nextPutAll: ' (avg obj bytes '; print: newAvgBytes maxDecimalPlaces: 2; nextPutAll: ' words '; print: newAvgBytes / self wordSize maxDecimalPlaces: 2; nextPut: $); cr;
nextPutAll: 'change: '; print: change * 100.0 maxDecimalPlaces: 2; nextPut: $%; cr;
flush!
----- Method: SpurBootstrap>>saveTransformedImage (in category 'development support') -----
saveTransformedImage
ImageHeaderFlags := oldInterpreter getImageHeaderFlags.
ImageScreenSize := oldInterpreter savedWindowSize.
ImageName := oldInterpreter imageName.
newHeap coInterpreter: nil.
(newHeap class allInstVarNames select: [:ivn| ivn beginsWith: 'stat']) do:
[:ivn| newHeap instVarNamed: ivn put: 0].
TransformedImage := newHeap veryDeepCopy!
----- Method: SpurBootstrap>>scavengeImage (in category 'bootstrap image') -----
scavengeImage
"Scavenge the image to get it into a simpler state."
newHeap coInterpreter voidVMStateForSnapshotFlushingExternalPrimitivesIf: false.
newHeap flushNewSpace!
----- Method: SpurBootstrap>>selectorForPrototypeMethod: (in category 'method prototypes') -----
selectorForPrototypeMethod: protoMethod
| protoSelector |
protoSelector := protoMethod selector.
protoSelector := protoSelector last: protoSelector size
- (protoSelector indexOfSubCollection: 'PROTOTYPE')
- 'PROTOTYPE' size
+ 1.
(protoSelector beginsWith: 'Dollar') ifTrue:
[protoSelector := (Dictionary newFromPairs: #('DollarEquals:' #=))
at: protoSelector].
^protoSelector asSymbol!
----- Method: SpurBootstrap>>silenceImage (in category 'bootstrap image') -----
silenceImage
"Turn off change notifications via SystemChangeNotifier"
(self allInstancesOf: (self findClassNamed: (self findSymbol: #SystemChangeNotifier))) do:
[:obj | oldHeap storePointer: 1 ofObject: obj withValue: (oldHeap integerObjectOf: 1)]!
----- Method: SpurBootstrap>>stringFor: (in category 'bootstrap methods') -----
stringFor: aString
| string |
string := oldHeap instantiateClass: (oldHeap splObj: ClassByteString) indexableSize: aString size.
1 to: aString size do:
[:i| oldHeap storeByte: i - 1 ofObject: string withValue: (aString at: i) asInteger].
^string
!
----- Method: SpurBootstrap>>symbolClass (in category 'bootstrap methods') -----
symbolClass
^oldHeap fetchClassOfNonImm: (oldHeap splObj: SelectorDoesNotUnderstand)!
----- Method: SpurBootstrap>>transform (in category 'bootstrap image') -----
transform
self silenceImage.
self findRequiredGlobals.
self installModifiedMethods.
self recreateSpecialObjectsArray.
self initializeClasses.
self bootstrapImage.
self validate.
self rehashImage.
self followForwardingPointers.
self scavengeImage.
self freeForwarders.
self compactImage.
self reportSizes!
----- Method: SpurBootstrap>>validate (in category 'bootstrap image') -----
validate
| p n duplicates maxClassIndex savedEndOfMemory |
self assert: (reverseMap at: newHeap specialObjectsOop) = oldHeap specialObjectsOop.
self assert: (map at: oldHeap specialObjectsOop) = newHeap specialObjectsOop.
self assert: (reverseMap at: newHeap classTableRootObj ifAbsent: []) isNil.
duplicates := { 3. newHeap arrayClassIndexPun. newHeap weakArrayClassIndexPun }.
maxClassIndex := classToIndex inject: 0 into: [:a :b| a max: b].
self assert: ((newHeap arrayClassIndexPun to: maxClassIndex) select:
[:idx| | classObj |
(classObj := newHeap classOrNilAtIndex: idx) ~= newHeap nilObject
and: [(newHeap classIndexOf: classObj) = (newHeap rawHashBitsOf: classObj)]]) isEmpty.
0 to: maxClassIndex do:
[:index| | classObj |
(index <= newHeap tagMask
and: [index > newHeap isForwardedObjectClassIndexPun]) ifTrue:
[(classObj := newHeap classOrNilAtIndex: index) = newHeap nilObject
ifTrue:
[self assert: (classToIndex keyAtValue: index ifAbsent: []) isNil]
ifFalse:
[self assert: (newHeap classIndexOf: classObj) ~= (newHeap rawHashBitsOf: classObj).
(duplicates includes: index) ifFalse:
[self assert: (newHeap rawHashBitsOf: classObj) = index]]]].
classToIndex keysAndValuesDo:
[:oldClass :idx|
self assert: (newHeap rawHashBitsOf: (map at: oldClass)) = idx.
self assert: oldClass = (reverseMap at: (newHeap classAtIndex: idx))].
n := 0.
savedEndOfMemory := newHeap endOfMemory.
newHeap setEndOfMemory: newHeap freeOldSpaceStart.
newHeap allObjectsDo:
[:o|
(o <= newHeap trueObject
or: [o > lastClassTablePage]) ifTrue:
[self assert: (reverseMap includesKey: o).
self assert: (newHeap fetchClassOfNonImm: o) = (map at: (oldHeap fetchClassOfNonImm: (reverseMap at: o)))].
n := n + 1.
p := o].
newHeap setEndOfMemory: savedEndOfMemory.
self touch: p.
self assert: (n between: map size and: map size + ((imageTypes includes: 'squeak')
ifTrue: [6]
ifFalse: [10])). "+ 6 or 10 is room for freelists & classTable"
"check some class properties to ensure the format changes are correct"
self assert: (newHeap fixedFieldsOfClassFormat: (newHeap formatOfClass: newHeap classArray)) = 0.
self assert: (newHeap instSpecOfClassFormat: (newHeap formatOfClass: newHeap classArray)) = newHeap arrayFormat!
----- Method: SpurBootstrap>>wordSize (in category 'word size') -----
wordSize
^self subclassResponsibility!
----- Method: SpurBootstrap>>wordSizeMask (in category 'word size') -----
wordSizeMask
^self subclassResponsibility!
----- Method: SpurBootstrap>>writeSnapshot:ofTransformedImage:headerFlags:screenSize: (in category 'testing') -----
writeSnapshot: imageFileName ofTransformedImage: spurHeap headerFlags: headerFlags screenSize: screenSizeInteger
"The bootstrapped image typically contains a few big free chunks and one huge free chunk.
Test snapshot writing and loading by turning the largest non-huge chunks into segment bridges
and saving."
| penultimate ultimate sim |
sim := StackInterpreterSimulator onObjectMemory: spurHeap.
sim bootstrapping: true.
spurHeap
coInterpreter: sim;
setEndOfMemory: spurHeap endOfMemory + spurHeap bridgeSize. "hack; initializeInterpreter: cuts it back by bridgeSize"
sim initializeInterpreter: 0;
setImageHeaderFlagsFrom: headerFlags;
setSavedWindowSize: screenSizeInteger;
setDisplayForm: nil.
spurHeap allOldSpaceEntitiesDo: [:e| penultimate := ultimate. ultimate := e].
"Check that we've left behind the old, pre-pigCompact segmented save"
self assert: (spurHeap isFreeObject: penultimate) not.
spurHeap checkFreeSpace.
spurHeap runLeakCheckerForFullGC.
sim bereaveAllMarriedContextsForSnapshotFlushingExternalPrimitivesIf: true.
sim imageName: imageFileName.
sim writeImageFileIO.
Transcript cr; show: 'Done!!'!
SpurBootstrap subclass: #SpurBootstrap32
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogAttic-Bootstrapping'!
----- Method: SpurBootstrap32>>fillInBitsObject:from: (in category 'bootstrap') -----
fillInBitsObject: newObj from: oldObj
0 to: (oldHeap numSlotsOf: oldObj) - 1 do:
[:i|
newHeap
storeLong32: i
ofObject: newObj
withValue: (oldHeap fetchLong32: i ofObject: oldObj)]!
----- Method: SpurBootstrap32>>wordSize (in category 'word size') -----
wordSize
^4!
----- Method: SpurBootstrap32>>wordSizeMask (in category 'word size') -----
wordSizeMask
^3!
SimulatorHarness subclass: #SpurOldToNewMethodFormatMunger
instanceVariableNames: 'interpreter heap prototypes replacements symbolOops'
classVariableNames: ''
poolDictionaries: 'VMObjectIndices'
category: 'CogAttic-Bootstrapping'!
!SpurOldToNewMethodFormatMunger commentStamp: 'eem 11/17/2014 10:36' prior: 0!
A SpurOldToNewMethodFormatMunger is a one-off for mirating a Spur image prior to the two formats to single format CompiledMethod header putsch.
!
----- Method: SpurOldToNewMethodFormatMunger>>cloneArrayLiteral: (in category 'munging') -----
cloneArrayLiteral: anArray
"Currently serves only to clone the #(0 0) literal in SpaceTallyPROTOTYPEspaceForInstancesOf:"
| array |
array := heap instantiateClass: (heap splObj: ClassArray) indexableSize: anArray size.
1 to: anArray size do:
[:i| | lit |
lit := anArray at: i.
lit class caseOf: {
[SmallInteger] -> [heap
storePointerUnchecked: i - 1
ofObject: array
withValue: (heap integerObjectOf: lit)].
[ByteSymbol] -> [heap
storePointer: i - 1
ofObject: array
withValue: (symbolOops at: lit)].
[UndefinedObject] -> [heap
storePointerUnchecked: i - 1
ofObject: array
withValue: heap nilObject] }].
^array
!
----- Method: SpurOldToNewMethodFormatMunger>>convertOldMethodHeader: (in category 'munging') -----
convertOldMethodHeader: methodHeader
^heap integerObjectOf:
((interpreter argumentCountOfMethodHeader: methodHeader) << 24)
+ ((interpreter temporaryCountOfMethodHeader: methodHeader) << 18)
+ ((interpreter methodHeaderIndicatesLargeFrame: methodHeader) ifTrue: [1 << 17] ifFalse: [0])
+ ((heap primitiveIndexOfMethodHeader: methodHeader) > 0 ifTrue: [1 << 16] ifFalse: [0])
+ (heap literalCountOfMethodHeader: methodHeader)!
----- Method: SpurOldToNewMethodFormatMunger>>incrementPCField:ofObject:by: (in category 'munging') -----
incrementPCField: fieldIndex ofObject: newObj by: n
| value |
value := heap fetchPointer: fieldIndex ofObject: newObj.
(heap isIntegerObject: value)
ifTrue:
[heap
storePointerUnchecked: fieldIndex
ofObject: newObj
withValue: (heap integerObjectOf: n + (heap integerValueOf: value))]
ifFalse:
[self assert: value = heap nilObject]!
----- Method: SpurOldToNewMethodFormatMunger>>indexOfSelector:in: (in category 'munging') -----
indexOfSelector: selectorOop in: methodDict
SelectorStart to: (heap numSlotsOf: methodDict) - 1 do:
[:i|
(heap fetchPointer: i ofObject: methodDict) = selectorOop ifTrue:
[^i]].
self error: 'could not find selector in method dict'!
----- Method: SpurOldToNewMethodFormatMunger>>installableMethodFor:selector:siblingMethod: (in category 'munging') -----
installableMethodFor: methodWithSource selector: selectorOop siblingMethod: sibling
| method classOop clone delta numBytes |
method := methodWithSource copyWithTempsFromMethodNode: methodWithSource methodNode.
delta := (method primitive > 0
and: [(method at: method initialPC) ~= method methodClass callPrimitiveCode])
ifTrue: [3]
ifFalse: [0].
clone := heap
allocateSlots: (heap numSlotsForBytes: (numBytes := method size) + delta)
format: (heap compiledMethodFormatForNumBytes: numBytes + delta)
classIndex: (heap classIndexOf: sibling).
classOop := interpreter methodClassOf: sibling.
method methodClass isMeta ifTrue:
[classOop := heap fetchPointer: interpreter thisClassIndex ofObject: classOop].
heap storePointer: 0
ofObject: clone
withValue: (self methodHeaderForMethod: method).
1 to: method numLiterals - 2 do:
[:i|
heap storePointer: i
ofObject: clone
withValue: (self literalFor: (method literalAt: i) inClass: classOop)].
heap
storePointer: method numLiterals - 1
ofObject: clone
withValue: selectorOop;
storePointer: method numLiterals
ofObject: clone
withValue: (interpreter methodClassAssociationOf: sibling).
delta > 0 ifTrue:
[heap
storeByte: method initialPC - 1 ofObject: clone withValue: 139;
storeByte: method initialPC + 0 ofObject: clone withValue: (method primitive bitAnd: 255);
storeByte: method initialPC + 1 ofObject: clone withValue: (method primitive bitShift: -8)].
method initialPC to: method size do:
[:i|
heap storeByte: i - 1 + delta ofObject: clone withValue: (method at: i)].
^clone!
----- Method: SpurOldToNewMethodFormatMunger>>literalFor:inClass: (in category 'munging') -----
literalFor: aLiteral inClass: classOop
| bindingOrNil |
aLiteral isSymbol ifTrue:
[^symbolOops at: aLiteral].
aLiteral isString ifTrue:
[^heap stringForCString: aLiteral].
(aLiteral isInteger and: [aLiteral class == SmallInteger]) ifTrue:
[^heap integerObjectOf: aLiteral].
aLiteral isFloat ifTrue:
[^heap floatObjectOf: aLiteral].
aLiteral isArray ifTrue:
[^self cloneArrayLiteral: aLiteral].
self assert: aLiteral isVariableBinding.
"interpreter
ensureDebugAtEachStepBlock;
instVarNamed: 'printBytecodeAtEachStep' put: true;
instVarNamed: 'printFrameAtEachStep' put: true."
bindingOrNil := self interpreter: interpreter
object: classOop
perform: (symbolOops at: #bindingOf:)
withArguments: {symbolOops at: aLiteral key}.
bindingOrNil ~= heap nilObject ifTrue:
[^bindingOrNil].
self error: 'couldn''t find literal ', aLiteral printString!
----- Method: SpurOldToNewMethodFormatMunger>>mapPCs (in category 'munging') -----
mapPCs
| cbc cmc |
cmc := 36.
cbc := 37.
heap allObjectsDo:
[:obj| | ci |
ci := heap classIndexOf: obj.
(ci <= 37 and: [ci >= 36]) ifTrue:
[ci = 37 ifTrue: [self mungeClosure: obj].
ci = 36 ifTrue: [self mungeContext: obj]]]!
----- Method: SpurOldToNewMethodFormatMunger>>methodHeaderForMethod: (in category 'munging') -----
methodHeaderForMethod: method
^heap integerObjectOf:
(method numArgs << 24)
+ (method numTemps << 18)
+ (method frameSize > method class smallFrameSize ifTrue: [1 << 17] ifFalse: [0])
+ (method primitive > 0 ifTrue: [1 << 16] ifFalse: [0])
+ method numLiterals!
----- Method: SpurOldToNewMethodFormatMunger>>munge: (in category 'public access') -----
munge: imageName
interpreter := StackInterpreterSimulator newWithOptions: #(ObjectMemory Spur32BitMemoryManager).
interpreter desiredNumStackPages: 4; initStackPages.
heap := interpreter objectMemory.
self assert: heap class == Spur32BitMMLESimulator.
SpurOldFormat32BitMMLESimulator adoptInstance: heap.
interpreter openOn: imageName extraMemory: 0.
self mapPCs.
self preparePrototypes.
self updateAndForwardMethods.
self snapshot!
----- Method: SpurOldToNewMethodFormatMunger>>mungeClosure: (in category 'munging') -----
mungeClosure: obj
| method |
method := heap
fetchPointer: MethodIndex
ofObject: (heap
fetchPointer: ClosureOuterContextIndex
ofObject: obj).
(heap primitiveIndexOfMethodHeader: (heap methodHeaderOf: method)) > 0 ifTrue:
[self incrementPCField: ClosureStartPCIndex ofObject: obj by: 3]!
----- Method: SpurOldToNewMethodFormatMunger>>mungeContext: (in category 'munging') -----
mungeContext: obj
| method |
method := heap fetchPointer: MethodIndex ofObject: obj.
(heap primitiveIndexOfMethodHeader: (heap methodHeaderOf: method)) > 0 ifTrue:
[self incrementPCField: InstructionPointerIndex ofObject: obj by: 3]!
----- Method: SpurOldToNewMethodFormatMunger>>mungePrimitiveMethod: (in category 'munging') -----
mungePrimitiveMethod: obj
| numBytes copy firstByteIndex primIndex numPointerSlots header |
numBytes := heap byteSizeOf: obj.
copy := heap allocateSlotsInOldSpace: (heap numSlotsForBytes: numBytes + 3)
format: (heap compiledMethodFormatForNumBytes: numBytes + 3)
classIndex: (heap classIndexOf: obj).
header := heap methodHeaderOf: obj.
numPointerSlots := (heap literalCountOfMethodHeader: header) + LiteralStart.
heap
storePointerUnchecked: 0
ofObject: copy
withValue: (self convertOldMethodHeader: header).
1 to: numPointerSlots - 1 do:
[:i|
heap storePointer: i
ofObject: copy
withValue: (heap fetchPointer: i ofObject: obj)].
primIndex := heap primitiveIndexOfMethodHeader: header.
firstByteIndex := numPointerSlots * heap bytesPerOop.
heap
storeByte: firstByteIndex + 0 ofObject: copy withValue: 139;
storeByte: firstByteIndex + 1 ofObject: copy withValue: (primIndex bitAnd: 255);
storeByte: firstByteIndex + 2 ofObject: copy withValue: (primIndex bitShift: -8).
firstByteIndex to: numBytes - 1 do:
[:i|
heap storeByte: i + 3 ofObject: copy withValue: (heap fetchByte: i ofObject: obj)].
heap forward: obj to: copy.
^copy!
----- Method: SpurOldToNewMethodFormatMunger>>preparePrototypes (in category 'munging') -----
preparePrototypes
replacements := OrderedCollection new.
heap classTableObjectsDo:
[:class| | name isMeta |
name := heap
fetchPointer: interpreter classNameIndex
ofObject: ((isMeta := (heap numSlotsOf: class) = interpreter metaclassNumSlots)
ifTrue: [heap fetchPointer: interpreter thisClassIndex ofObject: class]
ifFalse: [class]).
name := interpreter stringOf: name.
self prototypeClassNameMetaSelectorMethodDo:
[:protoClassName :protoIsMeta :selector :method|
(protoClassName = name
and: [protoIsMeta = isMeta]) ifTrue:
[replacements addLast: {class. selector. method}]]]!
----- Method: SpurOldToNewMethodFormatMunger>>prototypeClassNameMetaSelectorMethodDo: (in category 'munging') -----
prototypeClassNameMetaSelectorMethodDo: quaternaryBlock
prototypes ifNil:
[prototypes := OrderedCollection new.
SpurBootstrap new prototypeClassNameMetaSelectorMethodDo:
[:className :isMeta :selector :method|
(#(BytecodeEncoder CompiledMethod EncoderForSqueakV4PlusClosures
InstructionClient InstructionStream MethodNode) includes: className) ifTrue:
[prototypes addLast: {className. isMeta. selector. method}]]].
prototypes do: [:tuple| quaternaryBlock valueWithArguments: tuple]!
----- Method: SpurOldToNewMethodFormatMunger>>replaceMethods (in category 'munging') -----
replaceMethods
| byteSymbolClassIndex symbols symbolSizes |
byteSymbolClassIndex := heap classIndexOf: (heap splObj: SelectorDoesNotUnderstand).
symbols := Set with: #bindingOf:.
replacements do:
[:tuple| | method adder |
symbols add: tuple second.
method := tuple last.
adder := [:lit|
(lit isSymbol and: [lit ~~ method selector]) ifTrue: [symbols add: lit].
(lit isVariableBinding and: [lit key isSymbol]) ifTrue: [symbols add: lit key].
lit isArray ifTrue: [lit do: adder]].
method literals do: adder].
symbolSizes := symbols collect: [:ea| ea size].
symbolOops := Dictionary new.
heap allObjectsDo:
[:obj| | sz |
((heap classIndexOf: obj) = byteSymbolClassIndex
and: [symbolSizes includes: (sz := heap numBytesOf: obj)]) ifTrue:
[symbols do:
[:s|
(sz = s size
and: [(interpreter stringOf: obj) = s]) ifTrue:
[symbolOops at: s put: obj]]]].
replacements do:
[:tuple|
[:classOop :selector :method| | replacement methodDict methodArray index |
methodDict := heap fetchPointer: MethodDictionaryIndex ofObject: classOop.
methodArray := heap fetchPointer: MethodArrayIndex ofObject: methodDict.
index := (0 to: (heap numSlotsOf: methodArray) - 1) detect: [:i| (heap fetchPointer: i ofObject: methodArray) ~= heap nilObject].
replacement := self installableMethodFor: method
selector: (symbolOops at: selector)
siblingMethod: (heap fetchPointer: index ofObject: methodArray).
index := self indexOfSelector: (symbolOops at: selector) in: methodDict.
heap
storePointer: index - SelectorStart
ofObject: methodArray
withValue: replacement] valueWithArguments: tuple]!
----- Method: SpurOldToNewMethodFormatMunger>>snapshot (in category 'saving') -----
snapshot
Spur32BitMMLESimulator adoptInstance: heap.
interpreter imageName: 'munged-', (FileDirectory default localNameFor: interpreter imageName).
[heap parent: heap; setCheckForLeaks: 15; garbageCollectForSnapshot]
on: Halt
do: [:ex|
"suppress halts from the usual suspects (development time halts)"
(#(fullGC globalGarbageCollect) includes: ex signalerContext sender selector)
ifTrue: [ex resume]
ifFalse: [ex pass]].
interpreter
setDisplayForm: nil; "gets it to use savedWindowSize"
writeImageFileIO.
Transcript cr; show: 'Done!!'!
----- Method: SpurOldToNewMethodFormatMunger>>updateAndForwardMethods (in category 'munging') -----
updateAndForwardMethods
| new now lastDotTime |
new := Set new: 1000.
lastDotTime := Time now asSeconds.
heap allObjectsDo:
[:obj|
((heap isCompiledMethod: obj)
and: [(new includes: obj) not]) ifTrue:
[| header |
(heap primitiveIndexOfMethodHeader: (header := heap methodHeaderOf: obj)) > 0
ifTrue:
[new add: (self mungePrimitiveMethod: obj).
(now := Time now asSeconds) > lastDotTime ifTrue:
[Transcript nextPut: $.; flush.
lastDotTime := now]]
ifFalse:
[heap
storePointerUnchecked: 0
ofObject: obj
withValue: (self convertOldMethodHeader: header)]]].
Spur32BitMMLESimulator adoptInstance: interpreter objectMemory.
self withExecutableInterpreter: interpreter
do: [self replaceMethods]!
CogScripts subclass: #CogScriptsAttic
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogAttic-Scripts'!
----- Method: CogScriptsAttic class>>createSVMTree (in category 'separate vm scripts') -----
createSVMTree
"Create the parallel StackInterpreterS, CoInterpreterS tree in which
objectMemory is an inst var rather than ObjectMemory et al being a superclass"
"CogScripts createSVMTree"
| changes map |
changes := Cursor execute showWhile: [self changedMethodsForObjectMemorySends].
map := Cursor execute showWhile: [self createStackInterpreterSHierarchy].
(ChangeSet superclassOrder: (StackInterpreter withAllSubclasses select: [:c| map includesKey: c]) asArray) do:
[:sourceClass|
sourceClass selectors do:
[:sel| | destClass source stamp |
destClass := map
at: (((sel beginsWith: 'primitive')
and: [sel last ~~ $:
and: [sel ~~ #primitiveFail]])
ifTrue: [{sourceClass. #primitives}]
ifFalse: [sourceClass])
ifAbsent: [map at: sourceClass].
(changes detect: [:c| c changeClass == sourceClass and: [c selector = sel]] ifNone: [])
ifNotNil:
[:change|
source := change source.
stamp := Utilities changeStamp copyReplaceAll: Utilities authorInitials with: Utilities authorInitials, ' (objmem refactor)']
ifNil:
[source := sourceClass sourceCodeAt: sel.
stamp := (sourceClass >> sel) timeStamp].
[destClass
compile: source
classified: (sourceClass whichCategoryIncludesSelector: sel)
withStamp: stamp
notifying: nil]
on: SyntaxErrorNotification
do: [:ex| | newBrowser |
newBrowser := Browser new setClass: destClass selector: nil.
newBrowser selectMessageCategoryNamed: (sourceClass whichCategoryIncludesSelector: sel).
Browser
openBrowserView: (newBrowser openMessageCatEditString: source)
label: 'category "', (sourceClass whichCategoryIncludesSelector: sel), '" in ', destClass name]]].
self readWriteVars, self readOnlyVars do:
[:sym|
(NewObjectMemory whichClassIncludesSelector: sym) ifNil:
[(NewObjectMemory whichClassDefinesInstVar: sym asString)
compile: sym, (String with: Character cr with: Character tab with: $^), sym
classified: #accessing]].
self readWriteVars do:
[:sym| | setter | setter := (sym, ':') asSymbol.
(NewObjectMemory whichClassIncludesSelector: setter) ifNil:
[(NewObjectMemory whichClassDefinesInstVar: sym asString)
compile: setter, ' aValue', (String with: Character cr with: Character tab with: $^), sym, ' := aValue'
classified: #accessing]].!
----- Method: CogScriptsAttic class>>createStackInterpreterSHierarchy (in category 'separate vm scripts') -----
createStackInterpreterSHierarchy
"Create the parallel StackInterpreterS, CoInterpreterS tree (without methods).
Answer a Dictionary maping source class to dest class with {source. #primitives} -> dest
for the added primitives classes."
| map |
(Smalltalk classNamed: #StackInterpreterS) ifNotNil:
[:sis|
(Object confirm: 'StackInterpreterS exists, nuke?') ifTrue:
[(ChangeSet superclassOrder: sis withAllSubclasses asArray) reverseDo:
[:sissc| sissc removeFromSystemUnlogged]]].
map := Dictionary new.
(ChangeSet superclassOrder: (StackInterpreter withAllSubclasses
remove: SchizophrenicClosureFormatStackInterpreter;
yourself) asArray) do:
[:sisc| | def |
def := sisc definition.
def := sisc == StackInterpreter
ifTrue: [((def copyReplaceAll: sisc superclass name, ' ' with: ObjectMemory superclass name, ' ')
copyReplaceAll: 'instanceVariableNames: ''' with: 'instanceVariableNames: ''objectMemory ')
copyReplaceAll: 'poolDictionaries: ''' with: 'poolDictionaries: ''', (ObjectMemory poolDictionaryNames fold: [:a :b| a, ' ', b]), ' ']
ifFalse: [def copyReplaceAll: sisc superclass name, ' ' with: sisc superclass name, 'S '].
def := def copyReplaceAll: sisc name printString with: sisc name printString, 'S'.
map at: sisc put: (Compiler evaluate: def)].
map at: {StackInterpreter. #primitives}
put: (Compiler
evaluate: 'StackInterpreterS subclass: #StackInterpreterSPrimitives
instanceVariableNames: ''''
classVariableNames: ''''
poolDictionaries: ''''
category: ''VMMaker-Interpreter''');
at: {CoInterpreter. #primitives}
put: (Compiler
evaluate: 'CoInterpreterS subclass: #CoInterpreterSPrimitives
instanceVariableNames: ''''
classVariableNames: ''''
poolDictionaries: ''''
category: ''VMMaker-Interpreter''');
at: {StackInterpreter. #objmem}
put: (Compiler
evaluate: 'NewObjectMemory subclass: #NewObjectMemoryS
instanceVariableNames: ''coInterpreter''
classVariableNames: ''''
poolDictionaries: ''''
category: ''VMMaker-Interpreter''');
at: {CoInterpreter. #objmem}
put: (Compiler
evaluate: 'NewObjectMemoryS subclass: #NewCoObjectMemoryS
instanceVariableNames: ''''
classVariableNames: ''''
poolDictionaries: ''''
category: ''VMMaker-Interpreter''').
"reparent subclasses underneath StackInterpreterSPrimitives & CoInterpreterSPrimitives"
#(StackInterpreterS CoInterpreterS) do:
[:cn|
((Smalltalk classNamed: cn) subclasses reject: [:c| c name endsWith: 'Primitives']) do:
[:sisc| | def |
def := sisc definition.
def := def copyReplaceAll: cn, ' ' with: cn, 'Primitives '.
Compiler evaluate: def]].
^map!
More information about the Vm-dev
mailing list