[Vm-dev] VM Maker: VMMaker.oscog-eem.240.mcz
commits at source.squeak.org
commits at source.squeak.org
Thu Dec 20 20:23:47 UTC 2012
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.240.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.240
Author: eem
Time: 20 December 2012, 12:21:03.98 pm
UUID: f72e2cd1-8b0e-45af-acd7-06ba9bbc2a50
Ancestors: VMMaker.oscog-eem.239
Back out of the wrong-headed attempt to give compact class indices
to long header objects in changeClassOf:to:, and comment why
(markAndTrace: reuses header type bits and depends on compact
class and size fields to reconstruct type bits after traverse).
Consequently fix isClassOfNonImm:equalTo:compactClassIndex: so
it will still accept long-header objects that are insances of compact
classes but don't have a compact class index.
Clean-up accesses to the compactClassesArray so that they go
through the compactClassAt: where appropriate.
Use the short-hand class determinators such as isInstanceOfClassFloat:
in place of the long-winded is:instanceOf:compactClassIndex:.
Move the determinators to InterpreterPrimitives where they are
better-placed (but should eventually end up in Objectmemory and
siblings).
Remove obsolete use of cCode: 'magnitude >> 32' in the integer
conversion routines signed64BitIntegerFor: et al now that Slang
generates the correct cases for right-shift.
Eliminate the compactClassTable accessor. CompactClasses and splOb:
are both in scope in CogObjectRepresentationForSqueakV3.
Override sweepPhase in NewObjectMemory and hence eliminate
initializeFreeBlocksPreSweep.
Fix off-by-one error in okayOop:.
Make longPrintOop: print header type info.
Make allAccessibleObjectsOk answer a result.
Don't inline loadInitialContext for gdb breakpointing convenience.
Declare some constant variables as const in the Cogit.
Simulator:
Fix several sends to be to objectMemory, not self.
Make the storePointer: overrides bounds-check index.
Remove several obsolete overrides in StackInterpreter simulators
of methods now moved to ObjectMemory and subclasses.
Add printCallStackOf: menu access.
Add print of freeStart to GC overrides.
Add a printMemoryFrom:to:.
Implement vmProxyMajor/MinorVersion so that simulation can still
load plugins in new plugin interpreterProxy api access regime.
=============== Diff against VMMaker.oscog-eem.239 ===============
Item was changed:
----- Method: CoInterpreterMT>>markAndTraceInterpreterOops: (in category 'object memory support') -----
markAndTraceInterpreterOops: fullGCFlag
"Mark and trace all oops in the interpreter's state."
"Assume: All traced variables contain valid oops."
| oop |
<var: #vmThread type: #'CogVMThread *'>
"Must mark stack pages first to initialize the per-page trace
flags for full garbage collect before any subsequent tracing."
self markAndTraceStackPages: fullGCFlag.
self markAndTraceTraceLog.
self markAndTracePrimTraceLog.
objectMemory markAndTrace: objectMemory specialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes"
(objectMemory isIntegerObject: messageSelector) ifFalse:
[objectMemory markAndTrace: messageSelector].
(objectMemory isIntegerObject: newMethod) ifFalse:
[objectMemory markAndTrace: newMethod].
objectMemory markAndTrace: lkupClass.
self traceProfileState.
+ tempOop = 0 ifFalse: [objectMemory markAndTrace: tempOop].
- tempOop = 0 ifFalse: [self markAndTrace: tempOop].
1 to: objectMemory remapBufferCount do:
[:i|
oop := objectMemory remapBuffer at: i.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop]].
"Callback support - trace suspended callback list - will be made per-thread soon"
1 to: jmpDepth do:
[:i|
oop := suspendedCallbacks at: i.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
oop := suspendedMethods at: i.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop]].
"Per-thread state; trace each thread's own newMethod and stack of awol processes."
1 to: cogThreadManager getNumThreads do:
[:i| | vmThread |
vmThread := cogThreadManager vmThreadAt: i.
vmThread state notNil ifTrue:
[vmThread newMethodOrNull notNil ifTrue:
[objectMemory markAndTrace: vmThread newMethodOrNull].
0 to: vmThread awolProcIndex - 1 do:
[:j|
objectMemory markAndTrace: (vmThread awolProcesses at: j)]]]!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>genGetClassFormatOfNonInt:into:scratchReg: (in category 'compile abstract instructions') -----
genGetClassFormatOfNonInt: instReg into: destReg scratchReg: scratchReg
"Fetch the instance's class format into destReg, assuming the object is non-int."
| jumpCompact jumpGotClass |
<var: #jumpCompact type: #'AbstractInstruction *'>
<var: #jumpGotClass type: #'AbstractInstruction *'>
"Get header word in destReg"
cogit MoveMw: 0 r: instReg R: destReg.
"Form the byte index of the compact class field"
cogit LogicalShiftRightCq: (objectMemory compactClassFieldLSB - ShiftForWord) R: destReg.
cogit AndCq: self compactClassFieldMask << ShiftForWord R: destReg.
jumpCompact := cogit JumpNonZero: 0.
cogit MoveMw: objectMemory classFieldOffset r: instReg R: scratchReg.
"The use of signedIntFromLong is a hack to get round short addressing mode computations.
Much easier if offsets are signed and the arithmetic machinery we have makes it difficult to
mix signed and unsigned offsets."
cogit AndCq: AllButTypeMask signedIntFromLong R: scratchReg.
jumpGotClass := cogit Jump: 0.
"Don't have to subtract one from the destReg compactClassArray index because of the header word."
self assert: BaseHeaderSize = BytesPerWord.
jumpCompact jmpTarget:
+ (cogit annotate: (cogit MoveMw: (objectMemory splObj: CompactClasses) r: destReg R: scratchReg)
+ objRef: (objectMemory splObj: CompactClasses)).
- (cogit annotate: (cogit MoveMw: objectMemory compactClassTable r: destReg R: scratchReg)
- objRef: objectMemory compactClassTable).
jumpGotClass jmpTarget:
(cogit MoveMw: InstanceSpecificationIndex << ShiftForWord + BytesPerWord r: scratchReg R: destReg).
^0!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>genGetClassObjectOf:into:scratchReg: (in category 'compile abstract instructions') -----
genGetClassObjectOf: instReg into: destReg scratchReg: scratchReg
"Fetch the instance's class into destReg. This is almost identical
to genGetClassFormatOfNonInt:into:scratchReg: but because we
put the fetch of SmallInteger between the then and the else for
compact class/non-compact class we cannot easily share code."
| jumpIsInt jumpCompact jumpGotClass jumpGotClass2 |
<var: #jumpIsInt type: #'AbstractInstruction *'>
<var: #jumpCompact type: #'AbstractInstruction *'>
<var: #jumpGotClass type: #'AbstractInstruction *'>
<var: #jumpGotClass2 type: #'AbstractInstruction *'>
cogit MoveR: instReg R: scratchReg.
cogit AndCq: 1 R: scratchReg.
jumpIsInt := cogit JumpNonZero: 0.
"Get header word in scratchReg"
cogit MoveMw: 0 r: instReg R: scratchReg.
"Form the byte index of the compact class field"
cogit LogicalShiftRightCq: (objectMemory compactClassFieldLSB - ShiftForWord) R: scratchReg.
cogit AndCq: self compactClassFieldMask << ShiftForWord R: scratchReg.
jumpCompact := cogit JumpNonZero: 0.
cogit MoveMw: objectMemory classFieldOffset r: instReg R: destReg.
cogit AndCq: AllButTypeMask signedIntFromLong R: destReg.
jumpGotClass := cogit Jump: 0.
jumpIsInt jmpTarget:
(cogit annotate: (cogit MoveCw: objectMemory classSmallInteger R: destReg)
objRef: objectMemory classSmallInteger).
jumpGotClass2 := cogit Jump: 0.
"Don't have to subtract one from the destReg compactClassArray index because of the header word."
self assert: BaseHeaderSize = BytesPerWord.
jumpCompact jmpTarget:
+ (cogit annotate: (cogit MoveMw: (objectMemory splObj: CompactClasses) r: scratchReg R: destReg)
+ objRef: (objectMemory splObj: CompactClasses)).
- (cogit annotate: (cogit MoveMw: objectMemory compactClassTable r: scratchReg R: destReg)
- objRef: objectMemory compactClassTable).
jumpGotClass jmpTarget:
(jumpGotClass2 jmpTarget: cogit Label).
^0!
Item was removed:
- ----- Method: CogVMSimulator>>fullGC (in category 'debug support') -----
- fullGC
- self halt.
- transcript cr; show:'<Running full GC ...'.
- super fullGC.
- transcript show: ' done>'.!
Item was removed:
- ----- Method: CogVMSimulator>>incrementalGC (in category 'debug support') -----
- incrementalGC
- transcript cr; nextPutAll: 'incrementalGC ('; print: byteCount; nextPut: $); flush.
- ^super incrementalGC!
Item was removed:
- ----- Method: CogVMSimulator>>noteAsRoot:headerLoc: (in category 'debugging traps') -----
- noteAsRoot: oop headerLoc: headerLoc
- "Trap attempts to make cog methods roots."
- self assert: oop >= objectMemory startOfMemory.
- ^super noteAsRoot: oop headerLoc: headerLoc!
Item was removed:
- ----- Method: CogVMSimulator>>storePointer:ofObject:withValue: (in category 'interpreter access') -----
- storePointer: index ofObject: oop withValue: valuePointer
- "Override to ensure acess is within the heap"
- self assert: oop >= objectMemory startOfMemory.
- ^super storePointer: index ofObject: oop withValue: valuePointer!
Item was removed:
- ----- Method: CogVMSimulator>>storePointerUnchecked:ofObject:withValue: (in category 'interpreter access') -----
- storePointerUnchecked: fieldIndex ofObject: oop withValue: valuePointer
- self shouldNotImplement!
Item was removed:
- ----- Method: CogVMSimulator>>tenuringIncrementalGC (in category 'debug support') -----
- tenuringIncrementalGC
- transcript cr; nextPutAll: 'tenuringIncrementalGC ('; print: byteCount; nextPut: $); flush.
- ^super tenuringIncrementalGC!
Item was changed:
----- Method: CogVMSimulator>>utilitiesMenu: (in category 'UI') -----
utilitiesMenu: aMenuMorph
aMenuMorph
add: 'toggle transcript' action: #toggleTranscript;
addLine;
add: 'print ext head frame' action: #printExternalHeadFrame;
add: 'print int head frame' action: #printHeadFrame;
add: 'print mc/cog frame' action: [self printFrame: cogit processor fp WithSP: cogit processor sp];
add: 'short print ext frame & callers' action: [self shortPrintFrameAndCallers: framePointer];
add: 'short print int frame & callers' action: [self shortPrintFrameAndCallers: localFP];
add: 'short print mc/cog frame & callers' action: [self shortPrintFrameAndCallers: cogit processor fp];
add: 'long print ext frame & callers' action: [self printFrameAndCallers: framePointer SP: stackPointer];
add: 'long print int frame & callers' action: [self printFrameAndCallers: localFP SP: localSP];
add: 'long print mc/cog frame & callers' action: [self printFrameAndCallers: cogit processor fp SP: cogit processor sp];
add: 'print frame...' action: [(self promptHex: 'print frame') ifNotNil: [:fp| self printFrame: fp]];
add: 'print call stack' action: #printCallStack;
+ add: 'print call stack of...' action: [(self promptHex: 'context or process oop') ifNotNil: [:obj| self printCallStackOf: obj]];
add: 'print all stacks' action: #printAllStacks;
addLine;
add: 'print registers' action: [cogit processor printRegistersOn: transcript];
add: 'disassemble method/trampoline...' action: [(self promptHex: 'pc') ifNotNil: [:pc| cogit disassembleCodeAt: pc]];
add: 'disassemble method/trampoline at pc' action: [cogit disassembleCodeAt: cogit processor pc];
add: 'disassemble ext head frame method' action: [cogit disassembleMethod: (self frameMethod: framePointer)];
add: 'print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self printOop: oop]];
add: 'long print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self longPrintOop: oop]];
addLine;
add: 'inspect object memory' target: objectMemory action: #inspect;
add: 'inspect cointerpreter' action: #inspect;
add: 'inspect cogit' target: cogit action: #inspect;
add: 'inspect method zone' target: cogit methodZone action: #inspect.
self isThreadedVM ifTrue:
[aMenuMorph add: 'inspect thread manager' target: self threadManager action: #inspect].
aMenuMorph
addLine;
add: 'print cog methods' target: cogMethodZone action: #printCogMethods;
add: 'print trampoline table' target: cogit action: #printTrampolineTable;
add: 'report recent instructions' target: cogit action: #reportLastNInstructions;
add: 'set break pc...' action: [(self promptHex: 'break pc') ifNotNil: [:bpc| cogit breakPC: bpc]];
add: (cogit singleStep
ifTrue: ['no single step']
ifFalse: ['single step'])
action: [cogit singleStep: cogit singleStep not];
add: (cogit printRegisters
ifTrue: ['no print registers each instruction']
ifFalse: ['print registers each instruction'])
action: [cogit printRegisters: cogit printRegisters not];
add: (cogit printInstructions
ifTrue: ['no print instructions each instruction']
ifFalse: ['print instructions each instruction'])
action: [cogit printInstructions: cogit printInstructions not];
addLine;
add: 'set break count...' action: [|s| s := UIManager default request: 'break count (dec)'.
s notEmpty ifTrue: [breakCount := Integer readFrom: s readStream]];
add: 'set break selector...' action: [|s| s := UIManager default request: 'break selector'.
s notEmpty ifTrue: [self setBreakSelector: s]];
add: 'set break block...' action: [|s| s := UIManager default request: 'break selector'.
s notEmpty ifTrue: [self setBreakBlockFromString: s]];
add: (printBytecodeAtEachStep
ifTrue: ['no print bytecode each bytecode']
ifFalse: ['print bytecode each bytecode'])
action: [self ensureDebugAtEachStepBlock.
printBytecodeAtEachStep := printBytecodeAtEachStep not];
add: (printFrameAtEachStep
ifTrue: ['no print frame each bytecode']
ifFalse: ['print frame each bytecode'])
action: [self ensureDebugAtEachStepBlock.
printFrameAtEachStep := printFrameAtEachStep not].
^aMenuMorph!
Item was changed:
----- Method: Cogit class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
#( 'coInterpreter' 'objectMemory' 'methodZone' 'objectRepresentation'
'cogBlockMethodSurrogateClass' 'cogMethodSurrogateClass'
'threadManager' 'processor' 'lastNInstructions' 'simulatedAddresses'
'simulatedTrampolines' 'simulatedVariableGetters' 'simulatedVariableSetters'
'printRegisters' 'printInstructions' 'clickConfirm' 'singleStep') do:
[:simulationVariableNotNeededForRealVM|
aCCodeGenerator removeVariable: simulationVariableNotNeededForRealVM].
NewspeakVM ifFalse:
[#( 'dynSuperEntry' 'dynSuperEntryAlignment' 'dynamicSuperSendTrampolines'
'ceImplicitReceiverTrampoline' 'ceExplicitReceiverTrampoline' 'cmDynSuperEntryOffset') do:
[:variableNotNeededInNormalVM|
aCCodeGenerator removeVariable: variableNotNeededInNormalVM]].
aCCodeGenerator
addHeaderFile:'<stddef.h>'; "for e.g. offsetof"
addHeaderFile:'"sqCogStackAlignment.h"';
addHeaderFile:'"cogmethod.h"';
addHeaderFile:'#if COGMTVM';
addHeaderFile:'"cointerpmt.h"';
addHeaderFile:'#else';
addHeaderFile:'"cointerp.h"';
addHeaderFile:'#endif';
addHeaderFile:'"cogit.h"';
addHeaderFile:'"dispdbg.h"'.
aCCodeGenerator
var: #ceGetSP
declareC: 'unsigned long (*ceGetSP)(void)';
var: #ceCaptureCStackPointers
declareC: 'void (*ceCaptureCStackPointers)(void)';
var: #ceEnterCogCodePopReceiverReg
declareC: 'void (*ceEnterCogCodePopReceiverReg)(void)';
var: #realCEEnterCogCodePopReceiverReg
declareC: 'void (*realCEEnterCogCodePopReceiverReg)(void)';
var: #ceEnterCogCodePopReceiverAndClassRegs
declareC: 'void (*ceEnterCogCodePopReceiverAndClassRegs)(void)';
var: #realCEEnterCogCodePopReceiverAndClassRegs
declareC: 'void (*realCEEnterCogCodePopReceiverAndClassRegs)(void)';
var: #ceFlushICache
declareC: 'static void (*ceFlushICache)(unsigned long from, unsigned long to)';
var: #ceCheckFeaturesFunction
declareC: 'static unsigned long (*ceCheckFeaturesFunction)(void)';
var: #ceTryLockVMOwner
declareC: 'unsigned long (*ceTryLockVMOwner)(void)';
var: #ceUnlockVMOwner
declareC: 'void (*ceUnlockVMOwner)(void)';
var: #postCompileHook
declareC: 'void (*postCompileHook)(CogMethod *, void *)';
var: #openPICList declareC: 'CogMethod *openPICList = 0';
var: #maxMethodBefore type: #'CogBlockMethod *'.
aCCodeGenerator
declareVar: 'aMethodLabel' type: #'AbstractInstruction'; "Has to come lexicographically before backEnd & methodLabel"
+ var: #backEnd declareC: 'const AbstractInstruction *backEnd = &aMethodLabel';
- var: #backEnd declareC: 'AbstractInstruction *backEnd = &aMethodLabel';
var: #methodLabel declareC: 'AbstractInstruction *methodLabel = &aMethodLabel';
var: #primInvokeLabel type: #'AbstractInstruction *'.
self declareC: #(abstractOpcodes stackCheckLabel
blockEntryLabel blockEntryNoContextSwitch
stackOverflowCall sendMissCall entry noCheckEntry dynSuperEntry
mnuCall interpretCall endCPICCase0 endCPICCase1)
as: #'AbstractInstruction *'
in: aCCodeGenerator.
aCCodeGenerator
declareVar: #annotations type: #'InstructionAnnotation *';
declareVar: #blockStarts type: #'BlockStart *';
declareVar: #fixups type: #'BytecodeFixup *'.
aCCodeGenerator
var: #sendTrampolines
declareC: 'sqInt sendTrampolines[NumSendTrampolines]';
var: #superSendTrampolines
declareC: 'sqInt superSendTrampolines[NumSendTrampolines]';
var: #dynamicSuperSendTrampolines
declareC: 'sqInt dynamicSuperSendTrampolines[NumSendTrampolines]';
var: #trampolineAddresses
declareC: 'static char *trampolineAddresses[NumTrampolines*2]';
var: #objectReferencesInRuntime
declareC: 'static sqInt objectReferencesInRuntime[NumObjRefsInRuntime]';
var: #cePositive32BitIntegerTrampoline
declareC: 'static sqInt cePositive32BitIntegerTrampoline';
var: #labelCounter
declareC: 'static int labelCounter';
var: #traceFlags
declareC: 'int traceFlags = 8 /* prim trace log on by default */';
var: #cStackAlignment
declareC: 'const int cStackAlignment = STACK_ALIGN_BYTES'.
aCCodeGenerator
declareVar: #CFramePointer type: #'void *';
declareVar: #CStackPointer type: #'void *';
declareVar: #minValidCallAddress type: #'unsigned long';
declareVar: #debugPrimCallStackOffset type: #'unsigned long'.
aCCodeGenerator
var: #generatorTable
declareC: 'BytecodeDescriptor generatorTable[', aCCodeGenerator vmClass generatorTable size, ']'
, (self tableInitializerFor: aCCodeGenerator vmClass generatorTable
in: aCCodeGenerator);
var: #primitiveGeneratorTable
declareC: 'PrimitiveDescriptor primitiveGeneratorTable[MaxCompiledPrimitiveIndex+1]'
, (self tableInitializerFor: aCCodeGenerator vmClass primitiveTable
in: aCCodeGenerator).
"In C the abstract opcode names clash with the Smalltak generator syntactic sugar.
Most of the syntactic sugar is inlined, but alas some remains. Rename the syntactic
sugar to avoid the clash."
(self organization listAtCategoryNamed: #'abstract instructions') do:
[:s|
aCCodeGenerator addSelectorTranslation: s to: 'g', (aCCodeGenerator cFunctionNameFor: s)].
aCCodeGenerator addSelectorTranslation: #halt: to: 'haltmsg'!
Item was changed:
----- Method: Interpreter>>allAccessibleObjectsOkay (in category 'debug support') -----
allAccessibleObjectsOkay
"Ensure that all accessible objects in the heap are okay."
+ | oop ok |
+ ok := true.
- | oop |
oop := self firstAccessibleObject.
+ [oop = nil] whileFalse:
+ [ok := ok & (self okayFields: oop).
+ oop := self accessibleObjectAfter: oop].
+ ^ok!
- [oop = nil] whileFalse: [
- self okayFields: oop.
- oop := self accessibleObjectAfter: oop.
- ].!
Item was changed:
----- Method: Interpreter>>floatValueOf: (in category 'utilities') -----
floatValueOf: oop
+ "Answer the C double precision floating point value of the argument,
+ or fail if it is not a Float, and answer 0.
+ Note: May be called by translated primitive code."
- "Fetch the instance variable at the given index of the given object. Answer the C
- double precision floating point value of that instance variable, or fail if it is not a Float."
| isFloat result |
<returnTypeC: #double>
<var: #result type: #double>
+ isFloat := self isInstanceOfClassFloat: oop.
- "N.B. Because Slang always inlines is:instanceOf:compactClassIndex:
- (because is:instanceOf:compactClassIndex: has an inline: pragma) the
- phrase (self splObj: ClassArray) is expanded in-place and is _not_ evaluated if
- ClassArrayCompactIndex is non-zero."
- isFloat := self
- is: oop
- instanceOf: (self splObj: ClassFloat)
- compactClassIndex: ClassFloatCompactIndex.
isFloat ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
self fetchFloatAt: oop + BaseHeaderSize into: result.
^result].
self primitiveFail.
^0.0!
Item was changed:
----- Method: Interpreter>>primitiveChangeClass (in category 'object access primitives') -----
primitiveChangeClass
+ "Primitive. Change the class of the receiver into the class of the argument given that
+ the format of the receiver matches the format of the argument's class. Fail if the
+ receiver or argument are SmallIntegers, or the receiver is an instance of a compact
+ class and the argument isn't, or when the argument's class is compact and the receiver
+ isn't, or when the format of the receiver is different from the format of the argument's
+ class, or when the arguments class is fixed and the receiver's size differs from the size
+ that an instance of the argument's class should have."
- "Primitive. Change the class of the receiver into the class of the argument given that the format of the receiver matches the format of the argument's class. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have."
| arg rcvr argClass err |
arg := self stackObjectValue: 0.
rcvr := self stackObjectValue: 1.
self successful ifFalse:[^nil].
argClass := self fetchClassOfNonInt: arg.
-
err := self changeClassOf: rcvr to: argClass.
err = 0
ifTrue: ["Flush at cache because rcvr's class has changed."
self flushAtCache.
self pop: self methodArgumentCount]
ifFalse: [self primitiveFail].
^nil!
Item was changed:
----- Method: Interpreter>>signed64BitIntegerFor: (in category 'primitive support') -----
signed64BitIntegerFor: integerValue
"Return a Large Integer object for the given integer value"
| newLargeInteger magnitude largeClass intValue highWord sz |
<inline: false>
+ <var: 'integerValue' type: #sqLong>
+ <var: 'magnitude' type: #sqLong>
+ <var: 'highWord' type: #usqInt>
- <var: 'integerValue' type: 'sqLong'>
- <var: 'magnitude' type: 'sqLong'>
- <var: 'highWord' type: 'usqInt'>
integerValue < 0
+ ifTrue: [largeClass := self classLargeNegativeInteger.
- ifTrue:[ largeClass := self classLargeNegativeInteger.
magnitude := 0 - integerValue]
+ ifFalse: [largeClass := self classLargePositiveInteger.
- ifFalse:[ largeClass := self classLargePositiveInteger.
magnitude := integerValue].
"Make sure to handle the most -ve value correctly.
0 - most -ve = most -ve and most -ve - 1 is +ve"
(magnitude <= 16r7FFFFFFF
and: [integerValue >= 0 or: [integerValue - 1 < 0]]) ifTrue:
+ [^self signed32BitIntegerFor: integerValue].
- [^self signed32BitIntegerFor: integerValue].
+ highWord := magnitude >> 32.
- highWord := self cCode: 'magnitude >> 32'. "shift is coerced to usqInt otherwise"
highWord = 0
ifTrue:[sz := 4]
+ ifFalse:
+ [sz := 5.
- ifFalse:[
- sz := 5.
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
+ (highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1]].
- (highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
- ].
newLargeInteger := self instantiateClass: largeClass indexableSize: sz.
0 to: sz-1 do: [:i |
+ intValue := (magnitude >> (i * 8)) bitAnd: 255.
- intValue := self cCode: '(magnitude >> (i * 8)) & 255'.
self storeByte: i ofObject: newLargeInteger withValue: intValue].
+ ^newLargeInteger!
- ^ newLargeInteger!
Item was changed:
----- Method: InterpreterPrimitives>>cStringOrNullFor: (in category 'primitive support') -----
cStringOrNullFor: oop
"Answer either a malloced string with the null-terminated contents of oop if oop is a string,
or the null pointer if oop is nil, or fail. It is the client's responsibility to free the string later."
<api>
<returnTypeC: #'char *'>
| isString len cString |
<var: 'cString' type: #'char *'>
+ isString := self isInstanceOfClassByteString: oop.
- isString := objectMemory
- isClassOfNonImm: oop
- equalTo: (objectMemory splObj: ClassByteString)
- compactClassIndex: ClassByteStringCompactIndex.
isString ifFalse:
[oop ~= objectMemory nilObject ifTrue:
[self primitiveFailFor: PrimErrBadArgument].
^0].
len := objectMemory lengthOf: oop.
len = 0 ifTrue:
[^0].
cString := self malloc: len + 1.
cString ifNil:
[self primitiveFailFor: PrimErrNoCMemory.
^0].
self mem: cString cp: (objectMemory firstIndexableField: oop) y: len.
cString at: len put: 0.
^cString!
Item was added:
+ ----- Method: InterpreterPrimitives>>isInstanceOfClassArray: (in category 'primitive support') -----
+ isInstanceOfClassArray: oop
+ <inline: true>
+ "N.B. Because Slang always inlines is:instanceOf:compactClassIndex:
+ (because is:instanceOf:compactClassIndex: has an inline: pragma) the
+ phrase (objectMemory splObj: ClassArray) is expanded in-place and
+ is _not_ evaluated if oop has a non-zero CompactClassIndex."
+ ^objectMemory
+ is: oop
+ instanceOf: (objectMemory splObj: ClassArray)
+ compactClassIndex: ClassArrayCompactIndex!
Item was added:
+ ----- Method: InterpreterPrimitives>>isInstanceOfClassBlockClosure: (in category 'primitive support') -----
+ isInstanceOfClassBlockClosure: oop
+ <inline: true>
+ "N.B. Because Slang always inlines is:instanceOf:compactClassIndex:
+ (because is:instanceOf:compactClassIndex: has an inline: pragma) the
+ phrase (objectMemory splObj: ClassBlockClosure) is expanded in-place
+ and is _not_ evaluated if oop has a non-zero CompactClassIndex."
+ ^objectMemory
+ is: oop
+ instanceOf: (objectMemory splObj: ClassBlockClosure)
+ compactClassIndex: ClassBlockClosureCompactIndex!
Item was added:
+ ----- Method: InterpreterPrimitives>>isInstanceOfClassByteString: (in category 'primitive support') -----
+ isInstanceOfClassByteString: oop
+ <inline: true>
+ "N.B. Because Slang always inlines is:instanceOf:compactClassIndex:
+ (because is:instanceOf:compactClassIndex: has an inline: pragma) the
+ phrase (objectMemory splObj: ClassString) is expanded in-place and
+ is _not_ evaluated if oop has a non-zero CompactClassIndex."
+ ^objectMemory
+ is: oop
+ instanceOf: (objectMemory splObj: ClassString)
+ compactClassIndex: ClassByteStringCompactIndex!
Item was added:
+ ----- Method: InterpreterPrimitives>>isInstanceOfClassCharacter: (in category 'primitive support') -----
+ isInstanceOfClassCharacter: oop
+ <inline: true>
+ "N.B. Because Slang always inlines is:instanceOf:compactClassIndex:
+ (because is:instanceOf:compactClassIndex: has an inline: pragma) the
+ phrase (objectMemory splObj: ClassCharacter) is expanded in-place
+ and is _not_ evaluated if oop has a non-zero CompactClassIndex."
+ ^objectMemory
+ is: oop
+ instanceOf: (objectMemory splObj: ClassCharacter)
+ compactClassIndex: 0!
Item was added:
+ ----- Method: InterpreterPrimitives>>isInstanceOfClassFloat: (in category 'primitive support') -----
+ isInstanceOfClassFloat: oop
+ <inline: true>
+ "N.B. Because Slang always inlines is:instanceOf:compactClassIndex:
+ (because is:instanceOf:compactClassIndex: has an inline: pragma) the
+ phrase (objectMemory splObj: ClassFloat) is expanded in-place and is
+ _not_ evaluated if oop has a non-zero CompactClassIndex."
+ ^objectMemory
+ is: oop
+ instanceOf: (objectMemory splObj: ClassFloat)
+ compactClassIndex: ClassFloatCompactIndex!
Item was added:
+ ----- Method: InterpreterPrimitives>>isInstanceOfClassLargeNegativeInteger: (in category 'primitive support') -----
+ isInstanceOfClassLargeNegativeInteger: oop
+ <inline: true>
+ "N.B. Because Slang always inlines is:instanceOf:compactClassIndex:
+ (because is:instanceOf:compactClassIndex: has an inline: pragma) the
+ phrase (objectMemory splObj: ClassLargeNegativeInteger) is expanded
+ in-place and is _not_ evaluated if oop has a non-zero CompactClassIndex."
+ ^objectMemory
+ is: oop
+ instanceOf: (objectMemory splObj: ClassLargeNegativeInteger)
+ compactClassIndex: ClassLargeNegativeIntegerCompactIndex!
Item was added:
+ ----- Method: InterpreterPrimitives>>isInstanceOfClassLargePositiveInteger: (in category 'primitive support') -----
+ isInstanceOfClassLargePositiveInteger: oop
+ <inline: true>
+ "N.B. Because Slang always inlines is:instanceOf:compactClassIndex:
+ (because is:instanceOf:compactClassIndex: has an inline: pragma) the
+ phrase (objectMemory splObj: ClassLargePositiveInteger) is expanded
+ in-place and is _not_ evaluated if oop has a non-zero CompactClassIndex."
+ ^objectMemory
+ is: oop
+ instanceOf: (objectMemory splObj: ClassLargePositiveInteger)
+ compactClassIndex: ClassLargePositiveIntegerCompactIndex!
Item was changed:
----- Method: InterpreterPrimitives>>magnitude64BitIntegerFor:neg: (in category 'primitive support') -----
magnitude64BitIntegerFor: magnitude neg: isNegative
"Return a Large Integer object for the given integer magnitude and sign"
| newLargeInteger largeClass intValue highWord sz isSmall smallVal |
+ <var: 'magnitude' type: #usqLong>
+ <var: 'highWord' type: #usqInt>
- <var: 'magnitude' type: 'usqLong'>
- <var: 'highWord' type: 'usqInt'>
isSmall := isNegative
+ ifTrue: [magnitude <= 16r40000000]
+ ifFalse: [magnitude < 16r40000000].
+ isSmall ifTrue:
+ [smallVal := self cCoerceSimple: magnitude to: #sqInt.
+ isNegative ifTrue: [smallVal := 0 - smallVal].
+ ^objectMemory integerObjectOf: smallVal].
+ largeClass := isNegative
+ ifTrue: [objectMemory classLargeNegativeInteger]
+ ifFalse: [objectMemory classLargePositiveInteger].
+ highWord := magnitude >> 32.
- ifTrue: [magnitude <= 16r40000000]
- ifFalse: [magnitude < 16r40000000].
- isSmall
- ifTrue:
- [smallVal := self cCoerce: magnitude to: #sqInt.
- isNegative ifTrue: [smallVal := 0 - smallVal].
- ^self integerObjectOf: smallVal].
- isNegative
- ifTrue:[ largeClass := self classLargeNegativeInteger]
- ifFalse:[ largeClass := self classLargePositiveInteger].
- highWord := self cCode: 'magnitude >> 32'. "shift is coerced to usqInt otherwise"
highWord = 0
ifTrue: [sz := 4]
+ ifFalse:
+ [sz := 5.
+ (highWord := highWord >> 8) = 0 ifFalse: [sz := sz + 1].
+ (highWord := highWord >> 8) = 0 ifFalse: [sz := sz + 1].
+ (highWord := highWord >> 8) = 0 ifFalse: [sz := sz + 1]].
+ newLargeInteger := objectMemory instantiateClass: largeClass indexableSize: sz.
- ifFalse:[
- sz := 5.
- (highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
- (highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
- (highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
- ].
- newLargeInteger := self instantiateClass: largeClass indexableSize: sz.
0 to: sz-1 do: [:i |
+ intValue := (magnitude >> (i * 8)) bitAnd: 255.
+ objectMemory storeByte: i ofObject: newLargeInteger withValue: intValue].
+ ^newLargeInteger!
- intValue := self cCode: '(magnitude >> (i * 8)) & 255'.
- self storeByte: i ofObject: newLargeInteger withValue: intValue].
- ^ newLargeInteger!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveChangeClass (in category 'object access primitives') -----
primitiveChangeClass
+ "Primitive. Change the class of the receiver into the class of the argument given that
+ the format of the receiver matches the format of the argument's class. Fail if the
+ receiver or argument are SmallIntegers, or the receiver is an instance of a compact
+ class and the argument isn't, or when the argument's class is compact and the receiver
+ isn't, or when the format of the receiver is different from the format of the argument's
+ class, or when the arguments class is fixed and the receiver's size differs from the size
+ that an instance of the argument's class should have."
- "Primitive. Change the class of the receiver into the class of the argument given that the format of the receiver matches the format of the argument's class. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have."
| arg rcvr argClass err |
arg := self stackObjectValue: 0.
rcvr := self stackObjectValue: 1.
self successful ifFalse:[^nil].
+ argClass := objectMemory fetchClassOfNonInt: arg.
- argClass := self fetchClassOfNonInt: arg.
-
err := objectMemory changeClassOf: rcvr to: argClass.
err = 0
ifTrue: ["Flush at cache because rcvr's class has changed."
self flushAtCache.
self pop: self methodArgumentCount]
ifFalse: [self primitiveFailFor: err].
^nil!
Item was removed:
- ----- Method: NewCoObjectMemory>>compactClassTable (in category 'cog jit support') -----
- compactClassTable
- <api>
- ^self splObj: CompactClasses!
Item was changed:
----- Method: NewCoObjectMemorySimulator>>fullGC (in category 'debug support') -----
fullGC
self halt.
coInterpreter transcript
+ cr; nextPutAll:'<Running full GC ('; print: coInterpreter byteCount; space; print: freeStart; nextPutAll: ')...'; flush.
- cr; nextPutAll:'<Running full GC ('; print: coInterpreter byteCount; nextPutAll: ')...'; flush.
super fullGC.
coInterpreter transcript show: ' done>'!
Item was changed:
----- Method: NewCoObjectMemorySimulator>>incrementalGC (in category 'debug support') -----
incrementalGC
+ coInterpreter transcript cr; nextPutAll: 'incrementalGC ('; print: coInterpreter byteCount; space; print: freeStart; nextPut: $); flush.
- coInterpreter transcript cr; nextPutAll: 'incrementalGC ('; print: coInterpreter byteCount; nextPut: $); flush.
^super incrementalGC!
Item was changed:
----- Method: NewCoObjectMemorySimulator>>storePointer:ofObject:withValue: (in category 'interpreter access') -----
storePointer: index ofObject: oop withValue: valuePointer
+ "Override to ensure acess is within the heap, and within the object"
+ | fmt hdr |
- "Override to ensure acess is within the heap"
self assert: oop >= self startOfMemory.
+ hdr := self baseHeader: oop.
+ fmt := self formatOfHeader: hdr.
+ self assert: ((fmt <= 4 or: [fmt >= 12])
+ and: [index >= 0 and: [index < (self lengthOf: oop baseHeader: hdr format: fmt)]]).
^super storePointer: index ofObject: oop withValue: valuePointer!
Item was changed:
----- Method: NewCoObjectMemorySimulator>>storePointerUnchecked:ofObject:withValue: (in category 'interpreter access') -----
+ storePointerUnchecked: index ofObject: oop withValue: valuePointer
+ "Override to ensure acess is within the heap, and within the object"
+ | fmt hdr |
- storePointerUnchecked: fieldIndex ofObject: oop withValue: valuePointer
- "Override to ensure acess is within the heap"
self assert: oop >= self startOfMemory.
+ hdr := self baseHeader: oop.
+ fmt := self formatOfHeader: hdr.
+ self assert: ((fmt <= 4 or: [fmt >= 12])
+ and: [index >= 0 and: [index < (self lengthOf: oop baseHeader: hdr format: fmt)]]).
+ ^super storePointerUnchecked: index ofObject: oop withValue: valuePointer!
- ^super storePointerUnchecked: fieldIndex ofObject: oop withValue: valuePointer!
Item was changed:
----- Method: NewCoObjectMemorySimulator>>tenuringIncrementalGC (in category 'debug support') -----
tenuringIncrementalGC
+ coInterpreter transcript cr; nextPutAll: 'tenuringIncrementalGC ('; print: coInterpreter byteCount; space; print: freeStart; nextPut: $); flush.
- coInterpreter transcript cr; nextPutAll: 'tenuringIncrementalGC ('; print: coInterpreter byteCount; nextPut: $); flush.
^super tenuringIncrementalGC!
Item was changed:
----- Method: NewObjectMemory>>fullGC (in category 'garbage collection') -----
fullGC
+ "Do a mark/sweep garbage collection of the entire object memory.
+ Free inaccessible objects but do not move them."
- "Do a mark/sweep garbage collection of the entire object memory. Free inaccessible objects but do not move them."
<inline: false>
fullGCLock > 0 ifTrue:
[self warning: 'aborting fullGC because fullGCLock > 0'.
^self].
- self initializeFreeBlocksPreSweep.
self runLeakCheckerForFullGC: true.
self preGCAction: GCModeFull.
gcStartUsecs := self ioUTCMicrosecondsNow.
statSweepCount := statMarkCount := statMkFwdCount := statCompMoveCount := 0.
self clearRootsTable.
self initWeakTableForIncrementalGC: false.
youngStart := self startOfMemory. "process all of memory"
self markPhase: true.
"Sweep phase returns the number of survivors.
Use the up-to-date version instead the one from startup."
totalObjectCount := self sweepPhaseForFullGC.
self runLeakCheckerForFullGC: true.
self fullCompaction.
statFullGCs := statFullGCs + 1.
statGCEndUsecs := self ioUTCMicrosecondsNow.
statFullGCUsecs := statFullGCUsecs + (statGCEndUsecs - gcStartUsecs).
self capturePendingFinalizationSignals.
youngStart := freeStart. "reset the young object boundary"
self postGCAction.
self runLeakCheckerForFullGC: true!
Item was changed:
----- Method: NewObjectMemory>>incrementalGC (in category 'garbage collection') -----
incrementalGC
"Do a mark/sweep garbage collection of just the young object
area of object memory (i.e., objects above youngStart), using
the root table to identify objects containing pointers to
young objects from the old object area."
| survivorCount weDidGrow |
<inline: false>
rootTableCount >= RootTableSize ifTrue:
["root table overflow; cannot do an incremental GC (this should be very rare)"
statRootTableOverflows := statRootTableOverflows + 1.
^self fullGC].
-
- self initializeFreeBlocksPreSweep.
self runLeakCheckerForFullGC: false.
-
self preGCAction: GCModeIncr.
- "incremental GC and compaction"
-
gcStartUsecs := self ioUTCMicrosecondsNow.
statSweepCount := statMarkCount := statMkFwdCount := statCompMoveCount := 0.
self initWeakTableForIncrementalGC: true.
+ "implicitly process memory from youngStart to freeStart"
self markPhase: false.
self assert: weakRootCount <= WeakRootTableSize.
1 to: weakRootCount do:
[:i| self finalizeReference: (weakRoots at: i)].
survivorCount := self sweepPhase.
self runLeakCheckerForFullGC: false.
self incrementalCompaction.
statIncrGCs := statIncrGCs + 1.
statGCEndUsecs := self ioUTCMicrosecondsNow.
statIGCDeltaUsecs := statGCEndUsecs - gcStartUsecs.
statIncrGCUsecs := statIncrGCUsecs + statIGCDeltaUsecs.
self capturePendingFinalizationSignals.
statRootTableCount := rootTableCount.
statSurvivorCount := survivorCount.
weDidGrow := false.
(((survivorCount > tenuringThreshold)
or: [rootTableCount >= RootTableRedZone])
or: [forceTenureFlag == true]) ifTrue:
["move up the young space boundary if
* there are too many survivors:
this limits the number of objects that must be
processed on future incremental GC's
* we're about to overflow the roots table:
this limits the number of full GCs that may be caused
by root table overflows in the near future"
forceTenureFlag := false.
statTenures := statTenures + 1.
self clearRootsTable.
((self freeSize < growHeadroom)
and: [gcBiasToGrow > 0]) ifTrue:
[self biasToGrow.
weDidGrow := true].
youngStart := freeStart].
self postGCAction.
self runLeakCheckerForFullGC: false.
weDidGrow ifTrue:
[self biasToGrowCheckGCLimit]!
Item was removed:
- ----- Method: NewObjectMemory>>initializeFreeBlocksPreSweep (in category 'initialization') -----
- initializeFreeBlocksPreSweep
- "Set up the free block in preparation for any kind of sweep through all of memory."
- <inline: true>
- self setSizeOfFree: freeStart to: endOfMemory - freeStart. "bytes available for oops"
- self assert: (self isFreeObject: freeStart).
- self assert: freeStart + (self sizeOfFree: freeStart) = endOfMemory.
- self assert: (freeStart < endOfMemory and: [endOfMemory < memoryLimit])!
Item was changed:
----- Method: NewObjectMemory>>okayOop: (in category 'debug support') -----
okayOop: signedOop
"Verify that the given oop is legitimate. Check address, header, and size but not class."
| sz type fmt unusedBit oop |
<var: #oop type: #usqInt>
oop := self cCoerce: signedOop to: #usqInt.
"address and size checks"
(self isIntegerObject: oop) ifTrue: [ ^true ].
(oop >= self startOfMemory and: [oop < freeStart])
ifFalse: [ self error: 'oop is not a valid address'. ^false ].
((oop \\ BytesPerWord) = 0)
ifFalse: [ self error: 'oop is not a word-aligned address'. ^false ].
sz := self sizeBitsOf: oop.
+ (oop + sz) <= freeStart
- (oop + sz) < freeStart
ifFalse: [ self error: 'oop size would make it extend beyond the end of memory'. ^false ].
"header type checks"
type := self headerType: oop.
type = HeaderTypeFree
ifTrue: [ self error: 'oop is a free chunk, not an object'. ^false ].
type = HeaderTypeShort ifTrue: [
(self compactClassIndexOf: oop) = 0
ifTrue: [ self error: 'cannot have zero compact class field in a short header'. ^false ].
].
type = HeaderTypeClass ifTrue: [
((oop >= BytesPerWord) and: [(self headerType: oop - BytesPerWord) = type])
ifFalse: [ self error: 'class header word has wrong type'. ^false ].
].
type = HeaderTypeSizeAndClass ifTrue: [
((oop >= (BytesPerWord*2)) and:
[(self headerType: oop - (BytesPerWord*2)) = type and:
[(self headerType: oop - BytesPerWord) = type]])
ifFalse: [ self error: 'class header word has wrong type'. ^false ].
].
"format check"
fmt := self formatOf: oop.
((fmt = 5) | (fmt = 7))
ifTrue: [ self error: 'oop has an unknown format type'. ^false ].
"mark and root bit checks"
unusedBit := 16r20000000.
BytesPerWord = 8
ifTrue:
[unusedBit := unusedBit << 16.
unusedBit := unusedBit << 16].
((self longAt: oop) bitAnd: unusedBit) = 0
ifFalse: [ self error: 'unused header bit 30 is set; should be zero'. ^false ].
"xxx
((self longAt: oop) bitAnd: MarkBit) = 0
ifFalse: [ self error: 'mark bit should not be set except during GC' ].
xxx"
(((self longAt: oop) bitAnd: RootBit) = 1 and:
[oop >= youngStart])
ifTrue: [ self error: 'root bit is set in a young object'. ^false ].
^true
!
Item was added:
+ ----- Method: NewObjectMemory>>printHeaderTypeOf: (in category 'debug printing') -----
+ printHeaderTypeOf: obj
+ (self headerType: obj) caseOf: {
+ [HeaderTypeFree] -> [coInterpreter print: ' HeaderTypeFree (4 bytes)'].
+ [HeaderTypeShort] -> [coInterpreter print: ' HeaderTypeShort (4 bytes)'].
+ [HeaderTypeClass] -> [coInterpreter print: ' HeaderTypeClass (8 bytes)'].
+ [HeaderTypeSizeAndClass] -> [coInterpreter print: ' HeaderTypeSizeAndClass (12 bytes)'] }!
Item was added:
+ ----- Method: NewObjectMemory>>sweepPhase (in category 'gc -- mark and sweep') -----
+ sweepPhase
+ "Sweep memory from youngStart through the end of memory. Free all
+ inaccessible objects and coalesce adjacent free chunks. Clear the mark
+ bits of accessible objects. Compute the starting point for the first pass of
+ incremental compaction (compStart). Return the number of surviving
+ objects. "
+ "Details: Each time a non-free object is encountered, decrement the
+ number of available forward table entries. If all entries are spoken for
+ (i.e., entriesAvailable reaches zero), set compStart to the last free
+ chunk before that object or, if there is no free chunk before the given
+ object, the first free chunk after it. Thus, at the end of the sweep
+ phase, compStart through compEnd spans the highest collection of
+ non-free objects that can be accomodated by the forwarding table. This
+ information is used by the first pass of incremental compaction to
+ ensure that space is initially freed at the end of memory. Note that
+ there should always be at least one free chunk--the one at the end of
+ the heap."
+ | entriesAvailable survivors freeChunk firstFree oop oopHeader oopHeaderType hdrBytes oopSize freeChunkSize freeStartLocal |
+ <inline: false>
+ <var: #oop type: #usqInt>
+ <var: #freeStartLocal type: #usqInt>
+ entriesAvailable := self fwdTableInit: BytesPerWord*2.
+ survivors := 0.
+ freeChunk := nil.
+ firstFree := nil.
+ "will be updated later"
+ freeStartLocal := freeStart.
+ oop := self oopFromChunk: youngStart.
+ [oop < freeStartLocal]
+ whileTrue: ["get oop's header, header type, size, and header size"
+ statSweepCount := statSweepCount + 1.
+ oopHeader := self baseHeader: oop.
+ oopHeaderType := oopHeader bitAnd: TypeMask.
+ hdrBytes := headerTypeBytes at: oopHeaderType.
+ (oopHeaderType bitAnd: 1) = 1
+ ifTrue: [oopSize := oopHeader bitAnd: SizeMask]
+ ifFalse: [oopHeaderType = HeaderTypeSizeAndClass
+ ifTrue: [oopSize := (self sizeHeader: oop) bitAnd: LongSizeMask]
+ ifFalse: ["free chunk" oopSize := oopHeader bitAnd: LongSizeMask]].
+ (oopHeader bitAnd: MarkBit) = 0
+ ifTrue: ["object is not marked; free it"
+ "<-- Finalization support: We need to mark each oop chunk as free -->"
+ self longAt: oop - hdrBytes put: HeaderTypeFree.
+ freeChunk ~= nil
+ ifTrue: ["enlarge current free chunk to include this oop"
+ freeChunkSize := freeChunkSize + oopSize + hdrBytes]
+ ifFalse: ["start a new free chunk"
+ freeChunk := oop - hdrBytes.
+ "chunk may start 4 or 8 bytes before oop"
+ freeChunkSize := oopSize + (oop - freeChunk).
+ "adjust size for possible extra header bytes"
+ firstFree = nil ifTrue: [firstFree := freeChunk]]]
+ ifFalse: ["object is marked; clear its mark bit and possibly adjust
+ the compaction start"
+ self longAt: oop put: (oopHeader bitAnd: AllButMarkBit).
+ "<-- Finalization support: Check if we're running about a weak class -->"
+ (self isWeakNonInt: oop) ifTrue: [self finalizeReference: oop].
+ entriesAvailable > 0
+ ifTrue: [entriesAvailable := entriesAvailable - 1]
+ ifFalse: ["start compaction at the last free chunk before this object"
+ firstFree := freeChunk].
+ freeChunk ~= nil
+ ifTrue: ["record the size of the last free chunk"
+ self longAt: freeChunk put: ((freeChunkSize bitAnd: LongSizeMask) bitOr: HeaderTypeFree).
+ freeChunk := nil].
+ survivors := survivors + 1].
+ oopSize = 0 ifTrue:
+ [self error: 'zero sized object encountered in sweep'].
+ oop := self oopFromChunk: oop + oopSize].
+ freeChunk ~= nil
+ ifTrue: ["record size of final free chunk"
+ self longAt: freeChunk put: ((freeChunkSize bitAnd: LongSizeMask) bitOr: HeaderTypeFree)].
+ oop = freeStart
+ ifFalse: [self error: 'sweep failed to find exact end of memory'].
+ compStart := firstFree = nil
+ ifTrue: [freeStart]
+ ifFalse: [firstFree].
+ ^survivors!
Item was added:
+ ----- Method: NewObjectMemorySimulator class>>vmProxyMajorVersion (in category 'simulation only') -----
+ vmProxyMajorVersion
+ "hack around the CoInterpreter/ObjectMemory split refactoring"
+ ^StackInterpreter vmProxyMajorVersion!
Item was added:
+ ----- Method: NewObjectMemorySimulator class>>vmProxyMinorVersion (in category 'simulation only') -----
+ vmProxyMinorVersion
+ "hack around the CoInterpreter/ObjectMemory split refactoring"
+ ^CoInterpreter vmProxyMinorVersion!
Item was changed:
----- Method: NewObjectMemorySimulator>>fullGC (in category 'debug support') -----
fullGC
self halt.
coInterpreter transcript
+ cr; nextPutAll:'<Running full GC ('; print: coInterpreter byteCount; space; print: freeStart; nextPutAll: ')...'; flush.
- cr; nextPutAll:'<Running full GC ('; print: coInterpreter byteCount; nextPutAll: ')...'; flush.
super fullGC.
coInterpreter transcript show: ' done>'!
Item was changed:
----- Method: NewObjectMemorySimulator>>incrementalGC (in category 'debug support') -----
incrementalGC
+ coInterpreter transcript cr; nextPutAll: 'incrementalGC ('; print: coInterpreter byteCount; space; print: freeStart; nextPut: $); flush.
- coInterpreter transcript cr; nextPutAll: 'incrementalGC ('; print: coInterpreter byteCount; nextPut: $); flush.
^super incrementalGC!
Item was added:
+ ----- Method: NewObjectMemorySimulator>>printMemoryFrom:to: (in category 'printing') -----
+ printMemoryFrom: start to: end
+ | address |
+ address := start bitAnd: (BytesPerWord - 1) bitInvert.
+ [address < end] whileTrue:
+ [self printHex: address; printChar: $:; space; printHex: (self longAt: address); cr.
+ address := address + BytesPerWord]!
Item was added:
+ ----- Method: NewObjectMemorySimulator>>space (in category 'printing') -----
+ space
+ ^coInterpreter space!
Item was added:
+ ----- Method: NewObjectMemorySimulator>>storePointer:ofObject:withValue: (in category 'interpreter access') -----
+ storePointer: index ofObject: oop withValue: valuePointer
+ "Override to ensure acess is within the heap, and within the object"
+ | fmt hdr |
+ self assert: oop >= self startOfMemory.
+ hdr := self baseHeader: oop.
+ fmt := self formatOfHeader: hdr.
+ self assert: ((fmt <= 4 or: [fmt >= 12])
+ and: [index >= 0 and: [index < (self lengthOf: oop baseHeader: hdr format: fmt)]]).
+ ^super storePointer: index ofObject: oop withValue: valuePointer!
Item was added:
+ ----- Method: NewObjectMemorySimulator>>storePointerUnchecked:ofObject:withValue: (in category 'interpreter access') -----
+ storePointerUnchecked: index ofObject: oop withValue: valuePointer
+ "Override to ensure acess is within the heap, and within the object"
+ | fmt hdr |
+ self assert: oop >= self startOfMemory.
+ hdr := self baseHeader: oop.
+ fmt := self formatOfHeader: hdr.
+ self assert: ((fmt <= 4 or: [fmt >= 12])
+ and: [index >= 0 and: [index < (self lengthOf: oop baseHeader: hdr format: fmt)]]).
+ ^super storePointerUnchecked: index ofObject: oop withValue: valuePointer!
Item was changed:
----- Method: NewObjectMemorySimulator>>tenuringIncrementalGC (in category 'debug support') -----
tenuringIncrementalGC
+ coInterpreter transcript cr; nextPutAll: 'tenuringIncrementalGC ('; print: coInterpreter byteCount; space; print: freeStart; nextPut: $); flush.
- coInterpreter transcript cr; nextPutAll: 'tenuringIncrementalGC ('; print: coInterpreter byteCount; nextPut: $); flush.
^super tenuringIncrementalGC!
Item was changed:
----- Method: NewspeakInterpreter>>allAccessibleObjectsOkay (in category 'debug support') -----
allAccessibleObjectsOkay
"Ensure that all accessible objects in the heap are okay."
+ | oop ok |
+ ok := true.
- | oop |
oop := self firstAccessibleObject.
+ [oop = nil] whileFalse:
+ [ok := ok & (self okayFields: oop).
+ oop := self accessibleObjectAfter: oop].
+ ^ok!
- [oop = nil] whileFalse: [
- self okayFields: oop.
- oop := self accessibleObjectAfter: oop.
- ].!
Item was changed:
----- Method: NewspeakInterpreter>>assertClassOf:is: (in category 'utilities') -----
assertClassOf: oop is: classOop
"Succeed if the given (non-integer) object is an instance of the given class. Fail if the object is an integer."
- | ccIndex cl |
<inline: true>
+ <asmLabel: false>
+ self success: (self isClassOfNonImm: oop equalTo: classOop)!
- (self isIntegerObject: oop) ifTrue: [^self primitiveFail].
-
- ccIndex := ((self baseHeader: oop) >> 12) bitAnd: 16r1F.
- ccIndex = 0
- ifTrue: [ cl := ((self classHeader: oop) bitAnd: AllButTypeMask) ]
- ifFalse: [
- "look up compact class"
- cl := (self fetchPointer: (ccIndex - 1)
- ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop))].
-
- self success: cl = classOop.
- !
Item was changed:
----- Method: NewspeakInterpreter>>cStringOrNullFor: (in category 'primitive support') -----
cStringOrNullFor: oop
"Answer either a malloced string with the null-terminated contents of oop if oop is a string,
or the null pointer if oop is nil, or fail. It is the client's responsibility to free the string later."
<api>
<returnTypeC: #'char *'>
| isString len cString |
<var: 'cString' type: #'char *'>
+ isString := self isInstanceOfClassByteString: oop.
- isString := self
- isClassOfNonImm: oop
- equalTo: (self splObj: ClassByteString)
- compactClassIndex: ClassByteStringCompactIndex.
isString ifFalse:
[oop ~= nilObj ifTrue:
[self primitiveFailFor: PrimErrBadArgument].
^0].
len := self lengthOf: oop.
len = 0 ifTrue:
[^0].
cString := self malloc: len + 1.
cString ifNil:
[self primitiveFailFor: PrimErrNoCMemory.
^0].
self mem: cString cp: (self firstIndexableField: oop) y: len.
cString at: len put: 0.
^cString!
Item was changed:
----- Method: NewspeakInterpreter>>floatValueOf: (in category 'utilities') -----
floatValueOf: oop
+ "Answer the C double precision floating point value of the argument,
+ or fail if it is not a Float, and answer 0.
+ Note: May be called by translated primitive code."
- "Fetch the instance variable at the given index of the given object. Answer the C
- double precision floating point value of that instance variable, or fail if it is not a Float."
| isFloat result |
<returnTypeC: #double>
<var: #result type: #double>
+ isFloat := self isInstanceOfClassFloat: oop.
- "N.B. Because Slang always inlines is:instanceOf:compactClassIndex:
- (because is:instanceOf:compactClassIndex: has an inline: pragma) the
- phrase (self splObj: ClassArray) is expanded in-place and is _not_ evaluated if
- ClassArrayCompactIndex is non-zero."
- isFloat := self
- is: oop
- instanceOf: (self splObj: ClassFloat)
- compactClassIndex: ClassFloatCompactIndex.
isFloat ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
self fetchFloatAt: oop + BaseHeaderSize into: result.
^result].
self primitiveFail.
^0.0!
Item was removed:
- ----- Method: NewspeakInterpreter>>isContext:header: (in category 'contexts') -----
- isContext: oop header: hdr
- "NOTE: anOop is assumed not to be an integer"
- | ccIndex theClass |
- <inline: true>
- ccIndex := (hdr >> 12) bitAnd: 16r1F.
- ccIndex = 0
- ifTrue: [theClass := (self classHeader: oop) bitAnd: AllButTypeMask]
- ifFalse: ["look up compact class"
- theClass := self fetchPointer: ccIndex - 1 ofObject: (self splObj: CompactClasses)].
- ^ theClass = (self splObj: ClassMethodContext) or: [theClass = (self splObj: ClassBlockContext)]
- !
Item was changed:
----- Method: NewspeakInterpreter>>primitiveChangeClass (in category 'object access primitives') -----
primitiveChangeClass
+ "Primitive. Change the class of the receiver into the class of the argument given that
+ the format of the receiver matches the format of the argument's class. Fail if the
+ receiver or argument are SmallIntegers, or the receiver is an instance of a compact
+ class and the argument isn't, or when the argument's class is compact and the receiver
+ isn't, or when the format of the receiver is different from the format of the argument's
+ class, or when the arguments class is fixed and the receiver's size differs from the size
+ that an instance of the argument's class should have."
- "Primitive. Change the class of the receiver into the class of the argument given that
- the format of the receiver matches the format of the argument's class. Fail if receiver
- or argument are SmallIntegers, or the receiver is an instance of a compact class and
- the argument isn't, or when the format of the receiver is different from the format of
- the argument's class, or when the arguments class is fixed and the receiver's size
- differs from the size that an instance of the argument's class should have."
| arg rcvr argClass err |
arg := self stackObjectValue: 0.
rcvr := self stackObjectValue: 1.
self successful ifFalse:[^nil].
argClass := self fetchClassOfNonInt: arg.
-
err := self changeClassOf: rcvr to: argClass.
err = 0
ifTrue: ["Flush at cache because rcvr's class has changed."
self flushAtCache.
self pop: self methodArgumentCount]
ifFalse: [self primitiveFailFor: err].
^nil!
Item was changed:
----- Method: NewspeakInterpreter>>signed64BitIntegerFor: (in category 'primitive support') -----
signed64BitIntegerFor: integerValue
"Return a Large Integer object for the given integer value"
| newLargeInteger magnitude largeClass intValue highWord sz |
<inline: false>
+ <var: 'integerValue' type: #sqLong>
+ <var: 'magnitude' type: #sqLong>
+ <var: 'highWord' type: #usqInt>
- <var: 'integerValue' type: 'sqLong'>
- <var: 'magnitude' type: 'unsigned sqLong'>
- <var: 'highWord' type: 'usqInt'>
integerValue < 0
+ ifTrue: [largeClass := self classLargeNegativeInteger.
- ifTrue:[ largeClass := self classLargeNegativeInteger.
magnitude := 0 - integerValue]
+ ifFalse: [largeClass := self classLargePositiveInteger.
- ifFalse:[ largeClass := self classLargePositiveInteger.
magnitude := integerValue].
+ "Make sure to handle the most -ve value correctly.
+ 0 - most -ve = most -ve and most -ve - 1 is +ve"
+ (magnitude <= 16r7FFFFFFF
+ and: [integerValue >= 0 or: [integerValue - 1 < 0]]) ifTrue:
+ [^self signed32BitIntegerFor: integerValue].
- magnitude <= 16r7FFFFFFF ifTrue:[^self signed32BitIntegerFor: integerValue].
+ highWord := magnitude >> 32.
- highWord := self cCode: 'magnitude >> 32'. "shift is coerced to usqInt otherwise"
highWord = 0
ifTrue:[sz := 4]
+ ifFalse:
+ [sz := 5.
- ifFalse:[
- sz := 5.
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
+ (highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1]].
- (highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
- ].
newLargeInteger := self instantiateClass: largeClass indexableSize: sz.
0 to: sz-1 do: [:i |
+ intValue := (magnitude >> (i * 8)) bitAnd: 255.
- intValue := self cCode: '(magnitude >> (i * 8)) & 255'.
self storeByte: i ofObject: newLargeInteger withValue: intValue].
+ ^newLargeInteger!
- ^ newLargeInteger!
Item was changed:
----- Method: ObjectMemory>>changeClassOf:to: (in category 'interpreter access') -----
changeClassOf: rcvr to: argClass
+ "Attempt to change the class of the receiver to the argument given that the
+ format of the receiver matches the format of the argument. If successful,
+ answer 0, otherwise answer an error code indicating the reason for failure.
+ Fail if the receiver is an instance of a compact class and the argument isn't,
+ or if the format of the receiver is incompatible with the format of the argument,
+ or if the argument is a fixed class and the receiver's size differs from the size
+ that an instance of the argument should have."
+ | classHdr sizeHiBits argClassInstByteSize argFormat rcvrFormat rcvrHdr ccIndex |
- "Attempt to change the class of the receiver into the class of the the argument given that the
- format of the receiver matches the format of the argument. If successful answer 0, otherwise
- answer an error code indicating the reason for failure. Fail if receiver or argument are
- SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when
- the format of the receiver is different from the format of the argument's class, or when the
- arguments class is fixed and the receiver's size differs from the size that an instance of the
- argument's class should have."
- | classHdr sizeHiBits byteSize argFormat rcvrFormat rcvrHdr ccIndex |
"Check what the format of the class says"
classHdr := self formatOfClass: argClass. "Low 2 bits are 0"
"Compute the size of instances of the class (used for fixed field classes only)"
sizeHiBits := (classHdr bitAnd: 16r60000) >> 9.
classHdr := classHdr bitAnd: 16r1FFFF.
+ argClassInstByteSize := (classHdr bitAnd: SizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0"
- byteSize := (classHdr bitAnd: SizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0"
"Check the receiver's format against that of the class"
argFormat := self formatOfHeader: classHdr.
rcvrHdr := self baseHeader: rcvr.
rcvrFormat := self formatOfHeader: rcvrHdr.
"If the receiver is a byte object we need to clear the number of odd bytes from the format."
rcvrFormat > 8 ifTrue:
[rcvrFormat := rcvrFormat bitAnd: 16rC].
argFormat = rcvrFormat ifFalse:
[^PrimErrInappropriate]. "no way"
"For fixed field classes, the sizes must match.
+ Note: argClassInstByteSize-4 because base header is included in class size."
- Note: byteSize-4 because base header is included in class size."
argFormat < 2
ifTrue:
+ [(argClassInstByteSize - BaseHeaderSize) ~= (self byteSizeOf: rcvr) ifTrue:
- [(byteSize - BaseHeaderSize) ~= (self byteSizeOf: rcvr) ifTrue:
[^PrimErrBadReceiver]]
ifFalse:
[argFormat = 3 ifTrue: "For indexable plus fixed fields the receiver must be at least big enough."
+ [(argClassInstByteSize - BaseHeaderSize) > (self byteSizeOf: rcvr) ifTrue:
- [(byteSize - BaseHeaderSize) > (self byteSizeOf: rcvr) ifTrue:
[^PrimErrBadReceiver]]].
- ccIndex := classHdr bitAnd: CompactClassMask.
(self headerTypeOfHeader: rcvrHdr) = HeaderTypeShort
ifTrue: "Compact classes. Check if the arg's class is compact and exchange ccIndex"
+ [ccIndex := classHdr bitAnd: CompactClassMask.
+ ccIndex = 0 ifTrue:
- [ccIndex = 0 ifTrue:
[^PrimErrInappropriate]. "class is not compact"
self cppIf: IMMUTABILITY
ifTrue: [(rcvrHdr bitAnd: ImmutabilityBit) ~= 0 ifTrue:
[^PrimErrNoModification]].
+ self baseHeader: rcvr put: ((rcvrHdr bitClear: CompactClassMask) bitOr: ccIndex)]
+ ifFalse: "Exchange the class pointer, which could make rcvr a root for argClass"
- self baseHeader: rcvr
- put: (((self longAt: rcvr) bitClear: CompactClassMask) bitOr: ccIndex)]
- ifFalse: "Exchange the class pointer, which could make rcvr a root for argClass. Don't forget to set ccIndex."
[self cppIf: IMMUTABILITY
ifTrue: [(rcvrHdr bitAnd: ImmutabilityBit) ~= 0 ifTrue:
[^PrimErrNoModification]].
+ "N.B. the recursive scan-mark algorithm uses the header word's size and compact class
+ fields to determine the header type when it reuses the header type bits for the mark
+ state. So it is alas an invariant that non-compact headers have a 0 compact class field."
+ (self compactClassIndexOfHeader: rcvrHdr) ~= 0 ifTrue:
+ [self baseHeader: rcvr put: (rcvrHdr bitClear: CompactClassMask)].
+ self longAt: rcvr - BaseHeaderSize put: (argClass bitOr: (self headerTypeOfHeader: rcvrHdr)).
- self baseHeader: rcvr
- put: (((self baseHeader: rcvr) bitClear: CompactClassMask) bitOr: ccIndex).
- self longAt: rcvr-BaseHeaderSize put: (argClass bitOr: (self headerType: rcvr)).
(self oop: rcvr isLessThan: youngStart) ifTrue:
[self possibleRootStoreInto: rcvr value: argClass]].
"ok"
^0!
Item was changed:
----- Method: ObjectMemory>>checkCompactIndex:isClass:named: (in category 'initialization') -----
checkCompactIndex: compactIndex isClass: specialIndex named: name
"Check that a class the VM assumes is compact has the right index."
<inline: true> "macrofication of the name arg in invalidCompactClassError only works if this method is inlined so the name is a string literal not a parameter"
(compactIndex ~= 0
+ and: [(self splObj: specialIndex) ~= (self compactClassAt: compactIndex)]) ifTrue:
- and: [(self splObj: specialIndex) ~= (self fetchPointer: compactIndex - 1
- ofObject: (self splObj: CompactClasses))]) ifTrue:
[self invalidCompactClassError: name]!
Item was changed:
----- Method: ObjectMemory>>compactClassAt: (in category 'interpreter access') -----
compactClassAt: ccIndex
"Index must be between 1 and compactClassArray size. A zero compact class
+ index in the base header indicates that the class is in the class header word."
- index in the base header indicate that the class is in the class header word."
<api>
+ <inline: true>
+ ^self fetchPointer: ccIndex - 1 ofObject: (self splObj: CompactClasses)!
- | classesArray |
- classesArray := self fetchPointer: CompactClasses ofObject: self specialObjectsOop.
- ^self fetchPointer: ccIndex - 1 ofObject: classesArray!
Item was changed:
----- Method: ObjectMemory>>fetchClassOf: (in category 'interpreter access') -----
fetchClassOf: oop
| ccIndex |
<inline: true>
<asmLabel: false>
+ ^(self isIntegerObject: oop)
+ ifTrue: [self splObj: ClassInteger]
+ ifFalse:
+ [(ccIndex := (self compactClassIndexOf: oop)) = 0
+ ifTrue: [(self classHeader: oop) bitAnd: AllButTypeMask]
+ ifFalse: [self compactClassAt: ccIndex]]!
- (self isIntegerObject: oop) ifTrue: [^self splObj: ClassInteger].
-
- (ccIndex := (self compactClassIndexOf: oop)) = 0
- ifTrue: [^(self classHeader: oop) bitAnd: AllButTypeMask]
- ifFalse: "look up compact class"
- [^self fetchPointer: ccIndex - 1
- ofObject: (self splObj: CompactClasses)]!
Item was changed:
----- Method: ObjectMemory>>fetchClassOfNonInt: (in category 'interpreter access') -----
fetchClassOfNonInt: oop
| ccIndex |
<inline: true>
<asmLabel: false>
+ ^(ccIndex := (self compactClassIndexOf: oop)) = 0
+ ifTrue: [(self classHeader: oop) bitAnd: AllButTypeMask]
+ ifFalse: [self compactClassAt: ccIndex]!
- (ccIndex := (self compactClassIndexOf: oop)) = 0
- ifTrue: [^(self classHeader: oop) bitAnd: AllButTypeMask]
- ifFalse: "look up compact class"
- [^self fetchPointer: ccIndex - 1
- ofObject: (self splObj: CompactClasses)]!
Item was changed:
----- Method: ObjectMemory>>is:instanceOf:compactClassIndex: (in category 'header access') -----
is: oop instanceOf: classOop compactClassIndex: compactClassIndex
"Answer if oop is an instance of the given class. If the class has a (non-zero)
compactClassIndex use that to speed up the check. N.B. Inlining should
+ result in classOop not being accessed if oop's compact class index and
+ compactClassIndex are non-zero."
- result in classOop not being accessed if compactClassIndex is non-zero."
- | ccIndex |
<inline: true>
(self isIntegerObject: oop) ifTrue:
[^false].
+ ^self isClassOfNonImm: oop equalTo: classOop compactClassIndex: compactClassIndex!
- ccIndex := self compactClassIndexOf: oop.
- compactClassIndex ~= 0 ifTrue:
- [^compactClassIndex == ccIndex].
-
- ^ccIndex = 0
- and: [((self classHeader: oop) bitAnd: AllButTypeMask) = classOop]!
Item was changed:
----- Method: ObjectMemory>>isClassOfNonImm:equalTo: (in category 'header access') -----
isClassOfNonImm: oop equalTo: classOop
"Answer if the given (non-immediate) object is an instance of the given class."
| ccIndex cl |
<inline: true>
<asmLabel: false>
(self isIntegerObject: oop) ifTrue:
[^false].
cl := (ccIndex := self compactClassIndexOf: oop) = 0
ifTrue: [(self classHeader: oop) bitAnd: AllButTypeMask]
+ ifFalse: [self compactClassAt: ccIndex].
- ifFalse: "look up compact class"
- [self fetchPointer: ccIndex - 1
- ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop)].
-
^cl = classOop!
Item was changed:
----- Method: ObjectMemory>>isClassOfNonImm:equalTo:compactClassIndex: (in category 'header access') -----
isClassOfNonImm: oop equalTo: classOop compactClassIndex: compactClassIndex
"Answer if the given (non-immediate) object is an instance of the given class
that may have a compactClassIndex (if compactClassIndex is non-zero).
N.B. Inlining and/or compiler optimization should result in classOop not being
+ accessed if oop's compact class index and compactClassIndex are non-zero.
+ N.B. Generally one cannot assume that if compactClassIndex is non-zero the
+ instances of the corresponding class always have the compactClassIndex
+ because the compact class index is only non-zero in short header instances."
- accessed if compactClassIndex is non-zero."
| ccIndex |
<inline: true>
<asmLabel: false>
self assert: (self isIntegerObject: oop) not.
ccIndex := self compactClassIndexOf: oop.
+ ccIndex = 0 ifTrue:
+ [^((self classHeader: oop) bitAnd: AllButTypeMask) = classOop].
+ compactClassIndex ~= 0 ifTrue:
+ [^compactClassIndex = ccIndex].
+ ^classOop = (self compactClassAt: ccIndex)!
- ^compactClassIndex = 0
- ifTrue:
- [ccIndex = 0
- ifTrue: [((self classHeader: oop) bitAnd: AllButTypeMask) = classOop]
- ifFalse: [false]]
- ifFalse:
- [compactClassIndex == ccIndex]!
Item was changed:
----- Method: ObjectMemory>>splObj: (in category 'interpreter access') -----
splObj: index
<api>
+ <inline: true>
"Return one of the objects in the SpecialObjectsArray"
^self fetchPointer: index ofObject: specialObjectsOop!
Item was changed:
----- Method: StackInterpreter>>allAccessibleObjectsOkay (in category 'debug support') -----
allAccessibleObjectsOkay
"Ensure that all accessible objects in the heap are okay."
+ | ok oop |
+ ok := true.
-
- | oop |
oop := objectMemory firstAccessibleObject.
+ [oop = nil] whileFalse:
+ [ok := ok & (self okayFields: oop).
+ oop := objectMemory accessibleObjectAfter: oop].
+ ^ok!
- [oop = nil] whileFalse: [
- self okayFields: oop.
- oop := objectMemory accessibleObjectAfter: oop.
- ].!
Item was changed:
----- Method: StackInterpreter>>bytecodePrimValue (in category 'common selector sends') -----
bytecodePrimValue
| rcvr isBlock |
rcvr := self internalStackTop.
argumentCount := 0.
+ isBlock := self isInstanceOfClassBlockClosure: rcvr.
- isBlock := objectMemory
- is: rcvr
- instanceOf: (objectMemory splObj: ClassBlockClosure)
- compactClassIndex: ClassBlockClosureCompactIndex.
isBlock ifTrue:
[self externalizeIPandSP.
self initPrimCall.
self primitiveClosureValue.
self internalizeIPandSP.
self successful ifTrue:
[^self fetchNextBytecode].
primFailCode := 0].
messageSelector := self specialSelector: 25.
self normalSend!
Item was changed:
----- Method: StackInterpreter>>bytecodePrimValueWithArg (in category 'common selector sends') -----
bytecodePrimValueWithArg
| rcvr isBlock |
rcvr := self internalStackValue: 1.
argumentCount := 1.
+ isBlock := self isInstanceOfClassBlockClosure: rcvr.
- isBlock := objectMemory
- is: rcvr
- instanceOf: (objectMemory splObj: ClassBlockClosure)
- compactClassIndex: ClassBlockClosureCompactIndex.
isBlock ifTrue:
[self externalizeIPandSP.
self initPrimCall.
self primitiveClosureValue.
self internalizeIPandSP.
self successful ifTrue:
[^self fetchNextBytecode].
primFailCode := 0].
messageSelector := self specialSelector: 26.
self normalSend!
Item was changed:
----- Method: StackInterpreter>>findClassOfMethod:forReceiver: (in category 'debug support') -----
findClassOfMethod: meth forReceiver: rcvr
| rclass currClass classDict classDictSize methodArray i |
+ (objectMemory addressCouldBeObj: meth) ifFalse:
- (self addressCouldBeObj: meth) ifFalse:
[^objectMemory nilObject].
+ (objectMemory addressCouldBeOop: rcvr)
- (self addressCouldBeOop: rcvr)
ifTrue: [rclass := objectMemory fetchClassOf: rcvr]
ifFalse: [rclass := self methodClassOf: meth].
currClass := rclass.
[classDict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: currClass.
classDictSize := objectMemory fetchWordLengthOf: classDict.
methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
i := 0.
[i < (classDictSize - SelectorStart)] whileTrue:
[meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue:
[^currClass].
i := i + 1].
currClass := self superclassOf: currClass.
currClass = objectMemory nilObject] whileFalse.
^rclass "method not found in superclass chain"!
Item was changed:
----- Method: StackInterpreter>>findSelectorOfMethod:forReceiver: (in category 'debug support') -----
findSelectorOfMethod: meth forReceiver: rcvr
| currClass classDict classDictSize methodArray i |
+ (objectMemory addressCouldBeObj: meth) ifFalse:
- (self addressCouldBeObj: meth) ifFalse:
[^objectMemory nilObject].
+ (objectMemory addressCouldBeOop: rcvr)
- (self addressCouldBeOop: rcvr)
ifTrue: [currClass := objectMemory fetchClassOf: rcvr]
ifFalse: [currClass := self methodClassOf: meth].
[classDict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: currClass.
classDictSize := objectMemory fetchWordLengthOf: classDict.
methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
i := 0.
[i <= (classDictSize - SelectorStart)] whileTrue:
[meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue:
[^(objectMemory fetchPointer: i + SelectorStart ofObject: classDict)].
i := i + 1].
currClass := self superclassOf: currClass.
currClass = objectMemory nilObject] whileFalse.
^currClass "method not found in superclass chain"!
Item was changed:
----- Method: StackInterpreter>>floatValueOf: (in category 'utilities') -----
floatValueOf: oop
+ "Answer the C double precision floating point value of the argument,
+ or fail if it is not a Float, and answer 0.
+ Note: May be called by translated primitive code."
- "Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
- "Note: May be called by translated primitive code."
| isFloat result |
<returnTypeC: #double>
<var: #result type: #double>
+ isFloat := self isInstanceOfClassFloat: oop.
- "N.B. Because Slang always inlines is:instanceOf:compactClassIndex:
- (because is:instanceOf:compactClassIndex: has an inline: pragma) the
- phrase (self splObj: ClassArray) is expanded in-place and is _not_ evaluated if
- ClassArrayCompactIndex is non-zero."
- isFloat := objectMemory
- is: oop
- instanceOf: (objectMemory splObj: ClassFloat)
- compactClassIndex: ClassFloatCompactIndex.
isFloat ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
objectMemory fetchFloatAt: oop + BaseHeaderSize into: result.
^result].
self primitiveFail.
^0.0!
Item was removed:
- ----- Method: StackInterpreter>>isInstanceOfClassArray: (in category 'primitive support') -----
- isInstanceOfClassArray: oop
- <inline: true>
- ^objectMemory
- is: oop
- instanceOf: (objectMemory splObj: ClassArray)
- compactClassIndex: ClassArrayCompactIndex!
Item was removed:
- ----- Method: StackInterpreter>>isInstanceOfClassByteString: (in category 'primitive support') -----
- isInstanceOfClassByteString: oop
- <inline: true>
- ^objectMemory
- is: oop
- instanceOf: (objectMemory splObj: ClassString)
- compactClassIndex: ClassByteStringCompactIndex!
Item was removed:
- ----- Method: StackInterpreter>>isInstanceOfClassCharacter: (in category 'primitive support') -----
- isInstanceOfClassCharacter: oop
- <inline: true>
- ^objectMemory
- is: oop
- instanceOf: (objectMemory splObj: ClassCharacter)
- compactClassIndex: 0!
Item was removed:
- ----- Method: StackInterpreter>>isInstanceOfClassFloat: (in category 'primitive support') -----
- isInstanceOfClassFloat: oop
- <inline: true>
- ^objectMemory
- is: oop
- instanceOf: (objectMemory splObj: ClassFloat)
- compactClassIndex: ClassFloatCompactIndex!
Item was changed:
----- Method: StackInterpreter>>isLiveContext: (in category 'frame access') -----
isLiveContext: oop
"Answer if the argument, which can be any object, is a live context."
(self isContext: oop) ifFalse:
[^false].
(self isSingleContext: oop) ifTrue:
+ [^objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: oop)].
- [^self isIntegerObject: (self fetchPointer: InstructionPointerIndex ofObject: oop)].
^(self isWidowedContext: oop) not!
Item was changed:
----- Method: StackInterpreter>>loadInitialContext (in category 'initialization') -----
loadInitialContext
+ <inline: false>
| activeProc activeContext |
self cCode: [] inSmalltalk: [self initExtensions].
objectMemory leakCheckFullGC ifTrue:
[objectMemory clearLeakMapAndMapAccessibleObjects.
self assert: objectMemory checkHeapIntegrity].
activeProc := self activeProcess.
activeContext := objectMemory fetchPointer: SuspendedContextIndex ofObject: activeProc.
self marryContextInNewStackPageAndInitializeInterpreterRegisters: activeContext!
Item was changed:
----- Method: StackInterpreter>>longPrintOop: (in category 'debug printing') -----
longPrintOop: oop
<api>
| fmt lastIndex startIP bytecodesPerLine column |
((objectMemory isIntegerObject: oop)
or: [(oop between: objectMemory startOfMemory and: objectMemory freeStart) not
or: [(oop bitAnd: (BytesPerWord - 1)) ~= 0
+ or: [(objectMemory isFreeObject: oop)]]]) ifTrue:
- or: [(objectMemory isFreeObject: oop)
- or: [(fmt := objectMemory formatOf: oop) between: 5 and: 11]]]]) ifTrue:
[^self printOop: oop].
self printHex: oop;
print: ': a(n) ';
printNameOfClass: (objectMemory fetchClassOfNonInt: oop) count: 5.
+ fmt := objectMemory formatOf: oop.
fmt > 4 ifTrue:
[self print: ' nbytes '; printNum: (objectMemory byteSizeOf: oop)].
+ objectMemory printHeaderTypeOf: oop.
self cr.
+ (fmt between: 5 and: 11) ifTrue:
+ [^self].
lastIndex := 256 min: (startIP := (objectMemory lastPointerOf: oop) / BytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:i| | fieldOop |
fieldOop := objectMemory fetchPointer: i - 1 ofObject: oop.
self space; printNum: i - 1; space; printHex: fieldOop; space.
(i = 1 and: [objectMemory isCompiledMethod: oop])
ifTrue: [self printMethodHeaderOop: fieldOop]
ifFalse: [self printOopShort: fieldOop].
self cr]].
(objectMemory isCompiledMethod: oop)
ifFalse:
[startIP > 64 ifTrue: [self print: '...'; cr]]
ifTrue:
[startIP := startIP * BytesPerWord + 1.
lastIndex := objectMemory lengthOf: oop.
lastIndex - startIP > 100 ifTrue:
[lastIndex := startIP + 100].
bytecodesPerLine := 8.
column := 1.
startIP to: lastIndex do:
[:index| | byte |
column = 1 ifTrue:
[self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)'
inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']].
byte := objectMemory fetchByte: index - 1 ofObject: oop.
self cCode: 'printf(" %02x/%-3d", byte,byte)'
inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
column := column + 1.
column > bytecodesPerLine ifTrue:
[column := 1. self cr]].
column = 1 ifFalse:
[self cr]]!
Item was changed:
----- Method: StackInterpreter>>mapInterpreterOops (in category 'object memory support') -----
mapInterpreterOops
"Map all oops in the interpreter's state to their new values
during garbage collection or a become: operation."
"Assume: All traced variables contain valid oops."
| oop |
objectMemory nilObject: (objectMemory remap: objectMemory nilObject).
objectMemory falseObject: (objectMemory remap: objectMemory falseObject).
objectMemory trueObject: (objectMemory remap: objectMemory trueObject).
objectMemory specialObjectsOop: (objectMemory remap: objectMemory specialObjectsOop).
self mapStackPages.
self mapMachineCode.
self mapTraceLogs.
self mapVMRegisters.
self mapProfileState.
+ tempOop = 0 ifFalse: [tempOop := objectMemory remap: tempOop].
- tempOop = 0 ifFalse: [tempOop := self remap: tempOop].
1 to: objectMemory remapBufferCount do: [:i |
oop := objectMemory remapBuffer at: i.
(objectMemory isIntegerObject: oop)
ifFalse: [objectMemory remapBuffer at: i put: (objectMemory remap: oop)]].
"Callback support - trace suspended callback list"
1 to: jmpDepth do:[:i|
oop := suspendedCallbacks at: i.
(objectMemory isIntegerObject: oop)
ifFalse:[suspendedCallbacks at: i put: (objectMemory remap: oop)].
oop := suspendedMethods at: i.
(objectMemory isIntegerObject: oop)
ifFalse:[suspendedMethods at: i put: (objectMemory remap: oop)].
].
!
Item was changed:
----- Method: StackInterpreter>>markAndTraceInterpreterOops: (in category 'object memory support') -----
markAndTraceInterpreterOops: fullGCFlag
"Mark and trace all oops in the interpreter's state."
"Assume: All traced variables contain valid oops."
| oop |
"Must mark stack pages first to initialize the per-page trace
flags for full garbage collect before any subsequent tracing."
self markAndTraceStackPages: fullGCFlag.
self markAndTraceTraceLog.
self markAndTracePrimTraceLog.
objectMemory markAndTrace: objectMemory specialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes"
(objectMemory isIntegerObject: messageSelector) ifFalse:
[objectMemory markAndTrace: messageSelector].
(objectMemory isIntegerObject: newMethod) ifFalse:
[objectMemory markAndTrace: newMethod.
objectMemory markAndTrace: lkupClass].
self traceProfileState.
+ tempOop = 0 ifFalse: [objectMemory markAndTrace: tempOop].
- tempOop = 0 ifFalse: [self markAndTrace: tempOop].
1 to: objectMemory remapBufferCount do: [:i |
oop := objectMemory remapBuffer at: i.
(objectMemory isIntegerObject: oop) ifFalse: [objectMemory markAndTrace: oop]].
"Callback support - trace suspended callback list"
1 to: jmpDepth do:[:i|
oop := suspendedCallbacks at: i.
(objectMemory isIntegerObject: oop) ifFalse:[objectMemory markAndTrace: oop].
oop := suspendedMethods at: i.
(objectMemory isIntegerObject: oop) ifFalse:[objectMemory markAndTrace: oop].
]!
Item was changed:
----- Method: StackInterpreter>>printStringOf: (in category 'debug printing') -----
printStringOf: oop
| fmt len cnt max i |
<inline: false>
(objectMemory isIntegerObject: oop) ifTrue:
[^nil].
(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
[^nil].
(oop bitAnd: (BytesPerOop - 1)) ~= 0 ifTrue:
[^nil].
fmt := objectMemory formatOf: oop.
fmt < 8 ifTrue: [^nil].
cnt := (max := 128) min: (len := objectMemory lengthOf: oop).
i := 0.
((objectMemory is: oop
instanceOf: (objectMemory splObj: ClassByteArray)
compactClassIndex: classByteArrayCompactIndex)
+ or: [(self isInstanceOfClassLargePositiveInteger: oop)
+ or: [(self isInstanceOfClassLargeNegativeInteger: oop)]])
- or: [(objectMemory is: oop
- instanceOf: (objectMemory splObj: ClassLargePositiveInteger)
- compactClassIndex: ClassLargePositiveIntegerCompactIndex)
- or: [(objectMemory is: oop
- instanceOf: (objectMemory splObj: ClassLargeNegativeInteger)
- compactClassIndex: ClassLargeNegativeIntegerCompactIndex)]])
ifTrue:
[[i < cnt] whileTrue:
[self printHex: (objectMemory fetchByte: i ofObject: oop).
i := i + 1]]
ifFalse:
[[i < cnt] whileTrue:
[self printChar: (objectMemory fetchByte: i ofObject: oop).
i := i + 1]].
len > max ifTrue:
[self print: '...'].
self flush!
Item was changed:
----- Method: StackInterpreter>>signed64BitIntegerFor: (in category 'primitive support') -----
signed64BitIntegerFor: integerValue
"Return a Large Integer object for the given integer value"
| newLargeInteger magnitude largeClass intValue highWord sz |
<inline: false>
+ <var: 'integerValue' type: #sqLong>
+ <var: 'magnitude' type: #sqLong>
+ <var: 'highWord' type: #usqInt>
- <var: 'integerValue' type: 'sqLong'>
- <var: 'magnitude' type: 'sqLong'>
- <var: 'highWord' type: 'usqInt'>
integerValue < 0
ifTrue:[ largeClass := objectMemory classLargeNegativeInteger.
magnitude := 0 - integerValue]
ifFalse:[ largeClass := objectMemory classLargePositiveInteger.
magnitude := integerValue].
"Make sure to handle the most -ve value correctly. 0 - most -ve = most -ve and most -ve - 1
is +ve. Alas the simple (negative or: [integerValue - 1 < 0]) fails with contemporary gcc and icc
versions with optimization and sometimes without. The shift works on all, touch wood."
(magnitude <= 16r7FFFFFFF
and: [integerValue >= 0
or: [0 ~= (self cCode: [integerValue << 1]
inSmalltalk: [integerValue << 1 bitAnd: (1 << 64) - 1])]]) ifTrue:
[^self signed32BitIntegerFor: integerValue].
+ highWord := magnitude >> 32.
- highWord := self cCode: 'magnitude >> 32' inSmalltalk: [magnitude >> 32]. "shift is coerced to usqInt otherwise"
highWord = 0
ifTrue:[sz := 4]
+ ifFalse:
+ [sz := 5.
- ifFalse:[
- sz := 5.
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
+ (highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1]].
- (highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
- ].
newLargeInteger := objectMemory instantiateClass: largeClass indexableSize: sz.
0 to: sz-1 do: [:i |
+ intValue := (magnitude >> (i * 8)) bitAnd: 255.
- intValue := self cCode: '(magnitude >> (i * 8)) & 255' inSmalltalk: [(magnitude >> (i * 8)) bitAnd: 255].
objectMemory storeByte: i ofObject: newLargeInteger withValue: intValue].
+ ^newLargeInteger!
- ^ newLargeInteger!
Item was changed:
----- Method: StackInterpreter>>validInstructionPointer:inMethod:framePointer: (in category 'debug support') -----
validInstructionPointer: theInstrPointer inMethod: aMethod framePointer: fp
<var: #theInstrPointer type: #usqInt>
<var: #aMethod type: #usqInt>
^self
cppIf: MULTIPLEBYTECODESETS
ifTrue:
[| methodHeader |
methodHeader := self noAssertHeaderOf: aMethod. "-1 for pre-increment in fetchNextBytecode"
+ theInstrPointer >= (aMethod + (objectMemory lastPointerOf: aMethod) + BaseHeaderSize - 1)
+ and: [theInstrPointer < (aMethod + (objectMemory byteLengthOf: aMethod) + BaseHeaderSize - 1)
- theInstrPointer >= (aMethod + (self lastPointerOf: aMethod) + BaseHeaderSize - 1)
- and: [theInstrPointer < (aMethod + (self byteLengthOf: aMethod) + BaseHeaderSize - 1)
and: ["If the method starts with a CallPrimitive opcode the instruction pointer should be past it."
((self headerIndicatesAlternateBytecodeSet: methodHeader)
+ and: [(self alternateHeaderHasPrimitiveFlag: methodHeader)
- and: [(self methodHeaderHasPrimitive: methodHeader)
and: [theInstrPointer < (aMethod
+ BaseHeaderSize - 1
+ + (objectMemory lastPointerOf: aMethod)
- + (self lastPointerOf: aMethod)
+ (self sizeOfCallPrimitiveBytecode: methodHeader) - 1)]])
not]]]
ifFalse: "-1 for pre-increment in fetchNextBytecode"
[theInstrPointer >= (aMethod + (objectMemory lastPointerOf: aMethod) + BaseHeaderSize - 1)
and: [theInstrPointer < (aMethod + (objectMemory byteLengthOf: aMethod) + BaseHeaderSize - 1)]]!
Item was removed:
- ----- Method: StackInterpreterSimulator>>allocate:headerSize:h1:h2:h3:doFill:format: (in category 'debugging traps') -----
- allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill format: format
- | newObj |
- newObj := super allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill format: format.
- "newObj = 22186072 ifTrue: [self halt]."
- "byteCount < 600000 ifTrue: [^ newObj]."
- "(self baseHeader: newObj) = 16r0FCC0600 ifTrue: [self halt]."
- ^newObj!
Item was removed:
- ----- Method: StackInterpreterSimulator>>eeAllocate:headerSize:h1:h2:h3:doFill:format: (in category 'debugging traps') -----
- eeAllocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill format: format
- | newObj |
- newObj := super eeAllocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill format: format.
- "newObj = 22163268 ifTrue: [self halt]."
- "byteCount < 600000 ifTrue: [^ newObj]."
- "(self baseHeader: newObj) = 16r0FCC0600 ifTrue: [self halt]."
- ^newObj!
Item was removed:
- ----- Method: StackInterpreterSimulator>>fullGC (in category 'debug support') -----
- fullGC
- transcript cr; show:'<Running full GC ...'.
- super fullGC.
- transcript show: ' done>'.!
Item was removed:
- ----- Method: StackInterpreterSimulator>>incrementalGC (in category 'debug support') -----
- incrementalGC
- transcript cr; nextPutAll: 'incrementalGC ('; print: byteCount; nextPut: $); flush.
- ^super incrementalGC!
Item was changed:
----- Method: StackInterpreterSimulator>>primitiveDoPrimitiveWithArgs (in category 'debugging traps') -----
primitiveDoPrimitiveWithArgs
+ NewspeakVM ifFalse: [self halt].
- self halt.
^super primitiveDoPrimitiveWithArgs!
Item was removed:
- ----- Method: StackInterpreterSimulator>>tenuringIncrementalGC (in category 'debug support') -----
- tenuringIncrementalGC
- transcript cr; nextPutAll: 'tenuringIncrementalGC ('; print: byteCount; nextPut: $); flush.
- ^super tenuringIncrementalGC!
Item was changed:
----- Method: StackInterpreterSimulator>>utilitiesMenu: (in category 'UI') -----
utilitiesMenu: aMenuMorph
aMenuMorph
add: 'toggle transcript' action: #toggleTranscript;
addLine;
add: 'print ext head frame' action: #printExternalHeadFrame;
add: 'print int head frame' action: #printHeadFrame;
add: 'short print ext frame & callers' action: [self shortPrintFrameAndCallers: framePointer];
add: 'short print int frame & callers' action: [self shortPrintFrameAndCallers: localFP];
add: 'long print ext frame & callers' action: [self printFrameAndCallers: framePointer SP: stackPointer];
add: 'long print int frame & callers' action: [self printFrameAndCallers: localFP SP: localSP];
add: 'print frame...' action: [(self promptHex: 'print frame') ifNotNil: [:fp| self printFrame: fp]];
add: 'print call stack' action: #printCallStack;
+ add: 'print call stack of...' action: [(self promptHex: 'context or process oop') ifNotNil: [:obj| self printCallStackOf: obj]];
add: 'print all stacks' action: #printAllStacks;
addLine;
add: 'print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self printOop: oop]];
add: 'long print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self longPrintOop: oop]];
addLine;
add: 'inspect object memory' target: objectMemory action: #inspect;
add: 'inspect cointerpreter' action: #inspect;
addLine;
add: 'set break count...' action: [|s| s := UIManager default request: 'break count (dec)'.
s notEmpty ifTrue: [breakCount := Integer readFrom: s readStream]];
add: 'set break selector...' action: [|s| s := UIManager default request: 'break selector'.
s notEmpty ifTrue: [self setBreakSelector: s]];
add: (printSends
ifTrue: ['no print sends']
ifFalse: ['print sends'])
action: [self ensureDebugAtEachStepBlock.
printSends := printSends not];
"currently printReturns does nothing"
"add: (printReturns
ifTrue: ['no print returns']
ifFalse: ['print returns'])
action: [self ensureDebugAtEachStepBlock.
printReturns := printReturns not];"
add: (printBytecodeAtEachStep
ifTrue: ['no print bytecode each bytecode']
ifFalse: ['print bytecode each bytecode'])
action: [self ensureDebugAtEachStepBlock.
printBytecodeAtEachStep := printBytecodeAtEachStep not];
add: (printFrameAtEachStep
ifTrue: ['no print frame each bytecode']
ifFalse: ['print frame each bytecode'])
action: [self ensureDebugAtEachStepBlock.
printFrameAtEachStep := printFrameAtEachStep not].
^aMenuMorph!
Item was changed:
----- Method: StackToRegisterMappingCogit class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCodeGen
aCodeGen
var: #methodAbortTrampolines
declareC: 'sqInt methodAbortTrampolines[4]';
var: #picAbortTrampolines
declareC: 'sqInt picAbortTrampolines[4]';
var: #picMissTrampolines
declareC: 'sqInt picMissTrampolines[4]';
var: 'ceEnter0ArgsPIC'
declareC: 'void (*ceEnter0ArgsPIC)(void)';
var: 'ceEnter1ArgsPIC'
declareC: 'void (*ceEnter1ArgsPIC)(void)';
var: 'ceEnter2ArgsPIC'
declareC: 'void (*ceEnter2ArgsPIC)(void)';
var: #ceEnterCogCodePopReceiverArg0Regs
declareC: 'void (*ceEnterCogCodePopReceiverArg0Regs)(void)';
var: #realCEEnterCogCodePopReceiverArg0Regs
declareC: 'void (*realCEEnterCogCodePopReceiverArg0Regs)(void)';
var: #ceEnterCogCodePopReceiverArg1Arg0Regs
declareC: 'void (*ceEnterCogCodePopReceiverArg1Arg0Regs)(void)';
var: #realCEEnterCogCodePopReceiverArg1Arg0Regs
declareC: 'void (*realCEEnterCogCodePopReceiverArg1Arg0Regs)(void)';
var: 'simStack'
declareC: 'CogSimStackEntry simStack[', ((CoInterpreter bindingOf: #LargeContextSize) value * 5 / 4 // BytesPerWord) asString, ']';
var: 'simSelf'
type: #CogSimStackEntry;
var: #optStatus
type: #CogSSOptStatus;
+ var: #isPushNilFunction
+ declareC: 'const sqInt (*isPushNilFunction)(struct _BytecodeDescriptor *,sqInt,sqInt,sqInt) = ', (aCodeGen cFunctionNameFor: self isPushNilFunction);
+ var: #pushNilSizeFunction
+ declareC: 'const sqInt (*pushNilSizeFunction)(sqInt) = ', (aCodeGen cFunctionNameFor: self pushNilSizeFunction).
- var: 'isPushNilFunction'
- declareC: 'sqInt (*isPushNilFunction)(struct _BytecodeDescriptor *,sqInt,sqInt,sqInt) = ', (aCodeGen cFunctionNameFor: isPushNilFunction);
- var: 'pushNilSizeFunction'
- declareC: 'sqInt (*pushNilSizeFunction)(sqInt) = ', (aCodeGen cFunctionNameFor: pushNilSizeFunction).
aCodeGen
addSelectorTranslation: #register to: (aCodeGen cFunctionNameFor: 'registerr');
addSelectorTranslation: #register: to: (aCodeGen cFunctionNameFor: 'registerr:')!
Item was changed:
----- Method: StackToRegisterMappingCogit class>>requiredMethodNames (in category 'translation') -----
requiredMethodNames
"self requiredMethodNames"
^super requiredMethodNames
+ add: self isPushNilFunction;
+ add: self pushNilSizeFunction;
- add: isPushNilFunction;
- add: pushNilSizeFunction;
yourself!
More information about the Vm-dev
mailing list