Hi Esteban,
On Fri, Mar 31, 2017 at 12:15 AM, Eliot Miranda <eliot.miranda(a)gmail.com>
wrote:
>
> On Mar 30, 2017, at 2:58 AM, Pavel Krivanek <pavel.krivanek(a)gmail.com>
> wrote:
>
> Yes, the same priority. See:
>
> The VM may have issues with clock jitter due to the heartbeat thread
> not running at elevated priority.
>
>
> It better /not/ be. This is wrong. The heartbeat thread /must/ run at a
> higher priority for the VM not to lock up when it becomes compute bound.
I
> thought the resolution was that the VM /will/ try and raise the priority
if
> the heartbeat thread but will /not/ exit if it fails. This is /very/
> different from not trying to raise the priority at all.
>
> The resolution I thought we had reached means that if correctly installed
> the VM can work correctly, and will continue to work correctly if and when
> linux removes the annoyance of the conf files. The resolution you
describe
> Pavel (I hope inaccurately) means the threaded heartbeat VM will never
work
> correctly.
>
> One other thing. I know "threaded heartbeat" is verbose, but I would
really
> appreciate it if we could reserve "threaded vm" to mean a vm that
> multiplexes Smalltalk processes above native threads, even if not
> concurrently. This is the threaded ffi plan which we have a good chance
of
> realizing this year.
It took me a while to realize that a contributing factor of the language
we see about this in pharo-dev is the file naming at
http://files.pharo.org/vm/pharo-spur32/linux/.
which seemed quite reasonable, but it light of Eliot's request,
perhaps the following naming would help distinguish
the "threaded heartbeat" from "threaded vm"
...-i386threadbeat-
...-i386timerbeat-...
btw, I dropped the "i" from the timerbeat vm since timer_settime() might
be a good alternative to setitimer() to avoid conflict with third-party
alarm handling.
cheers -ben
(sorry to add another serving to your plate)
1
0
Hi guys,
I was reading the other thread this morning and I figure out I have an easy way of solve all problems (besides that damn String primitive problem that still needs to be fixed).
This is the thing:
If I can add special deploy script for Pharo (with my keys, so is not soooo cool, but is not so bad either), to deploy osvm build VMs into Pharo infrastructure, then I can
1) use that as our “stable” builds.
2) keep having the rest of the process unaltered, so we will keep the validation infrastructure and the nightly builds (that we call “latest”).
and then, everything will be “as it should be”.
what do you think, can I go ahead and modify that part?
Esteban
4
6
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2189.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.2189
Author: eem
Time: 5 April 2017, 1:14:07.351736 pm
UUID: 5f33d87d-a790-44c5-8250-aae6fba7da74
Ancestors: VMMaker.oscog-eem.2188
RegisterAllocatingCogit/SistaRegisterAllocatingCogit
Fix slips in RegisterAllocatingCogit>>genSpecialSelectorComparison (no need to juggle assigned registers) and mergeCurrentSimStackWith:forwards: (methodOrBlockNumTemps is the loop limit, not methodOrBlockNumArgs). Fix moveVolatileSimStackEntriesToRegisters to observe the registers assigned to temps.
Copy the merge logic into SistaRegisterAllocatingCogit>>genSpecialSelectorComparison
Add more places to check the duplicateRegisterAssignmentsInTemporaries deny.
Rewrite RegisterAllocatingCogit>>resetSimStack: to avoid a spurious assert-fail when preparing the second compilation pass.
SistaCogitClone's methods have also been auto-updated.
=============== Diff against VMMaker.oscog-eem.2188 ===============
Item was added:
+ ----- Method: RegisterAllocatingCogit>>allocatedRegisters (in category 'simulation stack') -----
+ allocatedRegisters
+ | regsSet |
+ self assert: needsFrame.
+ regsSet := 0.
+ 0 to: methodOrBlockNumTemps do:
+ [:i|
+ regsSet := regsSet bitOr: (self simStackAt: i) registerMask].
+ ^regsSet!
Item was changed:
----- Method: RegisterAllocatingCogit>>compileAbstractInstructionsFrom:through: (in category 'compile abstract instructions') -----
compileAbstractInstructionsFrom: start through: end
"Loop over bytecodes, dispatching to the generator for each bytecode, handling fixups in due course.
Override to provide a development-time only escape for failed merges due to partially implemented
parallel move. Override to recompile after a loop requiring a merge is detected."
^[| result initialOpcodeIndex initialCounterIndex initialIndexOfIRC |
compilationPass := 1.
initialOpcodeIndex := opcodeIndex.
initialCounterIndex := self maybeCounterIndex."for SistaCogit"
literalsManager saveForRecompile.
NewspeakVM ifTrue:
[initialIndexOfIRC := indexOfIRC].
[recompileForLoopRegisterAssignments := false.
result := super compileAbstractInstructionsFrom: start through: end.
result = 0 and: [recompileForLoopRegisterAssignments]]
whileTrue:
+ [self assert: compilationPass <= 2.
+ self reinitializeAllButBackwardFixupsFrom: start through: end.
- [self reinitializeAllButBackwardFixupsFrom: start through: end.
self resetSimStack: start.
self reinitializeOpcodesFrom: initialOpcodeIndex to: opcodeIndex - 1.
compilationPass := compilationPass + 1.
nextFixup := 0.
opcodeIndex := initialOpcodeIndex.
self maybeSetCounterIndex: initialCounterIndex. "For SistaCogit"
literalsManager resetForRecompile.
NewspeakVM ifTrue:
[indexOfIRC := initialIndexOfIRC]].
result]
on: Notification
do: [:ex|
ex tag == #failedMerge ifTrue:
[coInterpreter transcript
ensureCr; nextPutAll: 'FAILED MERGE IN ';
nextPutAll: (coInterpreter nameOfClass: (coInterpreter methodClassOf: methodObj));
nextPutAll: '>>#'; nextPutAll: (coInterpreter stringOf: (coInterpreter maybeSelectorOfMethod: methodObj));
flush.
^ShouldNotJIT].
ex pass]!
Item was changed:
----- Method: RegisterAllocatingCogit>>genSpecialSelectorComparison (in category 'bytecode generators') -----
genSpecialSelectorComparison
| nextPC postBranchPC targetPC primDescriptor branchDescriptor
rcvrIsInt rcvrIsConst argIsIntConst argInt jumpNotSmallInts inlineCAB index rcvrReg argReg branchToTarget needMergeToContinue needMergeToTarget |
<var: #primDescriptor type: #'BytecodeDescriptor *'>
<var: #branchDescriptor type: #'BytecodeDescriptor *'>
<var: #jumpNotSmallInts type: #'AbstractInstruction *'>
primDescriptor := self generatorAt: byte0.
argIsIntConst := self ssTop type = SSConstant
and: [objectMemory isIntegerObject: (argInt := self ssTop constant)].
rcvrIsInt := ((rcvrIsConst := (self ssValue: 1) type = SSConstant)
and: [objectMemory isIntegerObject: (self ssValue: 1) constant])
or: [self mclassIsSmallInteger and: [(self ssValue: 1) isSameEntryAs: (self addressOf: simSelf)]].
(argIsIntConst and: [rcvrIsInt and: [rcvrIsConst]]) ifTrue:
[^self genStaticallyResolvedSpecialSelectorComparison].
self extractMaybeBranchDescriptorInto: [ :descr :next :postBranch :target |
branchDescriptor := descr. nextPC := next. postBranchPC := postBranch. targetPC := target ].
"Only interested in inlining if followed by a conditional branch."
inlineCAB := branchDescriptor isBranchTrue or: [branchDescriptor isBranchFalse].
"Further, only interested in inlining = and ~= if there's a SmallInteger constant involved.
The relational operators successfully statically predict SmallIntegers; the equality operators do not."
(inlineCAB and: [primDescriptor opcode = JumpZero or: [primDescriptor opcode = JumpNonZero]]) ifTrue:
[inlineCAB := argIsIntConst or: [rcvrIsInt]].
inlineCAB ifFalse:
[^self genSpecialSelectorSend].
"In-line the comparison and the jump, but if the types are not SmallInteger then we will need
to do a send and fall through to the following conditional branch. Since we're allocating values
in registers we would like to keep those registers live on the inlined path and reload registers
along the non-inlined send path. The merge logic at the branch destinations handles this."
argIsIntConst
ifTrue:
[rcvrReg := self allocateRegForStackEntryAt: 1.
(self ssValue: 1) popToReg: rcvrReg.
argReg := NoReg]
ifFalse:
[self allocateRegForStackTopTwoEntriesInto: [:rTop :rNext| argReg := rTop. rcvrReg := rNext].
- rcvrReg = Arg0Reg ifTrue:
- [rcvrReg := argReg. argReg := Arg0Reg].
self ssTop popToReg: argReg.
(self ssValue: 1) popToReg: rcvrReg].
self ssPop: 2.
jumpNotSmallInts := (rcvrIsInt and: [argIsIntConst]) ifFalse:
[argIsIntConst
ifTrue: [objectRepresentation genJumpNotSmallInteger: rcvrReg]
ifFalse:
[rcvrIsInt
ifTrue: [objectRepresentation genJumpNotSmallInteger: argReg]
ifFalse: [objectRepresentation genJumpNotSmallIntegersIn: rcvrReg and: argReg scratch: TempReg]]].
argIsIntConst
ifTrue: [self CmpCq: argInt R: rcvrReg]
ifFalse: [self CmpR: argReg R: rcvrReg].
"self printSimStack; printSimStack: (self fixupAt: postBranchPC) mergeSimStack; printSimStack: (self fixupAt: targetPC) mergeSimStack"
"If there are merges to be performed on the forward branches we have to execute
the merge code only along the path requiring that merge, and exactly once."
needMergeToTarget := self mergeRequiredForJumpTo: targetPC.
needMergeToContinue := self mergeRequiredForJumpTo: postBranchPC.
"Cmp is weird/backwards so invert the comparison."
(needMergeToTarget and: [needMergeToContinue]) ifTrue:
[branchToTarget := self genConditionalBranch: (branchDescriptor isBranchTrue
ifTrue: [primDescriptor opcode]
ifFalse: [self inverseBranchFor: primDescriptor opcode])
operand: 0.
self Jump: (self ensureFixupAt: postBranchPC).
branchToTarget jmpTarget: self Label.
self Jump: (self ensureFixupAt: targetPC)].
(needMergeToTarget and: [needMergeToContinue not]) ifTrue:
[self genConditionalBranch: (branchDescriptor isBranchFalse
ifTrue: [primDescriptor opcode]
ifFalse: [self inverseBranchFor: primDescriptor opcode])
operand: (self ensureFixupAt: postBranchPC) asUnsignedInteger.
self Jump: (self ensureFixupAt: targetPC)].
(needMergeToTarget not and: [needMergeToContinue]) ifTrue:
[self genConditionalBranch: (branchDescriptor isBranchTrue
ifTrue: [primDescriptor opcode]
ifFalse: [self inverseBranchFor: primDescriptor opcode])
operand: (self ensureFixupAt: targetPC) asUnsignedInteger.
self Jump: (self ensureFixupAt: postBranchPC)].
(needMergeToTarget or: [needMergeToContinue]) ifFalse:
[self genConditionalBranch: (branchDescriptor isBranchTrue
ifTrue: [primDescriptor opcode]
ifFalse: [self inverseBranchFor: primDescriptor opcode])
operand: (self ensureFixupAt: targetPC) asUnsignedInteger.
self Jump: (self ensureFixupAt: postBranchPC)].
jumpNotSmallInts ifNil:
[self annotateInstructionForBytecode.
deadCode := true.
^0].
jumpNotSmallInts jmpTarget: self Label.
self ssFlushTo: simStackPtr.
rcvrReg = Arg0Reg
ifTrue:
[argReg = ReceiverResultReg
ifTrue: [self SwapR: Arg0Reg R: Arg0Reg Scratch: TempReg. argReg := Arg0Reg]
ifFalse: [self MoveR: rcvrReg R: ReceiverResultReg].
rcvrReg := ReceiverResultReg].
argIsIntConst
ifTrue: [self MoveCq: argInt R: Arg0Reg]
ifFalse: [argReg ~= Arg0Reg ifTrue: [self MoveR: argReg R: Arg0Reg]].
rcvrReg ~= ReceiverResultReg ifTrue: [self MoveR: rcvrReg R: ReceiverResultReg].
index := byte0 - self firstSpecialSelectorBytecodeOffset.
^self genMarshalledSend: index negated - 1 numArgs: 1 sendTable: ordinarySendTrampolines!
Item was changed:
----- Method: RegisterAllocatingCogit>>liveRegisters (in category 'simulation stack') -----
liveRegisters
| regsSet |
+ self assert: needsFrame.
regsSet := 0.
0 to: simStackPtr do:
[:i|
regsSet := regsSet bitOr: (self simStackAt: i) registerMask].
LowcodeVM ifTrue:
[(simNativeSpillBase max: 0) to: simNativeStackPtr do:
[:i|
regsSet := regsSet bitOr: (self simNativeStackAt: i) nativeRegisterMask]].
^regsSet!
Item was changed:
----- Method: RegisterAllocatingCogit>>mergeCurrentSimStackWith:forwards: (in category 'bytecode generator support') -----
mergeCurrentSimStackWith: fixup forwards: forwards
"At a merge point the cogit expects the stack to be in the same state as mergeSimStack.
mergeSimStack is the state as of some jump forward or backward to this point. So make simStack agree
with mergeSimStack (it is, um, problematic to plant code at the jump).
Values may have to be assigned to registers. Registers may have to be swapped.
The state of optStatus must agree.
Generate code to merge the current simStack with that of the target fixup,
the goal being to keep as many registers live as possible. If the merge is forwards
registers can be deassigned (since registers are always written to temp vars).
But if backwards, nothing can be deassigned, and the state /must/ reflect the target."
"self printSimStack; printSimStack: fixup mergeSimStack"
"abstractOpcodes object copyFrom: startIndex to: opcodeIndex"
<var: #fixup type: #'BytecodeFixup *'>
| startIndex mergeSimStack currentEntry targetEntry writtenToRegisters |
<var: #mergeSimStack type: #'SimStackEntry *'>
<var: #targetEntry type: #'SimStackEntry *'>
<var: #currentEntry type: #'SimStackEntry *'>
(mergeSimStack := fixup mergeSimStack) ifNil: [^self].
startIndex := opcodeIndex. "for debugging"
"Assignments amongst the registers must be made in order to avoid overwriting.
If necessary exchange registers amongst simStack's entries to resolve any conflicts."
self resolveRegisterOrderConflictsBetweenCurrentSimStackAnd: mergeSimStack.
(self asserta: (self conflictsResolvedBetweenSimStackAnd: mergeSimStack)) ifFalse:
[Notification new tag: #failedMerge; signal].
+ "Compute written to registers. Perhaps we should use 0 in place of methodOrBlockNumTemps
- "Compute written to registers. Perhaps we should use 0 in place of methodOrBlockNumArgs
but Smalltalk does not assign to arguments."
writtenToRegisters := 0.
(self pushForMergeWith: mergeSimStack)
ifTrue:
+ [methodOrBlockNumTemps to: simStackPtr do:
- [methodOrBlockNumArgs to: simStackPtr do:
[:i|
currentEntry := self simStack: simStack at: i.
targetEntry := self simStack: mergeSimStack at: i.
writtenToRegisters := writtenToRegisters bitOr: targetEntry registerMask.
(currentEntry reconcileForwardsWith: targetEntry) ifTrue:
+ [self assert: i >= methodOrBlockNumTemps.
- [self assert: i >= methodOrBlockNumArgs.
self deassignRegisterForTempVar: targetEntry in: mergeSimStack.
targetEntry
type: SSRegister;
register: targetEntry liveRegister].
"Note, we could update the simStack and spillBase here but that is done in restoreSimStackAtMergePoint:
spilled ifFalse:
[simSpillBase := i - 1].
simStack
at: i
put: (self
cCode: [mergeSimStack at: i]
inSmalltalk: [(mergeSimStack at: i) copy])"]]
ifFalse:
+ [simStackPtr to: methodOrBlockNumTemps by: -1 do:
- [simStackPtr to: methodOrBlockNumArgs by: -1 do:
[:i|
currentEntry := self simStack: simStack at: i.
targetEntry := self simStack: mergeSimStack at: i.
writtenToRegisters := writtenToRegisters bitOr: targetEntry registerMask.
(currentEntry reconcileForwardsWith: targetEntry) ifTrue:
+ [self assert: i >= methodOrBlockNumTemps.
- [self assert: i >= methodOrBlockNumArgs.
self deassignRegisterForTempVar: targetEntry in: mergeSimStack.
targetEntry
type: SSRegister;
register: targetEntry liveRegister].
"Note, we could update the simStack and spillBase here but that is done in restoreSimStackAtMergePoint:
spilled ifFalse:
[simSpillBase := i - 1].
simStack
at: i
put: (self
cCode: [mergeSimStack at: i]
inSmalltalk: [(mergeSimStack at: i) copy])"]].
"Note that since we've deassigned any conflicts beyond the temps above we need only compare the temps here."
methodOrBlockNumTemps - 1 to: 0 by: -1 do:
[:i|
targetEntry := self simStack: mergeSimStack at: i.
(targetEntry registerMask noMask: writtenToRegisters) ifTrue:
[currentEntry := self simStack: simStack at: i.
writtenToRegisters := writtenToRegisters bitOr: targetEntry registerMask.
(currentEntry reconcileForwardsWith: targetEntry) ifTrue:
[self assert: i >= methodOrBlockNumArgs.
self deassignRegisterForTempVar: targetEntry in: mergeSimStack]]].
optStatus isReceiverResultRegLive ifFalse:
[forwards
ifTrue: "a.k.a. fixup isReceiverResultRegSelf: (fixup isReceiverResultRegSelf and: [optStatus isReceiverResultRegLive])"
[fixup isReceiverResultRegSelf: false]
ifFalse:
[fixup isReceiverResultRegSelf ifTrue:
[self putSelfInReceiverResultReg]]]!
Item was changed:
----- Method: RegisterAllocatingCogit>>mergeWithFixupIfRequired: (in category 'simulation stack') -----
mergeWithFixupIfRequired: fixup
"If this bytecode has a fixup, some kind of merge needs to be done. There are 4 cases:
1) the bytecode has no fixup (fixup isNotAFixup)
do nothing
2) the bytecode has a non merge fixup
the fixup has needsNonMergeFixup.
The code generating non merge fixup (currently only special selector code) is responsible
for the merge so no need to do it.
We set deadCode to false as the instruction can be reached from jumps.
3) the bytecode has a merge fixup, but execution flow *cannot* fall through to the merge point.
the fixup has needsMergeFixup and deadCode = true.
ignores the current simStack as it does not mean anything
restores the simStack to the state the jumps to the merge point expects it to be.
4) the bytecode has a merge fixup and execution flow *can* fall through to the merge point.
the fixup has needsMergeFixup and deadCode = false.
Merge the state into the fixup's state via mergeCurrentSimStackWith:forwards:.
In addition, if this is a backjump merge point, we patch the fixup to hold the current simStackPtr
for later assertions. self printSimStack: fixup mergeSimStack"
<var: #fixup type: #'BytecodeFixup *'>
+ self deny: self duplicateRegisterAssignmentsInTemporaries.
+
"case 1"
fixup notAFixup ifTrue: [^0].
"case 2"
fixup isNonMergeFixup ifTrue:
[deadCode
ifTrue:
[self deny: fixup simStackPtr isNil.
simStackPtr := fixup simStackPtr.
self restoreSimStackAtMergePoint: fixup.
deadCode := false]
ifFalse:
[self flushRegistersOnlyLiveOnFallThrough: fixup].
^0].
"cases 3 and 4"
self assert: fixup isMergeFixup.
self traceMerge: fixup.
deadCode
ifTrue: [simStackPtr := fixup simStackPtr] "case 3"
ifFalse: [(fixup isBackwardBranchFixup and: [compilationPass > 1]) ifTrue:
[fixup simStackPtr: simStackPtr].
self mergeCurrentSimStackWith: fixup forwards: true]. "case 4"
"cases 3 and 4"
deadCode := false.
fixup isBackwardBranchFixup ifTrue:
[self assert: fixup mergeSimStack isNil == (compilationPass = 1).
fixup mergeSimStack ifNil:
[self setMergeSimStackOf: fixup]].
fixup targetInstruction: self Label.
self assert: simStackPtr = fixup simStackPtr.
self cCode: '' inSmalltalk:
[self assert: fixup simStackPtr = (self debugStackPointerFor: bytecodePC)].
self restoreSimStackAtMergePoint: fixup.
^0!
Item was changed:
----- Method: RegisterAllocatingCogit>>moveVolatileSimStackEntriesToRegisters (in category 'bytecode generator support') -----
moveVolatileSimStackEntriesToRegisters
"When jumping forward to a merge point the stack must be reconcilable with the state that falls through to the merge point.
We cannot easily arrange that later we add code to the branch, e.g. to spill values. Instead, any volatile contents must be
moved to registers. [In fact, that's not exactly true, consider these two code sequences:
self at: (expr ifTrue: [1] ifFalse: [2]) put: a
self at: 1 put: (expr ifTrue: [a] ifFalse: [b])
The first one needs 1 saving to a register to reconcile with 2.
The second one has 1 on both paths, but we're not clever enough to spot this case yet.]
Volatile contents are anything not spilled to the stack, because as yet we can only merge registers."
<inline: true>
+ | allocatedRegs |
<var: #desc type: #'SimStackEntry *'>
+ allocatedRegs := self allocatedRegisters.
(simSpillBase max: 0) to: simStackPtr do:
[:i| | desc reg |
desc := self simStackAt: i.
desc spilled
ifTrue: [simSpillBase := i]
ifFalse:
[desc registerOrNone = NoReg ifTrue:
+ [reg := self allocateRegNotConflictingWith: allocatedRegs.
- [reg := self allocateRegNotConflictingWith: 0.
reg = NoReg
ifTrue: [self halt] "have to spill"
+ ifFalse:
+ [desc storeToReg: reg.
+ allocatedRegs := allocatedRegs bitOr: (self registerMaskFor: reg)]]]].
+ self deny: self duplicateRegisterAssignmentsInTemporaries!
- ifFalse: [desc storeToReg: reg]]]]!
Item was changed:
----- Method: RegisterAllocatingCogit>>resetSimStack: (in category 'bytecode generator support') -----
resetSimStack: startPC
<inline: true>
simSpillBase := methodOrBlockNumTemps.
simStackPtr := methodOrBlockNumTemps - 1.
+ optStatus isReceiverResultRegLive: false.
- self voidReceiverResultRegContainsSelf.
self flushLiveRegistersForSend.
self cCode: '' inSmalltalk:
[0 to: methodOrBlockNumTemps - 1 do:
[:i|
(self simStackAt: i) bcptr: startPC]]!
Item was added:
+ ----- Method: SistaCogitClone class>>methodZoneClass (in category 'accessing class hierarchy') -----
+ methodZoneClass
+ ^SistaMethodZone!
Item was added:
+ ----- Method: SistaCogitClone>>defaultCogCodeSize (in category 'accessing') -----
+ defaultCogCodeSize
+ "Return the default number of bytes to allocate for native code at startup.
+ The actual value can be set via vmParameterAt: and/or a preference in the ini file."
+ <api>
+ ^2 * backEnd getDefaultCogCodeSize!
Item was changed:
----- Method: SistaCogitClone>>disassembleMethod:on: (in category 'disassembly') -----
disassembleMethod: surrogateOrAddress on: aStream
<doNotGenerate>
| cogMethod |
cogMethod := super disassembleMethod: surrogateOrAddress on: aStream.
(cogMethod cmType = CMMethod
and: [cogMethod counters ~= 0]) ifTrue:
[aStream nextPutAll: 'counters:'; cr.
+ 0 to: (objectRepresentation numCountersFor: cogMethod counters) - 1 do:
- numCounters := objectRepresentation numCountersFor: counters.
- 0 to: numCounters - 1 do:
[:i| | addr |
addr := i * CounterBytes + counters.
addr printOn: aStream base: 16.
aStream nextPut: $:; space.
(objectMemory long32At: addr) printOn: aStream base: 16.
aStream cr].
aStream flush]!
Item was added:
+ ----- Method: SistaCogitClone>>genAtPutInlinePrimitive: (in category 'inline primitive generators') -----
+ genAtPutInlinePrimitive: prim
+ "Unary inline primitives."
+ "SistaV1: 248 11111000 iiiiiiii mjjjjjjj Call Primitive #iiiiiiii + (jjjjjjj * 256) m=1 means inlined primitive, no hard return after execution.
+ See EncoderForSistaV1's class comment and StackInterpreter>>#trinaryInlinePrimitive:"
+ | ra1 ra2 rr adjust needsStoreCheck |
+ "The store check requires rr to be ReceiverResultReg"
+ needsStoreCheck := (objectRepresentation isUnannotatableConstant: self ssTop) not.
+ self
+ allocateRegForStackTopThreeEntriesInto: [:rTop :rNext :rThird | ra2 := rTop. ra1 := rNext. rr := rThird ]
+ thirdIsReceiver: (prim = 0 and: [ needsStoreCheck ]).
+ self assert: (rr ~= ra1 and: [rr ~= ra2 and: [ra1 ~= ra2]]).
+ self ssTop popToReg: ra2.
+ self ssPop: 1.
+ self ssTop popToReg: ra1.
+ self ssPop: 1.
+ self ssTop popToReg: rr.
+ self ssPop: 1.
+ objectRepresentation genConvertSmallIntegerToIntegerInReg: ra1.
+ "Now: ra is the variable object, rr is long, TempReg holds the value to store."
+ self flag: #TODO. "This is not really working as the immutability and store check needs to be present. "
+ prim caseOf: {
+ "0 - 1 pointerAt:put: and byteAt:Put:"
+ [0] -> [ adjust := (objectMemory baseHeaderSize >> objectMemory shiftForWord) - 1. "shift by baseHeaderSize and then move from 1 relative to zero relative"
+ adjust ~= 0 ifTrue: [ self AddCq: adjust R: ra1. ].
+ self MoveR: ra2 Xwr: ra1 R: rr.
+ "I added needsStoreCheck so if you initialize an array with a Smi such as 0 or a boolean you don't need the store check"
+ needsStoreCheck ifTrue:
+ [ self assert: needsFrame.
+ objectRepresentation genStoreCheckReceiverReg: rr valueReg: ra2 scratchReg: TempReg inFrame: true] ].
+ [1] -> [ objectRepresentation genConvertSmallIntegerToIntegerInReg: ra2.
+ adjust := objectMemory baseHeaderSize - 1. "shift by baseHeaderSize and then move from 1 relative to zero relative"
+ self AddCq: adjust R: ra1.
+ self MoveR: ra2 Xbr: ra1 R: rr.
+ objectRepresentation genConvertIntegerToSmallIntegerInReg: ra2. ].
+ }
+ otherwise: [^EncounteredUnknownBytecode].
+ self ssPushRegister: ra2.
+ ^0!
Item was changed:
----- Method: SistaCogitClone>>genBinaryInlineComparison:opFalse:destReg: (in category 'inline primitive generators') -----
genBinaryInlineComparison: opTrue opFalse: opFalse destReg: destReg
"Inlined comparison. opTrue = jump for true and opFalse = jump for false"
<var: #branchDescriptor type: #'BytecodeDescriptor *'>
| nextPC branchDescriptor targetBytecodePC postBranchPC |
self extractMaybeBranchDescriptorInto: [ :descr :next :postBranch :target |
branchDescriptor := descr. nextPC := next. postBranchPC := postBranch. targetBytecodePC := target ].
+
-
(branchDescriptor isBranchTrue or: [branchDescriptor isBranchFalse])
ifTrue: "This is the path where the inlined comparison is followed immediately by a branch"
[ (self fixupAt: nextPC) notAFixup
ifTrue: "The next instruction is dead. we can skip it."
[deadCode := true.
self ensureFixupAt: targetBytecodePC.
self ensureFixupAt: postBranchPC ]
ifFalse:
[self ssPushConstant: objectMemory trueObject]. "dummy value"
self genConditionalBranch: (branchDescriptor isBranchTrue ifTrue: [opTrue] ifFalse: [opFalse])
+ operand: (self ensureNonMergeFixupAt: targetBytecodePC) asUnsignedInteger.
+ "We can only elide the jump if the pc after nextPC is the same as postBranchPC.
+ Branch following means it may not be."
+ self nextDescriptorExtensionsAndNextPCInto:
+ [:iguana1 :iguana2 :iguana3 :followingPC| nextPC := followingPC].
+ (deadCode and: [nextPC = postBranchPC]) ifFalse:
+ [ self Jump: (self ensureNonMergeFixupAt: postBranchPC) ] ]
- operand: (self ensureNonMergeFixupAt: targetBytecodePC) asUnsignedInteger.
- deadCode ifFalse: [ self Jump: (self ensureNonMergeFixupAt: postBranchPC) ] ]
ifFalse: "This is the path where the inlined comparison is *not* followed immediately by a branch"
[| condJump jump |
condJump := self genConditionalBranch: opTrue operand: 0.
self genMoveFalseR: destReg.
jump := self Jump: 0.
condJump jmpTarget: (self genMoveTrueR: destReg).
jump jmpTarget: self Label].
^ 0!
Item was changed:
----- Method: SistaCogitClone>>genBinaryVarOpVarInlinePrimitive: (in category 'inline primitive generators') -----
genBinaryVarOpVarInlinePrimitive: prim
"Var op var version of binary inline primitives."
"SistaV1: 248 11111000 iiiiiiii mjjjjjjj Call Primitive #iiiiiiii + (jjjjjjj * 256) m=1 means inlined primitive, no hard return after execution.
See EncoderForSistaV1's class comment and StackInterpreter>>#binaryInlinePrimitive:"
<option: #SistaVM>
| ra rr adjust |
self allocateRegForStackTopTwoEntriesInto: [:rTop :rNext | ra := rTop. rr := rNext ].
self ssTop popToReg: ra.
self ssPop: 1.
self ssTop popToReg: rr.
self ssPop: 1.
prim caseOf: {
"0 through 6, +, -, *, /, //, \\, quo:, SmallInteger op SmallInteger => SmallInteger, no overflow"
[0] -> [objectRepresentation genRemoveSmallIntegerTagsInScratchReg: ra.
self AddR: ra R: rr].
[1] -> [self SubR: ra R: rr.
objectRepresentation genAddSmallIntegerTagsTo: rr].
[2] -> [self genShiftAwaySmallIntegerTagsInScratchReg: rr.
self genRemoveSmallIntegerTagsInScratchReg: ra.
self MulR: ra R: rr.
self genSetSmallIntegerTagsIn: rr].
+ "[4] -> [].
+ [5] -> [].
+ [6] -> []."
"2016 through 2020, bitAnd:, bitOr:, bitXor, bitShiftLeft:, bitShiftRight:, SmallInteger op SmallInteger => SmallInteger, no overflow"
[16] -> [ self AndR: ra R: rr ].
[17] -> [ self OrR: ra R: rr ].
[18] -> [objectRepresentation genRemoveSmallIntegerTagsInScratchReg: ra.
self XorR: ra R: rr. ].
[19] -> [ objectRepresentation genConvertSmallIntegerToIntegerInReg: ra.
objectRepresentation genRemoveSmallIntegerTagsInScratchReg: rr.
self LogicalShiftLeftR: ra R: rr.
objectRepresentation genAddSmallIntegerTagsTo: rr].
[20] -> [objectRepresentation genConvertSmallIntegerToIntegerInReg: ra.
self ArithmeticShiftRightR: ra R: rr.
objectRepresentation genClearAndSetSmallIntegerTagsIn: rr.].
"2032 through 2037, >, <, >=, <=. =, ~=, SmallInteger op SmallInteger => Boolean (flags?? then in jump bytecodes if ssTop is a flags value, just generate the instruction!!!!)"
"CmpCqR is SubRCq so everything is reversed."
[32] -> [ self CmpR: ra R: rr.
self genBinaryInlineComparison: JumpGreater opFalse: JumpLessOrEqual destReg: rr ].
[33] -> [ self CmpR: ra R: rr.
self genBinaryInlineComparison: JumpLess opFalse: JumpGreaterOrEqual destReg: rr ].
[34] -> [ self CmpR: ra R: rr.
self genBinaryInlineComparison: JumpGreaterOrEqual opFalse: JumpLess destReg: rr ].
[35] -> [ self CmpR: ra R: rr.
self genBinaryInlineComparison: JumpLessOrEqual opFalse: JumpGreater destReg: rr ].
[36] -> [ self CmpR: ra R: rr.
self genBinaryInlineComparison: JumpZero opFalse: JumpNonZero destReg: rr ].
[37] -> [ self CmpR: ra R: rr.
self genBinaryInlineComparison: JumpNonZero opFalse: JumpZero destReg: rr ].
"2064 through 2068, Pointer Object>>at:, Byte Object>>at:, Short16 Word Object>>at: LongWord32 Object>>at: Quad64Word Object>>at:. obj op 0-rel SmallInteger => oop"
[64] -> [objectRepresentation genConvertSmallIntegerToIntegerInReg: ra.
adjust := (objectMemory baseHeaderSize >> objectMemory shiftForWord) - 1. "shift by baseHeaderSize and then move from 1 relative to zero relative"
adjust ~= 0 ifTrue: [ self AddCq: adjust R: ra. ].
self MoveXwr: ra R: rr R: rr ].
[65] -> [objectRepresentation genConvertSmallIntegerToIntegerInReg: ra.
adjust := objectMemory baseHeaderSize - 1. "shift by baseHeaderSize and then move from 1 relative to zero relative"
self AddCq: adjust R: ra.
self MoveXbr: ra R: rr R: rr.
objectRepresentation genConvertIntegerToSmallIntegerInReg: rr]
}
otherwise: [^EncounteredUnknownBytecode].
self ssPushRegister: rr.
^0!
Item was added:
+ ----- Method: SistaCogitClone>>genByteEqualsInlinePrimitive: (in category 'inline primitive generators') -----
+ genByteEqualsInlinePrimitive: prim
+
+ "3021 Byte Object >> equals:length:
+ The receiver and the arguments are both byte objects and have both the same size (length in bytes).
+ The length argument is a smallinteger.
+ Answers true if all fields are equal, false if not.
+ Comparison is bulked to word comparison."
+
+ "Overview:
+ 1. The primitive is called like that: [byteObj1 equals: byteObj2 length: length].
+ In the worst case we use 5 registers including TempReg
+ and we produce a loop bulk comparing words.
+ 2. The common case is a comparison against a cst: [byteString = 'foo'].
+ which produces in Scorch [byteString equals: 'foo' length: 3].
+ We try to generate fast code for this case with 3 heuristics:
+ - specific fast code if len is a constant
+ - unroll the loop if len < 2 * wordSize
+ - compile-time reads if str1 or str2 is a constant and loop is unrolled.
+ We use 3 registers including TempReg in the common case.
+ We could use 1 less reg if the loop is unrolled, the instr is followed by a branch
+ AND one operand is a constant, but this is complicated enough.
+ 3. We ignore the case where all operands are constants
+ (We assume Scorch simplifies it, it works but it is not optimised)"
+
+ | str1Reg str2Reg lenReg extraReg jmp jmp2 needjmpZeroSize needLoop unroll jmpZeroSize instr lenCst mask |
+ <var: #jmp type: #'AbstractInstruction *'>
+ <var: #instr type: #'AbstractInstruction *'>
+ <var: #jmp2 type: #'AbstractInstruction *'>
+ <var: #jmpZeroSize type: #'AbstractInstruction *'>
+
+ "--- quick path for empty string---"
+ "This path does not allocate registers and right shift on negative int later in the code.
+ Normally this is resolved by Scorch but we keep it for correctness and consistency"
+ self ssTop type = SSConstant ifTrue:
+ [ lenCst := objectMemory integerValueOf: self ssTop constant.
+ lenCst = 0 ifTrue: [ self ssPop: 3. self ssPushConstant: objectMemory trueObject. ^ 0 ] ].
+
+ "--- Allocating & loading registers --- "
+ needLoop := (self ssTop type = SSConstant and: [ lenCst <= (objectMemory wordSize * 2) ]) not.
+ unroll := needLoop not and: [lenCst > objectMemory wordSize ].
+ needLoop
+ ifTrue:
+ [ str1Reg := self allocateRegForStackEntryAt: 1 notConflictingWith: self emptyRegisterMask.
+ str2Reg := self allocateRegForStackEntryAt: 2 notConflictingWith: (self registerMaskFor: str1Reg).
+ lenReg := self allocateRegForStackEntryAt: 0 notConflictingWith: (self registerMaskFor:str1Reg and: str2Reg).
+ (self ssValue: 1) popToReg: str1Reg.
+ (self ssValue: 2) popToReg: str2Reg.
+ extraReg := self allocateRegNotConflictingWith: (self registerMaskFor: str1Reg and: str2Reg and: lenReg)]
+ ifFalse:
+ [ mask := self emptyRegisterMask.
+ (self ssValue: 1) type = SSConstant ifFalse:
+ [ str1Reg := self allocateRegForStackEntryAt: 1 notConflictingWith: mask.
+ (self ssValue: 1) popToReg: str1Reg.
+ mask := mask bitOr: (self registerMaskFor: str1Reg) ].
+ (self ssValue: 2) type = SSConstant ifFalse:
+ [ str2Reg := self allocateRegForStackEntryAt: 2 notConflictingWith: mask.
+ (self ssValue: 2) popToReg: str2Reg.
+ mask := mask bitOr: (self registerMaskFor: str2Reg) ].
+ extraReg := self allocateRegNotConflictingWith: mask].
+
+ "--- Loading LenReg (or statically resolving it) --- "
+ "LenReg is loaded with (lenInBytes + objectMemory baseHeaderSize - 1 >> shiftForWord)
+ LenReg is the index for the last word to compare with MoveXwr:r:R:.
+ The loop iterates from LenReg to first word of ByteObj"
+ self ssTop type = SSConstant
+ ifTrue: "common case, str = 'foo'. We can precompute lenReg."
+ [ lenCst := lenCst + objectMemory baseHeaderSize - 1 >> objectMemory shiftForWord.
+ needLoop ifTrue: [self MoveCq: lenCst R: lenReg ].
+ needjmpZeroSize := false]
+ ifFalse: "uncommon case, str = str2. lenReg in word computed at runtime."
+ [ self ssTop popToReg: lenReg.
+ objectRepresentation genConvertSmallIntegerToIntegerInReg: lenReg.
+ self CmpCq: 0 R: lenReg.
+ jmpZeroSize := self JumpZero: 0.
+ needjmpZeroSize := true.
+ self AddCq: objectMemory baseHeaderSize - 1 R: lenReg.
+ self ArithmeticShiftRightCq: objectMemory shiftForWord R: lenReg ].
+
+ "--- Comparing the strings --- "
+ "LenReg has the index of the last word to read (unless no loop).
+ We decrement it to adjust -1 (0 in 64 bits) while comparing"
+ needLoop
+ ifTrue:
+ [instr := self MoveXwr: lenReg R: str1Reg R: extraReg.
+ self MoveXwr: lenReg R: str2Reg R: TempReg.
+ self CmpR: extraReg R: TempReg.
+ jmp := self JumpNonZero: 0. "then string are not equal (jmp target)"
+ self AddCq: -1 R: lenReg.
+ self CmpCq: (objectMemory baseHeaderSize >> objectMemory shiftForWord) - 1 R: lenReg. "first word of ByteObj, stop looping."
+ self JumpNonZero: instr]
+ ifFalse: "Common case, only 1 or 2 word to check: no lenReg allocation, cst micro optimisations"
+ [self genByteEqualsInlinePrimitiveCmp: str1Reg with: str2Reg scratch1: extraReg scratch2: TempReg field: 0.
+ jmp := self JumpNonZero: 0. "then string are not equal (jmp target)"
+ unroll ifTrue: "unrolling more than twice generate more instructions than the loop so we don't do it"
+ [self genByteEqualsInlinePrimitiveCmp: str1Reg with: str2Reg scratch1: extraReg scratch2: TempReg field: 1.
+ jmp2 := self JumpNonZero: 0. "then string are not equal (jmp target)"]].
+ needjmpZeroSize ifTrue: [ jmpZeroSize jmpTarget: self Label ].
+ "fall through, strings are equal"
+
+ "--- Pushing the result or pipelining a branch --- "
+ self ssPop: 3.
+ self genByteEqualsInlinePrimitiveResult: jmp returnReg: extraReg.
+ unroll ifTrue: [jmp2 jmpTarget: jmp getJmpTarget].
+ ^0!
Item was added:
+ ----- Method: SistaCogitClone>>genByteEqualsInlinePrimitiveCmp:with:scratch1:scratch2:field: (in category 'inline primitive generators') -----
+ genByteEqualsInlinePrimitiveCmp: str1Reg with: str2Reg scratch1: scratch1Reg scratch2: scratch2Reg field: index
+ | shift |
+ <inline: true>
+ shift := objectMemory baseHeaderSize + (index * objectMemory wordSize).
+ (self ssValue: 1) type = SSConstant
+ ifTrue: [self MoveCq: (objectMemory fetchPointer: index ofObject: (self ssValue: 1) constant) R: scratch1Reg]
+ ifFalse: [self MoveMw: shift r: str1Reg R: scratch1Reg].
+ (self ssValue: 2) type = SSConstant
+ ifTrue: [self MoveCq: (objectMemory fetchPointer: index ofObject: (self ssValue: 2) constant) R: scratch2Reg]
+ ifFalse: [self MoveMw: shift r: str2Reg R: scratch2Reg].
+ self CmpR: scratch1Reg R: scratch2Reg.!
Item was added:
+ ----- Method: SistaCogitClone>>genByteEqualsInlinePrimitiveResult:returnReg: (in category 'inline primitive generators') -----
+ genByteEqualsInlinePrimitiveResult: jmp returnReg: reg
+ "Byte equal is falling through if the result is true, or jumping using jmp if the result is false.
+ The method is required to set the jump target of jmp.
+ We look ahead for a branch and pipeline the jumps if possible..
+ ReturnReg is used only if not followed immediately by a branch."
+ | branchDescriptor nextPC postBranchPC targetBytecodePC localJump canElide |
+ <var: #localJump type: #'AbstractInstruction *'>
+ <var: #branchDescriptor type: #'BytecodeDescriptor *'>
+ self extractMaybeBranchDescriptorInto: [ :descr :next :postBranch :target |
+ branchDescriptor := descr. nextPC := next. postBranchPC := postBranch. targetBytecodePC := target ].
+
+ "Case 1 - not followed by a branch"
+ (branchDescriptor isBranchTrue or: [branchDescriptor isBranchFalse])
+ ifFalse:
+ [self genMoveTrueR: reg.
+ localJump := self Jump: 0.
+ jmp jmpTarget: (self genMoveFalseR: reg).
+ localJump jmpTarget: self Label.
+ self ssPushRegister: reg.
+ ^ 0].
+
+ "Case 2 - followed by a branch"
+ (self fixupAt: nextPC) notAFixup
+ ifTrue: "The next instruction is dead. we can skip it."
+ [deadCode := true.
+ self ensureFixupAt: targetBytecodePC.
+ self ensureFixupAt: postBranchPC ]
+ ifFalse:
+ [self ssPushConstant: objectMemory trueObject]. "dummy value"
+ "We can only elide the jump if the pc after nextPC is the same as postBranchPC.
+ Branch following means it may not be."
+ self nextDescriptorExtensionsAndNextPCInto:
+ [:iguana1 :iguana2 :iguana3 :followingPC| nextPC := followingPC].
+ canElide := deadCode and: [nextPC = postBranchPC].
+ branchDescriptor isBranchTrue
+ ifTrue:
+ [ self Jump: (self ensureNonMergeFixupAt: targetBytecodePC).
+ canElide
+ ifFalse: [ jmp jmpTarget: (self ensureNonMergeFixupAt: postBranchPC) ]
+ ifTrue: [ jmp jmpTarget: self Label ] ]
+ ifFalse: [ canElide ifFalse: [ self Jump: (self ensureNonMergeFixupAt: postBranchPC).
+ jmp jmpTarget: (self ensureNonMergeFixupAt: targetBytecodePC) ] ].
+ ^0!
Item was changed:
----- Method: SistaCogitClone>>genCallPrimitiveBytecode (in category 'bytecode generators') -----
genCallPrimitiveBytecode
"SistaV1: 248 11111000 iiiiiiii mjjjjjjj Call Primitive #iiiiiiii + (jjjjjjj * 256) m=1 means inlined primitive, no hard return after execution.
See EncoderForSistaV1's class comment and StackInterpreter>>#inlinePrimitiveBytecode:"
+ | prim primSet |
- | prim |
byte2 < 128 ifTrue:
[^bytecodePC = initialPC
ifTrue: [0]
ifFalse: [EncounteredUnknownBytecode]].
prim := byte2 - 128 << 8 + byte1.
+ primSet := prim >> 13 bitAnd: 3.
+ prim := prim bitAnd: 8191.
+ LowcodeVM
+ ifTrue:
+ [
+ primSet = 1 ifTrue: [
+ prim < 1000 ifTrue:
+ [^self genLowcodeNullaryInlinePrimitive: prim].
+ prim < 2000 ifTrue:
+ [^self genLowcodeUnaryInlinePrimitive: prim - 1000].
+
+ prim < 3000 ifTrue:
+ [^ self genLowcodeBinaryInlinePrimitive: prim - 2000].
+
+ prim < 4000 ifTrue:
+ [^self genLowcodeTrinaryInlinePrimitive: prim - 3000].
+ ]
+ ].
+
+ self assert: primSet = 0.
+
prim < 1000 ifTrue:
[^self genNullaryInlinePrimitive: prim].
prim < 2000 ifTrue:
[^self genUnaryInlinePrimitive: prim - 1000].
prim < 3000 ifTrue:
[self ssTop type = SSConstant ifTrue:
[^self genBinaryVarOpConstInlinePrimitive: prim - 2000].
(self ssValue: 1) type = SSConstant ifTrue:
[^self genBinaryConstOpVarInlinePrimitive: prim - 2000].
^self genBinaryVarOpVarInlinePrimitive: prim - 2000].
prim < 4000 ifTrue:
[^self genTrinaryInlinePrimitive: prim - 3000].
+
+ prim < 5000 ifTrue:
+ [^self genQuaternaryInlinePrimitive: prim - 4000].
+
+ prim < 6000 ifTrue:
+ [^self genQuinaryInlinePrimitive: prim - 5000].
+
-
^EncounteredUnknownBytecode!
Item was removed:
- ----- Method: SistaCogitClone>>genExtJumpIfNotInstanceOfBehaviorsBytecode (in category 'bytecode generators') -----
- genExtJumpIfNotInstanceOfBehaviorsBytecode
- "SistaV1: * 254 11111110 kkkkkkkk jjjjjjjj branch If Not Instance Of Behavior/Array Of Behavior kkkkkkkk (+ Extend A * 256, where Extend A >= 0) distance jjjjjjjj (+ Extend B * 256, where Extend B >= 0)"
- | reg literal distance targetFixUp inverse |
-
- "We lose the information of in which register is stack top
- when jitting the branch target so we need to flush everything.
- We could use a fixed register here...."
- reg := self allocateRegForStackEntryAt: 0.
- self ssTop popToReg: reg.
- self ssFlushTo: simStackPtr. "flushed but the value is still in reg"
- self ssPop: 1.
-
- literal := self getLiteral: (extA * 256 + byte1).
- (inverse := extB < 0) ifTrue:
- [extB := extB + 128].
- distance := extB * 256 + byte2.
- extA := extB := numExtB := 0.
-
- targetFixUp := self cCoerceSimple: (self ensureFixupAt: bytecodePC + 3 + distance) to: #'AbstractInstruction *'.
- inverse
- ifFalse:
- [(objectMemory isArrayNonImm: literal)
- ifTrue: [objectRepresentation branchIf: reg notInstanceOfBehaviors: literal target: targetFixUp]
- ifFalse: [objectRepresentation branchIf: reg notInstanceOfBehavior: literal target: targetFixUp] ]
- ifTrue:
- [(objectMemory isArrayNonImm: literal)
- ifTrue: [objectRepresentation branchIf: reg instanceOfBehaviors: literal target: targetFixUp]
- ifFalse: [objectRepresentation branchIf: reg instanceOfBehavior: literal target: targetFixUp]].
-
- ^0!
Item was added:
+ ----- Method: SistaCogitClone>>genQuaternaryInlinePrimitive: (in category 'inline primitive generators') -----
+ genQuaternaryInlinePrimitive: prim
+ "Quaternary inline primitives."
+ "SistaV1: 248 11111000 iiiiiiii mjjjjjjj Call Primitive #iiiiiiii + (jjjjjjj * 256) m=1 means inlined primitive, no hard return after execution.
+ See EncoderForSistaV1's class comment and StackInterpreter>>#quaternaryInlinePrimitive:"
+ | needStoreCheck sourceReg stopReg objReg adjust jmp cmp isStartCst isStopCst startCst stopCst iteratorReg |
+ <var: #jmp type: #'AbstractInstruction *'>
+ <var: #cmp type: #'AbstractInstruction *'>
+ prim = 0 ifFalse: [^EncounteredUnknownBytecode].
+
+ "4000 Pointer Object>> fillFrom:to:with: The receiver is a Pointer object. the middle two arguments are smallintegers. Last argument is any object. Fills the object in between the two indexes with last argument. Receiver is guaranteed to be mutable. The pointer accesses are raw (no inst var check). If ExtB is set to 1, no store check is present. Else a single store check is done for the bulk operation. Answers the receiver."
+ needStoreCheck := self sistaNeedsStoreCheck.
+ extB := numExtB := 0.
+
+ "Allocate reg for src, objToStore, iterator and stop."
+ sourceReg := needStoreCheck
+ ifTrue: [ self ssAllocateRequiredReg: ReceiverResultReg.
+ self voidReceiverResultRegContainsSelf.
+ ReceiverResultReg ]
+ ifFalse: [ self allocateRegForStackEntryAt: 3 notConflictingWith: self emptyRegisterMask ].
+ (self ssValue: 3) popToReg: sourceReg.
+ objReg := self allocateRegForStackEntryAt: 0 notConflictingWith: (self registerMaskFor: sourceReg).
+ self ssTop popToReg: objReg.
+
+ "Set up iterator to first index to write and stop to last index to write"
+ adjust := (objectMemory baseHeaderSize >> objectMemory shiftForWord) - 1. "shift by baseHeaderSize and then move from 1 relative to zero relative"
+ isStartCst := (self ssValue: 2) type = SSConstant.
+ isStopCst := (self ssValue: 1) type = SSConstant.
+ isStartCst ifTrue: [startCst := adjust + (objectMemory integerValueOf: (self ssValue: 2) constant)].
+ isStopCst ifTrue: [stopCst := adjust + (objectMemory integerValueOf: (self ssValue: 1) constant)].
+
+ (isStartCst
+ and: [isStopCst
+ and: [stopCst - startCst < 7 ]]) "The other path generates at least 7 instructions"
+ ifTrue: ["unroll"
+ startCst
+ to: stopCst
+ do: [ :i | self MoveMw: i r: sourceReg R: objReg ] ]
+ ifFalse: ["loop"
+ stopReg := self allocateRegNotConflictingWith: (self registerMaskFor: sourceReg and: objReg).
+ iteratorReg := self allocateRegNotConflictingWith: (self registerMaskFor: sourceReg and: objReg and: stopReg).
+ isStartCst
+ ifTrue: [ self MoveCq: startCst R: iteratorReg ]
+ ifFalse: [ (self ssValue: 2) popToReg: iteratorReg.
+ adjust ~= 0 ifTrue: [ self AddCq: adjust R: iteratorReg ] ].
+ isStopCst
+ ifTrue: [ self MoveCq: stopCst R: stopReg ]
+ ifFalse: [ (self ssValue: 1) popToReg: stopReg.
+ adjust ~= 0 ifTrue: [ self AddCq: adjust R: stopReg ] ].
+ cmp := self CmpR: stopReg R: iteratorReg.
+ jmp := self JumpAbove: 0.
+ self MoveR: objReg Xwr: iteratorReg R: sourceReg.
+ self AddCq: 1 R: iteratorReg.
+ self Jump: cmp.
+ jmp jmpTarget: self Label].
+
+ needStoreCheck ifTrue: [objectRepresentation genStoreCheckReceiverReg: sourceReg valueReg: objReg scratchReg: TempReg inFrame: true].
+
+ self ssPop: 4.
+ self ssPushRegister: sourceReg.
+ ^0!
Item was added:
+ ----- Method: SistaCogitClone>>genQuinaryInlinePrimitive: (in category 'inline primitive generators') -----
+ genQuinaryInlinePrimitive: prim
+ "SistaV1: 248 11111000 iiiiiiii mjjjjjjj Call Primitive #iiiiiiii + (jjjjjjj * 256) m=1 means inlined primitive, no hard return after execution.
+ See EncoderForSistaV1's class comment and StackInterpreter>>#quaternaryInlinePrimitive:"
+ ^EncounteredUnknownBytecode!
Item was changed:
----- Method: SistaCogitClone>>genTrinaryInlinePrimitive: (in category 'inline primitive generators') -----
genTrinaryInlinePrimitive: prim
+ "trinary inline primitives."
- "Unary inline primitives."
"SistaV1: 248 11111000 iiiiiiii mjjjjjjj Call Primitive #iiiiiiii + (jjjjjjj * 256) m=1 means inlined primitive, no hard return after execution.
See EncoderForSistaV1's class comment and StackInterpreter>>#trinaryInlinePrimitive:"
+
+ prim < 10 ifTrue: [^ self genAtPutInlinePrimitive: prim].
+ prim = 21 ifTrue: [^ self genByteEqualsInlinePrimitive: prim].
+ ^ EncounteredUnknownBytecode!
- | ra1 ra2 rr adjust needsStoreCheck |
- "The store check requires rr to be ReceiverResultReg"
- needsStoreCheck := (objectRepresentation isUnannotatableConstant: self ssTop) not.
- self
- allocateRegForStackTopThreeEntriesInto: [:rTop :rNext :rThird | ra2 := rTop. ra1 := rNext. rr := rThird ]
- thirdIsReceiver: (prim = 0 and: [ needsStoreCheck ]).
- self assert: (rr ~= ra1 and: [rr ~= ra2 and: [ra1 ~= ra2]]).
- self ssTop popToReg: ra2.
- self ssPop: 1.
- self ssTop popToReg: ra1.
- self ssPop: 1.
- self ssTop popToReg: rr.
- self ssPop: 1.
- objectRepresentation genConvertSmallIntegerToIntegerInReg: ra1.
- "Now: ra is the variable object, rr is long, TempReg holds the value to store."
- self flag: #TODO. "This is not really working as the immutability and store check needs to be present. "
- prim caseOf: {
- "0 - 1 pointerAt:put: and byteAt:Put:"
- [0] -> [ adjust := (objectMemory baseHeaderSize >> objectMemory shiftForWord) - 1. "shift by baseHeaderSize and then move from 1 relative to zero relative"
- adjust ~= 0 ifTrue: [ self AddCq: adjust R: ra1. ].
- self MoveR: ra2 Xwr: ra1 R: rr.
- "I added needsStoreCheck so if you initialize an array with a Smi such as 0 or a boolean you don't need the store check"
- needsStoreCheck ifTrue:
- [ self assert: needsFrame.
- objectRepresentation genStoreCheckReceiverReg: rr valueReg: ra2 scratchReg: TempReg inFrame: true] ].
- [1] -> [ objectRepresentation genConvertSmallIntegerToIntegerInReg: ra2.
- adjust := objectMemory baseHeaderSize - 1. "shift by baseHeaderSize and then move from 1 relative to zero relative"
- self AddCq: adjust R: ra1.
- self MoveR: ra2 Xbr: ra1 R: rr.
- objectRepresentation genConvertIntegerToSmallIntegerInReg: ra2. ]
- }
- otherwise: [^EncounteredUnknownBytecode].
- self ssPushRegister: ra2.
- ^0!
Item was changed:
----- Method: SistaCogitClone>>genUnaryInlinePrimitive: (in category 'inline primitive generators') -----
genUnaryInlinePrimitive: prim
"Unary inline primitives."
"SistaV1: 248 11111000 iiiiiiii mjjjjjjj Call Primitive #iiiiiiii + (jjjjjjj * 256) m=1 means inlined primitive, no hard return after execution.
See EncoderForSistaV1's class comment and StackInterpreter>>#unaryInlinePrimitive:"
| rcvrReg resultReg |
rcvrReg := self allocateRegForStackEntryAt: 0.
resultReg := self allocateRegNotConflictingWith: (self registerMaskFor: rcvrReg).
prim
caseOf: {
"00 unchecked class"
[1] -> "01 unchecked pointer numSlots"
[self ssTop popToReg: rcvrReg.
self ssPop: 1.
objectRepresentation
genGetNumSlotsOf: rcvrReg into: resultReg;
genConvertIntegerToSmallIntegerInReg: resultReg].
"02 unchecked pointer basicSize"
[3] -> "03 unchecked byte numBytes"
[self ssTop popToReg: rcvrReg.
self ssPop: 1.
objectRepresentation
genGetNumBytesOf: rcvrReg into: resultReg;
genConvertIntegerToSmallIntegerInReg: resultReg].
"04 unchecked short16Type format numShorts"
"05 unchecked word32Type format numWords"
"06 unchecked doubleWord64Type format numDoubleWords"
[11] -> "11 unchecked fixed pointer basicNew"
[self ssTop type ~= SSConstant ifTrue:
[^EncounteredUnknownBytecode].
(objectRepresentation
genGetInstanceOf: self ssTop constant
into: resultReg
initializingIf: self extBSpecifiesInitializeInstance) ~= 0 ifTrue:
[^ShouldNotJIT]. "e.g. bad class"
self ssPop: 1] .
[20] -> "20 identityHash"
+ [objectRepresentation genGetIdentityHash: rcvrReg resultReg: resultReg.
- [self ssTop popToReg: rcvrReg.
- objectRepresentation genGetHashFieldNonImmOf: rcvrReg asSmallIntegerInto: resultReg.
self ssPop: 1] .
"21 identityHash (SmallInteger)"
"22 identityHash (Character)"
"23 identityHash (SmallFloat64)"
"24 identityHash (Behavior)"
"30 immediateAsInteger (Character)
+ 31 immediateAsInteger (SmallFloat64)
+ 35 immediateAsFloat (SmallInteger) "
- 31 immediateAsInteger (SmallFloat64)"
[30] ->
+ [self ssTop popToReg: resultReg.
+ objectRepresentation genConvertCharacterToSmallIntegerInReg: resultReg.
+ self ssPop: 1].
+ [35] ->
+ [self assert: self processorHasDoublePrecisionFloatingPointSupport.
+ self MoveR: rcvrReg R: TempReg.
+ self genConvertSmallIntegerToIntegerInReg: TempReg.
+ self ConvertR: TempReg Rd: DPFPReg0.
+ self flag: #TODO. "Should never fail"
+ self
+ genAllocFloatValue: DPFPReg0
+ into: resultReg
+ scratchReg: TempReg
+ scratchReg: NoReg. "scratch2 for V3 only"]
- [self ssTop popToReg: rcvrReg.
- objectRepresentation genConvertCharacterToSmallIntegerInReg: rcvrReg.
- self ssPop: 1]
}
otherwise:
[^EncounteredUnknownBytecode].
extB := 0.
numExtB := 0.
self ssPushRegister: resultReg.
^0!
Item was changed:
----- Method: SistaCogitClone>>genUnconditionalTrapBytecode (in category 'bytecode generators') -----
genUnconditionalTrapBytecode
"SistaV1: * 217 Trap"
self ssFlushTo: simStackPtr.
self CallRT: ceTrapTrampoline.
self annotateBytecode: self Label.
+ deadCode := true.
^0!
Item was added:
+ ----- Method: SistaCogitClone>>isTrapAt: (in category 'simulation only') -----
+ isTrapAt: retpc
+ "For stack depth checking."
+ <doNotGenerate>
+ ^(backEnd isCallPrecedingReturnPC: retpc)
+ and: [(backEnd callTargetFromReturnAddress: retpc) = ceTrapTrampoline]!
Item was added:
+ ----- Method: SistaCogitClone>>setCogCodeZoneThreshold: (in category 'accessing') -----
+ setCogCodeZoneThreshold: threshold
+ <doNotGenerate>
+ ^methodZone setCogCodeZoneThreshold: threshold!
Item was changed:
----- Method: SistaRegisterAllocatingCogit>>genSpecialSelectorComparison (in category 'bytecode generators') -----
genSpecialSelectorComparison
"Override to count inlined branches if followed by a conditional branch.
We borrow the following conditional branch's counter and when about to
inline the comparison we decrement the counter (without writing it back)
and if it trips simply abort the inlining, falling back to the normal send which
will then continue to the conditional branch which will trip and enter the abort."
| nextPC postBranchPC targetPC primDescriptor branchDescriptor
rcvrIsInt rcvrIsConst argIsIntConst argInt jumpNotSmallInts inlineCAB
+ counterAddress countTripped counterReg index rcvrReg argReg
+ branchToTarget needMergeToContinue needMergeToTarget |
- counterAddress countTripped counterReg index rcvrReg argReg |
<var: #countTripped type: #'AbstractInstruction *'>
<var: #primDescriptor type: #'BytecodeDescriptor *'>
<var: #jumpNotSmallInts type: #'AbstractInstruction *'>
<var: #branchDescriptor type: #'BytecodeDescriptor *'>
(coInterpreter isOptimizedMethod: methodObj) ifTrue:
[^self genSpecialSelectorComparisonWithoutCounters].
primDescriptor := self generatorAt: byte0.
argIsIntConst := self ssTop type = SSConstant
and: [objectMemory isIntegerObject: (argInt := self ssTop constant)].
rcvrIsInt := ((rcvrIsConst := (self ssValue: 1) type = SSConstant)
and: [objectMemory isIntegerObject: (self ssValue: 1) constant])
or: [self mclassIsSmallInteger and: [(self ssValue: 1) isSameEntryAs: (self addressOf: simSelf)]].
"short-cut the jump if operands are SmallInteger constants."
(argIsIntConst and: [rcvrIsInt and: [rcvrIsConst]]) ifTrue:
[^ self genStaticallyResolvedSpecialSelectorComparison].
self extractMaybeBranchDescriptorInto: [ :descr :next :postBranch :target |
branchDescriptor := descr. nextPC := next. postBranchPC := postBranch. targetPC := target ].
+
-
"Only interested in inlining if followed by a conditional branch."
inlineCAB := branchDescriptor isBranchTrue or: [branchDescriptor isBranchFalse].
"Further, only interested in inlining = and ~= if there's a SmallInteger constant involved.
The relational operators successfully statically predict SmallIntegers; the equality operators do not."
(inlineCAB and: [primDescriptor opcode = JumpZero or: [primDescriptor opcode = JumpNonZero]]) ifTrue:
[inlineCAB := argIsIntConst or: [rcvrIsInt]].
inlineCAB ifFalse:
[^self genSpecialSelectorSend].
"In-line the comparison and the jump, but if the types are not SmallInteger then we will need
to do a send and fall through to the following conditional branch. Since we're allocating values
in registers we would like to keep those registers live on the inlined path and reload registers
along the non-inlined send path. The merge logic at the branch destinations handles this."
argIsIntConst
ifTrue:
[rcvrReg := self allocateRegForStackEntryAt: 1.
(self ssValue: 1) popToReg: rcvrReg.
+ counterReg := self allocateRegNotConflictingWith: (self registerMaskFor: rcvrReg).
+ argReg := NoReg]
- counterReg := self allocateRegNotConflictingWith: (self registerMaskFor: rcvrReg)]
ifFalse:
[self allocateRegForStackTopTwoEntriesInto: [:rTop :rNext| argReg := rTop. rcvrReg := rNext].
- rcvrReg = Arg0Reg ifTrue:
- [rcvrReg := argReg. argReg := Arg0Reg].
self ssTop popToReg: argReg.
(self ssValue: 1) popToReg: rcvrReg.
counterReg := self allocateRegNotConflictingWith: (self registerMaskFor: rcvrReg and: argReg)].
+ self ssPop: 2.
jumpNotSmallInts := (rcvrIsInt and: [argIsIntConst]) ifFalse:
[argIsIntConst
+ ifTrue: [objectRepresentation genJumpNotSmallInteger: rcvrReg]
- ifTrue: [objectRepresentation genJumpNotSmallInteger: ReceiverResultReg]
ifFalse:
[rcvrIsInt
+ ifTrue: [objectRepresentation genJumpNotSmallInteger: argReg]
+ ifFalse: [objectRepresentation genJumpNotSmallIntegersIn: rcvrReg and: argReg scratch: TempReg]]].
- ifTrue: [objectRepresentation genJumpNotSmallInteger: Arg0Reg]
- ifFalse: [objectRepresentation genJumpNotSmallIntegersIn: ReceiverResultReg and: Arg0Reg scratch: TempReg]]].
self
genExecutionCountLogicInto: [ :cAddress :countTripBranch |
counterAddress := cAddress.
countTripped := countTripBranch ]
counterReg: counterReg.
argIsIntConst
ifTrue: [self CmpCq: argInt R: rcvrReg]
ifFalse: [self CmpR: argReg R: rcvrReg].
+ "self printSimStack; printSimStack: (self fixupAt: postBranchPC) mergeSimStack; printSimStack: (self fixupAt: targetPC) mergeSimStack"
+ "If there are merges to be performed on the forward branches we have to execute
+ the merge code only along the path requiring that merge, and exactly once."
+ needMergeToTarget := self mergeRequiredForJumpTo: targetPC.
+ needMergeToContinue := self mergeRequiredForJumpTo: postBranchPC.
+ "Cmp is weird/backwards so invert the comparison."
+ (needMergeToTarget and: [needMergeToContinue]) ifTrue:
+ [branchToTarget := self genConditionalBranch: (branchDescriptor isBranchTrue
+ ifTrue: [primDescriptor opcode]
+ ifFalse: [self inverseBranchFor: primDescriptor opcode])
+ operand: 0.
+ self Jump: (self ensureFixupAt: postBranchPC).
+ branchToTarget jmpTarget: self Label.
+ self Jump: (self ensureFixupAt: targetPC)].
+ (needMergeToTarget and: [needMergeToContinue not]) ifTrue:
+ [self genConditionalBranch: (branchDescriptor isBranchFalse
+ ifTrue: [primDescriptor opcode]
+ ifFalse: [self inverseBranchFor: primDescriptor opcode])
+ operand: (self ensureFixupAt: postBranchPC) asUnsignedInteger.
+ self Jump: (self ensureFixupAt: targetPC)].
+ (needMergeToTarget not and: [needMergeToContinue]) ifTrue:
+ [self genConditionalBranch: (branchDescriptor isBranchTrue
+ ifTrue: [primDescriptor opcode]
+ ifFalse: [self inverseBranchFor: primDescriptor opcode])
+ operand: (self ensureFixupAt: targetPC) asUnsignedInteger.
+ self Jump: (self ensureFixupAt: postBranchPC)].
+ (needMergeToTarget or: [needMergeToContinue]) ifFalse:
+ [self genConditionalBranch: (branchDescriptor isBranchTrue
+ ifTrue: [primDescriptor opcode]
+ ifFalse: [self inverseBranchFor: primDescriptor opcode])
+ operand: (self ensureFixupAt: targetPC) asUnsignedInteger.
+ self Jump: (self ensureFixupAt: postBranchPC)].
+
- "Cmp is weird/backwards so invert the comparison. Further since there is a following conditional
- jump bytecode define non-merge fixups and leave the cond bytecode to set the mergeness."
- self genConditionalBranch: (branchDescriptor isBranchTrue
- ifTrue: [primDescriptor opcode]
- ifFalse: [self inverseBranchFor: primDescriptor opcode])
- operand: (self ensureFixupAt: targetPC) asUnsignedInteger.
-
- self genFallsThroughCountLogicCounterReg: counterReg counterAddress: counterAddress.
-
- self Jump: (self ensureFixupAt: postBranchPC).
countTripped jmpTarget: self Label.
jumpNotSmallInts ifNil:
[self annotateInstructionForBytecode.
deadCode := true.
^0].
jumpNotSmallInts jmpTarget: countTripped getJmpTarget.
self ssFlushTo: simStackPtr.
+ rcvrReg = Arg0Reg
+ ifTrue:
+ [argReg = ReceiverResultReg
+ ifTrue: [self SwapR: Arg0Reg R: Arg0Reg Scratch: TempReg. argReg := Arg0Reg]
+ ifFalse: [self MoveR: rcvrReg R: ReceiverResultReg].
+ rcvrReg := ReceiverResultReg].
- self deny: rcvrReg = Arg0Reg.
argIsIntConst
ifTrue: [self MoveCq: argInt R: Arg0Reg]
ifFalse: [argReg ~= Arg0Reg ifTrue: [self MoveR: argReg R: Arg0Reg]].
rcvrReg ~= ReceiverResultReg ifTrue: [self MoveR: rcvrReg R: ReceiverResultReg].
index := byte0 - self firstSpecialSelectorBytecodeOffset.
^self genMarshalledSend: index negated - 1 numArgs: 1 sendTable: ordinarySendTrampolines!
Item was changed:
----- Method: StackToRegisterMappingCogit>>assertCorrectSimStackPtr (in category 'compile abstract instructions') -----
assertCorrectSimStackPtr
<inline: true> "generates nothing anyway"
self cCode: '' inSmalltalk:
[deadCode ifFalse:
[self assert: simStackPtr + (needsFrame ifTrue: [0] ifFalse: [1])
+ = (self debugStackPointerFor: bytecodePC)].
+ self deny: self duplicateRegisterAssignmentsInTemporaries].
- = (self debugStackPointerFor: bytecodePC)]].
!
1
0
On Tue, Apr 4, 2017 at 10:00 AM, Denis Kudriashov <dionisiydk(a)gmail.com>
wrote:
>
> 2017-04-04 18:45 GMT+02:00 Esteban Lorenzano <estebanlm(a)gmail.com>:
>
>> > I think you are wrong because I check it carefully in Squeak and I
>> found it on github https://github.com/OpenSmallta
>> lk/opensmalltalk-vm/search?utf8=✓&q=primitiveFindSubstring&type=.
>>
>>
>> still is not there, because is not the same primitive :)
>>
>
> Does it also means that latest VM is built differently then stable?
> (primitive works on stable pharo). I just thought that we already moved to
> opensmalltalk build process.
>
Not yet. We are close. Last week I got angry with Esteban because I
thought that the joe was stalled because Pharo didn't want to move to
opensmalltalk-vm, but I over reacted. One of the issues preventing the
move was indeed this primitive and the fact that someone, without thinking
to talk to anyone working with the VM, renamed the primitive, and then
someone put it on the wrong class. Esteban and I have spent some hours
trying to work around such issues. I wish people would be more considerate.
If issues like this can be resolved we are very close to using the
opensmalltalk-vm process for stable Pharo VMs. Esteban wants (and has
built) a test build that tries to produce sources and generate Vs and runs
tests every time VMMaker is committed. On the Squeak side we only try and
build VMs when opensmalltalk-vm is committed in git. I don't want to stand
in Esteban's way. I *do* want stable VMs to be built from the
opensmalltalk-vm tree.
_,,,^..^,,,_
best, Eliot
3
4
[OpenSmalltalk/opensmalltalk-vm] 8a0197: linux SDL2 filename is still 0.4.1, even if librar...
by GitHub 04 Apr '17
by GitHub 04 Apr '17
04 Apr '17
Branch: refs/heads/Cog
Home: https://github.com/OpenSmalltalk/opensmalltalk-vm
Commit: 8a01973b8499449bd785533c357a5853203ecba5
https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/8a01973b8499449bd7…
Author: Esteban Lorenzano <estebanlm(a)gmail.com>
Date: 2017-04-04 (Tue, 04 Apr 2017)
Changed paths:
M third-party/libsdl2.spec
Log Message:
-----------
linux SDL2 filename is still 0.4.1, even if library is 0.5.0
don’t ask why
Commit: 8d69b898f6cdb8b9b97c3dd09c100a726a4cfaae
https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/8d69b898f6cdb8b9b9…
Author: Esteban Lorenzano <estebanlm(a)gmail.com>
Date: 2017-04-04 (Tue, 04 Apr 2017)
Changed paths:
M third-party/libssh2.spec
Log Message:
-----------
restore libssh2 version
Commit: 87188f2ee072e15dcdeecc33f462bca3bd7e1696
https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/87188f2ee072e15dcd…
Author: Esteban Lorenzano <estebanlm(a)gmail.com>
Date: 2017-04-04 (Tue, 04 Apr 2017)
Changed paths:
M build.win32x86/third-party/Makefile.cairo
Log Message:
-----------
force FREETYPE_CONFIG to see if it finds cairo
Commit: 0d7646be69838fd09dec4bef4d8e6c00effddbb4
https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/0d7646be69838fd09d…
Author: Esteban Lorenzano <estebanlm(a)gmail.com>
Date: 2017-04-04 (Tue, 04 Apr 2017)
Changed paths:
M third-party/cairo.spec
Log Message:
-----------
update cairo
Commit: 7f11a52de1e7bdd98026a803a71b90e45b7e6ad4
https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/7f11a52de1e7bdd980…
Author: Esteban Lorenzano <estebanlm(a)gmail.com>
Date: 2017-04-04 (Tue, 04 Apr 2017)
Changed paths:
M third-party/freetype2.spec
Log Message:
-----------
trying an older freetype version
Commit: 1d924fe6232c801669ea09962394af1641d454ff
https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/1d924fe6232c801669…
Author: Esteban Lorenzano <estebanlm(a)gmail.com>
Date: 2017-04-04 (Tue, 04 Apr 2017)
Changed paths:
M build.win32x86/third-party/Makefile.cairo
Log Message:
-----------
using Makefile.win32 (too see what happens)
Commit: fffbedae3afc541d9c83124a2069d9721ea021b4
https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/fffbedae3afc541d9c…
Author: Esteban Lorenzano <estebanlm(a)gmail.com>
Date: 2017-04-04 (Tue, 04 Apr 2017)
Changed paths:
M third-party/freetype2.spec
Log Message:
-----------
back to newer version
Commit: 7e85da50fd5c42892e45149b6fc3ca003a047765
https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/7e85da50fd5c42892e…
Author: Esteban Lorenzano <estebanlm(a)gmail.com>
Date: 2017-04-04 (Tue, 04 Apr 2017)
Changed paths:
M build.win32x86/third-party/Makefile.cairo
Log Message:
-----------
force freetype_libs
Commit: 3aa11ab38645d4f2e5f2ae84940dd77995b901e7
https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/3aa11ab38645d4f2e5…
Author: Esteban Lorenzano <estebanlm(a)gmail.com>
Date: 2017-04-04 (Tue, 04 Apr 2017)
Changed paths:
M build.win32x86/third-party/Makefile.cairo
Log Message:
-----------
force freetype flags
Compare: https://github.com/OpenSmalltalk/opensmalltalk-vm/compare/d8ab3d981f0f...3a…
1
0
Good morning, i want to know all about pharo'VM, books and notes, i also want to know differences between pharo'VM and JavaVM, thanks a lot
6
6
Hi Esteban,
> On Apr 4, 2017, at 9:45 AM, Esteban Lorenzano <estebanlm(a)gmail.com> wrote:
>
>
>> On 4 Apr 2017, at 18:01, Ben Coman <btc(a)openInWorld.com> wrote:
>>
>>
>>
>> On Tue, Apr 4, 2017 at 10:12 PM, Denis Kudriashov <dionisiydk(a)gmail.com> wrote:
>> >
>> >
>> > 2017-04-04 15:47 GMT+02:00 Esteban Lorenzano <estebanlm(a)gmail.com>:
>> >>
>> >> no it doesn't: squeak does not have that primitive, that’s why it does not fails :)
>> >
>> >
>> > I think you are wrong because I check it carefully in Squeak and I found it on github https://github.com/OpenSmalltalk/opensmalltalk-vm/search?utf8=✓&q=primitive….
>
> still is not there, because is not the same primitive :)
> look, this is the way where it is generated:
>
> translatedPrimitives
> "an assorted list of various primitives"
> (ByteString compiledMethodAt: #findSubstringViaPrimitive:in:startingAt:matchTable: ifAbsent: []) ifNotNil:
> [^#("Pharo uses findSubstringViaPrimitive:in:startingAt:matchTable:"
> (Bitmap compress:toByteArray:)
> (Bitmap decompress:fromByteArray:at:)
> (Bitmap encodeBytesOf:in:at:)
> (Bitmap encodeInt:in:at:)
> (ByteString compare:with:collated:)
> (ByteString translate:from:to:table:)
> (ByteString findFirstInString:inSet:startingAt:)
> (ByteString indexOfAscii:inString:startingAt:)
> (String findSubstringViaPrimitive:in:startingAt:matchTable:)
> (ByteArray hashBytes:startingWith:)
> (SampledSound convert8bitSignedFrom:to16Bit:))].
> ^#(
> (Bitmap compress:toByteArray:)
> (Bitmap decompress:fromByteArray:at:)
> (Bitmap encodeBytesOf:in:at:)
> (Bitmap encodeInt:in:at:)
> (ByteString compare:with:collated:)
> (ByteString translate:from:to:table:)
> (ByteString findFirstInString:inSet:startingAt:)
> (ByteString indexOfAscii:inString:startingAt:)
> (ByteString findSubstring:in:startingAt:matchTable:)
> (ByteArray hashBytes:startingWith:)
> (SampledSound convert8bitSignedFrom:to16Bit:)
> )
>
> means that Pharo uses #indSubstringViaPrimitive:in:startingAt:matchTable: while squeak uses #findSubstring:in:startingAt:matchTable:.
> Now, there is a bug there (because source is in String and not in ByteString), and I can fix that by asking correctly, but:
>
> 1) this means that sources for pharo and squeak will be different and pharo needs to be generated in pharo. This is contrary to what we are trying to do with the VM: we want all sources to be the same, and differences should come from compilation flags and/or the presence of certain plugins (this is because is a lot easier to debug the VM like that).
> 2) I wonder… why we are using this primitive an squeak is not? maybe we need to deprecate the use?
>
>> I believe Esteban's point Its not so much whether the VM has it
>> (since they are essentially the same VM + extra C-libs for Pharo)
>> but whether the Squeak Image is using it.
>>
>> Squeak does use primitiveFindSubstring, but a difference is attached to ByteString rather than String.
>> That was added to Squeak 2015.05.01. Squeak String seems to have never used the primitive (since 2005).
>
> this is the important thing, I think… so… why can’t we use that instead the other one?
> what’s the difference?
You have identified the problem. The bug is that Pharo broke this by renaming and repositioning the primitive to findSubstringViaPrimitive:in:startingAt:matchTable:. If it had stayed where it was things would still be working.
So my suggestions are
a) restore Pharo to using by the primitive correctly in the exactly the same configuration as Squeak
b) no one in the Pharo community changes the definition or position of a primitive without consulting a vm person (and Esteban is a vm person as is Clément and arguably Guille).
c) we measure the performance of the primitive and the equivalent non-primitive code in StackInterpreter, Cog and Sista configurations (using Spur, the current object representation) for a range of strings and see how much benefit we're getter by from the primitive; maybe we can nuke it.
But yes, it is a bad bug to position this primitive in String; it works only for ByteString.
>
> cheers!
> Esteban
>
>
>>
>> A diff shows some differences in implementation..
>> https://www.diffchecker.com/CmBJZjB6
>> which anyway wouldn't account for John's observations.
>>
>> cheers -ben
>
1
0
Eliot Miranda uploaded a new version of Cog to project VM Maker:
http://source.squeak.org/VMMaker/Cog-eem.338.mcz
==================== Summary ====================
Name: Cog-eem.338
Author: eem
Time: 3 April 2017, 9:49:41.714544 am
UUID: f996ae42-acb4-475e-b2f9-670019c3a702
Ancestors: Cog-eem.337
Cog minus the contents of CogAttic-eem.2
=============== Diff against Cog-eem.337 ===============
Item was removed:
- ----- Method: Behavior>>BehaviorPROTOTYPEinstSize (in category '*Cog-method prototypes') -----
- BehaviorPROTOTYPEinstSize
- "Answer the number of named instance variables
- (as opposed to indexed variables) of the receiver.
- Above Cog Spur the class format is
- <5 bits inst spec><16 bits inst size>"
- ^format bitAnd: 16rFFFF!
Item was removed:
- ----- Method: Behavior>>BehaviorPROTOTYPEinstSpec (in category '*Cog-method prototypes') -----
- BehaviorPROTOTYPEinstSpec
- "Answer the instance specification part of the format that defines what kind of object
- an instance of the receiver is. The formats are
- 0 = 0 sized objects (UndefinedObject True False et al)
- 1 = non-indexable objects with inst vars (Point et al)
- 2 = indexable objects with no inst vars (Array et al)
- 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
- 4 = weak indexable objects with inst vars (WeakArray et al)
- 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
- 6 = unused
- 7 = immediates (SmallInteger, Character)
- 8 = unused
- 9 = 64-bit indexable
- 10-11 = 32-bit indexable (Bitmap)
- 12-15 = 16-bit indexable
- 16-23 = 8-bit indexable
- 24-31 = compiled methods (CompiledMethod)"
- ^(format bitShift: -16) bitAnd: 16r1F!
Item was removed:
- ----- Method: BlockClosure>>BlockClosurePHAROPROTOTYPEsimulateValueWithArguments:caller: (in category '*Cog-method prototypes') -----
- BlockClosurePHAROPROTOTYPEsimulateValueWithArguments: anArray caller: aContext
- "Simulate the valueWithArguments: primitive. Fail if anArray is not an array of the right arity."
- | newContext sz |
- newContext := (Context newForMethod: outerContext method)
- setSender: aContext
- receiver: outerContext receiver
- method: outerContext method
- closure: self
- startpc: startpc.
- ((newContext objectClass: anArray) ~~ Array
- or: [numArgs ~= anArray size]) ifTrue:
- [^Context primitiveFailTokenFor: nil].
- sz := self basicSize.
- newContext stackp: sz + numArgs.
- 1 to: numArgs do:
- [:i| newContext at: i put: (anArray at: i)].
- 1 to: sz do:
- [:i| newContext at: i + numArgs put: (self at: i)].
- ^newContext!
Item was removed:
- ----- Method: BlockClosure>>BlockClosurePROTOTYPEsimulateValueWithArguments:caller: (in category '*Cog-method prototypes') -----
- BlockClosurePROTOTYPEsimulateValueWithArguments: anArray caller: aContext
- "Simulate the valueWithArguments: primitive. Fail if anArray is not an array of the right arity."
- | newContext sz |
- newContext := (MethodContext newForMethod: outerContext method)
- setSender: aContext
- receiver: outerContext receiver
- method: outerContext method
- closure: self
- startpc: startpc.
- ((newContext objectClass: anArray) ~~ Array
- or: [numArgs ~= anArray size]) ifTrue:
- [^ContextPart primitiveFailTokenFor: nil].
- sz := self basicSize.
- newContext stackp: sz + numArgs.
- 1 to: numArgs do:
- [:i| newContext at: i put: (anArray at: i)].
- 1 to: sz do:
- [:i| newContext at: i + numArgs put: (self at: i)].
- ^newContext!
Item was removed:
- ----- Method: ClassDescription>>ClassDescriptionPROTOTYPEupdateMethodBindingsTo: (in category '*Cog-method prototypes squeak') -----
- ClassDescriptionPROTOTYPEupdateMethodBindingsTo: aBinding
- "ClassBuilder support for maintaining valid method bindings."
- methodDict do: [:method| method methodClassAssociation: aBinding]!
Item was removed:
- ----- Method: CogScripts class>>bootstrapClosures (in category 'closure scripts') -----
- bootstrapClosures
- "CogScripts bootstrapClosures"
- | rep |
- Transcript clear.
- rep := false
- ifTrue: [MCCacheRepository default]
- ifFalse:
- [MCHttpRepository
- location: 'http://dev.qwaq.com/ss/Oinq'
- user: 'qwaq'
- password: ''].
- "This changes load order in Monticello such that additions come in before modifications."
- (rep loadVersionFromFileNamed: 'Monticello-eem.302.mcz') load.
- "This adds some prereqs the compiler uses that are loaded in later packages:
- Fix the ClassBuilder so redefining CompiledMethod can add and remove class variables.
- Add Object/Array>>isArray.
- Add new interface for accessing inst vars & fields on initializing the compiler (Encoder)."
- self bootstrapClosuresCompilerPreloadCode readStream fileIn.
- "This temporarily stops Monticello from unloading code on load and warning about overwriting changes.
- Since changes span multiple packages need all additions in before any deletions occur.
- Can't warn about anything until the new debugger api is installed."
- ChangeSet
- newChangesFromStream: self bootstrapClosuresNeuterMonticelloCode readStream
- named: 'neuterMonticello'.
- Smalltalk at: #DoNotUnload put: true.
- 1 to: 2 do:
- [:i|
- #( 'Compiler-eem.30.mcz'
- 'Files-eem.21.mcz'
- 'Exceptions-eem.14.mcz'
- 'Collections-eem.55.mcz'
- 'Tools-eem.45.mcz'
- 'Kernel-eem.82.mcz'
- 'System-eem.53.mcz'
- 'Brad-eem.51.mcz'
- 'Morphic-eem.38.mcz'
- 'Tweak-Compiler-eem.36.mcz'
- 'Tweak-Hacks-eem.30.mcz'
- 'Tweak-Basic-eem.151.mcz'
- 'Tweak-Core-Proto-eem.56.mcz') do:
- [:pn|
- Transcript clear; nextPutAll: pn; space; nextPut: $(; print: i; nextPut: $); endEntry.
- (rep loadVersionFromFileNamed: pn) load].
- Smalltalk at: #DoNotUnload put: false].
- "Now remove the temporary hacks to Monticello"
- (ChangeSet named: 'neuterMonticello') changedMessageList do:
- [:mr| | changeRecords |
- changeRecords := mr actualClass changeRecordsAt: mr methodSymbol.
- changeRecords second fileIn].
- "Install BlockClosure in the specialObjectsArray"
- Smalltalk recreateSpecialObjectsArray.
- "Throw the switch to compile to closures"
- self bootstrapClosuresClosureCompilerSwitchCode readStream fileIn.
- "Recompile the system except the one method we can't yet deal with in GeniePlugin (1 too many literals)"
- (Smalltalk forgetDoIts allClasses reject: [:c| c name == #GeniePlugin]) do:
- [:c|
- { c. c class } do:
- [:b|
- Transcript cr; print: b; endEntry.
- b selectors asSortedCollection do:
- [:s|
- b recompile: s from: b]]].
- UsefulScripts postRecompileCleanup.
- self inform: 'Save and quit and then run UsefulScripts postRecompileCleanup.\Rinse and repeat' withCRs!
Item was removed:
- ----- Method: CogScripts 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]].!
Item was removed:
- ----- Method: CogScripts 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!
Item was removed:
- ----- Method: CompiledMethod class>>CompiledMethodclassPROTOTYPEheaderFlagForEncoder: (in category '*Cog-method prototypes') -----
- CompiledMethodclassPROTOTYPEheaderFlagForEncoder: anEncoder
- anEncoder class == PrimaryBytecodeSetEncoderClass ifTrue:
- [^0].
- anEncoder class == SecondaryBytecodeSetEncoderClass ifTrue:
- [^SmallInteger minVal].
- self error: 'The encoder is not one of the two installed bytecode sets'!
Item was removed:
- ----- Method: CompiledMethod class>>CompiledMethodclassPROTOTYPEinitialize (in category '*Cog-method prototypes') -----
- CompiledMethodclassPROTOTYPEinitialize "CompiledMethod initialize"
- "Initialize class variables specifying the size of the temporary frame
- needed to run instances of me."
-
- SmallFrame := 16. "Context range for temps+stack"
- LargeFrame := 56.
- PrimaryBytecodeSetEncoderClass ifNil:
- [PrimaryBytecodeSetEncoderClass := EncoderForV3PlusClosures].
- SecondaryBytecodeSetEncoderClass ifNil:
- [SecondaryBytecodeSetEncoderClass := EncoderForV3PlusClosures]!
Item was removed:
- ----- Method: CompiledMethod class>>CompiledMethodclassPROTOTYPEinstallPrimaryBytecodeSet: (in category '*Cog-method prototypes') -----
- CompiledMethodclassPROTOTYPEinstallPrimaryBytecodeSet: aBytecodeEncoderSubclass
- PrimaryBytecodeSetEncoderClass == aBytecodeEncoderSubclass ifTrue:
- [^self].
- (aBytecodeEncoderSubclass inheritsFrom: BytecodeEncoder) ifFalse:
- [self error: 'A bytecode set encoder is expected to be a subclass of BytecodeEncoder'].
- (self allSubInstances
- detect: [:m| m header >= 0 and: [m encoderClass ~~ aBytecodeEncoderSubclass]]
- ifNone: []) ifNotNil:
- [Warning signal: 'There are existing CompiledMethods with a different encoderClass.'].
- PrimaryBytecodeSetEncoderClass := aBytecodeEncoderSubclass!
Item was removed:
- ----- Method: CompiledMethod class>>CompiledMethodclassPROTOTYPEinstallSecondaryBytecodeSet: (in category '*Cog-method prototypes') -----
- CompiledMethodclassPROTOTYPEinstallSecondaryBytecodeSet: aBytecodeEncoderSubclass
- PrimaryBytecodeSetEncoderClass == aBytecodeEncoderSubclass ifTrue:
- [^self].
- (aBytecodeEncoderSubclass inheritsFrom: BytecodeEncoder) ifFalse:
- [self error: 'A bytecode set encoder is expected to be a subclass of BytecodeEncoder'].
- (self allSubInstances
- detect: [:m| m header < 0 and: [m encoderClass ~~ aBytecodeEncoderSubclass]]
- ifNone: []) ifNotNil:
- [Warning signal: 'There are existing CompiledMethods with a different encoderClass.'].
- SecondaryBytecodeSetEncoderClass := aBytecodeEncoderSubclass!
Item was removed:
- ----- Method: CompiledMethod class>>CompiledMethodclassPROTOTYPEnewBytes:trailerBytes:nArgs:nTemps:nStack:nLits:primitive: (in category '*Cog-method prototypes') -----
- CompiledMethodclassPROTOTYPEnewBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex
- "Answer an instance of me. The header is specified by the message
- arguments. The remaining parts are not as yet determined."
- | method pc |
- nArgs > 15 ifTrue:
- [^self error: 'Cannot compile -- too many arguments'].
- nTemps > 63 ifTrue:
- [^self error: 'Cannot compile -- too many temporary variables'].
- nLits > 32768 ifTrue:
- [^self error: 'Cannot compile -- too many literals'].
-
- method := trailer
- createMethod: numberOfBytes
- class: self
- header: (nArgs bitShift: 24)
- + (nTemps bitShift: 18)
- + ((nTemps + stackSize) > SmallFrame ifTrue: [1 bitShift: 17] ifFalse: [0])
- + nLits
- + (primitiveIndex > 0 ifTrue: [1 bitShift: 16] ifFalse: [0]).
- primitiveIndex > 0 ifTrue:
- [pc := method initialPC.
- method
- at: pc + 0 put: method encoderClass callPrimitiveCode;
- at: pc + 1 put: (primitiveIndex bitAnd: 16rFF);
- at: pc + 2 put: (primitiveIndex bitShift: -8)].
- ^method!
Item was removed:
- ----- Method: CompiledMethod class>>CompiledMethodclassPROTOTYPEnewBytes:trailerBytes:nArgs:nTemps:nStack:nLits:primitive:flag: (in category '*Cog-method prototypes') -----
- CompiledMethodclassPROTOTYPEnewBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex flag: flag
- "Answer an instance of me. The header is specified by the message
- arguments. The remaining parts are not as yet determined."
- | method pc |
- nArgs > 15 ifTrue:
- [^self error: 'Cannot compile -- too many arguments'].
- nTemps > 63 ifTrue:
- [^self error: 'Cannot compile -- too many temporary variables'].
- nLits > 32768 ifTrue:
- [^self error: 'Cannot compile -- too many literals'].
-
- method := trailer
- createMethod: numberOfBytes
- class: self
- header: (nArgs bitShift: 24)
- + (nTemps bitShift: 18)
- + ((nTemps + stackSize) > SmallFrame ifTrue: [1 bitShift: 17] ifFalse: [0])
- + nLits
- + (primitiveIndex > 0 ifTrue: [1 bitShift: 16] ifFalse: [0])
- + (flag ifTrue: [1 bitShift: 29] ifFalse: [0]).
- primitiveIndex > 0 ifTrue:
- [pc := method initialPC.
- method
- at: pc + 0 put: method encoderClass callPrimitiveCode;
- at: pc + 1 put: (primitiveIndex bitAnd: 16rFF);
- at: pc + 2 put: (primitiveIndex bitShift: -8)].
- ^method!
Item was removed:
- ----- Method: CompiledMethod>>CompiledMethodPROTOTYPEencoderClass (in category '*Cog-method prototypes') -----
- CompiledMethodPROTOTYPEencoderClass
- "Answer the encoder class that encoded the bytecodes in this method.
- The sign flag bit is used by the VM to select a bytecode set. This formulation
- may seem odd but this has to be fast, so no property probe unless needed."
-
- ^self header >= 0
- ifTrue:
- [PrimaryBytecodeSetEncoderClass]
- ifFalse:
- [PrimaryBytecodeSetEncoderClass == SecondaryBytecodeSetEncoderClass
- ifTrue: "Support for testing prior to installing another set"
- [(self propertyValueAt: #encoderClass) ifNil: [SecondaryBytecodeSetEncoderClass]]
- ifFalse:
- [SecondaryBytecodeSetEncoderClass]]!
Item was removed:
- ----- Method: Context>>ContextPROTOTYPEdoPrimitive:method:receiver:args: (in category '*Cog-method prototypes') -----
- ContextPROTOTYPEdoPrimitive: primitiveIndex method: meth receiver: aReceiver 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:
- [ Smalltalk tools debugger
- openContext: self
- label:'Code simulation error'
- contents: nil].
-
- ((primitiveIndex between: 201 and: 222)
- and: [(self objectClass: aReceiver) includesBehavior: BlockClosure]) ifTrue:
- [((primitiveIndex between: 201 and: 205) "BlockClosure>>value[:value:...]"
- or: [primitiveIndex between: 221 and: 222]) ifTrue: "BlockClosure>>valueNoContextSwitch[:]"
- [^aReceiver simulateValueWithArguments: arguments caller: self].
- primitiveIndex = 206 ifTrue: "BlockClosure>>valueWithArguments:"
- [^aReceiver simulateValueWithArguments: arguments first caller: self]].
-
- primitiveIndex = 83 ifTrue: "afr 9/11/1998 19:50" "Object>>perform:[with:...]"
- [^self send: arguments first to: aReceiver 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: aReceiver with: (arguments at: 2) lookupIn: (self objectClass: aReceiver)].
- primitiveIndex = 100 ifTrue: "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:"
- [^self send: arguments first to: aReceiver 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: [aReceiver primitiveEnterCriticalSectionOnBehalfOf: effective]
- ifFalse: [aReceiver primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: effective].
- ^(self isPrimFailToken: value)
- ifTrue: [value]
- ifFalse: [self push: value]].
-
- primitiveIndex = 188 ifTrue: "eem 5/27/2008 11:10 Object>>withArgs:executeMethod:"
- [^Context
- sender: self
- receiver: aReceiver
- method: (arguments at: 2)
- arguments: (arguments at: 1)].
-
- "Closure primitives"
- (primitiveIndex = 200 and: [self == aReceiver]) ifTrue:
- "ContextPart>>closureCopy:copiedValues:; simulated to get startpc right"
- [^self push: (BlockClosure
- outerContext: aReceiver
- startpc: 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:
- [^Context primitiveFailTokenFor: nil].
- ^self doPrimitive: arguments first method: meth receiver: aReceiver args: arguments last].
-
- value := primitiveIndex = 120 "FFI method"
- ifTrue: [(meth literalAt: 1) tryInvokeWithArguments: arguments]
- ifFalse:
- [primitiveIndex = 117 "named primitives"
- ifTrue: [self tryNamedPrimitiveIn: meth for: aReceiver withArgs: arguments]
- ifFalse: [aReceiver tryPrimitive: primitiveIndex withArgs: arguments]].
-
- ^(self isPrimFailToken: value)
- ifTrue: [value]
- ifFalse: [self push: value]!
Item was removed:
- ----- Method: Context>>ContextPROTOTYPEfailPrimitiveWith: (in category '*Cog-method prototypes') -----
- ContextPROTOTYPEfailPrimitiveWith: maybePrimFailToken
- "The receiver is a freshly-created context on a primitive method. Skip the callPrimitive:
- bytecode and store the primitive fail code if there is one and the method consumes it."
- self skipCallPrimitive.
- ((self isPrimFailToken: maybePrimFailToken)
- and: [method encoderClass isStoreAt: pc in: method]) ifTrue:
- [self at: stackp put: maybePrimFailToken last]!
Item was removed:
- ----- Method: Context>>ContextPROTOTYPEisPrimFailToken: (in category '*Cog-method prototypes') -----
- ContextPROTOTYPEisPrimFailToken: anObject
- ^ anObject class == Array
- and: [anObject size = 2
- and: [anObject first == PrimitiveFailToken]]!
Item was removed:
- ----- Method: Context>>ContextPROTOTYPEobjectClass: (in category '*Cog-method prototypes') -----
- ContextPROTOTYPEobjectClass: aReceiver
- <primitive: 111>
- self primitiveFailed!
Item was changed:
----- Method: Context>>xray (in category '*Cog-Tests-xrays') -----
xray
"Lift the veil from a context and answer an integer describing its interior state.
Used for e.g. VM tests so they can verify they're testing what they think they're testing.
0 implies a vanilla heap context.
Bit 0 = is or was married to a frame
Bit 1 = is still married to a frame
Bit 2 = frame is executing machine code
Bit 3 = has machine code pc (as opposed to nil or a bytecode pc)
Bit 4 = method is currently compiled to machine code"
<primitive: 213>
^0 "Can only fail if unimplemented; therefore simply answer 0"!
Item was changed:
----- Method: Context>>xrayIsDivorced (in category '*Cog-Tests-xrays') -----
xrayIsDivorced
^(self xray bitAnd: 3) = 1!
Item was changed:
----- Method: Context>>xrayIsExecutingMachineCode (in category '*Cog-Tests-xrays') -----
xrayIsExecutingMachineCode
^self xray anyMask: 4!
Item was changed:
----- Method: Context>>xrayIsMarried (in category '*Cog-Tests-xrays') -----
xrayIsMarried
^self xray anyMask: 2!
Item was changed:
----- Method: Context>>xrayLastExecutedMachineCode (in category '*Cog-Tests-xrays') -----
xrayLastExecutedMachineCode
^self xray anyMask: 8!
Item was changed:
----- Method: Context>>xrayMethodIsCompiledToMachineCode (in category '*Cog-Tests-xrays') -----
xrayMethodIsCompiledToMachineCode
^self xray anyMask: 16!
Item was removed:
- ----- Method: ContextPart>>ContextPartPROTOTYPEdoPrimitive:method:receiver:args: (in category '*Cog-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:
- [ToolSet
- debugContext: self
- label:'Code simulation error'
- contents: nil].
-
- ((primitiveIndex between: 201 and: 222)
- and: [(self objectClass: receiver) includesBehavior: BlockClosure]) ifTrue:
- [((primitiveIndex between: 201 and: 205) "BlockClosure>>value[:value:...]"
- or: [primitiveIndex between: 221 and: 222]) ifTrue: "BlockClosure>>valueNoContextSwitch[:]"
- [^receiver simulateValueWithArguments: arguments caller: self].
- primitiveIndex = 206 ifTrue: "BlockClosure>>valueWithArguments:"
- [^receiver simulateValueWithArguments: arguments first caller: self]].
-
- 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: 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:
- [^ContextPart primitiveFailTokenFor: nil].
- ^self doPrimitive: arguments first method: meth receiver: receiver args: arguments last].
-
- value := primitiveIndex = 120 "FFI method"
- ifTrue: [(meth literalAt: 1) tryInvokeWithArguments: arguments]
- ifFalse:
- [primitiveIndex = 117 "named primitives"
- ifTrue: [self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments]
- ifFalse: [receiver tryPrimitive: primitiveIndex withArgs: arguments]].
-
- ^(self isPrimFailToken: value)
- ifTrue: [value]
- ifFalse: [self push: value]!
Item was removed:
- ----- Method: ContextPart>>ContextPartPROTOTYPEisPrimFailToken: (in category '*Cog-method prototypes') -----
- ContextPartPROTOTYPEisPrimFailToken: anObject
- ^(self objectClass: anObject) == Array
- and: [anObject size = 2
- and: [anObject first == PrimitiveFailToken]]!
Item was removed:
- ----- Method: Decompiler>>DecompilerPROTOTYPEdecompile:in:method:using: (in category '*Cog-method prototypes squeak 4.3') -----
- DecompilerPROTOTYPEdecompile: aSelector in: aClass method: aMethod using: aConstructor
-
- | block node |
- constructor := aConstructor.
- method := aMethod.
- self initSymbols: aClass. "create symbol tables"
- method isQuick
- ifTrue: [block := self quickMethod]
- ifFalse:
- [stack := OrderedCollection new: method frameSize.
- lastJumpIfPcStack := OrderedCollection new.
- caseExits := OrderedCollection new.
- statements := OrderedCollection new: 20.
- numLocalTemps := 0.
- super method: method pc: method initialPC.
- "skip primitive error code store if necessary"
- (method primitive ~= 0 and: [self skipCallPrimitive; willStore]) ifTrue:
- [pc := pc + (method encoderClass bytecodeSize: self firstByte).
- tempVars := tempVars asOrderedCollection].
- block := self blockTo: method endPC + 1.
- stack isEmpty ifFalse: [self error: 'stack not empty']].
- node := constructor
- codeMethod: aSelector
- block: block
- tempVars: tempVars
- primitive: method primitive
- class: aClass.
- method primitive > 0 ifTrue:
- [node removeAndRenameLastTempIfErrorCode].
- ^node preen!
Item was changed:
----- Method: ETC>>setMethod: (in category 'initialize-release') -----
setMethod: aCompiledMethod
scanner := InstructionStream new method: aCompiledMethod pc: aCompiledMethod initialPC.
contextStack := OrderedCollection new.
+ currentContext := Context
- currentContext := MethodContext
sender: nil
receiver: nil
method: aCompiledMethod
arguments: ((1 to: aCompiledMethod numArgs) collect:
[:i| 'arg', i printString]).
aCompiledMethod numArgs + 1 to: aCompiledMethod numTemps do:
[:i| currentContext at: i put: 'tmp', (i - aCompiledMethod numArgs) printString].
sends := Dictionary new.
joinOffsets := Dictionary new.
blockEndStack := OrderedCollection new.
blockEnd := aCompiledMethod endPC.
topIsVector := false!
Item was removed:
- ----- Method: EncoderForV3PlusClosures>>EncoderForV3PlusClosuresPROTOTYPEgenCallPrimitive: (in category '*Cog-method prototypes') -----
- EncoderForV3PlusClosuresPROTOTYPEgenCallPrimitive: primitiveIndex
- "139 11101111 iiiiiiii jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256)"
- (primitiveIndex < 1 or: [primitiveIndex > 65535]) ifTrue:
- [self outOfRangeError: 'primitive index' index: primitiveIndex range: 1 to: 65535].
- stream
- nextPut: 139;
- nextPut: (primitiveIndex bitAnd: 255);
- nextPut: (primitiveIndex bitShift: -8)!
Item was removed:
- ----- Method: InstructionStream>>InstructionStreamPROTOTYPEinterpretV3ClosuresExtension:in:for: (in category '*Cog-method prototypes') -----
- InstructionStreamPROTOTYPEinterpretV3ClosuresExtension: offset in: method for: client
- | type offset2 byte2 byte3 byte4 |
- offset <= 6 ifTrue:
- ["Extended op codes 128-134"
- byte2 := method at: pc. pc := pc + 1.
- offset <= 2 ifTrue:
- ["128-130: extended pushes and pops"
- type := byte2 // 64.
- offset2 := byte2 \\ 64.
- offset = 0 ifTrue:
- [type = 0 ifTrue: [^client pushReceiverVariable: offset2].
- type = 1 ifTrue: [^client pushTemporaryVariable: offset2].
- type = 2 ifTrue: [^client pushConstant: (method literalAt: offset2 + 1)].
- type = 3 ifTrue: [^client pushLiteralVariable: (method literalAt: offset2 + 1)]].
- offset = 1 ifTrue:
- [type = 0 ifTrue: [^client storeIntoReceiverVariable: offset2].
- type = 1 ifTrue: [^client storeIntoTemporaryVariable: offset2].
- type = 2 ifTrue: [self error: 'illegalStore'].
- type = 3 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: offset2 + 1)]].
- offset = 2 ifTrue:
- [type = 0 ifTrue: [^client popIntoReceiverVariable: offset2].
- type = 1 ifTrue: [^client popIntoTemporaryVariable: offset2].
- type = 2 ifTrue: [self error: 'illegalStore'].
- type = 3 ifTrue: [^client popIntoLiteralVariable: (method literalAt: offset2 + 1)]]].
- "131-134: extended sends"
- offset = 3 ifTrue: "Single extended send"
- [^client send: (method literalAt: byte2 \\ 32 + 1)
- super: false numArgs: byte2 // 32].
- offset = 4 ifTrue: "Double extended do-anything"
- [byte3 := method at: pc. pc := pc + 1.
- type := byte2 // 32.
- type = 0 ifTrue: [^client send: (method literalAt: byte3 + 1)
- super: false numArgs: byte2 \\ 32].
- type = 1 ifTrue: [^client send: (method literalAt: byte3 + 1)
- super: true numArgs: byte2 \\ 32].
- type = 2 ifTrue: [^client pushReceiverVariable: byte3].
- type = 3 ifTrue: [^client pushConstant: (method literalAt: byte3 + 1)].
- type = 4 ifTrue: [^client pushLiteralVariable: (method literalAt: byte3 + 1)].
- type = 5 ifTrue: [^client storeIntoReceiverVariable: byte3].
- type = 6 ifTrue: [^client popIntoReceiverVariable: byte3].
- type = 7 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: byte3 + 1)]].
- offset = 5 ifTrue: "Single extended send to super"
- [^client send: (method literalAt: byte2 \\ 32 + 1)
- super: true
- numArgs: byte2 // 32].
- offset = 6 ifTrue: "Second extended send"
- [^client send: (method literalAt: byte2 \\ 64 + 1)
- super: false
- numArgs: byte2 // 64]].
- offset = 7 ifTrue: [^client doPop].
- offset = 8 ifTrue: [^client doDup].
- offset = 9 ifTrue: [^client pushActiveContext].
- byte2 := method at: pc. pc := pc + 1.
- offset = 10 ifTrue:
- [^byte2 < 128
- ifTrue: [client pushNewArrayOfSize: byte2]
- ifFalse: [client pushConsArrayWithElements: byte2 - 128]].
- byte3 := method at: pc. pc := pc + 1.
- offset = 11 ifTrue: [^client callPrimitive: byte2 + (byte3 bitShift: 8)].
- offset = 12 ifTrue: [^client pushRemoteTemp: byte2 inVectorAt: byte3].
- offset = 13 ifTrue: [^client storeIntoRemoteTemp: byte2 inVectorAt: byte3].
- offset = 14 ifTrue: [^client popIntoRemoteTemp: byte2 inVectorAt: byte3].
- "offset = 15"
- byte4 := method at: pc. pc := pc + 1.
- ^client
- pushClosureCopyNumCopiedValues: (byte2 bitShift: -4)
- numArgs: (byte2 bitAnd: 16rF)
- blockSize: (byte3 * 256) + byte4!
Item was removed:
- ----- Method: InstructionStream>>InstructionStreamPROTOTYPEnextPc: (in category '*Cog-method prototypes') -----
- InstructionStreamPROTOTYPEnextPc: currentByte
- "Answer the pc of the next bytecode following the current one, given the current bytecode.."
-
- ^pc + (self method encoderClass bytecodeSize: currentByte)!
Item was removed:
- ----- Method: InstructionStream>>InstructionStreamPROTOTYPEskipCallPrimitive (in category '*Cog-method prototypes') -----
- InstructionStreamPROTOTYPEskipCallPrimitive
- "If the receiver's method starts with a callPrimitive: bytecode, skip it."
- | method encoderClass callPrimitiveCode |
- method := self method.
- encoderClass := method encoderClass.
- callPrimitiveCode := encoderClass callPrimitiveCode.
- (method byteAt: pc) = callPrimitiveCode ifTrue:
- [pc := pc + (encoderClass bytecodeSize: callPrimitiveCode)]!
Item was removed:
- ----- Method: MCClassDefinition>>MCClassDefinitionPROTOTYPEkindOfSubclass (in category '*Cog-method prototypes squeak 4.3') -----
- MCClassDefinitionPROTOTYPEkindOfSubclass
- type = #normal ifTrue: [^' subclass: '].
- type = #variable ifTrue: [^' variableSubclass: '].
- type = #bytes ifTrue: [^' variableByteSubclass: '].
- type = #compiledMethod ifTrue: [^' variableByteSubclass: ' ].
- type = #words ifTrue: [^' variableWordSubclass: '].
- type = #weak ifTrue: [^' weakSubclass: ' ].
- type = #ephemeron ifTrue: [^' ephemeronSubclass: ' ].
- type = #immediate ifTrue: [^' immediateSubclass: ' ].
- self error: 'Unrecognized class type'!
Item was removed:
- ----- Method: MCMethodDefinition>>MCMethodDefinitionPROTOTYPEinitializeWithClassName:classIsMeta:selector:category:timeStamp:source: (in category '*Cog-method prototypes squeak 4.3') -----
- MCMethodDefinitionPROTOTYPEinitializeWithClassName: classString
- classIsMeta: metaBoolean
- selector: selectorString
- category: catString
- timeStamp: timeString
- source: sourceString
- className := classString asSymbol.
- selector := selectorString asSymbol.
- category := catString ifNil: [Categorizer default] ifNotNil: [catString asSymbol].
- timeStamp := timeString.
- classIsMeta := metaBoolean.
- source := sourceString withSqueakLineEndings!
Item was removed:
- ----- Method: MethodContext>>MethodContextPROTOTYPEfailPrimitiveWith: (in category '*Cog-method prototypes') -----
- MethodContextPROTOTYPEfailPrimitiveWith: maybePrimFailToken
- "The receiver is a freshly-created context on a primitive method. Skip the callPrimitive:
- bytecode and store the primitive fail code if there is one and the method consumes it."
- self skipCallPrimitive.
- ((self isPrimFailToken: maybePrimFailToken)
- and: [method encoderClass isStoreAt: pc in: method]) ifTrue:
- [self at: stackp put: maybePrimFailToken last]!
Item was removed:
- ----- Method: MethodContext>>xray (in category '*Cog-Tests-xrays') -----
- xray
- "Lift the veil from a context and answer an integer describing its interior state.
- Used for e.g. VM tests so they can verify they're testing what they think they're testing.
- 0 implies a vanilla heap context.
- Bit 0 = is or was married to a frame
- Bit 1 = is still married to a frame
- Bit 2 = frame is executing machine code
- Bit 3 = has machine code pc (as opposed to nil or a bytecode pc)
- Bit 4 = method is currently compiled to machine code"
- <primitive: 213>
- ^0 "Can only fail if unimplemented; therefore simply answer 0"!
Item was removed:
- ----- Method: MethodContext>>xrayIsDivorced (in category '*Cog-Tests-xrays') -----
- xrayIsDivorced
- ^(self xray bitAnd: 3) = 1!
Item was removed:
- ----- Method: MethodContext>>xrayIsExecutingMachineCode (in category '*Cog-Tests-xrays') -----
- xrayIsExecutingMachineCode
- ^self xray anyMask: 4!
Item was removed:
- ----- Method: MethodContext>>xrayIsMarried (in category '*Cog-Tests-xrays') -----
- xrayIsMarried
- ^self xray anyMask: 2!
Item was removed:
- ----- Method: MethodContext>>xrayLastExecutedMachineCode (in category '*Cog-Tests-xrays') -----
- xrayLastExecutedMachineCode
- ^self xray anyMask: 8!
Item was removed:
- ----- Method: MethodContext>>xrayMethodIsCompiledToMachineCode (in category '*Cog-Tests-xrays') -----
- xrayMethodIsCompiledToMachineCode
- ^self xray anyMask: 16!
Item was removed:
- ----- Method: MethodNode>>MethodNodePROTOTYPEgenerate:using: (in category '*Cog-method prototypes') -----
- MethodNodePROTOTYPEgenerate: trailer using: aCompiledMethodClass
- "The receiver is the root of a parse tree. Answer an instance of aCompiledMethodClass.
- 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."
-
- | primErrNode blkSize nLits locals literals stack header method |
- self generate: trailer
- using: aCompiledMethodClass
- ifQuick:
- [:m |
- encoder noteBlockExtent: (0 to: 2) hasLocals: arguments.
- m literalAt: 2 put: encoder associationForClass;
- properties: properties.
- ^m].
- primErrNode := self primitiveErrorVariableName ifNotNil:
- [encoder fixTemp: self primitiveErrorVariableName].
- self ensureClosureAnalysisDone.
- encoder rootNode: self. "this is for BlockNode>>sizeCodeForClosureValue:"
- blkSize := (block sizeCodeForEvaluatedValue: encoder)
- + (primitive > 0
- ifTrue: [encoder sizeCallPrimitive: primitive]
- ifFalse: [0])
- + (primErrNode
- ifNil: [0]
- ifNotNil:
- [primErrNode
- index: arguments size + temporaries size;
- sizeCodeForStore: encoder "The VM relies on storeIntoTemp: (129)"]).
- locals := arguments, temporaries, (primErrNode ifNil: [#()] ifNotNil: [{primErrNode}]).
- encoder noteBlockExtent: block blockExtent hasLocals: locals.
- header := encoder computeMethodHeaderForNumArgs: arguments size
- numTemps: locals size
- numLits: (nLits := (literals := encoder allLiterals) size)
- primitive: primitive.
- method := trailer
- createMethod: blkSize
- class: aCompiledMethodClass
- header: header.
- 1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)].
- encoder streamToMethod: method.
- stack := ParseStack new init.
- primitive > 0 ifTrue:
- [encoder genCallPrimitive: primitive.
- primErrNode ifNotNil:
- [primErrNode emitCodeForStore: stack encoder: encoder]].
- stack position: method numTemps.
- [block emitCodeForEvaluatedValue: stack encoder: encoder]
- on: Error "If an attempt is made to write too much code the method will be asked"
- do: [:ex| "to grow, and the grow attempt will fail in CompiledMethod class>>#new:"
- ex signalerContext sender method = (CompiledMethod class>>#new:)
- ifTrue: [^self error: 'Compiler code size discrepancy']
- ifFalse: [ex pass]].
- stack position ~= (method numTemps + 1) ifTrue:
- [^self error: 'Compiler stack discrepancy'].
- encoder methodStreamPosition ~= (method size - trailer size) ifTrue:
- [^self error: 'Compiler code size discrepancy'].
- method needsFrameSize: stack size - method numTemps.
- method properties: properties.
- ^method!
Item was removed:
- ----- Method: MethodNode>>MethodNodePROTOTYPEgenerate:using:ifQuick: (in category '*Cog-method prototypes') -----
- MethodNodePROTOTYPEgenerate: trailer using: aCompiledMethodClass ifQuick: methodBlock
- | v |
- (primitive = 0 and: [arguments size = 0 and: [block isQuick]]) ifFalse:
- [^self].
- v := block code.
- v < 0 ifTrue:
- [^self].
- v = LdSelf ifTrue:
- [^methodBlock value: (aCompiledMethodClass toReturnSelfTrailerBytes: trailer)].
- (v between: LdTrue and: LdMinus1 + 3) ifTrue:
- [^methodBlock value: (aCompiledMethodClass toReturnConstant: v - LdSelf trailerBytes: trailer)].
- v < ((CodeBases at: LdInstType) + (CodeLimits at: LdInstType)) ifTrue:
- [^methodBlock value: (aCompiledMethodClass toReturnField: v trailerBytes: trailer)].
- v // 256 = 1 ifTrue:
- [^methodBlock value: (aCompiledMethodClass toReturnField: v \\ 256 trailerBytes: trailer)]!
Item was removed:
- ----- Method: MethodNode>>MethodNodePROTOTYPEprintPropertiesOn: (in category '*Cog-method prototypes') -----
- MethodNodePROTOTYPEprintPropertiesOn: aStream
- properties ifNil: [^self].
- properties propertyKeysAndValuesDo:
- [:prop :val|
- aStream crtab; nextPut: $<.
- prop = #on:in:
- ifTrue:
- [prop keywords with: val do:
- [:k :v | aStream nextPutAll: k; space; nextPutAll: v; space]]
- ifFalse:
- [prop = #on
- ifTrue: [aStream nextPutAll: prop; nextPutAll:': '; nextPutAll: val]
- ifFalse: [aStream nextPutAll: prop; nextPutAll:': '; print: val]].
- aStream nextPut: $>]!
Item was removed:
- 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: 'Cog-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!
Item was removed:
- ----- Method: SpurBootstrap class>>bootstrapCuisImage: (in category 'utilities') -----
- bootstrapCuisImage: imageFileBaseName
- self bootstrapImage: imageFileBaseName type: #('squeak' 'cuis')!
Item was removed:
- ----- 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'!
Item was removed:
- ----- Method: SpurBootstrap class>>bootstrapOldSqueakImage: (in category 'utilities') -----
- bootstrapOldSqueakImage: imageFileBaseName
- "Try asnd bootstrap a pre-CompiledMethodTrailer Squeak image."
- self bootstrapImage: imageFileBaseName type: #('squeak' 'old squeak')!
Item was removed:
- ----- 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 ]!
Item was removed:
- ----- Method: SpurBootstrap class>>bootstrapSqueakImage: (in category 'utilities') -----
- bootstrapSqueakImage: imageFileBaseName
- self bootstrapImage: imageFileBaseName type: 'squeak'!
Item was removed:
- ----- 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]!
Item was removed:
- ----- Method: SpurBootstrap class>>defaultIntegerBaseInDebugger (in category 'debugger') -----
- defaultIntegerBaseInDebugger
- ^16!
Item was removed:
- ----- 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]]]]]!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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)]]]]]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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'!
Item was removed:
- ----- 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
- !
Item was removed:
- ----- 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'!
Item was removed:
- ----- 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'))!
Item was removed:
- ----- 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)]]!
Item was removed:
- ----- 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}]!
Item was removed:
- ----- Method: SpurBootstrap>>classMetaclass (in category 'bootstrap image') -----
- classMetaclass
- ^classMetaclass ifNil:
- [classMetaclass := oldHeap fetchClassOfNonImm: (oldHeap fetchClassOfNonImm: oldHeap classArray)]!
Item was removed:
- ----- 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??'!
Item was removed:
- ----- Method: SpurBootstrap>>classTableSize (in category 'class indices') -----
- classTableSize
- ^newHeap classIndexMask + 1!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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
- !
Item was removed:
- ----- 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!
Item was removed:
- ----- 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)!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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)!
Item was removed:
- ----- 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)]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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)]]!
Item was removed:
- ----- 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]]]]!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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]].!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrap>>firstOrdinaryClassIndex (in category 'class indices') -----
- firstOrdinaryClassIndex
- ^newHeap classTablePageSize!
Item was removed:
- ----- 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)]]]]!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrap>>headerForOldMethodHeader: (in category 'bootstrap image') -----
- headerForOldMethodHeader: methodHeaderOop
- ^self isOnSpur
- ifTrue: [self convertOldMethodHeader: methodHeaderOop]
- ifFalse: [oldHeap integerValueOf: methodHeaderOop]!
Item was removed:
- ----- Method: SpurBootstrap>>imageTypes: (in category 'bootstrap image') -----
- imageTypes: anArray
- imageTypes := anArray!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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'!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrap>>initialize (in category 'initialize-release') -----
- initialize
- super initialize.
- imageTypes := {'squeak'}. "By default, image is Squeak (so Eliot does not kick me :P)"!
Item was removed:
- ----- 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: #()]]!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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)]]!
Item was removed:
- ----- 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]]!
Item was removed:
- ----- Method: SpurBootstrap>>isOnSpur (in category 'testing') -----
- isOnSpur
- ^$c class instSize = 0!
Item was removed:
- ----- Method: SpurBootstrap>>launch (in category 'testing') -----
- launch
- self launch: newHeap
- simulatorClass: StackInterpreterSimulator
- headerFlags: oldInterpreter getImageHeaderFlags!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrap>>launchSaved (in category 'testing') -----
- launchSaved
- self launch: TransformedImage veryDeepCopy
- simulatorClass: StackInterpreterSimulator
- headerFlags: ImageHeaderFlags!
Item was removed:
- ----- Method: SpurBootstrap>>launchSavedWithJIT (in category 'testing') -----
- launchSavedWithJIT
- self launch: (self coHeapFrom: TransformedImage veryDeepCopy)
- simulatorClass: CogVMSimulator
- headerFlags: ImageHeaderFlags!
Item was removed:
- ----- 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]]]!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrap>>measureOldHeapPostGC (in category 'stats') -----
- measureOldHeapPostGC
- oldHeapSize := oldHeap freeStart.
- oldHeapNumObjs := 0.
- oldHeap allObjectsDo: [:o| oldHeapNumObjs := oldHeapNumObjs + 1]!
Item was removed:
- ----- 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: #()!
Item was removed:
- ----- 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]]]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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'!
Item was removed:
- ----- Method: SpurBootstrap>>oldClassOopFor: (in category 'bootstrap image') -----
- oldClassOopFor: aClass
- ^oldHeap fetchPointer: ValueIndex ofObject: (literalMap at: aClass binding).!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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: #()]]]]!
Item was removed:
- ----- 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}]]]!
Item was removed:
- ----- 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]]]]]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrap>>scavengeImage (in category 'bootstrap image') -----
- scavengeImage
- "Scavenge the image to get it into a simpler state."
- newHeap coInterpreter voidVMStateForSnapshotFlushingExternalPrimitivesIf: false.
- newHeap flushNewSpace!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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)]!
Item was removed:
- ----- 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
- !
Item was removed:
- ----- Method: SpurBootstrap>>symbolClass (in category 'bootstrap methods') -----
- symbolClass
- ^oldHeap fetchClassOfNonImm: (oldHeap splObj: SelectorDoesNotUnderstand)!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrap>>wordSize (in category 'word size') -----
- wordSize
- ^self subclassResponsibility!
Item was removed:
- ----- Method: SpurBootstrap>>wordSizeMask (in category 'word size') -----
- wordSizeMask
- ^self subclassResponsibility!
Item was removed:
- ----- 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!!'!
Item was removed:
- SpurBootstrap subclass: #SpurBootstrap32
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Cog-Bootstrapping'!
Item was removed:
- ----- 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)]!
Item was removed:
- ----- Method: SpurBootstrap32>>wordSize (in category 'word size') -----
- wordSize
- ^4!
Item was removed:
- ----- Method: SpurBootstrap32>>wordSizeMask (in category 'word size') -----
- wordSizeMask
- ^3!
Item was removed:
- SpurBootstrapSqueakFamilyPrototypes subclass: #SpurBootstrapCuisPrototypes
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Cog-Bootstrapping'!
Item was removed:
- ----- Method: SpurBootstrapCuisPrototypes class>>imageType (in category 'accessing') -----
- imageType
- ^ 'cuis'!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapCuisPrototypes>>BlockClosurePROTOTYPEsimulateValueWithArguments:caller: (in category 'method prototypes') -----
- BlockClosurePROTOTYPEsimulateValueWithArguments: anArray caller: aContext
- <indirect>!
Item was removed:
- ----- Method: SpurBootstrapCuisPrototypes>>CharacterPROTOTYPEclone (in category 'method prototypes') -----
- CharacterPROTOTYPEclone
- "Answer the receiver, because Characters are unique."
- ^self!
Item was removed:
- ----- Method: SpurBootstrapCuisPrototypes>>CharacterPROTOTYPEsetValue: (in category 'method prototypes') -----
- CharacterPROTOTYPEsetValue: v
- <remove>!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapCuisPrototypes>>CharacterclassPROTOTYPEinitialize (in category 'method prototypes') -----
- CharacterclassPROTOTYPEinitialize
- <ignore>!
Item was removed:
- ----- 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"!
Item was removed:
- ----- Method: SpurBootstrapCuisPrototypes>>ClassDescriptionPROTOTYPEupdateMethodBindingsTo: (in category 'method prototypes') -----
- ClassDescriptionPROTOTYPEupdateMethodBindingsTo: aBinding
- <indirect>!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapCuisPrototypes>>CompiledMethodPROTOTYPEbytecodeSetName (in category 'method prototypes') -----
- CompiledMethodPROTOTYPEbytecodeSetName
- ^self encoderClass name copyReplaceAll: 'EncoderFor' with: ''!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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}!
Item was removed:
- ----- 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:
- [^ContextPart primitiveFailTokenFor: nil].
- ^self doPrimitive: arguments first method: meth receiver: receiver args: arguments last].
-
- value := primitiveIndex = 120 "FFI method"
- ifTrue: [(meth literalAt: 1) tryInvokeWithArguments: arguments]
- ifFalse:
- [primitiveIndex = 117 "named primitives"
- ifTrue: [self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments]
- ifFalse: [receiver tryPrimitive: primitiveIndex withArgs: arguments]].
-
- ^(self isPrimFailToken: value)
- ifTrue: [value]
- ifFalse: [self push: value]!
Item was removed:
- ----- Method: SpurBootstrapCuisPrototypes>>ContextPartPROTOTYPEisPrimFailToken: (in category 'method prototypes') -----
- ContextPartPROTOTYPEisPrimFailToken: anObject
- <indirect>!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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])!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapCuisPrototypes>>IntegerclassPROTOTYPEinitialize (in category 'method prototypes') -----
- IntegerclassPROTOTYPEinitialize
- "Integer initialize"
- self initializeLowBitPerByteTable!
Item was removed:
- ----- Method: SpurBootstrapCuisPrototypes>>MethodContextPROTOTYPEfailPrimitiveWith: (in category 'method prototypes') -----
- MethodContextPROTOTYPEfailPrimitiveWith: maybePrimFailToken
- <indirect>!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]!
Item was removed:
- ----- Method: SpurBootstrapCuisPrototypes>>MethodNodePROTOTYPEgenerate:using:ifQuick: (in category 'method prototypes') -----
- MethodNodePROTOTYPEgenerate: trailer using: aCompiledMethodClass ifQuick: methodBlock
- <indirect>!
Item was removed:
- ----- 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"!
Item was removed:
- ----- Method: SpurBootstrapCuisPrototypes>>SmallIntegerPROTOTYPEclone (in category 'method prototypes') -----
- SmallIntegerPROTOTYPEclone
- "Answer the receiver, because SmallIntegers are unique."
- ^self!
Item was removed:
- ----- Method: SpurBootstrapCuisPrototypes>>SmalltalkImagePROTOTYPErecreateSpecialObjectsArray (in category 'method prototypes') -----
- SmalltalkImagePROTOTYPErecreateSpecialObjectsArray
- <remove>!
Item was removed:
- ----- 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>!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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"!
Item was removed:
- ----- 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!
Item was removed:
- Object subclass: #SpurBootstrapMonticelloPackagePatcher
- instanceVariableNames: 'sourceDir destDir packagesAndPatches imageTypes'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Cog-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!
Item was removed:
- ----- 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')
- )!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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')!
Item was removed:
- ----- Method: SpurBootstrapMonticelloPackagePatcher>>directoryFrom: (in category 'initialization') -----
- directoryFrom: dirName
- ^FileDirectory on: (dirName first = $/
- ifTrue: [dirName]
- ifFalse: [(FileDirectory default directoryNamed: dirName) fullName])!
Item was removed:
- ----- 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].!
Item was removed:
- ----- 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)]]!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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'!
Item was removed:
- ----- Method: SpurBootstrapMonticelloPackagePatcher>>from:to: (in category 'initialization') -----
- from: sourceDirName to: destDirName
- sourceDir := self directoryFrom: sourceDirName.
- destDir := self directoryFrom: destDirName!
Item was removed:
- ----- Method: SpurBootstrapMonticelloPackagePatcher>>imageTypes: (in category 'initialization') -----
- imageTypes: typeArray
- imageTypes := typeArray!
Item was removed:
- ----- 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])!
Item was removed:
- ----- 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')])!
Item was removed:
- ----- Method: SpurBootstrapMonticelloPackagePatcher>>packageForMissingClassNamed: (in category 'accessing') -----
- packageForMissingClassNamed: className
- (className = #BoxedFloat64
- or: [className = #SmallFloat64]) ifTrue:
- [^PackageInfo named: 'Kernel'].
- self error: 'unknown missing class'!
Item was removed:
- ----- Method: SpurBootstrapMonticelloPackagePatcher>>packages (in category 'private-accessing') -----
- packages
- "Answer the packages Spur modifies."
- ^self packagesAndPatches keys!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]]!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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]"!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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']!
Item was removed:
- ----- 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'!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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)]!
Item was removed:
- ----- Method: SpurBootstrapMonticelloPackagePatcher>>trunk (in category 'repository population') -----
- trunk
- ^self repositoryForUrl: 'http://source.squeak.org/trunk'!
Item was removed:
- ----- Method: SpurBootstrapMonticelloPackagePatcher>>uploadFrom:to: (in category 'repository population') -----
- uploadFrom: localRepo to: uploadRepository
- localRepo allVersionsDo:
- [:version|
- (uploadRepository includesVersionNamed: version info name) ifFalse:
- [uploadRepository storeVersion: version]]!
Item was removed:
- ----- 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]]]!
Item was removed:
- ----- 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"!
Item was removed:
- ----- 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]!
Item was removed:
- Object subclass: #SpurBootstrapNewspeakFilePatcher
- instanceVariableNames: 'source substitutions'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Cog-Bootstrapping'!
Item was removed:
- ----- 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]!
Item was removed:
- ----- Method: SpurBootstrapNewspeakFilePatcher>>findClassDeclarationFor:in: (in category 'parsing') -----
- findClassDeclarationFor: className in: ast "<ClassDeclarationAST>" "^(ClassDeclarationAST|nil)"
- ^ast instanceSide nestedClasses
- detect: [:classDecl| classDecl name = className]
- ifNone: []!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapNewspeakFilePatcher>>initialize (in category 'initialize-release') -----
- initialize
- substitutions := SortedCollection sortBlock: [:tupleA :tupleB | tupleA first <= tupleB first]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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')!
Item was removed:
- ----- 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}]]]]!
Item was removed:
- SpurBootstrapPrototypes subclass: #SpurBootstrapPharoPrototypes
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Cog-Bootstrapping'!
Item was removed:
- ----- Method: SpurBootstrapPharoPrototypes class>>imageType (in category 'accessing') -----
- imageType
- ^ 'pharo'!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapPharoPrototypes>>BlockClosurePHAROPROTOTYPEsimulateValueWithArguments:caller: (in category 'method prototypes') -----
- BlockClosurePHAROPROTOTYPEsimulateValueWithArguments: anArray caller: aContext
- <indirect>!
Item was removed:
- ----- Method: SpurBootstrapPharoPrototypes>>CharacterPROTOTYPEcodePoint (in category 'method prototypes') -----
- CharacterPROTOTYPEcodePoint
- "Just for ANSI Compliance"
- ^self asciiValue!
Item was removed:
- ----- Method: SpurBootstrapPharoPrototypes>>CharacterPROTOTYPEsetValue: (in category 'method prototypes') -----
- CharacterPROTOTYPEsetValue: newValue
- self error: 'Characters are immutable'!
Item was removed:
- ----- Method: SpurBootstrapPharoPrototypes>>CharacterPROTOTYPEshallowCopy (in category 'method prototypes') -----
- CharacterPROTOTYPEshallowCopy
- "Answer the receiver, because Characters are unique."
- ^self!
Item was removed:
- ----- Method: SpurBootstrapPharoPrototypes>>ContextPROTOTYPEdoPrimitive:method:receiver:args: (in category 'method prototypes') -----
- ContextPROTOTYPEdoPrimitive: primitiveIndex method: meth receiver: aReceiver args: arguments
- <indirect>!
Item was removed:
- ----- Method: SpurBootstrapPharoPrototypes>>ContextPROTOTYPEfailPrimitiveWith: (in category 'method prototypes') -----
- ContextPROTOTYPEfailPrimitiveWith: maybePrimFailToken
- <indirect>!
Item was removed:
- ----- Method: SpurBootstrapPharoPrototypes>>ContextPROTOTYPEisPrimFailToken: (in category 'method prototypes') -----
- ContextPROTOTYPEisPrimFailToken: anObject
- <indirect>
- !
Item was removed:
- ----- Method: SpurBootstrapPharoPrototypes>>ContextPROTOTYPEobjectClass: (in category 'method prototypes') -----
- ContextPROTOTYPEobjectClass: aReceiver
- <indirect>!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEallInstances (in category 'method prototypes') -----
- TraitBehaviorPROTOTYPEallInstances
- "Answer all instances of the receiver."
- self error: 'Traits does not have instances.'!
Item was removed:
- ----- 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.'!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]]!
Item was removed:
- ----- 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: ']]]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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"!
Item was removed:
- Object subclass: #SpurBootstrapPrototypes
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Cog-Bootstrapping'!
Item was removed:
- ----- 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']]!
Item was removed:
- ----- Method: SpurBootstrapPrototypes class>>imageType (in category 'accessing') -----
- imageType
- ^ self subclassResponsibility!
Item was removed:
- ----- Method: SpurBootstrapPrototypes class>>prototypeClassFor: (in category 'instance creation') -----
- prototypeClassFor: type
- | deepest |
- deepest := nil.
- self allSubclassesDo:
- [:aClass | aClass imageType = type ifTrue: [deepest := aClass]].
- ^deepest!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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"!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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"!
Item was removed:
- ----- 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"!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEinstSize (in category 'method prototypes') -----
- BehaviorPROTOTYPEinstSize
- <indirect>!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEinstSpec (in category 'method prototypes') -----
- BehaviorPROTOTYPEinstSpec
- <indirect>!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEisCompiledMethodClass (in category 'method prototypes') -----
- BehaviorPROTOTYPEisCompiledMethodClass
- "Answer whether the receiver has compiled method instances that mix pointers and bytes."
- ^self instSpec >= 24!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]]!
Item was removed:
- ----- 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: ']]]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>BoxedFloat64classPROTOTYPEbasicNew (in category 'method prototypes') -----
- BoxedFloat64classPROTOTYPEbasicNew
- ^self basicNew: 2!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>BytecodeEncoderPROTOTYPEsizeCallPrimitive: (in category 'method prototypes') -----
- BytecodeEncoderPROTOTYPEsizeCallPrimitive: primitiveIndex
- ^self sizeOpcodeSelector: #genCallPrimitive: withArguments: {primitiveIndex}!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEasInteger (in category 'method prototypes') -----
- CharacterPROTOTYPEasInteger
- "Answer the receiver's character code."
- <primitive: 171>
- ^self primitiveFailed!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEcomeFullyUpOnReload: (in category 'method prototypes') -----
- CharacterPROTOTYPEcomeFullyUpOnReload: smartRefStream
- "Now Characters are immediates, this can be deleted."
- <remove>!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEcopy (in category 'method prototypes') -----
- CharacterPROTOTYPEcopy
- "Answer the receiver, because Characters are unique."
- ^self!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEdeepCopy (in category 'method prototypes') -----
- CharacterPROTOTYPEdeepCopy
- "Answer the receiver, because Characters are unique."
- ^self!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEhash (in category 'method prototypes') -----
- CharacterPROTOTYPEhash
- "Hash is reimplemented because = is implemented.
- Answer the receiver's character code."
- <primitive: 171>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEidentityHash (in category 'method prototypes') -----
- CharacterPROTOTYPEidentityHash
- "Answer the receiver's character code."
- <primitive: 171>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEshallowCopy (in category 'method prototypes') -----
- CharacterPROTOTYPEshallowCopy
- "Answer the receiver, because Characters are unique."
- ^self!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEveryDeepCopyWith: (in category 'method prototypes') -----
- CharacterPROTOTYPEveryDeepCopyWith: deepCopier
- "Answer the receiver, because Characters are unique."
- ^self!
Item was removed:
- ----- 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])!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>CharacterclassPROTOTYPEinitialize (in category 'method prototypes') -----
- CharacterclassPROTOTYPEinitialize
- "Create the DigitsValues table."
- "Character initialize"
- self initializeDigitValues!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>CharacterclassPROTOTYPEvalue: (in category 'method prototypes') -----
- CharacterclassPROTOTYPEvalue: anInteger
- "Answer the Character whose value is anInteger."
- <primitive: 170>
- ^self primitiveFailed!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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"!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>CompiledMethodPROTOTYPEnumLiterals (in category 'method prototypes') -----
- CompiledMethodPROTOTYPEnumLiterals
- "Answer the number of literals used by the receiver."
- ^self header bitAnd: 16r7FFF!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEheaderFlagForEncoder: (in category 'method prototypes') -----
- CompiledMethodclassPROTOTYPEheaderFlagForEncoder: anEncoder
- <indirect>!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEinitialize (in category 'method prototypes') -----
- CompiledMethodclassPROTOTYPEinitialize "CompiledMethod initialize"
- <indirect>!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEinstallPrimaryBytecodeSet: (in category 'method prototypes') -----
- CompiledMethodclassPROTOTYPEinstallPrimaryBytecodeSet: aBytecodeEncoderSubclass
- <indirect>!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEinstallSecondaryBytecodeSet: (in category 'method prototypes') -----
- CompiledMethodclassPROTOTYPEinstallSecondaryBytecodeSet: aBytecodeEncoderSubclass
- <indirect>!
Item was removed:
- ----- 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>!
Item was removed:
- ----- 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>!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>EncoderForV3PROTOTYPEcomputeMethodHeaderForNumArgs:numTemps:numLits:primitive: (in category 'method prototypes') -----
- EncoderForV3PROTOTYPEcomputeMethodHeaderForNumArgs: numArgs numTemps: numTemps numLits: numLits primitive: primitiveIndex
- <remove>!
Item was removed:
- ----- 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>!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>EncoderForV3PlusClosuresclassPROTOTYPEcallPrimitiveCode (in category 'method prototypes') -----
- EncoderForV3PlusClosuresclassPROTOTYPEcallPrimitiveCode
- "139 11101111 iiiiiiii jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256)"
- ^139!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>FloatclassPROTOTYPEbasicNew (in category 'method prototypes') -----
- FloatclassPROTOTYPEbasicNew
- ^BoxedFloat64 basicNew: 2!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>FloatclassPROTOTYPEbasicNew: (in category 'method prototypes') -----
- FloatclassPROTOTYPEbasicNew: anInteger
- ^BoxedFloat64 basicNew: 2!
Item was removed:
- ----- 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"!
Item was removed:
- ----- 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."!
Item was removed:
- ----- 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>!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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>!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>ObjectPROTOTYPEoopAge (in category 'method prototypes') -----
- ObjectPROTOTYPEoopAge
- <remove>!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>ObjectPROTOTYPEoopTimestamp (in category 'method prototypes') -----
- ObjectPROTOTYPEoopTimestamp
- <remove>!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>SmallFloat64PROTOTYPEclone (in category 'method prototypes') -----
- SmallFloat64PROTOTYPEclone
- "Answer the receiver, because SmallFloat64s are unique."
- ^self!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>SmallFloat64PROTOTYPEcopy (in category 'method prototypes') -----
- SmallFloat64PROTOTYPEcopy
- "Answer the receiver, because SmallFloat64s are unique."
- ^self!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>SmallFloat64PROTOTYPEdeepCopy (in category 'method prototypes') -----
- SmallFloat64PROTOTYPEdeepCopy
- "Answer the receiver, because SmallFloat64s are unique."
- ^self!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>SmallFloat64PROTOTYPEidentityHash (in category 'method prototypes') -----
- SmallFloat64PROTOTYPEidentityHash
- "Answer an integer unique to the receiver."
- <primitive: 171>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>SmallFloat64PROTOTYPEshallowCopy (in category 'method prototypes') -----
- SmallFloat64PROTOTYPEshallowCopy
- "Answer the receiver, because SmallFloat64s are unique."
- ^self!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>SmallFloat64PROTOTYPEveryDeepCopyWith: (in category 'method prototypes') -----
- SmallFloat64PROTOTYPEveryDeepCopyWith: deepCopier
- "Answer the receiver, because SmallFloat64s are unique."
- ^self!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>SmallFloat64classPROTOTYPEbasicNew (in category 'method prototypes') -----
- SmallFloat64classPROTOTYPEbasicNew
- self error: 'SmallFloat64s can only be created by performing arithmetic'!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>SmallFloat64classPROTOTYPEbasicNew: (in category 'method prototypes') -----
- SmallFloat64classPROTOTYPEbasicNew: anInteger
- ^self basicNew!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>SmallIntegerPROTOTYPEasCharacter (in category 'method prototypes') -----
- SmallIntegerPROTOTYPEasCharacter
- <primitive: 170>
- ^self primitiveFailed!
Item was removed:
- ----- 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]]]]]]!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>SmalltalkImagePROTOTYPEcompactClassesArray (in category 'method prototypes') -----
- SmalltalkImagePROTOTYPEcompactClassesArray
- "Smalltalk compactClassesArray"
- "Backward-compatibility support. Spur does not have compact classes."
- ^{}!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>SmalltalkImagePROTOTYPEmaxIdentityHash (in category 'method prototypes') -----
- SmalltalkImagePROTOTYPEmaxIdentityHash
- "Answer the maximum identityHash value supported by the VM."
- <primitive: 176>
- ^self primitiveFailed!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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 }!
Item was removed:
- ----- 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]!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>SystemDictionaryPROTOTYPEmaxIdentityHash (in category 'method prototypes') -----
- SystemDictionaryPROTOTYPEmaxIdentityHash
- "Answer the maximum identityHash value supported by the VM."
- <primitive: 176>
- ^self primitiveFailed!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]]!
Item was removed:
- ----- 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]!
Item was removed:
- SpurBootstrapSqueakFamilyPrototypes subclass: #SpurBootstrapSqueak43Prototypes
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Cog-Bootstrapping'!
Item was removed:
- ----- Method: SpurBootstrapSqueak43Prototypes class>>imageType (in category 'accessing') -----
- imageType
- ^ 'squeak 4.3'!
Item was removed:
- ----- Method: SpurBootstrapSqueak43Prototypes>>BlockClosurePROTOTYPEsimulateValueWithArguments:caller: (in category 'method prototypes') -----
- BlockClosurePROTOTYPEsimulateValueWithArguments: anArray caller: aContext
- <indirect>!
Item was removed:
- ----- Method: SpurBootstrapSqueak43Prototypes>>CharacterPROTOTYPEshouldBePrintedAsLiteral (in category 'method prototypes') -----
- CharacterPROTOTYPEshouldBePrintedAsLiteral
-
- ^(self asInteger between: 33 and: 255) and: [self asInteger ~= 127]!
Item was removed:
- ----- Method: SpurBootstrapSqueak43Prototypes>>CompiledMethodPROTOTYPEencoderClass (in category 'method prototypes') -----
- CompiledMethodPROTOTYPEencoderClass
- <indirect>!
Item was removed:
- ----- Method: SpurBootstrapSqueak43Prototypes>>DecompilerPROTOTYPEdecompile:in:method:using: (in category 'method prototypes') -----
- DecompilerPROTOTYPEdecompile: aSelector in: aClass method: aMethod using: aConstructor
- <indirect>!
Item was removed:
- ----- Method: SpurBootstrapSqueak43Prototypes>>InstructionStreamPROTOTYPEinterpretExtension:in:for: (in category 'method prototypes') -----
- InstructionStreamPROTOTYPEinterpretExtension: offset in: method for: client
- ^self interpretV3ClosuresExtension: offset in: method for: client!
Item was removed:
- ----- Method: SpurBootstrapSqueak43Prototypes>>InstructionStreamPROTOTYPEnextPc: (in category 'method prototypes') -----
- InstructionStreamPROTOTYPEnextPc: currentByte
- <indirect>!
Item was removed:
- ----- Method: SpurBootstrapSqueak43Prototypes>>InstructionStreamPROTOTYPEskipCallPrimitive (in category 'method prototypes') -----
- InstructionStreamPROTOTYPEskipCallPrimitive
- <indirect>!
Item was removed:
- ----- Method: SpurBootstrapSqueak43Prototypes>>MCClassDefinitionPROTOTYPEkindOfSubclass (in category 'method prototypes') -----
- MCClassDefinitionPROTOTYPEkindOfSubclass
- <indirect>!
Item was removed:
- ----- 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>!
Item was removed:
- ----- Method: SpurBootstrapSqueak43Prototypes>>MethodNodePROTOTYPEprintPropertiesOn: (in category 'method prototypes') -----
- MethodNodePROTOTYPEprintPropertiesOn: aStream
- <indirect>!
Item was removed:
- SpurBootstrapPrototypes subclass: #SpurBootstrapSqueakFamilyPrototypes
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Cog-Bootstrapping'!
Item was removed:
- ----- Method: SpurBootstrapSqueakFamilyPrototypes class>>imageType (in category 'accessing') -----
- imageType
- ^'squeak'!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapSqueakFamilyPrototypes>>InstructionPrinterPROTOTYPEcallPrimitive: (in category 'method prototypes') -----
- InstructionPrinterPROTOTYPEcallPrimitive: index
- "Print the callPrimitive bytecode."
-
- self print: 'callPrimitive: ' , index printString!
Item was removed:
- SpurBootstrapSqueakFamilyPrototypes subclass: #SpurBootstrapSqueakPrototypes
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Cog-Bootstrapping'!
Item was removed:
- ----- Method: SpurBootstrapSqueakPrototypes class>>imageType (in category 'accessing') -----
- imageType
- ^ 'squeak'!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapSqueakPrototypes>>BlockClosurePROTOTYPEsimulateValueWithArguments:caller: (in category 'method prototypes') -----
- BlockClosurePROTOTYPEsimulateValueWithArguments: anArray caller: aContext
- <indirect>!
Item was removed:
- ----- Method: SpurBootstrapSqueakPrototypes>>CharacterPROTOTYPEclone (in category 'method prototypes') -----
- CharacterPROTOTYPEclone
- "Answer the receiver, because Characters are unique."
- ^self!
Item was removed:
- ----- Method: SpurBootstrapSqueakPrototypes>>CharacterPROTOTYPEsetValue: (in category 'method prototypes') -----
- CharacterPROTOTYPEsetValue: v
- <remove>!
Item was removed:
- ----- Method: SpurBootstrapSqueakPrototypes>>ClassDescriptionPROTOTYPEupdateMethodBindingsTo: (in category 'method prototypes') -----
- ClassDescriptionPROTOTYPEupdateMethodBindingsTo: aBinding
- <indirect>!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapSqueakPrototypes>>CompiledMethodPROTOTYPEbytecodeSetName (in category 'method prototypes') -----
- CompiledMethodPROTOTYPEbytecodeSetName
- ^self encoderClass name copyReplaceAll: 'EncoderFor' with: ''!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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}!
Item was removed:
- ----- Method: SpurBootstrapSqueakPrototypes>>ContextPartPROTOTYPEdoPrimitive:method:receiver:args: (in category 'method prototypes') -----
- ContextPartPROTOTYPEdoPrimitive: primitiveIndex method: meth receiver: receiver args: arguments
- <indirect>!
Item was removed:
- ----- Method: SpurBootstrapSqueakPrototypes>>ContextPartPROTOTYPEisPrimFailToken: (in category 'method prototypes') -----
- ContextPartPROTOTYPEisPrimFailToken: anObject
- <indirect>!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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])!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SpurBootstrapSqueakPrototypes>>IntegerclassPROTOTYPEinitialize (in category 'method prototypes') -----
- IntegerclassPROTOTYPEinitialize
- "Integer initialize"
- self initializeLowBitPerByteTable!
Item was removed:
- ----- Method: SpurBootstrapSqueakPrototypes>>MethodContextPROTOTYPEfailPrimitiveWith: (in category 'method prototypes') -----
- MethodContextPROTOTYPEfailPrimitiveWith: maybePrimFailToken
- <indirect>!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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"!
Item was removed:
- ----- Method: SpurBootstrapSqueakPrototypes>>SmallIntegerPROTOTYPEclone (in category 'method prototypes') -----
- SmallIntegerPROTOTYPEclone
- "Answer the receiver, because SmallIntegers are unique."
- ^self!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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"!
Item was removed:
- ----- 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"!
Item was removed:
- Spur32BitMMLESimulator subclass: #SpurOldFormat32BitMMLESimulator
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Cog-Bootstrapping'!
Item was removed:
- ----- Method: SpurOldFormat32BitMMLESimulator>>literalCountOfMethodHeader: (in category 'method access') -----
- literalCountOfMethodHeader: header
- self assert: (self isIntegerObject: header).
- ^header >> 10 bitAnd: 16rFF!
Item was removed:
- ----- Method: SpurOldFormat32BitMMLESimulator>>primitiveIndexOfMethodHeader: (in category 'method access') -----
- primitiveIndexOfMethodHeader: methodHeader
- | primBits |
- primBits := (self integerValueOf: methodHeader) bitAnd: 16r100001FF.
- ^(primBits bitAnd: 16r1FF) + (primBits >> 19)!
Item was removed:
- SimulatorHarness subclass: #SpurOldToNewMethodFormatMunger
- instanceVariableNames: 'interpreter heap prototypes replacements symbolOops'
- classVariableNames: ''
- poolDictionaries: 'VMObjectIndices'
- category: 'Cog-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.
- !
Item was removed:
- ----- 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
- !
Item was removed:
- ----- 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)!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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'!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]]]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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}]]]!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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!!'!
Item was removed:
- ----- 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]!
1
0
Eliot Miranda uploaded a new version of CogAttic to project VM Maker:
http://source.squeak.org/VMMaker/CogAttic-eem.2.mcz
==================== Summary ====================
Name: CogAttic-eem.2
Author: eem
Time: 3 April 2017, 9:46:38.619161 am
UUID: 385514d5-9588-46f5-bdcd-624613922bb4
Ancestors: CogAttic-eem.1
Move all the Spur bootstrap method prototypes and the CLosure bootstrap script to the attic.
=============== Diff against CogAttic-eem.1 ===============
Item was added:
+ ----- Method: Behavior>>BehaviorPROTOTYPEinstSize (in category '*CogAttic-method prototypes') -----
+ BehaviorPROTOTYPEinstSize
+ "Answer the number of named instance variables
+ (as opposed to indexed variables) of the receiver.
+ Above Cog Spur the class format is
+ <5 bits inst spec><16 bits inst size>"
+ ^format bitAnd: 16rFFFF!
Item was added:
+ ----- Method: Behavior>>BehaviorPROTOTYPEinstSpec (in category '*CogAttic-method prototypes') -----
+ BehaviorPROTOTYPEinstSpec
+ "Answer the instance specification part of the format that defines what kind of object
+ an instance of the receiver is. The formats are
+ 0 = 0 sized objects (UndefinedObject True False et al)
+ 1 = non-indexable objects with inst vars (Point et al)
+ 2 = indexable objects with no inst vars (Array et al)
+ 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
+ 4 = weak indexable objects with inst vars (WeakArray et al)
+ 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
+ 6 = unused
+ 7 = immediates (SmallInteger, Character)
+ 8 = unused
+ 9 = 64-bit indexable
+ 10-11 = 32-bit indexable (Bitmap)
+ 12-15 = 16-bit indexable
+ 16-23 = 8-bit indexable
+ 24-31 = compiled methods (CompiledMethod)"
+ ^(format bitShift: -16) bitAnd: 16r1F!
Item was added:
+ ----- Method: BlockClosure>>BlockClosurePHAROPROTOTYPEsimulateValueWithArguments:caller: (in category '*CogAttic-method prototypes') -----
+ BlockClosurePHAROPROTOTYPEsimulateValueWithArguments: anArray caller: aContext
+ "Simulate the valueWithArguments: primitive. Fail if anArray is not an array of the right arity."
+ | newContext sz |
+ newContext := (Context newForMethod: outerContext method)
+ setSender: aContext
+ receiver: outerContext receiver
+ method: outerContext method
+ closure: self
+ startpc: startpc.
+ ((newContext objectClass: anArray) ~~ Array
+ or: [numArgs ~= anArray size]) ifTrue:
+ [^Context primitiveFailTokenFor: nil].
+ sz := self basicSize.
+ newContext stackp: sz + numArgs.
+ 1 to: numArgs do:
+ [:i| newContext at: i put: (anArray at: i)].
+ 1 to: sz do:
+ [:i| newContext at: i + numArgs put: (self at: i)].
+ ^newContext!
Item was added:
+ ----- Method: BlockClosure>>BlockClosurePROTOTYPEsimulateValueWithArguments:caller: (in category '*CogAttic-method prototypes') -----
+ BlockClosurePROTOTYPEsimulateValueWithArguments: anArray caller: aContext
+ "Simulate the valueWithArguments: primitive. Fail if anArray is not an array of the right arity."
+ | newContext sz |
+ newContext := (MethodContext newForMethod: outerContext method)
+ setSender: aContext
+ receiver: outerContext receiver
+ method: outerContext method
+ closure: self
+ startpc: startpc.
+ ((newContext objectClass: anArray) ~~ Array
+ or: [numArgs ~= anArray size]) ifTrue:
+ [^MethodContext primitiveFailTokenFor: nil].
+ sz := self basicSize.
+ newContext stackp: sz + numArgs.
+ 1 to: numArgs do:
+ [:i| newContext at: i put: (anArray at: i)].
+ 1 to: sz do:
+ [:i| newContext at: i + numArgs put: (self at: i)].
+ ^newContext!
Item was added:
+ ----- Method: ClassDescription>>ClassDescriptionPROTOTYPEupdateMethodBindingsTo: (in category '*CogAttic-method prototypes squeak') -----
+ ClassDescriptionPROTOTYPEupdateMethodBindingsTo: aBinding
+ "ClassBuilder support for maintaining valid method bindings."
+ methodDict do: [:method| method methodClassAssociation: aBinding]!
Item was added:
+ ----- Method: CogScriptsAttic class>>bootstrapClosures (in category 'closure scripts') -----
+ bootstrapClosures
+ "CogScripts bootstrapClosures"
+ | rep |
+ Transcript clear.
+ rep := false
+ ifTrue: [MCCacheRepository default]
+ ifFalse:
+ [MCHttpRepository
+ location: 'http://dev.qwaq.com/ss/Oinq'
+ user: 'qwaq'
+ password: ''].
+ "This changes load order in Monticello such that additions come in before modifications."
+ (rep loadVersionFromFileNamed: 'Monticello-eem.302.mcz') load.
+ "This adds some prereqs the compiler uses that are loaded in later packages:
+ Fix the ClassBuilder so redefining CompiledMethod can add and remove class variables.
+ Add Object/Array>>isArray.
+ Add new interface for accessing inst vars & fields on initializing the compiler (Encoder)."
+ self bootstrapClosuresCompilerPreloadCode readStream fileIn.
+ "This temporarily stops Monticello from unloading code on load and warning about overwriting changes.
+ Since changes span multiple packages need all additions in before any deletions occur.
+ Can't warn about anything until the new debugger api is installed."
+ ChangeSet
+ newChangesFromStream: self bootstrapClosuresNeuterMonticelloCode readStream
+ named: 'neuterMonticello'.
+ Smalltalk at: #DoNotUnload put: true.
+ 1 to: 2 do:
+ [:i|
+ #( 'Compiler-eem.30.mcz'
+ 'Files-eem.21.mcz'
+ 'Exceptions-eem.14.mcz'
+ 'Collections-eem.55.mcz'
+ 'Tools-eem.45.mcz'
+ 'Kernel-eem.82.mcz'
+ 'System-eem.53.mcz'
+ 'Brad-eem.51.mcz'
+ 'Morphic-eem.38.mcz'
+ 'Tweak-Compiler-eem.36.mcz'
+ 'Tweak-Hacks-eem.30.mcz'
+ 'Tweak-Basic-eem.151.mcz'
+ 'Tweak-Core-Proto-eem.56.mcz') do:
+ [:pn|
+ Transcript clear; nextPutAll: pn; space; nextPut: $(; print: i; nextPut: $); endEntry.
+ (rep loadVersionFromFileNamed: pn) load].
+ Smalltalk at: #DoNotUnload put: false].
+ "Now remove the temporary hacks to Monticello"
+ (ChangeSet named: 'neuterMonticello') changedMessageList do:
+ [:mr| | changeRecords |
+ changeRecords := mr actualClass changeRecordsAt: mr methodSymbol.
+ changeRecords second fileIn].
+ "Install BlockClosure in the specialObjectsArray"
+ Smalltalk recreateSpecialObjectsArray.
+ "Throw the switch to compile to closures"
+ self bootstrapClosuresClosureCompilerSwitchCode readStream fileIn.
+ "Recompile the system except the one method we can't yet deal with in GeniePlugin (1 too many literals)"
+ (Smalltalk forgetDoIts allClasses reject: [:c| c name == #GeniePlugin]) do:
+ [:c|
+ { c. c class } do:
+ [:b|
+ Transcript cr; print: b; endEntry.
+ b selectors asSortedCollection do:
+ [:s|
+ b recompile: s from: b]]].
+ UsefulScripts postRecompileCleanup.
+ self inform: 'Save and quit and then run UsefulScripts postRecompileCleanup.\Rinse and repeat' withCRs!
Item was added:
+ ----- Method: CompiledMethod class>>CompiledMethodclassPROTOTYPEheaderFlagForEncoder: (in category '*CogAttic-method prototypes') -----
+ CompiledMethodclassPROTOTYPEheaderFlagForEncoder: anEncoder
+ anEncoder class == PrimaryBytecodeSetEncoderClass ifTrue:
+ [^0].
+ anEncoder class == SecondaryBytecodeSetEncoderClass ifTrue:
+ [^SmallInteger minVal].
+ self error: 'The encoder is not one of the two installed bytecode sets'!
Item was added:
+ ----- Method: CompiledMethod class>>CompiledMethodclassPROTOTYPEinitialize (in category '*CogAttic-method prototypes') -----
+ CompiledMethodclassPROTOTYPEinitialize "CompiledMethod initialize"
+ "Initialize class variables specifying the size of the temporary frame
+ needed to run instances of me."
+
+ SmallFrame := 16. "Context range for temps+stack"
+ LargeFrame := 56.
+ PrimaryBytecodeSetEncoderClass ifNil:
+ [PrimaryBytecodeSetEncoderClass := EncoderForV3PlusClosures].
+ SecondaryBytecodeSetEncoderClass ifNil:
+ [SecondaryBytecodeSetEncoderClass := EncoderForV3PlusClosures]!
Item was added:
+ ----- Method: CompiledMethod class>>CompiledMethodclassPROTOTYPEinstallPrimaryBytecodeSet: (in category '*CogAttic-method prototypes') -----
+ CompiledMethodclassPROTOTYPEinstallPrimaryBytecodeSet: aBytecodeEncoderSubclass
+ PrimaryBytecodeSetEncoderClass == aBytecodeEncoderSubclass ifTrue:
+ [^self].
+ (aBytecodeEncoderSubclass inheritsFrom: BytecodeEncoder) ifFalse:
+ [self error: 'A bytecode set encoder is expected to be a subclass of BytecodeEncoder'].
+ (self allSubInstances
+ detect: [:m| m header >= 0 and: [m encoderClass ~~ aBytecodeEncoderSubclass]]
+ ifNone: []) ifNotNil:
+ [Warning signal: 'There are existing CompiledMethods with a different encoderClass.'].
+ PrimaryBytecodeSetEncoderClass := aBytecodeEncoderSubclass!
Item was added:
+ ----- Method: CompiledMethod class>>CompiledMethodclassPROTOTYPEinstallSecondaryBytecodeSet: (in category '*CogAttic-method prototypes') -----
+ CompiledMethodclassPROTOTYPEinstallSecondaryBytecodeSet: aBytecodeEncoderSubclass
+ PrimaryBytecodeSetEncoderClass == aBytecodeEncoderSubclass ifTrue:
+ [^self].
+ (aBytecodeEncoderSubclass inheritsFrom: BytecodeEncoder) ifFalse:
+ [self error: 'A bytecode set encoder is expected to be a subclass of BytecodeEncoder'].
+ (self allSubInstances
+ detect: [:m| m header < 0 and: [m encoderClass ~~ aBytecodeEncoderSubclass]]
+ ifNone: []) ifNotNil:
+ [Warning signal: 'There are existing CompiledMethods with a different encoderClass.'].
+ SecondaryBytecodeSetEncoderClass := aBytecodeEncoderSubclass!
Item was added:
+ ----- Method: CompiledMethod class>>CompiledMethodclassPROTOTYPEnewBytes:trailerBytes:nArgs:nTemps:nStack:nLits:primitive: (in category '*CogAttic-method prototypes') -----
+ CompiledMethodclassPROTOTYPEnewBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex
+ "Answer an instance of me. The header is specified by the message
+ arguments. The remaining parts are not as yet determined."
+ | method pc |
+ nArgs > 15 ifTrue:
+ [^self error: 'Cannot compile -- too many arguments'].
+ nTemps > 63 ifTrue:
+ [^self error: 'Cannot compile -- too many temporary variables'].
+ nLits > 32768 ifTrue:
+ [^self error: 'Cannot compile -- too many literals'].
+
+ method := trailer
+ createMethod: numberOfBytes
+ class: self
+ header: (nArgs bitShift: 24)
+ + (nTemps bitShift: 18)
+ + ((nTemps + stackSize) > SmallFrame ifTrue: [1 bitShift: 17] ifFalse: [0])
+ + nLits
+ + (primitiveIndex > 0 ifTrue: [1 bitShift: 16] ifFalse: [0]).
+ primitiveIndex > 0 ifTrue:
+ [pc := method initialPC.
+ method
+ at: pc + 0 put: method encoderClass callPrimitiveCode;
+ at: pc + 1 put: (primitiveIndex bitAnd: 16rFF);
+ at: pc + 2 put: (primitiveIndex bitShift: -8)].
+ ^method!
Item was added:
+ ----- Method: CompiledMethod class>>CompiledMethodclassPROTOTYPEnewBytes:trailerBytes:nArgs:nTemps:nStack:nLits:primitive:flag: (in category '*CogAttic-method prototypes') -----
+ CompiledMethodclassPROTOTYPEnewBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex flag: flag
+ "Answer an instance of me. The header is specified by the message
+ arguments. The remaining parts are not as yet determined."
+ | method pc |
+ nArgs > 15 ifTrue:
+ [^self error: 'Cannot compile -- too many arguments'].
+ nTemps > 63 ifTrue:
+ [^self error: 'Cannot compile -- too many temporary variables'].
+ nLits > 32768 ifTrue:
+ [^self error: 'Cannot compile -- too many literals'].
+
+ method := trailer
+ createMethod: numberOfBytes
+ class: self
+ header: (nArgs bitShift: 24)
+ + (nTemps bitShift: 18)
+ + ((nTemps + stackSize) > SmallFrame ifTrue: [1 bitShift: 17] ifFalse: [0])
+ + nLits
+ + (primitiveIndex > 0 ifTrue: [1 bitShift: 16] ifFalse: [0])
+ + (flag ifTrue: [1 bitShift: 29] ifFalse: [0]).
+ primitiveIndex > 0 ifTrue:
+ [pc := method initialPC.
+ method
+ at: pc + 0 put: method encoderClass callPrimitiveCode;
+ at: pc + 1 put: (primitiveIndex bitAnd: 16rFF);
+ at: pc + 2 put: (primitiveIndex bitShift: -8)].
+ ^method!
Item was added:
+ ----- Method: CompiledMethod>>CompiledMethodPROTOTYPEencoderClass (in category '*CogAttic-method prototypes') -----
+ CompiledMethodPROTOTYPEencoderClass
+ "Answer the encoder class that encoded the bytecodes in this method.
+ The sign flag bit is used by the VM to select a bytecode set. This formulation
+ may seem odd but this has to be fast, so no property probe unless needed."
+
+ ^self header >= 0
+ ifTrue:
+ [PrimaryBytecodeSetEncoderClass]
+ ifFalse:
+ [PrimaryBytecodeSetEncoderClass == SecondaryBytecodeSetEncoderClass
+ ifTrue: "Support for testing prior to installing another set"
+ [(self propertyValueAt: #encoderClass) ifNil: [SecondaryBytecodeSetEncoderClass]]
+ ifFalse:
+ [SecondaryBytecodeSetEncoderClass]]!
Item was added:
+ ----- Method: Context>>MethodContextPROTOTYPEfailPrimitiveWith: (in category '*CogAttic-method prototypes') -----
+ MethodContextPROTOTYPEfailPrimitiveWith: maybePrimFailToken
+ "The receiver is a freshly-created context on a primitive method. Skip the callPrimitive:
+ bytecode and store the primitive fail code if there is one and the method consumes it."
+ self skipCallPrimitive.
+ ((self isPrimFailToken: maybePrimFailToken)
+ and: [method encoderClass isStoreAt: pc in: method]) ifTrue:
+ [self at: stackp put: maybePrimFailToken last]!
Item was added:
+ ----- Method: Decompiler>>DecompilerPROTOTYPEdecompile:in:method:using: (in category '*CogAttic-method prototypes squeak 4.3') -----
+ DecompilerPROTOTYPEdecompile: aSelector in: aClass method: aMethod using: aConstructor
+
+ | block node |
+ constructor := aConstructor.
+ method := aMethod.
+ self initSymbols: aClass. "create symbol tables"
+ method isQuick
+ ifTrue: [block := self quickMethod]
+ ifFalse:
+ [stack := OrderedCollection new: method frameSize.
+ lastJumpIfPcStack := OrderedCollection new.
+ caseExits := OrderedCollection new.
+ statements := OrderedCollection new: 20.
+ numLocalTemps := 0.
+ super method: method pc: method initialPC.
+ "skip primitive error code store if necessary"
+ (method primitive ~= 0 and: [self skipCallPrimitive; willStore]) ifTrue:
+ [pc := pc + (method encoderClass bytecodeSize: self firstByte).
+ tempVars := tempVars asOrderedCollection].
+ block := self blockTo: method endPC + 1.
+ stack isEmpty ifFalse: [self error: 'stack not empty']].
+ node := constructor
+ codeMethod: aSelector
+ block: block
+ tempVars: tempVars
+ primitive: method primitive
+ class: aClass.
+ method primitive > 0 ifTrue:
+ [node removeAndRenameLastTempIfErrorCode].
+ ^node preen!
Item was added:
+ ----- Method: EncoderForV3PlusClosures>>EncoderForV3PlusClosuresPROTOTYPEgenCallPrimitive: (in category '*CogAttic-method prototypes') -----
+ EncoderForV3PlusClosuresPROTOTYPEgenCallPrimitive: primitiveIndex
+ "139 11101111 iiiiiiii jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256)"
+ (primitiveIndex < 1 or: [primitiveIndex > 65535]) ifTrue:
+ [self outOfRangeError: 'primitive index' index: primitiveIndex range: 1 to: 65535].
+ stream
+ nextPut: 139;
+ nextPut: (primitiveIndex bitAnd: 255);
+ nextPut: (primitiveIndex bitShift: -8)!
Item was added:
+ ----- Method: InstructionStream>>InstructionStreamPROTOTYPEinterpretV3ClosuresExtension:in:for: (in category '*CogAttic-method prototypes') -----
+ InstructionStreamPROTOTYPEinterpretV3ClosuresExtension: offset in: method for: client
+ | type offset2 byte2 byte3 byte4 |
+ offset <= 6 ifTrue:
+ ["Extended op codes 128-134"
+ byte2 := method at: pc. pc := pc + 1.
+ offset <= 2 ifTrue:
+ ["128-130: extended pushes and pops"
+ type := byte2 // 64.
+ offset2 := byte2 \\ 64.
+ offset = 0 ifTrue:
+ [type = 0 ifTrue: [^client pushReceiverVariable: offset2].
+ type = 1 ifTrue: [^client pushTemporaryVariable: offset2].
+ type = 2 ifTrue: [^client pushConstant: (method literalAt: offset2 + 1)].
+ type = 3 ifTrue: [^client pushLiteralVariable: (method literalAt: offset2 + 1)]].
+ offset = 1 ifTrue:
+ [type = 0 ifTrue: [^client storeIntoReceiverVariable: offset2].
+ type = 1 ifTrue: [^client storeIntoTemporaryVariable: offset2].
+ type = 2 ifTrue: [self error: 'illegalStore'].
+ type = 3 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: offset2 + 1)]].
+ offset = 2 ifTrue:
+ [type = 0 ifTrue: [^client popIntoReceiverVariable: offset2].
+ type = 1 ifTrue: [^client popIntoTemporaryVariable: offset2].
+ type = 2 ifTrue: [self error: 'illegalStore'].
+ type = 3 ifTrue: [^client popIntoLiteralVariable: (method literalAt: offset2 + 1)]]].
+ "131-134: extended sends"
+ offset = 3 ifTrue: "Single extended send"
+ [^client send: (method literalAt: byte2 \\ 32 + 1)
+ super: false numArgs: byte2 // 32].
+ offset = 4 ifTrue: "Double extended do-anything"
+ [byte3 := method at: pc. pc := pc + 1.
+ type := byte2 // 32.
+ type = 0 ifTrue: [^client send: (method literalAt: byte3 + 1)
+ super: false numArgs: byte2 \\ 32].
+ type = 1 ifTrue: [^client send: (method literalAt: byte3 + 1)
+ super: true numArgs: byte2 \\ 32].
+ type = 2 ifTrue: [^client pushReceiverVariable: byte3].
+ type = 3 ifTrue: [^client pushConstant: (method literalAt: byte3 + 1)].
+ type = 4 ifTrue: [^client pushLiteralVariable: (method literalAt: byte3 + 1)].
+ type = 5 ifTrue: [^client storeIntoReceiverVariable: byte3].
+ type = 6 ifTrue: [^client popIntoReceiverVariable: byte3].
+ type = 7 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: byte3 + 1)]].
+ offset = 5 ifTrue: "Single extended send to super"
+ [^client send: (method literalAt: byte2 \\ 32 + 1)
+ super: true
+ numArgs: byte2 // 32].
+ offset = 6 ifTrue: "Second extended send"
+ [^client send: (method literalAt: byte2 \\ 64 + 1)
+ super: false
+ numArgs: byte2 // 64]].
+ offset = 7 ifTrue: [^client doPop].
+ offset = 8 ifTrue: [^client doDup].
+ offset = 9 ifTrue: [^client pushActiveContext].
+ byte2 := method at: pc. pc := pc + 1.
+ offset = 10 ifTrue:
+ [^byte2 < 128
+ ifTrue: [client pushNewArrayOfSize: byte2]
+ ifFalse: [client pushConsArrayWithElements: byte2 - 128]].
+ byte3 := method at: pc. pc := pc + 1.
+ offset = 11 ifTrue: [^client callPrimitive: byte2 + (byte3 bitShift: 8)].
+ offset = 12 ifTrue: [^client pushRemoteTemp: byte2 inVectorAt: byte3].
+ offset = 13 ifTrue: [^client storeIntoRemoteTemp: byte2 inVectorAt: byte3].
+ offset = 14 ifTrue: [^client popIntoRemoteTemp: byte2 inVectorAt: byte3].
+ "offset = 15"
+ byte4 := method at: pc. pc := pc + 1.
+ ^client
+ pushClosureCopyNumCopiedValues: (byte2 bitShift: -4)
+ numArgs: (byte2 bitAnd: 16rF)
+ blockSize: (byte3 * 256) + byte4!
Item was added:
+ ----- Method: InstructionStream>>InstructionStreamPROTOTYPEnextPc: (in category '*CogAttic-method prototypes') -----
+ InstructionStreamPROTOTYPEnextPc: currentByte
+ "Answer the pc of the next bytecode following the current one, given the current bytecode.."
+
+ ^pc + (self method encoderClass bytecodeSize: currentByte)!
Item was added:
+ ----- Method: InstructionStream>>InstructionStreamPROTOTYPEskipCallPrimitive (in category '*CogAttic-method prototypes') -----
+ InstructionStreamPROTOTYPEskipCallPrimitive
+ "If the receiver's method starts with a callPrimitive: bytecode, skip it."
+ | method encoderClass callPrimitiveCode |
+ method := self method.
+ encoderClass := method encoderClass.
+ callPrimitiveCode := encoderClass callPrimitiveCode.
+ (method byteAt: pc) = callPrimitiveCode ifTrue:
+ [pc := pc + (encoderClass bytecodeSize: callPrimitiveCode)]!
Item was added:
+ ----- Method: MCClassDefinition>>MCClassDefinitionPROTOTYPEkindOfSubclass (in category '*CogAttic-method prototypes squeak 4.3') -----
+ MCClassDefinitionPROTOTYPEkindOfSubclass
+ type = #normal ifTrue: [^' subclass: '].
+ type = #variable ifTrue: [^' variableSubclass: '].
+ type = #bytes ifTrue: [^' variableByteSubclass: '].
+ type = #compiledMethod ifTrue: [^' variableByteSubclass: ' ].
+ type = #words ifTrue: [^' variableWordSubclass: '].
+ type = #weak ifTrue: [^' weakSubclass: ' ].
+ type = #ephemeron ifTrue: [^' ephemeronSubclass: ' ].
+ type = #immediate ifTrue: [^' immediateSubclass: ' ].
+ self error: 'Unrecognized class type'!
Item was added:
+ ----- Method: MCMethodDefinition>>MCMethodDefinitionPROTOTYPEinitializeWithClassName:classIsMeta:selector:category:timeStamp:source: (in category '*CogAttic-method prototypes squeak 4.3') -----
+ MCMethodDefinitionPROTOTYPEinitializeWithClassName: classString
+ classIsMeta: metaBoolean
+ selector: selectorString
+ category: catString
+ timeStamp: timeString
+ source: sourceString
+ className := classString asSymbol.
+ selector := selectorString asSymbol.
+ category := catString ifNil: [Categorizer default] ifNotNil: [catString asSymbol].
+ timeStamp := timeString.
+ classIsMeta := metaBoolean.
+ source := sourceString withSqueakLineEndings!
Item was added:
+ ----- Method: MethodNode>>MethodNodePROTOTYPEgenerate:using: (in category '*CogAttic-method prototypes') -----
+ MethodNodePROTOTYPEgenerate: trailer using: aCompiledMethodClass
+ "The receiver is the root of a parse tree. Answer an instance of aCompiledMethodClass.
+ 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."
+
+ | primErrNode blkSize nLits locals literals stack header method |
+ self generate: trailer
+ using: aCompiledMethodClass
+ ifQuick:
+ [:m |
+ encoder noteBlockExtent: (0 to: 2) hasLocals: arguments.
+ m literalAt: 2 put: encoder associationForClass;
+ properties: properties.
+ ^m].
+ primErrNode := self primitiveErrorVariableName ifNotNil:
+ [encoder fixTemp: self primitiveErrorVariableName].
+ self ensureClosureAnalysisDone.
+ encoder rootNode: self. "this is for BlockNode>>sizeCodeForClosureValue:"
+ blkSize := (block sizeCodeForEvaluatedValue: encoder)
+ + (primitive > 0
+ ifTrue: [encoder sizeCallPrimitive: primitive]
+ ifFalse: [0])
+ + (primErrNode
+ ifNil: [0]
+ ifNotNil:
+ [primErrNode
+ index: arguments size + temporaries size;
+ sizeCodeForStore: encoder "The VM relies on storeIntoTemp: (129)"]).
+ locals := arguments, temporaries, (primErrNode ifNil: [#()] ifNotNil: [{primErrNode}]).
+ encoder noteBlockExtent: block blockExtent hasLocals: locals.
+ header := encoder computeMethodHeaderForNumArgs: arguments size
+ numTemps: locals size
+ numLits: (nLits := (literals := encoder allLiterals) size)
+ primitive: primitive.
+ method := trailer
+ createMethod: blkSize
+ class: aCompiledMethodClass
+ header: header.
+ 1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)].
+ encoder streamToMethod: method.
+ stack := ParseStack new init.
+ primitive > 0 ifTrue:
+ [encoder genCallPrimitive: primitive.
+ primErrNode ifNotNil:
+ [primErrNode emitCodeForStore: stack encoder: encoder]].
+ stack position: method numTemps.
+ [block emitCodeForEvaluatedValue: stack encoder: encoder]
+ on: Error "If an attempt is made to write too much code the method will be asked"
+ do: [:ex| "to grow, and the grow attempt will fail in CompiledMethod class>>#new:"
+ ex signalerContext sender method = (CompiledMethod class>>#new:)
+ ifTrue: [^self error: 'Compiler code size discrepancy']
+ ifFalse: [ex pass]].
+ stack position ~= (method numTemps + 1) ifTrue:
+ [^self error: 'Compiler stack discrepancy'].
+ encoder methodStreamPosition ~= (method size - trailer size) ifTrue:
+ [^self error: 'Compiler code size discrepancy'].
+ method needsFrameSize: stack size - method numTemps.
+ method properties: properties.
+ ^method!
Item was added:
+ ----- Method: MethodNode>>MethodNodePROTOTYPEgenerate:using:ifQuick: (in category '*CogAttic-method prototypes') -----
+ MethodNodePROTOTYPEgenerate: trailer using: aCompiledMethodClass ifQuick: methodBlock
+ | v |
+ (primitive = 0 and: [arguments size = 0 and: [block isQuick]]) ifFalse:
+ [^self].
+ v := block code.
+ v < 0 ifTrue:
+ [^self].
+ v = LdSelf ifTrue:
+ [^methodBlock value: (aCompiledMethodClass toReturnSelfTrailerBytes: trailer)].
+ (v between: LdTrue and: LdMinus1 + 3) ifTrue:
+ [^methodBlock value: (aCompiledMethodClass toReturnConstant: v - LdSelf trailerBytes: trailer)].
+ v < ((CodeBases at: LdInstType) + (CodeLimits at: LdInstType)) ifTrue:
+ [^methodBlock value: (aCompiledMethodClass toReturnField: v trailerBytes: trailer)].
+ v // 256 = 1 ifTrue:
+ [^methodBlock value: (aCompiledMethodClass toReturnField: v \\ 256 trailerBytes: trailer)]!
Item was added:
+ ----- Method: MethodNode>>MethodNodePROTOTYPEprintPropertiesOn: (in category '*CogAttic-method prototypes') -----
+ MethodNodePROTOTYPEprintPropertiesOn: aStream
+ properties ifNil: [^self].
+ properties propertyKeysAndValuesDo:
+ [:prop :val|
+ aStream crtab; nextPut: $<.
+ prop = #on:in:
+ ifTrue:
+ [prop keywords with: val do:
+ [:k :v | aStream nextPutAll: k; space; nextPutAll: v; space]]
+ ifFalse:
+ [prop = #on
+ ifTrue: [aStream nextPutAll: prop; nextPutAll:': '; nextPutAll: val]
+ ifFalse: [aStream nextPutAll: prop; nextPutAll:': '; print: val]].
+ aStream nextPut: $>]!
1
0
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!
1
0