[Vm-dev] VM Maker: VMMaker-oscog-EstebanLorenzano.231.mcz
commits at source.squeak.org
commits at source.squeak.org
Wed Feb 13 15:03:34 UTC 2013
Esteban Lorenzano uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker-oscog-EstebanLorenzano.231.mcz
==================== Summary ====================
Name: VMMaker-oscog-EstebanLorenzano.231
Author: EstebanLorenzano
Time: 13 February 2013, 3:59:35.838 pm
UUID: a9e39f38-e1fa-4851-a3a3-1a0f1f7a4062
Ancestors: VMMaker-oscog-EstebanLorenzano.230, VMMaker.oscog-eem.264
- merged with Eliot's 264
- added <api> to isIntegerValue: and firstFixedField: to ensure is exported (then supress warnings)
=============== Diff against VMMaker-oscog-EstebanLorenzano.230 ===============
Item was changed:
----- Method: CCodeGenerator>>emitCAPIExportHeaderOn: (in category 'C code generator') -----
+ emitCAPIExportHeaderOn: aStream
- emitCAPIExportHeaderOn: aStream
"Store prototype declarations for all non-inlined methods on the given stream."
| api methodList |
api := vmClass translationClass exportAPISelectors.
methodList := api select: [:s| (methods includesKey: s) or: [(vmClass whichClassIncludesSelector: s) notNil]]
thenCollect:
[:s|
methods
at: s
ifAbsent: [self compileToTMethodSelector: s
in: (vmClass whichClassIncludesSelector: s)]].
methodList := self sortMethods: methodList.
methodList do:
[:m|
m static ifTrue:
+ [logger ensureCr; show: m selector, ' excluded from export API because it is static'; cr]
+ ifFalse: [ m forceExport ]
+ ].
- [logger ensureCr; show: m selector, ' excluded from export API because it is static'; cr]].
self emitCFunctionPrototypes: methodList on: aStream.
self emitGlobalCVariablesOn: aStream.
self emitCMacros: methodList on: aStream!
Item was changed:
----- Method: CCodeGenerator>>emitGlobalCVariablesOn: (in category 'C code generator') -----
emitGlobalCVariablesOn: aStream
"Store the global variable declarations on the given stream."
aStream cr; nextPutAll: '/*** Global Variables ***/'; cr.
+
(self sortStrings: (variables select: [:v| vmClass mustBeGlobal: v])) do:
[:var | | varString decl |
varString := var asString.
decl := variableDeclarations at: varString ifAbsent: ['sqInt ' , varString].
decl first == $# "support cgen var: #bytecodeSetSelector declareC: '#define bytecodeSetSelector 0' hack"
ifTrue:
[aStream nextPutAll: decl; cr]
ifFalse:
+ [
+ ((decl includesSubString: ' private ')
- [((decl includesSubString: ' private ')
or: [decl beginsWith: 'static']) ifFalse: "work-around hack to prevent localization of variables only referenced once."
+ [
+ aStream nextPutAll: 'VM_EXPORT '.
+
+ (decl includes: $=) ifTrue:
- [(decl includes: $=) ifTrue:
[decl := decl copyFrom: 1 to: (decl indexOf: $=) - 1].
aStream
nextPutAll: decl;
nextPut: $;;
cr]]].
aStream cr!
Item was changed:
----- Method: CCodeGeneratorTests>>testIntegerGeneration (in category 'tests') -----
testIntegerGeneration
"Test the 32-bit integers. They need to be marked as unsigned longs.
Test 16rFFFFFFFF, 16rFFFFFFFE, ... through to ..., 16rC0000000, 16r80000000"
((0 to: 31) collect: [:shift| 16rFFFFFFFF bitClear: (1 bitShift: shift) - 1]) do:
[:number| | literal |
literal := self cg cLiteralFor: number.
self assert: ((literal allButLast: 2) allSatisfy: [:c| c isDigit]).
self assert: (literal endsWith: 'UL').
literal := self cg cLiteralFor: number name: 'Mask'.
self assert: (literal beginsWith: '0x').
self assert: (((literal allButFirst: 2) allButLast: 2) allSatisfy: [:c| '0123456789CEF' includes: c]).
self assert: (literal endsWith: 'UL')].
"Test the 64-bit integers. They need to be marked as unsigned long longs."
+ ((32 to: 63) collect: [:shift| 16rFFFFFFFFFFFFFFFF bitClear: (1 bitShift: shift) - 1]) do:
- ((32 to: 64) collect: [:shift| 16rFFFFFFFFFFFFFFFF bitClear: (1 bitShift: shift) - 1]) do:
[:number| | literal |
literal := self cg cLiteralFor: number.
self assert: ((literal allButLast: 3) allSatisfy: [:c| c isDigit]).
self assert: (literal endsWith: 'ULL').
literal := self cg cLiteralFor: number name: 'Mask'.
self assert: (literal beginsWith: '0x').
self assert: (((literal allButFirst: 2) allButLast: 3) allSatisfy: [:c| '0123456789CEF' includes: c]).
self assert: (literal endsWith: 'ULL')]!
Item was added:
+ ----- Method: CoInterpreter>>checkOkayFields: (in category 'debug support') -----
+ checkOkayFields: oop
+ "Check if the argument is an ok object.
+ If this is a pointers object, check that its fields are all okay oops."
+
+ | hasYoung i fieldOop |
+ (oop = nil or: [oop = 0]) ifTrue: [ ^true ]. "?? eem 1/16/2013"
+ (objectMemory isIntegerObject: oop) ifTrue: [ ^true ].
+ (objectMemory checkOkayOop: oop) ifFalse: [ ^false ].
+ (self checkOopHasOkayClass: oop) ifFalse: [ ^false ].
+ hasYoung := objectMemory isYoung: (objectMemory fetchClassOfNonInt: oop).
+ ((objectMemory isPointers: oop) or: [objectMemory isCompiledMethod: oop]) ifFalse: [ ^true ].
+ (objectMemory isCompiledMethod: oop)
+ ifTrue:
+ [i := (self literalCountOf: oop) - 1]
+ ifFalse:
+ [(self isContext: oop)
+ ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1]
+ ifFalse: [i := (objectMemory lengthOf: oop) - 1]].
+ [i >= 0] whileTrue:
+ [fieldOop := objectMemory fetchPointer: i ofObject: oop.
+ (objectMemory isNonIntegerObject: fieldOop) ifTrue:
+ [(i = 0 and: [objectMemory isCompiledMethod: oop])
+ ifTrue:
+ [(cogMethodZone methodFor: (self pointerForOop: fieldOop)) = 0 ifTrue:
+ [self print: 'method '; printHex: oop; print: ' has an invalid cog method reference'.
+ ^false]]
+ ifFalse:
+ [hasYoung := hasYoung or: [objectMemory isYoung: fieldOop].
+ (objectMemory checkOkayOop: fieldOop) ifFalse: [ ^false ].
+ (self checkOopHasOkayClass: fieldOop) ifFalse: [ ^false ]]].
+ i := i - 1].
+ hasYoung ifTrue:
+ [^objectMemory checkOkayYoungReferrer: oop].
+ ^true!
Item was changed:
----- Method: CoInterpreter>>initStackPagesAndInterpret (in category 'initialization') -----
initStackPagesAndInterpret
"Initialize the stack pages and enter interpret. Use alloca'ed memory so that when
we have a JIT its stack pointer will be on the native stack since alloca allocates
memory on the stack. Certain thread systems use the native stack pointer as the
frame ID so putting the stack anywhere else can confuse the thread system."
"Override to establish the setjmp/longjmp handler for reentering the interpreter
from machine code, and disable executablity on the heap and stack pages."
"This should be in its own initStackPages method but Slang can't inline
C code strings."
| stackPageBytes stackPagesBytes theStackMemory |
<var: #theStackMemory type: #'char *'>
stackPageBytes := self stackPageByteSize.
stackPagesBytes := self computeStackZoneSize.
theStackMemory := self
cCode: [self alloca: stackPagesBytes]
inSmalltalk:
[stackPages := self stackPagesClass new.
stackPages initializeWithByteSize: stackPagesBytes for: self].
+ self cCode: [self me: theStackMemory ms: 0 et: stackPagesBytes].
self sqMakeMemoryNotExecutableFrom: objectMemory startOfMemory asUnsignedInteger
To: objectMemory memoryLimit asUnsignedInteger.
self sqMakeMemoryNotExecutableFrom: theStackMemory asUnsignedInteger
To: theStackMemory asUnsignedInteger + stackPagesBytes.
stackPages
initializeStack: theStackMemory
numSlots: stackPagesBytes / BytesPerWord
+ pageSize: stackPageBytes / BytesPerWord.
+ self assert: self minimumUnusedHeadroom = stackPageBytes.
- pageSize: stackPageBytes / BytesPerWord
- stackLimitOffset: self stackLimitOffset
- stackPageHeadroom: self stackPageHeadroom.
"Once the stack pages are initialized we can continue to bootstrap the system."
self loadInitialContext.
"We're ready for the heartbeat (poll interrupt)"
self ioInitHeartbeat.
self initialEnterSmalltalkExecutive.
^nil!
Item was changed:
----- Method: CoInterpreter>>interpretMethodFromMachineCode (in category 'message sending') -----
interpretMethodFromMachineCode
"Execute a method interpretively from machine code. We assume (require) that newMethod
messageSelector, primitiveFunctionPointer and argumentCount have been set in the caller.
Once evaluated either continue in the interpreter via a jongjmp or in machine code via an
enilopmart (a form of longjmp - a stinking rose by any other name)."
<inline: false>
cogit assertCStackWellAligned.
self assert: (self validInstructionPointer: instructionPointer inFrame: framePointer).
primitiveFunctionPointer ~= 0
ifTrue:
[primitiveFunctionPointer = #primitiveInvokeObjectAsMethod
ifTrue: [self assert: (objectMemory isOopCompiledMethod: newMethod) not]
ifFalse: [self assert: ((objectMemory isOopCompiledMethod: newMethod)
and: [(self primitiveIndexOf: newMethod) ~= 0])].
"Invoke an interpreter primitive (because the method is to be interpreted or has not yet been
compiled). This is very similar to invoking an interpreter primitive from a compiled primitive
(see e.g. SimpleStackBasedCogit>>compileInterpreterPrimitive:). Cut back the stack pointer
(done above) to skip the return address and invoke the function. On return if it has succeeded
simply continue otherwise restore the stackPointer, collect the pc and interpret. Note that
frame building primitives such as primitiveClosureValue, primitiveEvaluateMethod et al will not
return but will instead jump into either machine code or longjmp back to the interpreter."
"Assign stackPage headFP so we can tell if the primitive built a frame. We can't simply save
the framePointer since e.g. assignment to contexts (via primitiveInstVarAt:put:) can change the
framePointer. But context assignments will change both the framePointer and stackPage headFP."
+
+ self assert: (framePointer < stackPage baseAddress
+ and: [framePointer > (stackPage realStackLimit - (LargeContextSize / 2))]).
stackPage headFP: framePointer.
self isPrimitiveFunctionPointerAnIndex
ifTrue:
[self externalQuickPrimitiveResponse.
primFailCode := 0]
ifFalse:
[self slowPrimitiveResponse].
self successful ifTrue:
[self return: self popStack toExecutive: false
"NOTREACHED"]]
ifFalse:
[self assert: ((objectMemory isOopCompiledMethod: newMethod)
and: [(self primitiveIndexOf: newMethod) = 0
or: [(self functionPointerFor: (self primitiveIndexOf: newMethod) inClass: objectMemory nilObject) = 0
or: [self isNullExternalPrimitiveCall: newMethod]]])].
"if not primitive, or primitive failed, activate the method and reenter the interpreter"
self activateNewMethod.
self siglong: reenterInterpreter jmp: ReturnToInterpreter.
"NOTREACHED"
^nil!
Item was removed:
- ----- Method: CoInterpreter>>interpreterAllocationReserveBytes (in category 'stack pages') -----
- interpreterAllocationReserveBytes
- "At a rough approximation we may need to allocate up to a couple
- of page's worth of contexts when switching stack pages, assigning
- to senders, etc. But the snapshot primitive voids all stack pages.
- So a safe margin is the size of a large context times the maximum
- number of frames per page times the number of pages."
- | availableBytesPerPage maxFramesPerPage |
- availableBytesPerPage := self stackPageByteSize - self stackLimitOffset - self stackPageHeadroom.
- maxFramesPerPage := availableBytesPerPage / BytesPerWord // MFrameSlots.
- ^2 raisedTo: (maxFramesPerPage * LargeContextSize * numStackPages) highBit!
Item was changed:
----- Method: CoInterpreter>>markAndTraceStackPage: (in category 'object memory support') -----
markAndTraceStackPage: thePage
| theSP theFP frameRcvrOffset callerFP oop |
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #frameRcvrOffset type: #'char *'>
<var: #callerFP type: #'char *'>
<inline: false>
self assert: (stackPages isFree: thePage) not.
theSP := thePage headSP.
theFP := thePage headFP.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
[theSP := theSP + BytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
[self assert: (self isContext: (self frameContext: theFP)).
objectMemory markAndTrace: (self frameContext: theFP)].
(self isMachineCodeFrame: theFP)
ifTrue: [self markAndTraceMachineCodeMethod: (self mframeCogMethod: theFP)]
ifFalse: [objectMemory markAndTrace: (self iframeMethod: theFP)].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
+ theSP := theFP + FoxCallerSavedIP + BytesPerWord. "caller ip is ceBaseReturnPC"
- theSP := self isCog
- ifTrue: [theFP + FoxCallerSavedIP + BytesPerWord] "caller ip is ceBaseReturnPC"
- ifFalse: [theFP + FoxCallerSavedIP]. "caller ip is frameCallerContext in a base frame"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
theSP := theSP + BytesPerWord]!
Item was added:
+ ----- Method: CoInterpreter>>minimumUnusedHeadroom (in category 'debug support') -----
+ minimumUnusedHeadroom
+ "Traverse all stack pages looking for non-zero bytes in the headroom part of each page.
+ Answer the minimum size of unused headroom (zero bytes) in the pages. This is for
+ checking that there is enough headroom allocated in stack pages."
+ | minUnused page |
+ <var: #page type: #'StackPage *'>
+ <var: #p type: #'char *'>
+ minUnused := (stackPages stackPageAt: 0) baseAddress - (stackPages stackPageAt: 0) lastAddress.
+ 0 to: numStackPages - 1 do:
+ [:i| | p unused |
+ page := stackPages stackPageAt: i.
+ p := page lastAddress.
+ [p := p + BytesPerWord.
+ (self longAtPointer: p) = 0
+ and: [p <= page baseAddress]] whileTrue.
+ unused := p - BytesPerWord - page lastAddress.
+ unused < minUnused ifTrue:
+ [minUnused := unused]].
+ ^minUnused!
Item was changed:
----- Method: CoInterpreter>>moveFramesIn:through:toPage: (in category 'frame access') -----
moveFramesIn: oldPage through: theFP toPage: newPage
"Move frames from the hot end of oldPage through to theFP to newPage.
This has the effect of making theFP a base frame which can be stored into.
Answer theFP's new location."
| newSP newFP stackedReceiverOffset delta callerFP callerIP fpInNewPage offsetCallerFP theContext |
<inline: false>
<var: #oldPage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #newPage type: #'StackPage *'>
<var: #newSP type: #'char *'>
<var: #newFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #fpInNewPage type: #'char *'>
<var: #offsetCallerFP type: #'char *'>
<var: #source type: #'char *'>
<returnTypeC: #'char *'>
"A base frame must have a context for cannotReturn: processing."
self assert: (self isBaseFrame: theFP) not.
self assert: self validStackPageBaseFrames.
callerFP := self frameCallerFP: theFP.
self assert: (self frameHasContext: callerFP).
self assert: (self isContext: (self frameContext: callerFP)).
theContext := self ensureFrameIsMarried: theFP
SP: theFP + ((self isMachineCodeFrame: theFP) ifTrue: [FoxMFReceiver] ifFalse: [FoxIFReceiver]).
stackPages
longAt: (newSP := newPage baseAddress) put: (self frameContext: callerFP);
longAt: (newSP := newSP - BytesPerWord) put: theContext.
stackedReceiverOffset := self frameStackedReceiverOffset: theFP.
"First move the data, leaving room for the caller and base frame contexts. We will fix up frame pointers later."
theFP + stackedReceiverOffset
to: oldPage headSP
by: BytesPerWord negated
do: [:source|
newSP := newSP - BytesPerWord.
stackPages longAt: newSP put: (stackPages longAt: source)].
"newSP = oldSP + delta => delta = newSP - oldSP"
delta := newSP - oldPage headSP.
newFP := newPage baseAddress - stackedReceiverOffset - (2 * BytesPerWord).
self setHeadFP: oldPage headFP + delta andSP: newSP inPage: newPage.
newPage baseFP: newFP.
callerIP := self oopForPointer: (self frameCallerSavedIP: theFP).
callerIP asUnsignedInteger >= objectMemory startOfMemory ifTrue:
[self iframeSavedIP: callerFP put: callerIP.
callerIP := cogit ceReturnToInterpreterPC].
stackPages longAt: theFP + stackedReceiverOffset put: callerIP.
+ self assert: (callerFP < oldPage baseAddress
+ and: [callerFP > (oldPage realStackLimit - (LargeContextSize / 2))]).
oldPage
headFP: callerFP;
headSP: theFP + stackedReceiverOffset.
"Mark the new base frame in the new page"
stackPages
longAt: newFP + FoxCallerSavedIP put: cogit ceBaseFrameReturnPC;
longAt: newFP + FoxSavedFP put: 0.
"Now relocate frame pointers, updating married contexts to refer to their moved spouse frames."
fpInNewPage := newPage headFP.
[offsetCallerFP := self frameCallerFP: fpInNewPage.
offsetCallerFP ~= 0 ifTrue:
[offsetCallerFP := offsetCallerFP + delta].
stackPages longAt: fpInNewPage + FoxSavedFP put: (self oopForPointer: offsetCallerFP).
(self frameHasContext: fpInNewPage) ifTrue:
[theContext := self frameContext: fpInNewPage.
objectMemory storePointerUnchecked: SenderIndex
ofObject: theContext
withValue: (self withSmallIntegerTags: fpInNewPage).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: theContext
withValue: (self withSmallIntegerTags: offsetCallerFP)].
fpInNewPage := offsetCallerFP.
fpInNewPage ~= 0] whileTrue.
self assert: self validStackPageBaseFrames.
^newFP!
Item was added:
+ ----- Method: CoInterpreter>>reportMinimumUnusedHeadroom (in category 'debug support') -----
+ reportMinimumUnusedHeadroom
+ "Report the stack page size and minimum unused headroom to stdout."
+ <api>
+ self cCode:
+ [self pri: 'stack page bytes %ld available headroom %ld minimum unused headroom %ld\n'
+ n: self stackPageByteSize
+ t: self stackPageByteSize - self stackLimitBytes - self stackLimitOffset
+ f: self minimumUnusedHeadroom]
+ inSmalltalk:
+ ["CogVMSimulator new initStackPagesForTests reportMinimumUnusedHeadroom"
+ self print: 'stack page bytes '; printNum: self stackPageByteSize;
+ print: ' available headroom '; printNum: self stackPageByteSize - self stackLimitBytes - self stackLimitOffset;
+ print: ' minimum unused headroom '; printNum: self minimumUnusedHeadroom;
+ cr]!
Item was changed:
----- Method: CoInterpreter>>stackPageHeadroom (in category 'stack pages') -----
stackPageHeadroom
"Return a minimum amount of headroom for each stack page (in bytes).
+ In the interpreter we don't actually need any headroom. In a JIT the stack
+ has to have room for interrupt handlers which will run on the stack.
+ Defer to the platform for this one."
+ <inline: true>
+ ^self osCogStackPageHeadroom!
- In a JIT the stack has to have room for interrupt handlers which will run on the
- stack. In the interpreter we don't actually need any headroom."
- ^cogit stackPageHeadroomBytes + 1024!
Item was changed:
----- Method: CoInterpreterMT>>checkForEventsMayContextSwitch: (in category 'process primitive support') -----
checkForEventsMayContextSwitch: mayContextSwitch
"Check for possible interrupts and handle one if necessary.
Answer if a context switch has occurred."
| switched sema now |
<inline: false>
<var: #now type: #usqLong>
self assertSaneThreadAndProcess.
cogit assertCStackWellAligned.
statCheckForEvents := statCheckForEvents + 1.
"restore the stackLimit if it has been smashed."
self restoreStackLimit.
self externalWriteBackHeadFramePointers.
self assert: stackPage = stackPages mostRecentlyUsedPage.
"Allow the platform to do anything it needs to do synchronously."
self ioSynchronousCheckForEvents.
self checkCogCompiledCodeCompactionCalledFor.
objectMemory needGCFlag ifTrue:
+ ["sufficientSpaceAfterGC: runs the incremental GC and
- [objectMemory needGCFlag: false.
- "sufficientSpaceAfterGC: runs the incremental GC and
then, if not enough space is available, the fullGC."
(objectMemory sufficientSpaceAfterGC: 0) ifFalse:
[self setSignalLowSpaceFlagAndSaveProcess]].
mayContextSwitch ifFalse: [^false].
switched := false.
self assert: deferThreadSwitch not.
deferThreadSwitch := true.
(profileProcess ~= objectMemory nilObject
or: [nextProfileTick > 0 and:[self ioHighResClock >= nextProfileTick]]) ifTrue:
["Take a sample (if not already done so) for the profiler if it is active. This
must be done before any of the synchronousSignals below or else we will
attribute a pause in ioRelinquishProcessor to the newly activated process."
profileProcess = objectMemory nilObject ifTrue:
[profileProcess := self activeProcess.
profileMethod := objectMemory nilObject].
"and signal the profiler semaphore if it is present"
(profileSemaphore ~= objectMemory nilObject
and: [self synchronousSignal: profileSemaphore]) ifTrue:
[switched := true].
nextProfileTick := 0].
self checkDeliveryOfLongRunningPrimitiveSignal ifTrue:
[switched := true].
objectMemory signalLowSpace ifTrue:
[objectMemory signalLowSpace: false. "reset flag"
sema := objectMemory splObj: TheLowSpaceSemaphore.
(sema ~= objectMemory nilObject
and: [self synchronousSignal: sema]) ifTrue:
[switched := true]].
"inIOProcessEvents prevents reentrancy into ioProcessEvents and allows disabling
ioProcessEvents e.g. for native GUIs. We would like to manage that here but can't
since the platform code may choose to call ioProcessEvents itself in various places."
false
ifTrue:
[((now := self ioUTCMicroseconds) >= nextPollUsecs
and: [inIOProcessEvents = 0]) ifTrue:
[statIOProcessEvents := statIOProcessEvents + 1.
inIOProcessEvents := inIOProcessEvents + 1.
self ioProcessEvents. "sets interruptPending if interrupt key pressed; may callback"
inIOProcessEvents > 0 ifTrue:
[inIOProcessEvents := inIOProcessEvents - 1].
nextPollUsecs := now + 20000
"msecs to wait before next call to ioProcessEvents. Note that strictly
speaking we might need to update 'now' at this point since
ioProcessEvents could take a very long time on some platforms"]]
ifFalse:
[(now := self ioUTCMicroseconds) >= nextPollUsecs ifTrue:
[statIOProcessEvents := statIOProcessEvents + 1.
self ioProcessEvents. "sets interruptPending if interrupt key pressed; may callback"
nextPollUsecs := now + 20000
"msecs to wait before next call to ioProcessEvents. Note that strictly
speaking we might need to update 'now' at this point since
ioProcessEvents could take a very long time on some platforms"]].
interruptPending ifTrue:
[interruptPending := false.
"reset interrupt flag"
sema := objectMemory splObj: TheInterruptSemaphore.
(sema ~= objectMemory nilObject
and: [self synchronousSignal: sema]) ifTrue:
[switched := true]].
nextWakeupUsecs ~= 0 ifTrue:
[now >= nextWakeupUsecs ifTrue:
[nextWakeupUsecs := 0.
"set timer interrupt to 0 for 'no timer'"
sema := objectMemory splObj: TheTimerSemaphore.
(sema ~= objectMemory nilObject
and: [self synchronousSignal: sema]) ifTrue:
[switched := true]]].
"signal any pending finalizations"
pendingFinalizationSignals > 0 ifTrue:
[sema := objectMemory splObj: TheFinalizationSemaphore.
((objectMemory isClassOfNonImm: sema equalTo: (objectMemory splObj: ClassSemaphore))
and: [self synchronousSignal: sema]) ifTrue:
[switched := true].
pendingFinalizationSignals := 0].
"signal all semaphores in semaphoresToSignal"
self signalExternalSemaphores ifTrue:
[switched := true].
deferThreadSwitch := false.
checkThreadActivation ifTrue:
[checkThreadActivation := false.
self cedeToHigherPriorityThreads]. "N.B. This may not return if we do switch."
self threadSwitchIfNecessary: self activeProcess from: CSCheckEvents.
^switched!
Item was added:
+ ----- Method: CoInterpreterPrimitives>>primitiveMinimumUnusedHeadroom (in category 'other primitives') -----
+ primitiveMinimumUnusedHeadroom
+ <export: true>
+ self methodReturnValue: (self integerObjectOf: self minimumUnusedHeadroom)!
Item was changed:
----- Method: CoInterpreterPrimitives>>primitiveSnapshot (in category 'system control primitives') -----
primitiveSnapshot
"Save a normal snapshot under the same name as it was loaded
unless it has been renamed by the last primitiveImageName.
Override to jump to the interpreter because the machine code zone is now void."
<inline: false>
self snapshot: false.
+ (self iframeMethod: framePointer) = newMethod ifTrue:
+ ["snapshot: has reached the end and built a frame.
+ In the JIT we need to back-up the pc before reentering the interpreter."
+ instructionPointer := instructionPointer - 1].
self siglong: reenterInterpreter jmp: ReturnToInterpreter
"NOTREACHED"!
Item was changed:
----- Method: CoInterpreterPrimitives>>primitiveSnapshotEmbedded (in category 'system control primitives') -----
primitiveSnapshotEmbedded
"Save an embedded snapshot.
Override to jump to the interpreter because the machine code zone is now void."
<inline: false>
self snapshot: true.
+ (self iframeMethod: framePointer) = newMethod ifTrue:
+ ["snapshot: has reached the end and built a frame.
+ In the JIT we need to back-up the pc before reentering the interpreter."
+ instructionPointer := instructionPointer - 1].
self siglong: reenterInterpreter jmp: ReturnToInterpreter
"NOTREACHED"!
Item was added:
+ ----- Method: CoInterpreterStackPages>>initializeStack:numSlots:pageSize: (in category 'initialization') -----
+ initializeStack: theStackPages numSlots: stackSlots pageSize: slotsPerPage
+ "Initialize the stack pages. In the C VM theStackPages will be alloca'ed memory to hold the
+ stack pages on the C stack. In the simulator they are housed in the memory between the
+ cogMethodZone and the heap."
+
+ <var: #theStackPages type: #'char *'>
+ <returnTypeC: #void>
+ | numPages page structStackPageSize pageStructBase count |
+ <var: #page type: #'StackPage *'>
+ <var: #pageStructBase type: #'char *'>
+ self cCode: []
+ inSmalltalk:
+ [self assert: objectMemory startOfMemory - coInterpreter cogCodeSize - coInterpreter methodCacheSize - coInterpreter primTraceLogSize - coInterpreter rumpCStackSize
+ = (stackSlots * BytesPerWord)].
+ structStackPageSize := coInterpreter sizeof: CogStackPage.
+ bytesPerPage := slotsPerPage * BytesPerWord.
+ numPages := coInterpreter numStkPages.
+
+ "Because stack pages grow down baseAddress is at the top of a stack page and so to avoid
+ subtracting BytesPerWord from baseAddress and lastAddress in the init loop below we simply
+ push the stackPage array up one word to avoid the overlap. This word is extraStackBytes."
+ pageStructBase := theStackPages + (numPages * bytesPerPage) + BytesPerWord.
+ pages := self cCode: [self cCoerceSimple: pageStructBase to: #'StackPage *']
+ inSmalltalk:
+ [pageMap := Dictionary new.
+ ((0 to: numPages - 1) collect:
+ [:i|
+ CogStackPage surrogateClass new
+ address: pageStructBase + (i * structStackPageSize)
+ simulator: coInterpreter
+ zoneBase: coInterpreter stackZoneBase
+ zoneLimit: objectMemory startOfMemory])
+ do: [:pageSurrogate|
+ pageMap at: pageSurrogate address put: pageSurrogate];
+ yourself].
+ "make sure there's enough headroom"
+ self assert: coInterpreter stackPageByteSize - coInterpreter stackLimitBytes - coInterpreter stackLimitOffset
+ >= coInterpreter stackPageHeadroom.
+ 0 to: numPages - 1 do:
+ [:index|
+ page := self stackPageAt: index.
+ page
+ lastAddress: theStackPages + (index * bytesPerPage);
+ baseAddress: page lastAddress + bytesPerPage;
+ stackLimit: page baseAddress - coInterpreter stackLimitBytes;
+ realStackLimit: page stackLimit;
+ baseFP: 0;
+ nextPage: (self stackPageAt: (index = (numPages - 1) ifTrue: [0] ifFalse: [index + 1]));
+ prevPage: (self stackPageAt: (index = 0 ifTrue: [numPages - 1] ifFalse: [index - 1]))].
+
+ "Now compute stackBasePlus1 so that the pageIndexFor: call maps all addresses from
+ aPage baseAddress to aBase limitAddress + 1 to the same index (stacks grow down)"
+ stackBasePlus1 := (self cCoerceSimple: theStackPages to: #'char *') + 1.
+ self cCode: []
+ inSmalltalk:
+ [minStackAddress := theStackPages.
+ maxStackAddress := theStackPages + (numPages * bytesPerPage) + BytesPerWord - 1].
+
+ "The overflow limit is the amount of stack to retain when moving frames from an overflowing
+ stack to reduce thrashing. See stackOverflowOrEvent:mayContextSwitch:"
+ page := self stackPageAt: 0.
+ overflowLimit := page baseAddress - page realStackLimit * 3 // 5.
+ 0 to: numPages - 1 do:
+ [:index|
+ page := self stackPageAt: index.
+ self assert: (self pageIndexFor: page baseAddress) == index.
+ self assert: (self pageIndexFor: page baseAddress - (slotsPerPage - 1 * BytesPerWord)) == index.
+ self assert: (self stackPageFor: page baseAddress) == page.
+ self assert: (self stackPageFor: page stackLimit) == page.
+ self cCode: []
+ inSmalltalk:
+ [| memIndex |
+ memIndex := index * slotsPerPage + 1. "this is memIndex in the block above"
+ self assert: (self memIndexFor: (self oopForPointer: page baseAddress))
+ == (memIndex + slotsPerPage - 1).
+ index < (numPages - 1) ifTrue:
+ [self assert: (self stackPageFor: page baseAddress + BytesPerWord) == (self stackPageAt: index + 1)]].
+ self assert: (page trace: -1) ~= 0 "for assert checking of the page tracing flags. -1 == invalid state"].
+
+ mostRecentlyUsedPage := self stackPageAt: 0.
+ page := mostRecentlyUsedPage.
+ count := 0.
+ [| theIndex |
+ count := count + 1.
+ theIndex := self pageIndexFor: page baseAddress.
+ self assert: (self stackPageAt: theIndex) == page.
+ self assert: (self pageIndexFor: page baseAddress) == theIndex.
+ self assert: (self pageIndexFor: page stackLimit) == theIndex.
+ self assert: (self pageIndexFor: page lastAddress + 1) == theIndex.
+ (page := page nextPage) ~= mostRecentlyUsedPage] whileTrue.
+ self assert: count == numPages.
+ self assert: self pageListIsWellFormed!
Item was removed:
- ----- Method: CoInterpreterStackPages>>initializeStack:numSlots:pageSize:stackLimitOffset:stackPageHeadroom: (in category 'initialization') -----
- initializeStack: theStackPages numSlots: stackSlots pageSize: slotsPerPage stackLimitOffset: stackLimitOffsetBytes stackPageHeadroom: stackPageHeadroomBytes
- "Initialize the stack pages. In the C VM theStackPages will be alloca'ed memory to hold the
- stack pages on the C stack. In the simulator they are housed in the memory between the
- cogMethodZone and the heap."
-
- <var: #theStackPages type: #'char *'>
- <returnTypeC: #void>
- | numPages page structStackPageSize pageStructBase count |
- <var: #page type: #'StackPage *'>
- <var: #pageStructBase type: #'char *'>
- self cCode: []
- inSmalltalk:
- [self assert: objectMemory startOfMemory - coInterpreter cogCodeSize - coInterpreter methodCacheSize - coInterpreter primTraceLogSize - coInterpreter rumpCStackSize
- = (stackSlots * BytesPerWord)].
- structStackPageSize := coInterpreter sizeof: CogStackPage.
- bytesPerPage := slotsPerPage * BytesPerWord.
- numPages := coInterpreter numStkPages.
-
- "Because stack pages grow down baseAddress is at the top of a stack page and so to avoid
- subtracting BytesPerWord from baseAddress and lastAddress in the init loop below we simply
- push the stackPage array up one word to avoid the overlap. This word is extraStackBytes."
- pageStructBase := theStackPages + (numPages * bytesPerPage) + BytesPerWord.
- pages := self cCode: [self cCoerceSimple: pageStructBase to: #'StackPage *']
- inSmalltalk:
- [pageMap := Dictionary new.
- ((0 to: numPages - 1) collect:
- [:i|
- CogStackPage surrogateClass new
- address: pageStructBase + (i * structStackPageSize)
- simulator: coInterpreter
- zoneBase: coInterpreter stackZoneBase
- zoneLimit: objectMemory startOfMemory])
- do: [:pageSurrogate|
- pageMap at: pageSurrogate address put: pageSurrogate];
- yourself].
- 0 to: numPages - 1 do:
- [:index|
- page := self stackPageAt: index.
- page
- lastAddress: theStackPages + (index * bytesPerPage);
- baseAddress: page lastAddress + bytesPerPage;
- stackLimit: page baseAddress
- - stackLimitOffsetBytes
- - stackPageHeadroomBytes;
- realStackLimit: page stackLimit;
- baseFP: 0;
- nextPage: (self stackPageAt: (index = (numPages - 1) ifTrue: [0] ifFalse: [index + 1]));
- prevPage: (self stackPageAt: (index = 0 ifTrue: [numPages - 1] ifFalse: [index - 1]))].
-
- "Now compute stackBasePlus1 so that the pageIndexFor: call maps all addresses from
- aPage baseAddress to aBase limitAddress + 1 to the same index (stacks grow down)"
- stackBasePlus1 := (self cCoerceSimple: theStackPages to: #'char *') + 1.
- self cCode: []
- inSmalltalk:
- [minStackAddress := theStackPages.
- maxStackAddress := theStackPages + (numPages * bytesPerPage) + BytesPerWord - 1].
-
- "The overflow limit is the amount of stack to retain when moving frames from an overflowing
- stack to reduce thrashing. See stackOverflowOrEvent:mayContextSwitch:"
- page := self stackPageAt: 0.
- overflowLimit := page baseAddress - page realStackLimit * 3 // 5.
- 0 to: numPages - 1 do:
- [:index|
- page := self stackPageAt: index.
- self assert: (self pageIndexFor: page baseAddress) == index.
- self assert: (self pageIndexFor: page baseAddress - (slotsPerPage - 1 * BytesPerWord)) == index.
- self assert: (self stackPageFor: page baseAddress) == page.
- self assert: (self stackPageFor: page stackLimit) == page.
- self cCode: []
- inSmalltalk:
- [| memIndex |
- memIndex := index * slotsPerPage + 1. "this is memIndex in the block above"
- self assert: (self memIndexFor: (self oopForPointer: page baseAddress))
- == (memIndex + slotsPerPage - 1).
- index < (numPages - 1) ifTrue:
- [self assert: (self stackPageFor: page baseAddress + BytesPerWord) == (self stackPageAt: index + 1)]].
- self assert: (page trace: -1) ~= 0 "for assert checking of the page tracing flags. -1 == invalid state"].
-
- mostRecentlyUsedPage := self stackPageAt: 0.
- page := mostRecentlyUsedPage.
- count := 0.
- [| theIndex |
- count := count + 1.
- theIndex := self pageIndexFor: page baseAddress.
- self assert: (self stackPageAt: theIndex) == page.
- self assert: (self pageIndexFor: page baseAddress) == theIndex.
- self assert: (self pageIndexFor: page stackLimit) == theIndex.
- self assert: (self pageIndexFor: page lastAddress + 1) == theIndex.
- (page := page nextPage) ~= mostRecentlyUsedPage] whileTrue.
- self assert: count == numPages.
- self assert: self pageListIsWellFormed!
Item was added:
+ TestCase subclass: #CoInterpreterTests
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: 'VMBasicConstants'
+ category: 'VMMaker-Tests'!
Item was added:
+ ----- Method: CoInterpreterTests>>testMinimumUnusedHeadroom (in category 'tests') -----
+ testMinimumUnusedHeadroom
+ "self new testMinimumUnusedHeadroom"
+ | ci |
+ CoInterpreter initializeWithOptions: Dictionary new.
+ ci := CogVMSimulator new.
+ ci initStackPagesForTests.
+ self assert: ci minimumUnusedHeadroom = ci stackPageByteSize.
+ 0 to: ci stackPageByteSize - 1 by: BytesPerWord do:
+ [:p|
+ 0 to: ci numStackPages - 1 do:
+ [:i| | page |
+ page := ci stackPages stackPageAt: i.
+ ci longAt: page baseAddress - p put: 1].
+ self assert: ci minimumUnusedHeadroom = (ci stackPageByteSize - (p + BytesPerWord))]!
Item was changed:
----- Method: CogARMCompiler>>at:moveCw:intoR: (in category 'generate machine code - concretize') -----
at: offset moveCw: constant intoR: destReg
"This loads aWord into the inter-opcode temporary register. Because most ARM instruction enable using a (8-12bit) offset relative to a register, the LS Byte can be included in that instruction, saving one instruction. This is done in a decorator, e.g. CmpCqR"
"Generates:along the lines of
MOV destReg, #<constantByte3>, 12
ORR destReg, destReg, #<constantByte2>, 8
ORR destReg, destReg, #<constantByte1>, 4
ORR destReg, destReg, #<constantByte0>, 0
with minimal choice of the rotation (last digit)"
"The same area can be modified multiple times, because the opperation is (inclusive) or."
<inline: true>
+ 0 to: 12 by: 4 do: [ :i | | rightRingRotation |
+ rightRingRotation := self minimalRightRingRotationFor: constant initialRotation: 12 - i.
- 0 to: 12 by: 4 do: [ :i | | rightRingRotation byte |
- rightRingRotation := 16rC - i.
- "Counter rotation to get the according byte. Because Smalltalk does not have left ring shift, shift further right."
- rightRingRotation ~= 0 ifTrue: [
- byte := constant >> (-2 * rightRingRotation + 32) bitAnd: 16rFF.
- "For 0, the shift has to be 0. For other immediates, the encoding with minimal rightRingRotation should be choosen."
- byte = 0
- ifTrue: [ rightRingRotation := 0]
- ifFalse: [
- 0 to: 2 do: [ :j |
- (byte bitAnd: 16r03) = 0
- ifTrue: [ rightRingRotation := rightRingRotation - 1.
- byte := byte >> 2 ]]]]
- ifFalse: [ byte := constant bitAnd: 16rFF].
machineCode
at: offset + i + 3 put: 16rE3;
at: offset + i + 2 put: (16r80 bitOr: destReg);
+ at: offset + i + 1 put: ((rightRingRotation at: 1) bitOr: destReg << 4);
+ at: offset + i"+0"put: (rightRingRotation at: 2).
- at: offset + i + 1 put: (rightRingRotation bitOr: destReg << 4);
- at: offset + i"+0"put: byte.
].
machineCode at: offset + 2 put: 16rA0. "only the first operation need be MOV"
^16!
Item was changed:
----- Method: CogARMCompiler>>callTargetFromReturnAddress: (in category 'inline cacheing') -----
callTargetFromReturnAddress: callSiteReturnAddress
"Answer the address the call immediately preceeding callSiteReturnAddress will jump to."
| callDistance call |
call := self instructionBeforeAddress: callSiteReturnAddress.
+ self assert: call ~= 0. "andeq r0, r0 will not be generated, not even as nops"
(self isBranch: call)
ifTrue: [ callDistance := (call bitAnd: 16r00FFFFFF) << 2.
"The distance is a signed 24bit number. Therefore, the highest (26th) bit has to be expanded"
(callDistance bitAnd: 16r02000000) ~= 0
ifTrue: [callDistance := callDistance bitOr: 16rFC000000]]
ifFalse: [ "A Long Jump. Extract the value saved to RISCTempReg from all the instructions before."
self notYetImplemented ].
^callSiteReturnAddress + 4 + callDistance signedIntFromLong!
Item was changed:
----- Method: CogARMCompiler>>computeMaximumSize (in category 'generate machine code') -----
computeMaximumSize
"Because we don't use Thumb, each ARM instruction has 4 bytes. Some abstract opcodes need more than one instruction."
| rotateableAt0then4or20Block |
rotateableAt0then4or20Block := [^self rotateable8bitImmediate: (operands at: 0)
ifTrue: [:r :i| maxSize := 4]
ifFalse: [maxSize := 20]].
(opcode between: FirstShortJump and: LastJump) ifTrue: [^maxSize := 16].
opcode
caseOf: {
[Label] -> [^maxSize := 0].
[AlignmentNops] -> [^maxSize := (operands at: 0) - 1].
[MoveAwR] -> [^maxSize := 16].
[MoveCqR] -> [^self rotateable8bitImmediate: (operands at: 0)
ifTrue: [:r :i| maxSize := 4]
ifFalse: [maxSize := 16]].
[MoveCwR] -> [^maxSize := 16].
[MoveRAw] -> [^maxSize := 16].
[MoveRMwr] -> [self is12BitValue: (operands at: 1)
ifTrue: [ :u :i | ^maxSize := 4]
ifFalse: [ ^maxSize := 20 ]].
[MoveRMbr] -> [self is12BitValue: (operands at: 1)
ifTrue: [ :u :i | ^maxSize := 4]
ifFalse: [ ^maxSize := 20 ]].
[MoveMwrR] -> [self is12BitValue: (operands at: 0)
ifTrue: [ :u :i | ^maxSize := 4]
ifFalse: [ ^maxSize := 20 ]].
[MoveMbrR] -> [self is12BitValue: (operands at: 0)
ifTrue: [ :u :i | ^maxSize := 4]
ifFalse: [ ^maxSize := 20 ]].
[PrefetchAw] -> [^maxSize := 16].
+ [Call] -> [^maxSize := 20 "recomputed in #sizePCDependentInstruction."].
- [Call] -> [^maxSize := "<="24 "recomputed in #sizePCDependentInstruction."].
[RetN] -> [^(operands at: 0) = 0
ifTrue: [maxSize := 4]
ifFalse: [maxSize := 8]].
[CmpCqR] -> [rotateableAt0then4or20Block value].
[AddCqR] -> [rotateableAt0then4or20Block value].
[SubCqR] -> [rotateableAt0then4or20Block value].
[AndCqR] -> [rotateableAt0then4or20Block value].
[OrCqR] -> [rotateableAt0then4or20Block value].
[XorCqR] -> [rotateableAt0then4or20Block value].
[CmpCwR] -> [^maxSize := 20].
[AddCwR] -> [^maxSize := 20].
[SubCwR] -> [^maxSize := 20].
[AndCwR] -> [^maxSize := 20].
[OrCwR] -> [^maxSize := 20].
[XorCwR] -> [^maxSize := 20].
[JumpR] -> [^maxSize := 4].
[JumpFPEqual] -> [^maxSize := 8].
[JumpFPNotEqual] -> [^maxSize := 8].
[JumpFPLess] -> [^maxSize := 8].
[JumpFPGreaterOrEqual]-> [^maxSize := 8].
[JumpFPGreater] -> [^maxSize := 8].
[JumpFPLessOrEqual] -> [^maxSize := 8].
[JumpFPOrdered] -> [^maxSize := 8].
[JumpFPUnordered] -> [^maxSize := 8].
[JumpLong] -> [^maxSize := 16].
[JumpLongZero] -> [^maxSize := 16].
[JumpLongNonZero] -> [^maxSize := 16].
[LoadEffectiveAddressMwrR] -> [rotateableAt0then4or20Block value].
[PushCw] -> [^maxSize := 20].
}
otherwise: [^maxSize := 4].
^4 "to keep C compiler quiet"
!
Item was changed:
----- Method: CogARMCompiler>>concreteRegister: (in category 'encoding') -----
concreteRegister: registerIndex
"Map a possibly abstract register into a concrete one. Abstract registers
(defined in CogAbstractOpcodes) are all negative. If registerIndex is
negative assume it is an abstract register."
"N.B. According to BSABI, R0-R3 are caller-save, R4-R12 are callee save.
Note that R9 might be a special register for the implementation. In some slides it is refered to as sb. R10 can contain the stack limit (sl), R11 the fp. R12 is an intra-procedure scratch instruction pointer for link purposes. It can also be used.
R10 is used as temporary inside a single abstract opcode implementation"
"R0-R3 are used when calling back to the interpreter. Using them would require saving and restoring their values, so they are omitted so far. R12 is the only unused register at the moment.."
^registerIndex
caseOf: {
[TempReg] -> [R7].
[ClassReg] -> [R8].
[ReceiverResultReg] -> [R9].
[SendNumArgsReg] -> [R6].
[SPReg] -> [SP].
[FPReg] -> [R11].
[Arg0Reg] -> [R4].
+ [Arg1Reg] -> [R5].
+ [LinkReg] -> [LR]. }
- [Arg1Reg] -> [R5] }
otherwise:
[self assert: (registerIndex between: R0 and: PC).
registerIndex]!
Item was changed:
----- Method: CogARMCompiler>>concretizeCall (in category 'generate machine code - concretize') -----
concretizeCall
"Will get inlined into concretizeAt: switch."
<inline: true>
| offset |
self assert: (operands at: 0) ~= 0.
self assert: (operands at: 0) \\ 4 = 0.
+ offset := (operands at: 0) signedIntFromLong - (address + 8 "normal pc offset") signedIntFromLong.
- offset := (operands at: 0) signedIntFromLong - (address + 8 "normal pc offset" + 4 "push instruction") signedIntFromLong.
(self isQuick: offset)
ifTrue: [
+ self machineCodeAt: 0 put: (self t: 5 o: 8) + (offset >> 2 bitAnd: 16r00FFFFFF). "BL offset"
+ ^machineCodeSize := 4]
- self machineCodeAt: 0 put: (self t: 4 o: 9 s: 0 rn: SP rd: 8 shifterOperand: 0). "push {pc}"
- self machineCodeAt: 4 put: (self t: 5 o: 8) + (offset >> 2 bitAnd: 16r00FFFFFF). "BL offset"
- ^machineCodeSize := 8]
ifFalse: [
+ self error: 'While we know how to generate a long distance call, we can''t update such a send site yet. Please restart with smaller cache size'.
self concretizeConditionalJumpLong: AL.
"move the actual jump two instructions further, inserting the pc back-up to lr and the pc push."
+ self machineCodeAt: 16 put: (self machineCodeAt: 12).
- self machineCodeAt: 20 put: (self machineCodeAt: 12).
"Because the pc always points to the actual address + 8, the value at pc is the address of the instruction after the branch"
+ "mov lr, pc"
+ self machineCodeAt: 12 put: (self t: 0 o: 16rD s: 0 rn: 0 rd: LR shifterOperand: PC).
+ ^machineCodeSize := 20]!
- "add lr, pc, #4"
- self machineCodeAt: 12 put: (self t: 1 o: 4 s: 0 rn: PC rd: LR shifterOperand: 4).
- "self machineCodeAt: 12 put: (self t: 0 o: 16rD s: 0 rn: 0 rd: LR shifterOperand: PC)."
-
- "push {pc} -- IA32 ABI, needed only for within JIT, when calling outside, like in a trampoline, maybe not."
- self machineCodeAt: 16 put: (self new t: 4 o: 9 s: 0 rn: SP rd: 8 shifterOperand: 0).
- ^machineCodeSize := 24]!
Item was added:
+ ----- Method: CogARMCompiler>>concretizeMoveXbrRR (in category 'generate machine code - concretize') -----
+ concretizeMoveXbrRR
+ "Will get inlined into concretizeAt: switch."
+
+ <inline: true>
+ | index base dest |
+ index := self concreteRegister: (operands at: 0).
+ base := self concreteRegister: (operands at: 1).
+ dest := self concreteRegister: (operands at: 2).
+ "LDR dest, [base, +index, LSL #0]"
+ "cond 011 1100 1 base dest 00000 00 0 inde"
+ self machineCodeAt: 0 put: (self t: 3 o: 16rC s: 1 rn: base rd: dest shifterOperand: index).
+ ^machineCodeSize := 4!
Item was added:
+ ----- Method: CogARMCompiler>>concretizeMoveXwrRR (in category 'generate machine code - concretize') -----
+ concretizeMoveXwrRR
+ "Will get inlined into concretizeAt: switch."
+
+ <inline: true>
+ | index base dest |
+ index := self concreteRegister: (operands at: 0).
+ base := self concreteRegister: (operands at: 1).
+ dest := self concreteRegister: (operands at: 2).
+ "LDR dest, [base, +index, LSL #2]"
+ "cond 011 1100 1 base dest 00010 00 0 inde"
+ self machineCodeAt: 0 put: (self t: 3 o: 16rC s: 1 rn: base rd: dest shifterOperand: (16r100 bitOr: index)).
+ ^machineCodeSize := 4!
Item was changed:
----- Method: CogARMCompiler>>isCallPreceedingReturnPC: (in category 'testing') -----
isCallPreceedingReturnPC: mcpc
"Assuming mcpc is a return pc answer if the instruction before it is a call."
+ "There are two types of calls: BL and (MOV, ORR, ORR, ADD, ADD)"
- "There are two types of calls: PUSH, BL and (MOV, ORR, ORR, ADD, PUSH, ADD)"
"PUSH {pc} is not sufficient as a test, because pc may be pushed using the PushR opcode"
+ ^ (objectMemory byteAt: mcpc - 3) >> 4 = 16rB "BL"
+ or: [ (objectMemory longAt: mcpc - 4) >> 12 = ((self t: 1 o: 4 s: 0 rn: RISCTempReg rd: PC)"add pc, r3, 0" >> 12) ]!
- ^(objectMemory longAt: mcpc - 8) = (self t: 4 o: 9 s: 0 rn: SP rd: 8 shifterOperand: 0)
- and: [(objectMemory byteAt: mcpc - 3) >> 4 = 16rB "BL"
- or: [ (objectMemory longAt: mcpc - 12) = 16rE1A0E00F "MOV pc, lr" ]]!
Item was added:
+ ----- Method: CogARMCompiler>>minimalRightRingRotationFor:initialRotation: (in category 'encoding') -----
+ minimalRightRingRotationFor: constant initialRotation: iniRightRingRotation
+ "Given a constant and some initial rotation, tries to minimize that rotation in an effort to encode the according byte in constant. This is used, to encode the last 12bit of many operations, for which a 8bit immediate rotated by (2*)4bit is available. That immediate need be encoded with minimal rotation."
+ | byte rightRingRotation |
+ rightRingRotation := iniRightRingRotation.
+ "Counter rotation to get the according byte. Because Smalltalk does not have left ring shift, shift further right."
+ rightRingRotation ~= 0 ifTrue: [
+ byte := constant >> (-2 * rightRingRotation + 32) bitAnd: 16rFF.
+ "For 0, the shift has to be 0. For other immediates, the encoding with minimal rightRingRotation should be choosen."
+ byte = 0
+ ifTrue: [ rightRingRotation := 0]
+ ifFalse: [
+ 0 to: 2 do: [ :j |
+ (byte bitAnd: 16r03) = 0
+ ifTrue: [ rightRingRotation := rightRingRotation - 1.
+ byte := byte >> 2 ]]]]
+ ifFalse: [ byte := constant bitAnd: 16rFF].
+ ^{rightRingRotation. byte}!
Item was changed:
----- Method: CogARMCompiler>>numberOfSaveableRegisters (in category 'abi') -----
numberOfSaveableRegisters
"Answer the number of registers to be saved in a trampoline call that saves registers.
+ None, See genSaveRegisters."
+ <cmacro: '(self) 0'>
+ ^0!
- R0 through R12, See genSaveRegisters."
- <cmacro: '(self) 13'>
- ^13!
Item was added:
+ ----- Method: CogARMCompiler>>rewriteInlineCacheAt:tag:target: (in category 'inline cacheing') -----
+ rewriteInlineCacheAt: callSiteReturnAddress tag: cacheTag target: callTargetAddress
+ "Rewrite an inline cache to call a different target for a new tag. This variant is used
+ to link unlinked sends in ceSend:to:numArgs: et al. Answer the extent of the code
+ change which is used to compute the range of the icache to flush."
+
+ "chacheTag contains an oop to the selector which need be loaded before jumping"
+ <var: #callSiteReturnAddress type: #usqInt>
+ <var: #callTargetAddress type: #usqInt>
+ | call callDistance |
+ "self cCode: ''
+ inSmalltalk: [cogit disassembleFrom: callSiteReturnAddress - 20 to: callSiteReturnAddress -1]."
+ false
+ ifTrue: [self assert: callTargetAddress >= cogit minCallAddress]
+ ifFalse: [callTargetAddress >= cogit minCallAddress ifFalse:
+ [self error: 'linking callsite to invalid address']].
+ callDistance := (callTargetAddress - (callSiteReturnAddress + 8 "pc offset"- 4 "return offset")) signedIntToLong.
+
+ self assert: (self isQuick: callDistance). "we don't support long call updates, yet"
+ call := (self t: 5 o: 8)"BL" + (callDistance >> 2 bitAnd: 16rFFFFFF).
+ objectMemory
+ byteAt: callSiteReturnAddress - 1 put: (call >> 24 bitAnd: 16rFF);
+ byteAt: callSiteReturnAddress - 2 put: (call >> 16 bitAnd: 16rFF);
+ byteAt: callSiteReturnAddress - 3 put: (call >> 8 bitAnd: 16rFF);
+ byteAt: callSiteReturnAddress - 4 put: (call bitAnd: 16rFF).
+
+ "The cacheTag is loaded byte by byte. Each byte needs to be encoded with minimal right ring rotation. See also #at:moveCw:intoR:"
+ -20 to: -8 by: 4 do: [ :offset || rotation |
+ rotation := self minimalRightRingRotationFor: cacheTag initialRotation: (offset + 8) negated.
+ (offset + 8) ~= 0 ifTrue: [ "in case of decoration which may change the last instrution, we should not overwrite bits 9 to 12"
+ objectMemory
+ byteAt: callSiteReturnAddress + offset + 1
+ put: (((objectMemory byteAt: callSiteReturnAddress - offset + 1)
+ bitAnd: 16rF0)
+ bitOr: (rotation at: 1))].
+ objectMemory
+ byteAt: callSiteReturnAddress + offset
+ put: (rotation at: 2)].
+
+ self assert: (self callTargetFromReturnAddress: callSiteReturnAddress) signedIntToLong = callTargetAddress.
+ "self cCode: ''
+ inSmalltalk: [cogit disassembleFrom: callSiteReturnAddress - 20 to: callSiteReturnAddress - 1]."
+ ^20!
Item was changed:
----- Method: CogARMCompiler>>sizePCDependentInstructionAt: (in category 'generate machine code') -----
sizePCDependentInstructionAt: eventualAbsoluteAddress
"Size a jump and set its address. The target may be another instruction
or an absolute address. On entry the address inst var holds our virtual
address. On exit address is set to eventualAbsoluteAddress, which is
where this instruction will be output. The span of a jump to a following
instruction is therefore between that instruction's address and this
instruction's address ((which are both still their virtual addresses), but the
span of a jump to a preceeding instruction or to an absolute address is
between that instruction's address (which by now is its eventual absolute
address) or absolute address and eventualAbsoluteAddress."
| target maximumSpan |
<var: #abstractInstruction type: #'AbstractInstruction *'>
opcode = AlignmentNops ifTrue:
[| alignment |
address := eventualAbsoluteAddress.
alignment := operands at: 0.
^machineCodeSize := (eventualAbsoluteAddress + (alignment - 1) bitAnd: alignment negated)
- eventualAbsoluteAddress].
self assert: (self isJump or: [opcode = Call]).
self isJump ifTrue: [self resolveJumpTarget].
target := operands at: 0.
"maximumSpan calculation copied from CogIA32Compiler TODO: extract method?"
(self isAnInstruction: (cogit cCoerceSimple: target to: #'void *'))
ifTrue:
[| abstractInstruction |
abstractInstruction := cogit cCoerceSimple: target to: #'AbstractInstruction *'.
maximumSpan := abstractInstruction address
- (((cogit abstractInstruction: self follows: abstractInstruction)
ifTrue: [eventualAbsoluteAddress]
ifFalse: [address]) + 2)]
ifFalse:
[maximumSpan := target - (eventualAbsoluteAddress + 2)].
address := eventualAbsoluteAddress.
^machineCodeSize := opcode = Call
+ ifTrue: [(self isQuick: maximumSpan) ifTrue: [4] ifFalse: [20]]
- ifTrue: [(self isQuick: maximumSpan - 4 "push instruction") ifTrue: [8] ifFalse: [24]]
ifFalse: [(self isLongJump not and: [self isQuick: maximumSpan])
ifTrue: [4]
ifFalse: [16]] "load address to register, add"!
Item was changed:
----- Method: CogARMCompilerTests>>strip: (in category 'accessing') -----
strip: aFancyDisassembledInstruction
"When havin an immediate > 15, the disassembler appends ' ; 0x\d\d'. That is stripped."
+ ^((aFancyDisassembledInstruction
+ allButFirst: (aFancyDisassembledInstruction indexOf: $:) + 1)
+ copyUpTo: $;) withBlanksTrimmed!
- ^(aFancyDisassembledInstruction copyUpTo: $;) withBlanksTrimmed!
Item was changed:
----- Method: CogBytecodeDescriptor>>printCInitializerOn:in: (in category 'translation') -----
printCInitializerOn: aStream in: aCCodeGenerator
<doNotGenerate>
| first |
first := true.
aStream nextPut: ${; space.
self class instVarNamesAndTypesForTranslationDo:
[:ivn :type| | value |
first ifTrue: [first := false] ifFalse: [aStream nextPut: $,; space].
value := self instVarNamed: ivn.
(#(#'unsigned char' #'signed char' #('unsigned' ' : 1')) includes: type)
ifTrue: [value isInteger
+ ifTrue: [ivn = 'opcode'
+ ifTrue: [aStream nextPutAll: (CogRTLOpcodes nameForOpcode: value)]
+ ifFalse: [aStream print: value]]
- ifTrue: [aStream print: value]
ifFalse: [aStream nextPut: ((value notNil and: [value]) ifTrue: [$1] ifFalse: [$0])]]
ifFalse: [(false and: [#('spanFunction' 'isBackwardBranchFunction') includes: ivn]) ifTrue:
[aStream nextPut: $(; nextPutAll: type first; nextPutAll: type last; nextPut: $)].
aStream nextPutAll: (value
ifNotNil: [aCCodeGenerator cFunctionNameFor: value]
ifNil: ['0'])]].
aStream space; nextPut: $}!
Item was added:
+ ----- Method: CogClass class>>minimumUnusedStackHeadroom (in category 'system primitives') -----
+ minimumUnusedStackHeadroom
+ "self minimumUnusedStackHeadroom"
+ <primitive: 'primitiveMinimumUnusedHeadroom'>
+ self primitiveFailed!
Item was changed:
SharedPool subclass: #CogRTLOpcodes
instanceVariableNames: ''
+ classVariableNames: 'AddCqR AddCwR AddRR AddRdRd AlignmentNops AndCqR AndCwR AndRR Arg0Reg Arg1Reg ArithmeticShiftRightCqR ArithmeticShiftRightRR Call ClassReg CmpCqR CmpCwR CmpRR CmpRdRd ConvertRRd DPFPReg0 DPFPReg1 DPFPReg2 DPFPReg3 DPFPReg4 DPFPReg5 DPFPReg6 DPFPReg7 DivRdRd FPReg Fill16 Fill32 Fill8 FillBytesFrom FillFromWord FirstJump FirstShortJump GPRegMax GPRegMin Jump JumpAbove JumpAboveOrEqual JumpBelow JumpBelowOrEqual JumpCarry JumpFPEqual JumpFPGreater JumpFPGreaterOrEqual JumpFPLess JumpFPLessOrEqual JumpFPNotEqual JumpFPOrdered JumpFPUnordered JumpGreater JumpGreaterOrEqual JumpLess JumpLessOrEqual JumpLong JumpLongNonZero JumpLongZero JumpNegative JumpNoCarry JumpNoOverflow JumpNonNegative JumpNonZero JumpOverflow JumpR JumpZero Label LastJump LastRTLCode LinkReg LoadEffectiveAddressMwrR LogicalShiftLeftCqR LogicalShiftLeftRR LogicalShiftRightCqR LogicalShiftRightRR MoveAbR MoveAwR MoveC32R MoveC64R MoveCqR MoveCwR MoveM16rR MoveM64rRd MoveMbrR MoveMwrR MoveRAw MoveRM16r MoveRMbr MoveRMwr MoveRR MoveRX16rR MoveRXbrR MoveRXwrR MoveRdM64r MoveRdRd MoveX16rRR MoveXbrRR MoveXwrRR MulCqR MulCwR MulRR MulRdRd NegateR Nop OrCqR OrCwR OrRR PopR PrefetchAw PushCw PushR ReceiverResultReg RetN SPReg SendNumArgsReg SqrtRd SubCqR SubCwR SubRR SubRdRd TempReg XorCqR XorCwR XorRR'
- classVariableNames: 'AddCqR AddCwR AddRR AddRdRd AlignmentNops AndCqR AndCwR AndRR Arg0Reg Arg1Reg ArithmeticShiftRightCqR ArithmeticShiftRightRR Call ClassReg CmpCqR CmpCwR CmpRR CmpRdRd ConvertRRd DPFPReg0 DPFPReg1 DPFPReg2 DPFPReg3 DPFPReg4 DPFPReg5 DPFPReg6 DPFPReg7 DivRdRd FPReg Fill16 Fill32 Fill8 FillBytesFrom FillFromWord FirstJump FirstShortJump GPRegMax GPRegMin Jump JumpAbove JumpAboveOrEqual JumpBelow JumpBelowOrEqual JumpCarry JumpFPEqual JumpFPGreater JumpFPGreaterOrEqual JumpFPLess JumpFPLessOrEqual JumpFPNotEqual JumpFPOrdered JumpFPUnordered JumpGreater JumpGreaterOrEqual JumpLess JumpLessOrEqual JumpLong JumpLongNonZero JumpLongZero JumpNegative JumpNoCarry JumpNoOverflow JumpNonNegative JumpNonZero JumpOverflow JumpR JumpZero Label LastJump LastRTLCode LoadEffectiveAddressMwrR LogicalShiftLeftCqR LogicalShiftLeftRR LogicalShiftRightCqR LogicalShiftRightRR MoveAbR MoveAwR MoveC32R MoveC64R MoveCqR MoveCwR MoveM16rR MoveM64rRd MoveMbrR MoveMwrR MoveRAw MoveRM16r MoveRMbr MoveRMwr MoveRR MoveRX16rR MoveRXbrR MoveRXwrR MoveRdM64r MoveRdRd MoveX16rRR MoveXbrRR MoveXwrRR MulCqR MulCwR MulRR MulRdRd NegateR Nop OrCqR OrCwR OrRR PopR PrefetchAw PushCw PushR ReceiverResultReg RetN SPReg SendNumArgsReg SqrtRd SubCqR SubCwR SubRR SubRdRd TempReg XorCqR XorCwR XorRR'
poolDictionaries: ''
category: 'VMMaker-JIT'!
!CogRTLOpcodes commentStamp: '<historical>' prior: 0!
I am a pool for the Register-Transfer-Language to which Cog compiles. I define unique integer values for all RTL opcodes and abstract registers. See CogAbstractInstruction for instances of instructions with the opcodes that I define.!
Item was changed:
----- Method: CogRTLOpcodes class>>initialize (in category 'class initialization') -----
initialize
"Abstract opcodes are a compound of a one word operation specifier and zero or more operand type specifiers.
e.g. MoveRR is the Move opcode with two register operand specifiers and defines a move register to
register instruction from operand 0 to operand 1. The operand specifiers are
R - general purpose register
Rd - double-precision floating-point register
Cq - a quick constant that can be encoded in the minimum space possible.
Cw - a constant with word size where word is the default operand size for the Smalltalk VM, 32-bits
for a 32-bit VM, 64-bits for a 64-bit VM. The generated constant must occupy the default number
of bits. This allows e.g. a garbage collector to update the value without invalidating the code.
C32 - a constant with 32 bit size. The generated constant must occupy 32 bits.
C64 - a constant with 64 bit size. The generated constant must occupy 64 bits.
Aw - memory word with an absolute address
Ab - memory byte with an absolute address
Mwr - memory word whose address is at a constant offset from an address in a register
Mbr - memory byte whose address is at a constant offset from an address in a register
M16r - memory 16-bit halfword whose address is at a constant offset from an address in a register
M64r - memory 64-bit doubleword whose address is at a constant offset from an address in a register
XbrR- memory word whose address is r * byte size away from an address in a register
X16rR- memory word whose address is r * (2 bytes size) away from an address in a register
XwrR- memory word whose address is r * word size away from an address in a register
An alternative would be to decouple opcodes from operands, e.g.
Move := 1. Add := 2. Sub := 3...
RegisterOperand := 1. ConstantQuickOperand := 2. ConstantWordOperand := 3...
But not all combinations make sense and even fewer are used so we stick with the simple compound approach.
The assumption is that comparison and arithmetic instructions set condition codes and that move instrucions
leave the condition codes unaffected. In particular LoadEffectiveAddressMwrR does not set condition codes
although it can be used to do arithmetic.
Note that there are no generic division instructions defined, but a processor may define some."
"CogRTLOpcodes initialize.
CogAbstractInstruction allSubclasses do: [:sc| sc initialize]"
| opcodeNames refs |
FPReg := -1.
SPReg := -2.
ReceiverResultReg := GPRegMax := -3.
TempReg := -4.
ClassReg := -5.
SendNumArgsReg := -6.
Arg0Reg := -7.
Arg1Reg := GPRegMin := -8.
DPFPReg0 := -9.
DPFPReg1 := -10.
DPFPReg2 := -11.
DPFPReg3 := -12.
DPFPReg4 := -13.
DPFPReg5 := -14.
DPFPReg6 := -15.
DPFPReg7 := -16.
+
+ LinkReg := -17.
opcodeNames := #("Noops & Pseudo Ops"
Label
AlignmentNops
FillBytesFrom "output operand 0's worth of bytes from the address in operand 1"
Fill8 "output a byte's worth of bytes with operand 0"
Fill16 "output two byte's worth of bytes with operand 0"
Fill32 "output four byte's worth of bytes with operand 0"
FillFromWord "output BytesPerWord's worth of bytes with operand 0 + operand 1"
Nop
"Control"
Call
RetN
JumpR "Not a regular jump, i.e. not pc dependent."
"N.B. Jumps are contiguous. Long jumps are contigiuous within them. See FirstJump et al below"
JumpLong
JumpLongZero "a.k.a. JumpLongEqual"
JumpLongNonZero "a.k.a. JumpLongNotEqual"
Jump
JumpZero "a.k.a. JumpEqual"
JumpNonZero "a.k.a. JumpNotEqual"
JumpNegative
JumpNonNegative
JumpOverflow
JumpNoOverflow
JumpCarry
JumpNoCarry
JumpLess "signed"
JumpGreaterOrEqual
JumpGreater
JumpLessOrEqual
JumpBelow "unsigned"
JumpAboveOrEqual
JumpAbove
JumpBelowOrEqual
JumpFPEqual
JumpFPNotEqual
JumpFPLess
JumpFPLessOrEqual
JumpFPGreater
JumpFPGreaterOrEqual
JumpFPOrdered
JumpFPUnordered
"Data Movement; destination is always last operand"
MoveRR
MoveAwR
MoveRAw
MoveAbR
MoveMwrR MoveRMwr MoveXwrRR MoveRXwrR
MoveM16rR MoveRM16r MoveX16rRR MoveRX16rR
MoveMbrR MoveRMbr MoveXbrRR MoveRXbrR
MoveCqR MoveCwR MoveC32R MoveC64R
MoveRdRd MoveM64rRd MoveRdM64r
PopR PushR PushCw
PrefetchAw
"Arithmetic; destination is always last operand except Cmp; CmpXR is SubRX with no update of result"
LoadEffectiveAddressMwrR "A variant of add"
NegateR "2's complement negation"
ArithmeticShiftRightCqR ArithmeticShiftRightRR
LogicalShiftRightCqR LogicalShiftRightRR
LogicalShiftLeftCqR LogicalShiftLeftRR
CmpRR AddRR SubRR AndRR OrRR XorRR MulRR
CmpCqR AddCqR SubCqR AndCqR OrCqR XorCqR MulCqR
CmpCwR AddCwR SubCwR AndCwR OrCwR XorCwR MulCwR
CmpRdRd AddRdRd SubRdRd MulRdRd DivRdRd SqrtRd
"Conversion"
ConvertRRd
LastRTLCode).
refs := (thisContext method literals select: [:l| l isVariableBinding and: [classPool includesKey: l key]]) collect:
[:ea| ea key].
(classPool keys reject: [:k| (opcodeNames includes: k) or: [refs includes: k]]) do:
[:k|
Undeclared declare: k from: classPool].
opcodeNames withIndexDo:
[:classVarName :value|
self classPool
declare: classVarName from: Undeclared;
at: classVarName put: value].
FirstJump := JumpLong.
LastJump := JumpFPUnordered.
FirstShortJump := Jump!
Item was changed:
----- Method: CogRTLOpcodes class>>nameForAbstractRegister: (in category 'debug printing') -----
nameForAbstractRegister: reg "<Integer>"
^#(Arg0Reg Arg1Reg ClassReg FPReg ReceiverResultReg SPReg SendNumArgsReg TempReg
+ DPFPReg0 DPFPReg1 DPFPReg2 DPFPReg3 DPFPReg4 DPFPReg5 DPFPReg6 DPFPReg7 LinkReg)
- DPFPReg0 DPFPReg1 DPFPReg2 DPFPReg3 DPFPReg4 DPFPReg5 DPFPReg6 DPFPReg7)
detect: [:sym| (classPool at: sym) = reg]!
Item was changed:
----- Method: CogRTLOpcodes class>>nameForRegister: (in category 'debug printing') -----
nameForRegister: reg "<Integer>"
^#(Arg0Reg Arg1Reg ClassReg FPReg ReceiverResultReg SPReg SendNumArgsReg TempReg
+ DPFPReg0 DPFPReg1 DPFPReg2 DPFPReg3 DPFPReg4 DPFPReg5 DPFPReg6 DPFPReg7 LinkReg)
- DPFPReg0 DPFPReg1 DPFPReg2 DPFPReg3 DPFPReg4 DPFPReg5 DPFPReg6 DPFPReg7)
detect: [:sym| (classPool at: sym) = reg]!
Item was added:
+ ----- Method: CogVMSimulator>>initStackPagesForTests (in category 'test support') -----
+ initStackPagesForTests
+ numStackPages := 8.
+ stackPages := self stackPagesClass new.
+ objectMemory allocateMemoryOfSize: 1024 * 1024.
+ cogCodeSize := 0.
+ heapBase := self methodCacheSize
+ + self primTraceLogSize
+ + self rumpCStackSize
+ + self computeStackZoneSize.
+ self initStackPages!
Item was changed:
----- Method: CogVMSimulator>>initialize (in category 'initialization') -----
initialize
"Initialize the StackInterpreterSimulator when running the interpreter
inside Smalltalk. The primary responsibility of this method is to allocate
Smalltalk Arrays for variables that will be declared as statically-allocated
global arrays in the translated code."
| objectMemoryClass |
"initialize class variables"
objectMemory ifNotNil:
[^self halt].
objectMemoryClass := self class objectMemoryClass.
objectMemoryClass initBytesPerWord: objectMemoryClass bytesPerWord.
((Smalltalk classNamed: #CoInterpreterMT) ifNil: [CoInterpreter] ifNotNil: [:cimt| cimt]) initialize.
(self class cogitClass withAllSuperclasses copyUpThrough: Cogit) reverseDo:
[:c| c initialize].
super initialize.
objectMemory := objectMemoryClass simulatorClass new.
cogit := self class cogitClass new setInterpreter: self.
cogit numRegArgs > 0 ifTrue:
[debugStackDepthDictionary := Dictionary new].
objectMemory coInterpreter: self cogit: cogit.
"Note: we must initialize ConstMinusOne & HasBeenReturnedFromMCPC differently
for simulation, due to the fact that the simulator works only with +ve 32-bit values"
ConstMinusOne := objectMemory integerObjectOf: -1.
HasBeenReturnedFromMCPC := objectMemory integerObjectOf: -1.
cogMethodZone := cogit methodZone. "Because Slang can't remove intermediate implicit receivers (cogit methodZone foo doesn't reduce to foo())"
enableCog := true.
methodCache := Array new: MethodCacheSize.
atCache := Array new: AtCacheTotalSize.
self flushMethodCache.
self flushAtCache.
cogCompiledCodeCompactionCalledFor := false.
gcSemaphoreIndex := 0.
externalSemaphoreSignalRequests := externalSemaphoreSignalResponses := #().
externalPrimitiveTable := CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize).
externalPrimitiveTableFirstFreeIndex := 0.
primitiveTable := self class primitiveTable copy.
pluginList := #().
mappedPluginEntries := OrderedCollection new.
desiredNumStackPages := desiredEdenBytes := desiredCogCodeSize := 0.
+ "This is initialized on loading the image, but convenient for testing stack page values..."
+ numStackPages := self defaultNumStackPages.
startMicroseconds := Time totalSeconds * 1000000.
maxLiteralCountForCompile := MaxLiteralCountForCompile.
minBackwardJumpCountForCompile := MinBackwardJumpCountForCompile.
flagInterpretedMethods := false.
"initialize InterpreterSimulator variables used for debugging"
byteCount := lastPollCount := sendCount := 0.
quitBlock := [^ self].
traceOn := true.
printSends := printFrameAtEachStep := printBytecodeAtEachStep := false.
myBitBlt := BitBltSimulator new setInterpreter: self.
transcript := Transcript.
displayForm := 'Display has not yet been installed' asDisplayText form.
suppressHeartbeatFlag := deferSmash := deferredSmash := false.
systemAttributes := Dictionary new.
primTraceLog := CArrayAccessor on: (Array new: 256 withAll: 0).
primTraceLogIndex := 0.
traceLog := CArrayAccessor on: (Array new: TraceBufferSize withAll: 0).
traceLogIndex := 0.
traceSources := TraceSources.
statCodeCompactionCount := 0.
statCodeCompactionUsecs := 0.
extSemTabSize := 256!
Item was changed:
----- Method: CogVMSimulator>>internalFindNewMethod (in category 'testing') -----
internalFindNewMethod
"
| cName |
traceOn ifTrue:
[cName := (self sizeBitsOf: class) = 16r20
ifTrue: ['class ' , (self nameOfClass: (self fetchPointer: 6 ofObject: class))]
ifFalse: [(self nameOfClass: class)].
self cr; print: cName , '>>' , (self stringOf: messageSelector)].
"
+ messageSelector = (objectMemory splObj: SelectorDoesNotUnderstand) ifTrue: [self halt].
- (self stringOf: messageSelector) = 'doesNotUnderstand:' ifTrue: [self halt].
self logSend: messageSelector.
"
(sendCount > 1000 and: [sendCount\\10 = 0]) ifTrue:
[Transcript print: sendCount; space.
self validate].
"
"
(sendCount > 100150) ifTrue:
[self qvalidate.
messageQueue == nil ifTrue: [messageQueue := OrderedCollection new].
messageQueue addLast: (self stringOf: messageSelector)].
"
^super internalFindNewMethod!
Item was added:
+ ----- Method: CogVMSimulator>>numStackPages (in category 'test support') -----
+ numStackPages
+ ^numStackPages!
Item was added:
+ ----- Method: CogVMSimulator>>osCogStackPageHeadroom (in category 'stack pages') -----
+ osCogStackPageHeadroom
+ "Notional headroom for the simulator. The platform provides this in the real VM."
+ ^1024!
Item was changed:
----- Method: CogVMSimulator>>writeImageFileIO: (in category 'image save/restore') -----
writeImageFileIO: numberOfBytesToWrite
"Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."
| headerSize file |
BytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
headerSize := 64.
[
+ file := FileStream fileNamed: imageName.
+ file == nil ifTrue:
+ [self primitiveFail.
+ ^nil].
+ file binary.
+
- file := (FileStream fileNamed: imageName) binary.
- file == nil ifTrue: [^nil].
-
{
self imageFormatVersion.
headerSize.
numberOfBytesToWrite.
objectMemory startOfMemory.
(objectMemory specialObjectsOop).
(objectMemory lastHash).
self ioScreenSize.
self getImageHeaderFlags.
extraVMMemory
}
do: [:long | self putLong: long toFile: file].
{ desiredNumStackPages. self unknownShortOrCodeSizeInKs } do:
[:short| self putShort: short toFile: file].
self putLong: desiredEdenBytes toFile: file.
{ maxExtSemTabSizeSet ifTrue: [self ioGetMaxExtSemTableSize] ifFalse: [0]. 0 } do:
[:short| self putShort: short toFile: file].
"Pad the rest of the header."
4 timesRepeat: [self putLong: 0 toFile: file].
"Position the file after the header."
file position: headerSize.
"Write the object memory."
objectMemory startOfMemory // 4 + 1
to: numberOfBytesToWrite // 4
do: [:index |
self
putLong: (objectMemory memory at: index)
toFile: file].
self success: true
]
+ ensure: [file ifNotNil: [file close]]!
- ensure: [file close]!
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 removeConstant: #COGMTVM. "this should be defined at compile time"
aCCodeGenerator
addHeaderFile:'<stddef.h>'; "for e.g. offsetof"
+ addHeaderFile:'<setjmp.h>';
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: 'AbstractInstruction * const backEnd = &aMethodLabel';
var: #methodLabel declareC: 'AbstractInstruction * const 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 asString, ']'
, (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: Cogit>>compileAbort (in category 'compile abstract instructions') -----
compileAbort
"The start of a CogMethod has a call to a run-time abort routine that either
handles an in-line cache failure or a stack overflow. The routine selects the
path depending on ReceiverResultReg; if zero it takes the stack overflow
path; if nonzero the in-line cache miss path. Neither of these paths returns.
The abort routine must be called; In the callee the method is located by
adding the relevant offset to the return address of the call."
stackOverflowCall := self MoveCq: 0 R: ReceiverResultReg.
+ backEnd hasLinkRegister ifTrue:
+ [self PushR: LinkReg].
sendMissCall := self Call: (self methodAbortTrampolineFor: methodOrBlockNumArgs)!
Item was changed:
----- Method: Cogit>>compileTrampolineFor:callJumpBar:numArgs:arg:arg:arg:arg:saveRegs:resultReg: (in category 'initialization') -----
compileTrampolineFor: aRoutine callJumpBar: callJumpBar "<Boolean>" numArgs: numArgs arg: regOrConst0 arg: regOrConst1 arg: regOrConst2 arg: regOrConst3 saveRegs: saveRegs resultReg: resultRegOrNil
"Generate a trampoline with up to four arguments. Generate either a call or a jump to aRoutine
as requested by callJumpBar. If generating a call and resultRegOrNil is non-zero pass the C result
back in resultRegOrNil.
Hack: a negative value indicates an abstract register, a non-negative value indicates a constant."
<var: #aRoutine type: #'void *'>
<inline: false>
+ "If on a RISC processor the return address needs to be pushed to the
+ stack so that the interpreter sees the same stack layout as on CISC."
+ backEnd hasLinkRegister ifTrue:
+ [self PushR: LinkReg].
self genSaveStackPointers.
self genLoadCStackPointers.
cStackAlignment > BytesPerWord ifTrue:
[backEnd
genAlignCStackSavingRegisters: saveRegs
numArgs: numArgs
wordAlignment: cStackAlignment / BytesPerWord].
saveRegs ifTrue:
[callJumpBar ifFalse:
[self error: 'why save registers when you''re not going to return?'].
backEnd genSaveRegisters].
numArgs > 0 ifTrue:
[numArgs > 1 ifTrue:
[numArgs > 2 ifTrue:
[numArgs > 3 ifTrue:
[regOrConst3 < 0
ifTrue: [backEnd genPassReg: regOrConst3 asArgument: 3]
ifFalse: [backEnd genPassConst: regOrConst3 asArgument: 3]].
regOrConst2 < 0
ifTrue: [backEnd genPassReg: regOrConst2 asArgument: 2]
ifFalse: [backEnd genPassConst: regOrConst2 asArgument: 2]].
regOrConst1 < 0
ifTrue: [backEnd genPassReg: regOrConst1 asArgument: 1]
ifFalse: [backEnd genPassConst: regOrConst1 asArgument: 1]].
regOrConst0 < 0
ifTrue: [backEnd genPassReg: regOrConst0 asArgument: 0]
ifFalse: [backEnd genPassConst: regOrConst0 asArgument: 0]].
self gen: (callJumpBar ifTrue: [Call] ifFalse: [Jump])
operand: (self cCode: [aRoutine asUnsignedInteger]
inSmalltalk: [self simulatedTrampolineFor: aRoutine]).
callJumpBar ifTrue:
[resultRegOrNil ifNotNil:
[backEnd genWriteCResultIntoReg: resultRegOrNil].
saveRegs ifTrue:
[numArgs > 0 ifTrue:
[backEnd genRemoveNArgsFromStack: numArgs].
resultRegOrNil
ifNotNil: [backEnd genRestoreRegsExcept: resultRegOrNil]
ifNil: [backEnd genRestoreRegs]].
self genLoadStackPointers.
+ backEnd hasLinkRegister ifTrue:
+ [self PopR: LinkReg].
self RetN: 0]!
Item was removed:
- ----- Method: Cogit>>stackPageHeadroomBytes (in category 'jit - api') -----
- stackPageHeadroomBytes
- <api>
- "Delegate this to the processor..."
- ^backEnd stackPageInterruptHeadroomBytes!
Item was changed:
----- Method: Interpreter>>primitiveRootTable (in category 'memory space primitives') -----
primitiveRootTable
"Primitive. Answer a copy (snapshot) element of the root table.
The primitive can cause GC itself and if so the return value may
be inaccurate - in this case one should guard the read operation
by looking at the gc counter statistics."
+ self pop: argumentCount + 1 thenPush: self rootTableObject!
- | oop sz |
- <export: true>
- sz := rootTableCount.
- oop := self instantiateClass: self classArray indexableSize: sz. "can cause GC"
- sz > rootTableCount ifTrue:[sz := rootTableCount].
- 1 to: sz do:[:i|
- self storePointer: i-1 ofObject: oop withValue: (rootTable at: i).
- ].
- self pop: argumentCount + 1.
- self push: oop.!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveRootTable (in category 'memory space primitives') -----
primitiveRootTable
"Primitive. Answer a copy (snapshot) element of the root table.
The primitive can cause GC itself and if so the return value may
be inaccurate - in this case one should guard the read operation
by looking at the gc counter statistics."
+ self pop: argumentCount + 1 thenPush: objectMemory rootTableObject!
- | oop sz |
- <export: true>
- sz := objectMemory rootTableCount.
- oop := objectMemory instantiateClass: objectMemory classArray indexableSize: sz. "can cause GC"
- sz > objectMemory rootTableCount ifTrue:[sz := objectMemory rootTableCount].
- 1 to: sz do:[:i|
- objectMemory storePointer: i-1 ofObject: oop withValue: (objectMemory rootTable at: i).
- ].
- self pop: argumentCount + 1.
- self push: oop.!
Item was added:
+ ----- Method: InterpreterProxy>>callbackEnter: (in category 'callback support') -----
+ callbackEnter: callbackID
+ "Re-enter the interpreter for executing a callback"
+ <var: #callbackID type: #'sqInt *'>
+ ^self notYetImplementedError!
Item was added:
+ ----- Method: InterpreterProxy>>callbackLeave: (in category 'callback support') -----
+ callbackLeave: cbID
+ "Leave from a previous callback"
+ <var: #callbackID type: #'sqInt *'>
+ ^self notYetImplementedError!
Item was changed:
----- Method: InterpreterProxy>>disownVM: (in category 'FFI support') -----
disownVM: flags
+ ^self notYetImplementedError!
- self error: 'not yet implemented in Smalltalk'!
Item was changed:
----- Method: InterpreterProxy>>getInterruptPending (in category 'other') -----
getInterruptPending
+ ^self notYetImplementedError!
- self error: 'not yet implemented in Smalltalk'!
Item was changed:
----- Method: InterpreterProxy>>getStackPointer (in category 'other') -----
getStackPointer
<returnTypeC: #'sqInt *'>
+ ^self notYetImplementedError!
- self error: 'not yet implemented in Smalltalk'!
Item was changed:
----- Method: InterpreterProxy>>isOopImmutable: (in category 'testing') -----
isOopImmutable: anOop
<api>
+ ^self notYetImplementedError!
- ^self error: 'not yet implemented in Smalltalk'!
Item was changed:
----- Method: InterpreterProxy>>isOopMutable: (in category 'testing') -----
isOopMutable: anOop
<api>
+ ^self notYetImplementedError!
- ^self error: 'not yet implemented in Smalltalk'!
Item was changed:
----- Method: InterpreterProxy>>isYoung: (in category 'FFI support') -----
isYoung: anOop
+ ^self notYetImplementedError!
- self error: 'not yet implemented in Smalltalk'!
Item was added:
+ ----- Method: InterpreterProxy>>notYetImplementedError (in category 'private') -----
+ notYetImplementedError
+ ^self error: 'not yet implemented in Smalltalk'!
Item was changed:
----- Method: InterpreterProxy>>ownVM: (in category 'FFI support') -----
ownVM: flags
+ ^self notYetImplementedError!
- self error: 'not yet implemented in Smalltalk'!
Item was changed:
----- Method: InterpreterProxy>>setInterruptCheckChain: (in category 'other') -----
setInterruptCheckChain: aFunction
<returnTypeC: 'void (*setInterruptCheckChain(void (*aFunction)(void)))()'>
<var: #aFunction declareC: 'void (*aFunction)()'>
+ ^self notYetImplementedError!
- self error: 'not yet implemented in Smalltalk'!
Item was changed:
----- Method: InterpreterProxy>>signalNoResume: (in category 'callback support') -----
signalNoResume: aSemaphore
+ ^self notYetImplementedError!
- self error: 'not yet implemented in Smalltalk'!
Item was added:
+ ----- Method: InterpreterStackPages>>initializeStack:numSlots:pageSize: (in category 'initialization') -----
+ initializeStack: theStackPages numSlots: stackSlots pageSize: slotsPerPage
+ "Initialize the stack pages. For testing I want stack addresses to be disjoint from
+ normal memory addresses so stack addresses are negative. The first address is
+ -pageSize bytes. So for example if there are 1024 bytes per page and 3 pages
+ then the pages are organized as
+
+ byte address: -1024 <-> -2047 | -2048 <-> -3071 | -3072 <-> -4096 |
+ page 3 page 2 page 1
+ mem index: 769 <-> 513 | 512 <-> 257 | 256 <-> 1 |
+
+ The byte address is the external address corresponding to a real address in the VM.
+ mem index is the index in the memory Array holding the stack, an index internal to
+ the stack pages. The first stack page allocated will be the last page in the array of pages
+ at the highest effective address. Its base address be -1024 and grow down towards -2047."
+
+ "The lFoo's are to get around the foo->variable scheme in the C call to allocStackPages below."
+ <var: #theStackPages type: #'char *'>
+ | page structStackPageSize pageStructBase count |
+ <var: #page type: #'StackPage *'>
+ <var: #pageStructBase type: #'char *'>
+ self cCode: ''
+ inSmalltalk:
+ [self assert: stackMemory size = stackSlots.
+ self assert: stackMemory size - self extraStackBytes \\ slotsPerPage = 0.
+ self assert: stackMemory == theStackPages].
+ stackMemory := theStackPages. "For initialization in the C code."
+ self cCode: '' inSmalltalk: [pageSizeInSlots := slotsPerPage].
+ structStackPageSize := interpreter sizeof: InterpreterStackPage.
+ bytesPerPage := slotsPerPage * BytesPerWord.
+ numPages := stackSlots // (slotsPerPage + (structStackPageSize / BytesPerWord)).
+
+ "Because stack pages grow down baseAddress is at the top of a stack page and so to avoid
+ subtracting BytesPerWord from baseAddress and lastAddress in the init loop below we simply
+ push the stackPage array up one word to avoid the overlap. This word is extraStackBytes."
+ pageStructBase := theStackPages + (numPages * bytesPerPage) + BytesPerWord.
+ pages := self cCode: '(StackPage *)pageStructBase'
+ inSmalltalk:
+ [pageStructBase class.
+ (1 to: numPages) collect: [:i| InterpreterStackPage new]].
+
+ "Simulation only. Since addresses are negative the offset is positive. To make all
+ stack addresses negative we make the offset a page more than it needs to be so the
+ address of the last slot in memory (the highest address in the stack, or its start) is
+ - pageByteSize
+ and the address of the first slot (the lowest address, or its end) is
+ - pageByteSize * (numPages + 1)"
+ self cCode: '' inSmalltalk: [indexOffset := (numPages + 1) * slotsPerPage].
+ "make sure there's enough headroom"
+ self assert: interpreter stackPageByteSize - interpreter stackLimitBytes - interpreter stackLimitOffset
+ >= interpreter stackPageHeadroom.
+ 0 to: numPages - 1 do:
+ [:index|
+ page := self stackPageAt: index.
+ page
+ lastAddress: (self cCode: '(char *)theStackPages + (index * GIV(bytesPerPage))'
+ inSmalltalk: [(index * slotsPerPage - indexOffset) * BytesPerWord]);
+ baseAddress: (page lastAddress + bytesPerPage);
+ stackLimit: page baseAddress - interpreter stackLimitBytes;
+ realStackLimit: page stackLimit;
+ baseFP: 0;
+ nextPage: (self stackPageAt: (index = (numPages - 1) ifTrue: [0] ifFalse: [index + 1]));
+ prevPage: (self stackPageAt: (index = 0 ifTrue: [numPages - 1] ifFalse: [index - 1]))].
+ self cCode: ''
+ inSmalltalk:
+ [| lowestAddress highestAddress |
+ lowestAddress := (pages at: 1) lastAddress + BytesPerWord.
+ highestAddress := (pages at: numPages) baseAddress.
+ "see InterpreterStackPages>>longAt:"
+ self assert: lowestAddress // BytesPerWord + indexOffset = 1.
+ self assert: highestAddress // BytesPerWord + indexOffset = (numPages * slotsPerPage)].
+
+ "The overflow limit is the amount of stack to retain when moving frames from an overflowing
+ stack to reduce thrashing. See stackOverflowOrEvent:mayContextSwitch:"
+ page := self stackPageAt: 0.
+ overflowLimit := page baseAddress - page realStackLimit * 3 // 5.
+
+ 0 to: numPages - 1 do:
+ [:index|
+ page := self stackPageAt: index.
+ self assert: (self pageIndexFor: page baseAddress) == index.
+ self assert: (self pageIndexFor: page baseAddress - (slotsPerPage - 1 * BytesPerWord)) == index.
+ self assert: (self stackPageFor: page baseAddress) == page.
+ self assert: (self stackPageFor: page stackLimit) == page.
+ self cCode: ''
+ inSmalltalk:
+ [| memIndex |
+ memIndex := index * slotsPerPage + 1. "this is memIndex in the block above"
+ self assert: (self memIndexFor: (self oopForPointer: page baseAddress))
+ == (memIndex + slotsPerPage - 1).
+ index < (numPages - 1) ifTrue:
+ [self assert: (self stackPageFor: page baseAddress + BytesPerWord) == (self stackPageAt: index + 1)]].
+ self assert: (page trace: -1) ~= 0 "for assert checking of the page tracing flags. -1 == invalid state"].
+
+ mostRecentlyUsedPage := self stackPageAt: 0.
+ page := mostRecentlyUsedPage.
+ count := 0.
+ [| theIndex |
+ count := count + 1.
+ theIndex := self pageIndexFor: page baseAddress.
+ self assert: (self stackPageAt: theIndex) == page.
+ self assert: (self pageIndexFor: page baseAddress) == theIndex.
+ self assert: (self pageIndexFor: page stackLimit) == theIndex.
+ self assert: (self pageIndexFor: page lastAddress + BytesPerWord) == theIndex.
+ (page := page nextPage) ~= mostRecentlyUsedPage] whileTrue.
+ self assert: count == numPages.
+ self assert: self pageListIsWellFormed!
Item was removed:
- ----- Method: InterpreterStackPages>>initializeStack:numSlots:pageSize:stackLimitOffset:stackPageHeadroom: (in category 'initialization') -----
- initializeStack: theStackPages numSlots: stackSlots pageSize: slotsPerPage stackLimitOffset: stackLimitOffsetBytes stackPageHeadroom: stackPageHeadroomBytes
- "Initialize the stack pages. For testing I want stack addresses to be disjoint from
- normal memory addresses so stack addresses are negative. The first address is
- -pageSize bytes. So for example if there are 1024 bytes per page and 3 pages
- then the pages are organized as
-
- byte address: -1024 <-> -2047 | -2048 <-> -3071 | -3072 <-> -4096 |
- page 3 page 2 page 1
- mem index: 769 <-> 513 | 512 <-> 257 | 256 <-> 1 |
-
- The byte address is the external address corresponding to a real address in the VM.
- mem index is the index in the memory Array holding the stack, an index internal to
- the stack pages. The first stack page allocated will be the last page in the array of pages
- at the highest effective address. Its base address be -1024 and grow down towards -2047."
-
- "The lFoo's are to get around the foo->variable scheme in the C call to allocStackPages below."
- <var: #theStackPages type: #'char *'>
- | page structStackPageSize pageStructBase count |
- <var: #page type: #'StackPage *'>
- <var: #pageStructBase type: #'char *'>
- self cCode: ''
- inSmalltalk:
- [self assert: stackMemory size = stackSlots.
- self assert: stackMemory size - self extraStackBytes \\ slotsPerPage = 0.
- self assert: stackMemory == theStackPages].
- stackMemory := theStackPages. "For initialization in the C code."
- self cCode: '' inSmalltalk: [pageSizeInSlots := slotsPerPage].
- structStackPageSize := interpreter sizeof: InterpreterStackPage.
- bytesPerPage := slotsPerPage * BytesPerWord.
- numPages := stackSlots // (slotsPerPage + (structStackPageSize / BytesPerWord)).
-
- "Because stack pages grow down baseAddress is at the top of a stack page and so to avoid
- subtracting BytesPerWord from baseAddress and lastAddress in the init loop below we simply
- push the stackPage array up one word to avoid the overlap. This word is extraStackBytes."
- pageStructBase := theStackPages + (numPages * bytesPerPage) + BytesPerWord.
- pages := self cCode: '(StackPage *)pageStructBase'
- inSmalltalk:
- [pageStructBase class.
- (1 to: numPages) collect: [:i| InterpreterStackPage new]].
-
- "Simulation only. Since addresses are negative the offset is positive. To make all
- stack addresses negative we make the offset a page more than it needs to be so the
- address of the last slot in memory (the highest address in the stack, or its start) is
- - pageByteSize
- and the address of the first slot (the lowest address, or its end) is
- - pageByteSize * (numPages + 1)"
- self cCode: '' inSmalltalk: [indexOffset := (numPages + 1) * slotsPerPage].
-
- 0 to: numPages - 1 do:
- [:index|
- page := self stackPageAt: index.
- page
- lastAddress: (self cCode: '(char *)theStackPages + (index * GIV(bytesPerPage))'
- inSmalltalk: [(index * slotsPerPage - indexOffset) * BytesPerWord]);
- baseAddress: (page lastAddress + bytesPerPage);
- stackLimit: page lastAddress
- + stackLimitOffsetBytes
- + stackPageHeadroomBytes;
- realStackLimit: page stackLimit;
- baseFP: 0;
- nextPage: (self stackPageAt: (index = (numPages - 1) ifTrue: [0] ifFalse: [index + 1]));
- prevPage: (self stackPageAt: (index = 0 ifTrue: [numPages - 1] ifFalse: [index - 1]))].
- self cCode: ''
- inSmalltalk:
- [| lowestAddress highestAddress |
- lowestAddress := (pages at: 1) lastAddress + BytesPerWord.
- highestAddress := (pages at: numPages) baseAddress.
- "see InterpreterStackPages>>longAt:"
- self assert: lowestAddress // BytesPerWord + indexOffset = 1.
- self assert: highestAddress // BytesPerWord + indexOffset = (numPages * slotsPerPage)].
-
- "The overflow limit is the amount of stack to retain when moving frames from an overflowing
- stack to reduce thrashing. See stackOverflowOrEvent:mayContextSwitch:"
- page := self stackPageAt: 0.
- overflowLimit := page baseAddress - page realStackLimit * 3 // 5.
-
- 0 to: numPages - 1 do:
- [:index|
- page := self stackPageAt: index.
- self assert: (self pageIndexFor: page baseAddress) == index.
- self assert: (self pageIndexFor: page baseAddress - (slotsPerPage - 1 * BytesPerWord)) == index.
- self assert: (self stackPageFor: page baseAddress) == page.
- self assert: (self stackPageFor: page stackLimit) == page.
- self cCode: ''
- inSmalltalk:
- [| memIndex |
- memIndex := index * slotsPerPage + 1. "this is memIndex in the block above"
- self assert: (self memIndexFor: (self oopForPointer: page baseAddress))
- == (memIndex + slotsPerPage - 1).
- index < (numPages - 1) ifTrue:
- [self assert: (self stackPageFor: page baseAddress + BytesPerWord) == (self stackPageAt: index + 1)]].
- self assert: (page trace: -1) ~= 0 "for assert checking of the page tracing flags. -1 == invalid state"].
-
- mostRecentlyUsedPage := self stackPageAt: 0.
- page := mostRecentlyUsedPage.
- count := 0.
- [| theIndex |
- count := count + 1.
- theIndex := self pageIndexFor: page baseAddress.
- self assert: (self stackPageAt: theIndex) == page.
- self assert: (self pageIndexFor: page baseAddress) == theIndex.
- self assert: (self pageIndexFor: page stackLimit) == theIndex.
- self assert: (self pageIndexFor: page lastAddress + BytesPerWord) == theIndex.
- (page := page nextPage) ~= mostRecentlyUsedPage] whileTrue.
- self assert: count == numPages.
- self assert: self pageListIsWellFormed!
Item was changed:
----- Method: NewCoObjectMemorySimulator>>objectBefore: (in category 'testing') -----
objectBefore: addr
| oop prev |
oop := self firstObject.
+ [oop < freeStart] whileTrue:
- [oop < endOfMemory] whileTrue:
[prev := oop. "look here if debugging prev obj overlapping this one"
oop := self objectAfter: oop.
oop >= addr ifTrue: [^ prev]].
^0!
Item was changed:
----- Method: NewCoObjectMemorySimulator>>validOop: (in category 'testing') -----
validOop: oop
" Return true if oop appears to be valid "
(oop bitAnd: 1) = 1 ifTrue: [^ true]. "Integer"
(oop bitAnd: 3) = 0 ifFalse: [^ false]. "Uneven address"
+ oop >= freeStart ifTrue: [^ false]. "Out of range"
- oop >= endOfMemory ifTrue: [^ false]. "Out of range"
"could test if within the first large freeblock"
(self longAt: oop) = 4 ifTrue: [^ false].
(self headerType: oop) = 2 ifTrue: [^ false]. "Free object"
^ true!
Item was added:
+ ----- Method: NewObjectMemory>>adjustAllOopsBy: (in category 'initialization') -----
+ adjustAllOopsBy: bytesToShift
+ "Adjust all oop references by the given number of bytes. This
+ is done just after reading in an image when the new base
+ address of the object heap is different from the base address
+ in the image."
+ "di 11/18/2000 - return number of objects found"
+
+ | oop totalObjects |
+ <inline: false>
+ bytesToShift = 0 ifTrue: [^300000].
+ "this is probably an improvement over the previous answer of
+ nil, but maybe we should do the obejct counting loop and
+ simply guard the adjustFieldsAndClass... with a bytesToShift
+ = 0 ifFalse: ?"
+ totalObjects := 0.
+ oop := self firstObject.
+ [self oop: oop isLessThan: freeStart]
+ whileTrue:
+ [(self isFreeObject: oop)
+ ifFalse:
+ [totalObjects := totalObjects + 1.
+ self adjustFieldsAndClassOf: oop by: bytesToShift].
+ oop := self objectAfter: oop].
+ ^totalObjects!
Item was changed:
----- Method: NewObjectMemory>>become:with:twoWay:copyHash: (in category 'become') -----
become: array1 with: array2 twoWay: twoWayFlag copyHash: copyHashFlag
"All references to each object in array1 are swapped with all references to the corresponding object in array2. That is, all pointers to one object are replaced with with pointers to the other. The arguments must be arrays of the same length.
Returns PrimNoErr if the primitive succeeds."
"Implementation: Uses forwarding blocks to update references as done in compaction."
| start |
self leakCheckBecome ifTrue:
[self runLeakCheckerForFullGC: true].
(self isArray: array1) ifFalse:
[^PrimErrBadReceiver].
((self isArray: array2)
and: [(self lastPointerOf: array1) = (self lastPointerOf: array2)]) ifFalse:
[^PrimErrBadArgument].
(twoWayFlag or: [copyHashFlag])
ifTrue: [(self containOnlyOops: array1 and: array2) ifFalse: [^PrimErrInappropriate]]
ifFalse: [(self containOnlyOops: array1) ifFalse: [^PrimErrInappropriate]].
(self prepareForwardingTableForBecoming: array1 with: array2 twoWay: twoWayFlag) ifFalse:
[^PrimErrNoMemory]. "fail; not enough space for forwarding table"
(self allYoung: array1 and: array2)
ifTrue: [start := youngStart"sweep only the young objects plus the roots"]
ifFalse: [start := self startOfMemory"sweep all objects"].
coInterpreter preBecomeAction.
+ self mapPointersInObjectsFrom: start to: freeStart.
- self mapPointersInObjectsFrom: start to: endOfMemory.
twoWayFlag
ifTrue: [self restoreHeadersAfterBecoming: array1 with: array2]
ifFalse: [self restoreHeadersAfterForwardBecome: copyHashFlag].
coInterpreter postBecomeAction.
self initializeMemoryFirstFree: freeStart. "re-initialize memory used for forwarding table"
self leakCheckBecome ifTrue:
[self runLeakCheckerForFullGC: true].
self forceInterruptCheck. "pretty much guaranteed to take a long time, so check for timers etc ASAP"
^PrimNoErr "success"!
Item was added:
+ ----- Method: NewObjectMemory>>checkHeapIntegrity (in category 'memory access') -----
+ checkHeapIntegrity
+ "Perform an integrity/leak check using the heapMap. Assume
+ clearLeakMapAndMapAccessibleObjects has set a bit at each
+ object's header. Scan all objects in the heap checking that every
+ pointer points to a header. Scan the rootTable, remapBuffer and
+ extraRootTable checking that every entry is a pointer to a header.
+ Check that the number of roots is correct and that all rootTable
+ entries have their rootBit set. Answer if all checks pass."
+ | ok obj sz hdr fmt fi fieldOop numRootsInHeap |
+ <inline: false>
+ ok := true.
+ numRootsInHeap := 0.
+ obj := self firstObject.
+ [self oop: obj isLessThan: self startOfFreeSpace] whileTrue:
+ [(self isFreeObject: obj)
+ ifTrue:
+ [sz := self sizeOfFree: obj]
+ ifFalse:
+ [hdr := self baseHeader: obj.
+ (self isYoungRootHeader: hdr) ifTrue:
+ [numRootsInHeap := numRootsInHeap + 1].
+ (self compactClassIndexOfHeader: hdr) = 0 ifTrue:
+ [fieldOop := (self classHeader: obj) bitAnd: AllButTypeMask.
+ ((self isIntegerObject: fieldOop)
+ or: [(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
+ [self print: 'object leak in '; printHex: obj; print: ' class = '; printHex: fieldOop; cr.
+ ok := false]].
+ fmt := self formatOfHeader: hdr.
+ (fmt <= 4 "pointers" or: [fmt >= 12 "compiled method"]) ifTrue:
+ [fmt >= 12
+ ifTrue: [fi := (self literalCountOf: obj) + 1 "+ 1 = methodHeader slot"]
+ ifFalse: [(fmt = 3 and: [self isContextHeader: hdr])
+ ifTrue: [fi := CtxtTempFrameStart + (self fetchStackPointerOf: obj)]
+ ifFalse: [fi := self lengthOf: obj]].
+ [(fi := fi - 1) >= 0] whileTrue:
+ [fieldOop := self fetchPointer: fi ofObject: obj.
+ (self isNonIntegerObject: fieldOop) ifTrue:
+ [(fieldOop bitAnd: BytesPerWord - 1) ~= 0
+ ifTrue:
+ [self print: 'misaligned oop in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
+ ok := false]
+ ifFalse:
+ [(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
+ [self print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
+ ok := false]]]]].
+ sz := self sizeBitsOf: obj].
+ obj := self oopFromChunk: obj + sz].
+ numRootsInHeap ~= rootTableCount ifTrue:
+ [self print: 'root count mismatch. #heap roots '; printNum: numRootsInHeap; print: '; #roots '; printNum: rootTableCount; cr.
+ "But the system copes with overflow..."
+ ok := rootTableOverflowed and: [needGCFlag]].
+ 1 to: rootTableCount do:
+ [:ri|
+ obj := rootTable at: ri.
+ (obj bitAnd: BytesPerWord - 1) ~= 0
+ ifTrue:
+ [self print: 'misaligned oop in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ ok := false]
+ ifFalse:
+ [(self heapMapAtWord: (self pointerForOop: obj)) = 0
+ ifTrue:
+ [self print: 'object leak in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ ok := false]
+ ifFalse:
+ [hdr := self baseHeader: obj.
+ (self isYoungRootHeader: hdr) ifFalse:
+ [self print: 'non-root in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ ok := false]]]].
+ 1 to: remapBufferCount do:
+ [:ri|
+ obj := remapBuffer at: ri.
+ (obj bitAnd: BytesPerWord - 1) ~= 0
+ ifTrue:
+ [self print: 'misaligned remapRoot @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ ok := false]
+ ifFalse:
+ [(self heapMapAtWord: (self pointerForOop: obj)) = 0
+ ifTrue:
+ [self print: 'object leak in remapRoots @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ ok := false]]].
+ 1 to: extraRootCount do:
+ [:ri|
+ obj := (extraRoots at: ri) at: 0.
+ (obj bitAnd: BytesPerWord - 1) ~= 0
+ ifTrue:
+ [self print: 'misaligned extraRoot @ '; printNum: ri; print: ' => '; printHex: obj; cr.
+ ok := false]
+ ifFalse:
+ [(self heapMapAtWord: (self pointerForOop: obj)) = 0
+ ifTrue:
+ [self print: 'object leak in extraRoots @ '; printNum: ri; print: ' => '; printHex: obj; cr.
+ ok := false]]].
+ ^ok!
Item was changed:
----- Method: NewObjectMemory>>checkOkayOop: (in category 'debug support') -----
checkOkayOop: oop
"Verify that the given oop is legitimate. Check address, header, and size but not class.
Answer true if OK. Otherwise print reason and answer false."
<api>
<var: #oop type: #usqInt>
| sz type fmt unusedBit |
"address and size checks"
(self isIntegerObject: oop) ifTrue: [ ^true ].
+ ((self oop: oop isGreaterThanOrEqualTo: self startOfMemory) and: [self oop: oop isLessThan: freeStart])
+ ifFalse: [ self print: 'oop '; printHex: oop; print: ' is not a valid address'; cr. ^false ].
- (oop >= self startOfMemory and: [oop < freeStart])
- ifFalse: [ self print: 'oop is not a valid address'; cr. ^false ].
((oop \\ BytesPerWord) = 0)
+ ifFalse: [ self print: 'oop '; printHex: oop; print: ' is not a word-aligned address'; cr. ^false ].
- ifFalse: [ self print: 'oop is not a word-aligned address'; cr. ^false ].
sz := self sizeBitsOf: oop.
+ (self oop: oop + sz isLessThanOrEqualTo: freeStart)
+ ifFalse: [ self print: 'oop '; printHex: oop; print: ' size would make it extend beyond the end of memory'; cr. ^false ].
- (oop + sz) < freeStart
- ifFalse: [ self print: 'oop size would make it extend beyond the end of memory'; cr. ^false ].
"header type checks"
type := self headerType: oop.
type = HeaderTypeFree
+ ifTrue: [ self print: 'oop '; printHex: oop; print: ' is a free chunk, not an object'; cr. ^false ].
- ifTrue: [ self print: 'oop is a free chunk, not an object'; cr. ^false ].
type = HeaderTypeShort ifTrue: [
(self compactClassIndexOf: oop) = 0
+ ifTrue: [ self print: 'oop '; printHex: oop; print: ' cannot have zero compact class field in a short header'; cr. ^false ].
- ifTrue: [ self print: 'cannot have zero compact class field in a short header'; cr. ^false ].
].
type = HeaderTypeClass ifTrue: [
((oop >= BytesPerWord) and: [(self headerType: oop - BytesPerWord) = type])
+ ifFalse: [ self print: 'oop '; printHex: oop; print: ' class header word has wrong type'; cr. ^false ].
- ifFalse: [ self print: 'class header word has wrong type'; cr. ^false ].
].
type = HeaderTypeSizeAndClass ifTrue: [
((oop >= (BytesPerWord*2)) and:
[(self headerType: oop - (BytesPerWord*2)) = type and:
[(self headerType: oop - BytesPerWord) = type]])
+ ifFalse: [ self print: 'oop '; printHex: oop; print: ' class header word has wrong type'; cr. ^false ].
- ifFalse: [ self print: 'class header word has wrong type'; cr. ^false ].
].
"format check"
fmt := self formatOf: oop.
((fmt = 5) | (fmt = 7))
+ ifTrue: [ self print: 'oop '; printHex: oop; print: ' has an unknown format type'; cr. ^false ].
- ifTrue: [ self print: 'oop has an unknown format type'; cr. ^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 print: 'oop '; printHex: oop; print: ' unused header bit 30 is set; should be zero'; cr. ^false ].
- ifFalse: [ self print: 'unused header bit 30 is set; should be zero'; cr. ^false ].
"xxx
((self longAt: oop) bitAnd: MarkBit) = 0
ifFalse: [ self print: 'mark bit should not be set except during GC' ].
xxx"
((self isYoungRoot: oop) and: [oop >= youngStart])
+ ifTrue: [ self print: 'oop '; printHex: oop; print: ' root bit is set in a young object'; cr. ^false ].
- ifTrue: [ self print: 'root bit is set in a young object'; cr. ^false ].
^true
!
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."
<inline: false>
fullGCLock > 0 ifTrue:
[self warning: 'aborting fullGC because fullGCLock > 0'.
^self].
self runLeakCheckerForFullGC: true.
self preGCAction: GCModeFull.
+ needGCFlag := false.
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>>incCompMakeFwd (in category 'gc -- compaction') -----
incCompMakeFwd
"Create and initialize forwarding blocks for all non-free objects
following compStart. If the supply of forwarding blocks is exhausted,
set compEnd to the first chunk above the area to be compacted;
otherwise, set it to endOfMemory. Return the number of bytes to be freed."
| bytesToBeFreed oop fwdBlock newOop |
<inline: false>
bytesToBeFreed := 0.
oop := self oopFromChunk: compStart.
self assert: (self oop: oop isGreaterThan: self startOfMemory andLessThan: freeStart).
[self oop: oop isLessThan: freeStart] whileTrue:
[statMkFwdCount := statMkFwdCount + 1.
self assert: (self oop: oop isGreaterThan: self startOfMemory andLessThan: freeStart).
(self isFreeObject: oop)
ifTrue: [bytesToBeFreed := bytesToBeFreed + (self sizeOfFree: oop)]
ifFalse: "create a forwarding block for oop"
[fwdBlock := self fwdBlockGet: BytesPerWord*2.
"Two-word block"
fwdBlock = nil ifTrue: "stop; we have used all available forwarding blocks"
[compEnd := self chunkFromOop: oop.
^bytesToBeFreed].
newOop := oop - bytesToBeFreed.
self assert: (self oop: newOop isGreaterThan: self startOfMemory andLessThan: freeStart).
self initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: false].
oop := self objectAfterWhileForwarding: oop].
+ compEnd := freeStart.
- compEnd := endOfMemory.
^bytesToBeFreed!
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>
+ rootTableOverflowed ifTrue:
+ ["root table overflow; cannot do an incremental GC because some roots are missing.
+ (this should be very rare)"
- rootTableCount >= RootTableSize ifTrue:
- ["root table overflow; cannot do an incremental GC (this should be very rare)"
statRootTableOverflows := statRootTableOverflows + 1.
^self fullGC].
self runLeakCheckerForFullGC: false.
self preGCAction: GCModeIncr.
+ needGCFlag := false.
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 changed:
----- Method: NewObjectMemory>>initialize (in category 'initialization') -----
initialize
<doNotGenerate>
"Initialize NewObjectMemory when simulating the VM inside Smalltalk."
super initialize.
+ checkForLeaks := fullGCLock := 0.
+ needGCFlag := false!
- checkForLeaks := fullGCLock := 0!
Item was changed:
----- Method: NewObjectMemory>>initializeMemoryFirstFree: (in category 'initialization') -----
initializeMemoryFirstFree: firstFree
"Initialize endOfMemory to the top of oop storage space, reserving some space
for forwarding blocks, and set freeStart from which space is allocated."
"Note: The amount of space reserved for forwarding blocks should be chosen to
ensure that incremental compactions can usually be done in a single pass.
However, there should be enough forwarding blocks so a full compaction can be done
in a reasonable number of passes, say ten. (A full compaction requires N object-moving
passes, where N = number of non-garbage objects / number of forwarding blocks).
di 11/18/2000 Re totalObjectCount: Provide a margin of one byte per object to be
used for forwarding pointers at GC time. Since fwd blocks are 8 bytes, this means
an absolute worst case of 8 passes to compact memory. In most cases it will be
adequate to do compaction in a single pass. "
| fwdBlockBytes totalReserve |
"reserve space for forwarding blocks and the interpreter. We can sacrifice
forwarding block space at the cost of slower compactions but we cannot
safely sacrifice interpreter allocation headroom."
fwdBlockBytes := totalObjectCount bitAnd: WordMask - BytesPerWord + 1.
totalReserve := fwdBlockBytes + self interpreterAllocationReserveBytes.
(self oop: memoryLimit - totalReserve isLessThan: firstFree + BaseHeaderSize) ifTrue:
["reserve enough space for a minimal free block of BaseHeaderSize bytes.
We are apparently in an emergency situation here because we have no space
for reserve and forwarding blocks. But a full GC will occur immediately in
sufficientSpaceAfterGC: which will grow memory and restore the reserve."
fwdBlockBytes := memoryLimit - (firstFree + BaseHeaderSize)].
"set endOfMemory reserveStart and freeStart"
self setEndOfMemory: memoryLimit - fwdBlockBytes.
reserveStart := endOfMemory - self interpreterAllocationReserveBytes.
freeStart := firstFree. "bytes available for oops"
scavengeThreshold := freeStart + edenBytes min: reserveStart.
+ self maybeFillWithAllocationCheckFillerFrom: freeStart to: scavengeThreshold.
- AllocationCheckFiller ~= 0 ifTrue:
- [freeStart to: scavengeThreshold by: BytesPerWord do:
- [:i| self longAt: i put: (AllocationCheckFiller == 16rADD4E55
- ifTrue: [i]
- ifFalse: [AllocationCheckFiller])]].
- needGCFlag := false.
+ self assert: (self oop: freeStart isLessThan: reserveStart).
+ "We would like to assert this but can't because in GC situations it may be false. It is
+ established by sufficientSpaceToAllocate: and sufficientSpaceAfterGC:"
+ false ifTrue: [self assert: (self oop: reserveStart isLessThan: endOfMemory)].
+ self assert: (self oop: endOfMemory isLessThan: memoryLimit)!
- self assert: freeStart < reserveStart.
- self assert: reserveStart < endOfMemory.
- self assert: endOfMemory < memoryLimit!
Item was changed:
----- Method: NewObjectMemory>>initializeObjectMemory: (in category 'initialization') -----
initializeObjectMemory: bytesToShift
"Initialize object memory variables at startup time. Assume endOfMemory is initially set (by the image-reading code) to the end of the last object in the image. Initialization redefines endOfMemory to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks."
"Assume: image reader initializes the following variables:
memory
endOfMemory
memoryLimit
specialObjectsOop
lastHash
"
"di 11/18/2000 fix slow full GC"
<inline: false>
"set the start of the young object space"
+ youngStart := freeStart := endOfMemory.
- youngStart := endOfMemory.
"image may be at a different address; adjust oops for new location"
totalObjectCount := self adjustAllOopsBy: bytesToShift.
self initializeMemoryFirstFree: endOfMemory. "initializes endOfMemory, freeStart"
specialObjectsOop := specialObjectsOop + bytesToShift.
"heavily used special objects"
nilObj := self splObj: NilObject.
falseObj := self splObj: FalseObject.
trueObj := self splObj: TrueObject.
rootTableCount := 0.
+ rootTableOverflowed := false.
lowSpaceThreshold := 0.
signalLowSpace := false.
compStart := 0.
compEnd := 0.
fwdTableNext := 0.
fwdTableLast := 0.
remapBufferCount := 0.
tenuringThreshold := 2000. "tenure all suriving objects if survivor count is over this threshold"
growHeadroom := 4*1024*1024. "four megabytes of headroom when growing"
shrinkThreshold := 8*1024*1024. "eight megabytes of free space before shrinking"
"garbage collection statistics"
statFullGCs := 0.
statFullGCUsecs := 0.
statIncrGCs := 0.
statIncrGCUsecs := 0.
statTenures := 0.
statRootTableOverflows := 0.
statGrowMemory := 0.
statShrinkMemory := 0.
forceTenureFlag := 0.
gcBiasToGrow := 0.
gcBiasToGrowGCLimit := 0.
extraRootCount := 0.
!
Item was added:
+ ----- Method: NewObjectMemory>>maybeFillWithAllocationCheckFillerFrom:to: (in category 'allocation') -----
+ maybeFillWithAllocationCheckFillerFrom: start to: end
+ "Fill free memory with a bit pattern for chekcing if the last object has been overwritten."
+ <inline: true>
+ AllocationCheckFiller ~= 0 ifTrue:
+ [start to: end by: BytesPerWord do:
+ [:i|
+ self longAt: i put: (AllocationCheckFiller = 16rADD4E55
+ ifTrue: [i]
+ ifFalse: [AllocationCheckFiller])]]!
Item was removed:
- ----- Method: NewObjectMemory>>needGCFlag: (in category 'accessing') -----
- needGCFlag: aValue
- ^needGCFlag := aValue!
Item was changed:
----- Method: NewObjectMemory>>noteAsRoot:headerLoc: (in category 'garbage collection') -----
noteAsRoot: oop headerLoc: headerLoc
+ "Record that the given oop in the old object area points to an object in the young area.
+ HeaderLoc is usually = oop, but may be an addr in a forwarding block."
- "Record that the given oop in the old object area points to an
- object in the young area. HeaderLoc is usually = oop, but may
- be an addr in a forwarding block."
| header |
<inline: true>
<asmLabel: false>
header := self longAt: headerLoc.
(self isYoungRootHeader: header) ifFalse:
"record oop as root only if not already recorded"
+ [rootTableCount < RootTableSize
+ ifTrue:
+ "record root if there is enough room in the roots table.
+ IMPORTANT: since clearRootsTable is the only thing that clears root bits
+ do *not* set the root bit unless an object is in the root table. checking
+ routines will complain about the root bit being unset instead of the table
+ being full, but that's life"
+ [rootTableCount := rootTableCount + 1.
+ rootTable at: rootTableCount put: oop.
+ self longAt: headerLoc put: (header bitOr: RootBit).
+ rootTableCount >= RootTableRedZone ifTrue:
+ "if we're now in the red zone force an IGC ASAP"
+ [self scheduleIncrementalGC]]
+ ifFalse: "note overflow; will need to do a fullGC instead of an incremental."
+ [rootTableOverflowed := true]]!
- [rootTableCount < RootTableSize ifTrue:
- "record root if there is enough room in the roots table"
- [rootTableCount := rootTableCount + 1.
- rootTable at: rootTableCount put: oop.
- self longAt: headerLoc put: (header bitOr: RootBit).
- rootTableCount > RootTableRedZone ifTrue:
- "if we're now in the red zone force an IGC ASAP"
- [self scheduleIncrementalGC]]]!
Item was added:
+ ----- Method: NewObjectMemory>>objectAfter: (in category 'object enumeration') -----
+ objectAfter: oop
+ "Return the object or free chunk immediately following the
+ given object or free chunk in memory. Return endOfMemory
+ when enumeration is complete."
+ | sz |
+ <api>
+ <inline: true>
+ <asmLabel: false>
+ (self asserta: (self oop: oop isLessThan: freeStart)) ifFalse:
+ [self error: 'no objects after the end of memory'].
+ (self isFreeObject: oop)
+ ifTrue: [sz := self sizeOfFree: oop]
+ ifFalse: [sz := self sizeBitsOf: oop].
+ ^self oopFromChunk: oop + sz!
Item was added:
+ ----- Method: NewObjectMemory>>setEndOfMemory: (in category 'initialization') -----
+ setEndOfMemory: newEndOfMemory
+ super setEndOfMemory: newEndOfMemory.
+ freeStart isNil ifTrue:
+ [freeStart := newEndOfMemory]!
Item was added:
+ ----- Method: NewObjectMemory>>shorten:toIndexableSize: (in category 'allocation') -----
+ shorten: obj toIndexableSize: nSlots
+ "Currently this works for pointer objects only, and is almost certainly wrong for 64 bits."
+ | deltaBytes desiredLength fixedFields fmt hdr totalLength |
+ (self isPointers: obj) ifFalse:
+ [^obj].
+ hdr := self baseHeader: obj.
+ fmt := self formatOfHeader: hdr.
+ totalLength := self lengthOf: obj baseHeader: hdr format: fmt.
+ fixedFields := self fixedFieldsOf: obj format: fmt length: totalLength.
+ desiredLength := fixedFields + nSlots.
+ deltaBytes := (totalLength - desiredLength) * BytesPerWord.
+ obj + BaseHeaderSize + (totalLength * BytesPerWord) = freeStart
+ ifTrue: "Shortening the last object. Need to reduce freeStart."
+ [self maybeFillWithAllocationCheckFillerFrom: obj + BaseHeaderSize + (desiredLength * BytesPerWord) to: freeStart.
+ freeStart := obj + BaseHeaderSize + (desiredLength * BytesPerWord)]
+ ifFalse: "Shortening some interior object. Need to create a free block."
+ [self setSizeOfFree: obj + BaseHeaderSize + (desiredLength * BytesPerWord)
+ to: deltaBytes].
+ (self headerType: obj) caseOf: {
+ [HeaderTypeSizeAndClass] ->
+ [self longAt: obj put: hdr - deltaBytes].
+ [HeaderTypeClass] ->
+ [self longAt: obj put: ((hdr bitClear: SizeMask) bitOr: (hdr bitAnd: SizeMask) - deltaBytes)].
+ [HeaderTypeShort] ->
+ [self longAt: obj put: ((hdr bitClear: SizeMask) bitOr: (hdr bitAnd: SizeMask) - deltaBytes)] }.
+ ^obj!
Item was changed:
----- Method: NewObjectMemorySimulator>>objectBefore: (in category 'testing') -----
objectBefore: addr
| oop prev |
oop := self firstObject.
+ [oop < freeStart] whileTrue:
- [oop < endOfMemory] whileTrue:
[prev := oop. "look here if debugging prev obj overlapping this one"
oop := self objectAfter: oop.
oop >= addr ifTrue: [^ prev]].
^0!
Item was changed:
----- Method: NewObjectMemorySimulator>>validOop: (in category 'testing') -----
validOop: oop
" Return true if oop appears to be valid "
(oop bitAnd: 1) = 1 ifTrue: [^ true]. "Integer"
(oop bitAnd: 3) = 0 ifFalse: [^ false]. "Uneven address"
+ oop >= freeStart ifTrue: [^ false]. "Out of range"
- oop >= endOfMemory ifTrue: [^ false]. "Out of range"
"could test if within the first large freeblock"
(self longAt: oop) = 4 ifTrue: [^ false].
(self headerType: oop) = 2 ifTrue: [^ false]. "Free object"
^ true!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveRootTable (in category 'memory space primitives') -----
primitiveRootTable
"Primitive. Answer a copy (snapshot) element of the root table.
The primitive can cause GC itself and if so the return value may
be inaccurate - in this case one should guard the read operation
by looking at the gc counter statistics."
+ self pop: argumentCount + 1 thenPush: self rootTableObject!
- | oop sz |
- <export: true>
- sz := rootTableCount.
- oop := self instantiateClass: self classArray indexableSize: sz. "can cause GC"
- sz > rootTableCount ifTrue:[sz := rootTableCount].
- 1 to: sz do:[:i|
- self storePointer: i-1 ofObject: oop withValue: (rootTable at: i).
- ].
- self pop: argumentCount + 1.
- self push: oop.!
Item was changed:
----- Method: NewspeakInterpreterSimulator>>writeImageFileIO: (in category 'image save/restore') -----
writeImageFileIO: numberOfBytesToWrite
"Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."
| headerSize file |
BytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
headerSize := 64.
[
+ file := FileStream fileNamed: imageName.
+ file == nil ifTrue:
+ [self primitiveFail.
+ ^nil].
+ file binary.
- file := (FileStream fileNamed: imageName) binary.
- file == nil ifTrue: [^nil].
{
self imageFormatVersion.
headerSize.
numberOfBytesToWrite.
self startOfMemory.
specialObjectsOop.
lastHash.
self ioScreenSize.
fullScreenFlag.
extraVMMemory
}
do: [:long | self putLong: long toFile: file].
"Pad the rest of the header."
7 timesRepeat: [self putLong: 0 toFile: file].
"Position the file after the header."
file position: headerSize.
"Write the object memory."
1
to: numberOfBytesToWrite // 4
do: [:index |
self
putLong: (memory at: index)
toFile: file].
self success: true
]
+ ensure: [file ifNotNil: [file close]]!
- ensure: [file close]!
Item was changed:
VMClass subclass: #ObjectMemory
+ instanceVariableNames: 'memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop rootTable rootTableCount rootTableOverflowed extraRoots extraRootCount weakRoots weakRootCount child field parentField freeBlock lastHash allocationCount lowSpaceThreshold signalLowSpace compStart compEnd fwdTableNext fwdTableLast remapBuffer remapBufferCount allocationsBetweenGCs tenuringThreshold gcBiasToGrow gcBiasToGrowGCLimit gcBiasToGrowThreshold statFullGCs statIncrGCs statFullGCUsecs statIncrGCUsecs statGCEndTime statIGCDeltaUsecs statTenures statRootTableOverflows freeContexts freeLargeContexts interruptCheckCounter totalObjectCount shrinkThreshold growHeadroom headerTypeBytes youngStartLocal statMarkCount statMarkCountLocal statSweepCount statMkFwdCount statCompMoveCount statGrowMemory statShrinkMemory statRootTableCount statAllocationCount statSurvivorCount statSpecialMarkCount forceTenureFlag gcStartUsecs'
- instanceVariableNames: 'memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop rootTable rootTableCount extraRoots extraRootCount weakRoots weakRootCount child field parentField freeBlock lastHash allocationCount lowSpaceThreshold signalLowSpace compStart compEnd fwdTableNext fwdTableLast remapBuffer remapBufferCount allocationsBetweenGCs tenuringThreshold gcBiasToGrow gcBiasToGrowGCLimit gcBiasToGrowThreshold statFullGCs statIncrGCs statFullGCUsecs statIncrGCUsecs statGCEndTime statIGCDeltaUsecs statTenures statRootTableOverflows freeContexts freeLargeContexts interruptCheckCounter totalObjectCount shrinkThreshold growHeadroom headerTypeBytes youngStartLocal statMarkCount statMarkCountLocal statSweepCount statMkFwdCount statCompMoveCount statGrowMemory statShrinkMemory statRootTableCount statAllocationCount statSurvivorCount statSpecialMarkCount forceTenureFlag gcStartUsecs'
classVariableNames: 'AllButHashBits AllButImmutabilityBit AllButMarkBit AllButMarkBitAndTypeMask AllButRootBit Done ExtraRootSize GCTopMarker HashBits HeaderTypeClass HeaderTypeExtraBytes HeaderTypeFree HeaderTypeGC LongSizeNumBits NilContext RemapBufferSize RootTableRedZone RootTableSize StartField StartObj Upward WeakRootTableSize WordMask'
poolDictionaries: 'VMBasicConstants VMObjectIndices VMSqueakV3BytecodeConstants VMSqueakV3ObjectRepresentationConstants'
category: 'VMMaker-Interpreter'!
!ObjectMemory commentStamp: '<historical>' prior: 0!
This class describes a 32-bit direct-pointer object memory for Smalltalk. The model is very simple in principle: a pointer is either a SmallInteger or a 32-bit direct object pointer.
SmallIntegers are tagged with a low-order bit equal to 1, and an immediate 31-bit 2s-complement signed value in the rest of the word.
All object pointers point to a header, which may be followed by a number of data fields. This object memory achieves considerable compactness by using a variable header size (the one complexity of the design). The format of the 0th header word is as follows:
3 bits reserved for gc (mark, root, unused)
12 bits object hash (for HashSets)
5 bits compact class index
4 bits object format
6 bits object size in 32-bit words
2 bits header type (0: 3-word, 1: 2-word, 2: forbidden, 3: 1-word)
If a class is in the compact class table, then this is the only header information needed. If it is not, then it will have another header word at offset -4 bytes with its class in the high 30 bits, and the header type repeated in its low 2 bits. It the objects size is greater than 255 bytes, then it will have yet another header word at offset -8 bytes with its full word size in the high 30 bits and its header type repeated in the low two bits.
The object format field provides the remaining information as given in the formatOf: method (including isPointers, isVariable, isBytes, and the low 2 size bits of byte-sized objects).
This implementation includes incremental (2-generation) and full garbage collection, each with compaction and rectification of direct pointers. It also supports a bulk-become (exchange object identity) feature that allows many objects to be becomed at once, as when all instances of a class must be grown or shrunk.
There is now a simple 64-bit version of the object memory. It is the simplest possible change that could work. It merely sign-extends all integer oops, and extends all object headers and oops by adding 32 zeroes in the high bits. The format of the base header word is changed in one minor, not especially elegant, way. Consider the old 32-bit header:
ggghhhhhhhhhhhhcccccffffsssssstt
The 64-bit header is almost identical, except that the size field (now being in units of 8 bytes, has a zero in its low-order bit. At the same time, the byte-size residue bits for byte objects, which are in the low order bits of formats 8-11 and 12-15, are now in need of another bit of residue. So, the change is as follows:
ggghhhhhhhhhhhhcccccffffsssssrtt
where bit r supplies the 4's bit of the byte size residue for byte objects. Oh, yes, this is also needed now for 'variableWord' objects, since their size in 32-bit words requires a low-order bit.
See the comment in formatOf: for the change allowing for 64-bit wide bitmaps, now dubbed 'variableLong'.!
Item was changed:
----- Method: ObjectMemory>>beRootWhileForwarding: (in category 'gc -- compaction') -----
beRootWhileForwarding: oop
"Record that the given oop in the old object area points to an object in the young area when oop may be forwarded."
"Warning: No young objects should be recorded as roots. Callers are responsible for ensuring this constraint is not violated."
+ <inline: false> "for debugging..."
+ | header fwdBlock headerLoc |
-
- | header fwdBlock |
"If labelled, gcc duplicates the label when inlining updatePointersInRangeFrom:to:"
+ <asmLabel: false>
- <asmLabel: false>
header := self longAt: oop.
(header bitAnd: MarkBit) ~= 0
+ ifTrue: "This oop is forwarded"
+ [fwdBlock := (header bitAnd: AllButMarkBitAndTypeMask) << 1.
+ self assert: (self fwdBlockValid: fwdBlock).
+ headerLoc := fwdBlock + BytesPerWord]
+ ifFalse: "Normal -- no forwarding"
+ [headerLoc := oop].
+ "use headerLoc var to eliminate duplication on inlining noteAsRoot:headerLoc:
+ older versions of this method had two separate sends of noteAsRoot:headerLoc:"
+ self noteAsRoot: oop headerLoc: headerLoc!
- ifTrue: ["This oop is forwarded"
- fwdBlock := (header bitAnd: AllButMarkBitAndTypeMask) << 1.
- self assert: (self fwdBlockValid: fwdBlock).
- self noteAsRoot: oop headerLoc: fwdBlock + BytesPerWord]
- ifFalse: ["Normal -- no forwarding"
- self noteAsRoot: oop headerLoc: oop]!
Item was changed:
----- Method: ObjectMemory>>checkHeapIntegrity (in category 'memory access') -----
checkHeapIntegrity
"Perform an integrity/leak check using the heapMap. Assume
clearLeakMapAndMapAccessibleObjects has set a bit at each
object's header. Scan all objects in the heap checking that every
pointer points to a header. Scan the rootTable, remapBuffer and
extraRootTable checking that every entry is a pointer to a header.
Check that the number of roots is correct and that all rootTable
entries have their rootBit set. Answer if all checks pass."
| ok obj sz hdr fmt fi fieldOop numRootsInHeap |
<inline: false>
ok := true.
numRootsInHeap := 0.
obj := self firstObject.
[self oop: obj isLessThan: self startOfFreeSpace] whileTrue:
[(self isFreeObject: obj)
ifTrue:
[sz := self sizeOfFree: obj]
ifFalse:
[hdr := self baseHeader: obj.
(self isYoungRootHeader: hdr) ifTrue:
[numRootsInHeap := numRootsInHeap + 1].
(self compactClassIndexOfHeader: hdr) = 0 ifTrue:
[fieldOop := (self classHeader: obj) bitAnd: AllButTypeMask.
((self isIntegerObject: fieldOop)
or: [(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
[self print: 'object leak in '; printHex: obj; print: ' class = '; printHex: fieldOop; cr.
ok := false]].
fmt := self formatOfHeader: hdr.
(fmt <= 4 "pointers" or: [fmt >= 12 "compiled method"]) ifTrue:
[fmt >= 12
ifTrue: [fi := (self literalCountOf: obj) + 1 "+ 1 = methodHeader slot"]
ifFalse: [(fmt = 3 and: [self isContextHeader: hdr])
ifTrue: [fi := CtxtTempFrameStart + (self fetchStackPointerOf: obj)]
ifFalse: [fi := self lengthOf: obj]].
[(fi := fi - 1) >= 0] whileTrue:
[fieldOop := self fetchPointer: fi ofObject: obj.
(self isNonIntegerObject: fieldOop) ifTrue:
[(fieldOop bitAnd: BytesPerWord - 1) ~= 0
ifTrue:
[self print: 'misaligned oop in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
ok := false]
ifFalse:
[(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
[self print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
ok := false]]]]].
sz := self sizeBitsOf: obj].
obj := self oopFromChunk: obj + sz].
numRootsInHeap ~= rootTableCount ifTrue:
[self print: 'root count mismatch. #heap roots '; printNum: numRootsInHeap; print: '; #roots '; printNum: rootTableCount; cr.
+ "But the system copes with overflow..."
+ ok := rootTableOverflowed and: [allocationCount > allocationsBetweenGCs]].
- ok := false].
1 to: rootTableCount do:
[:ri|
obj := rootTable at: ri.
(obj bitAnd: BytesPerWord - 1) ~= 0
ifTrue:
[self print: 'misaligned oop in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
ok := false]
ifFalse:
[(self heapMapAtWord: (self pointerForOop: obj)) = 0
ifTrue:
[self print: 'object leak in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
ok := false]
ifFalse:
[hdr := self baseHeader: obj.
(self isYoungRootHeader: hdr) ifFalse:
[self print: 'non-root in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
ok := false]]]].
1 to: remapBufferCount do:
[:ri|
obj := remapBuffer at: ri.
(obj bitAnd: BytesPerWord - 1) ~= 0
ifTrue:
[self print: 'misaligned remapRoot @ '; printNum: ri; print: ' = '; printHex: obj; cr.
ok := false]
ifFalse:
[(self heapMapAtWord: (self pointerForOop: obj)) = 0
ifTrue:
[self print: 'object leak in remapRoots @ '; printNum: ri; print: ' = '; printHex: obj; cr.
ok := false]]].
1 to: extraRootCount do:
[:ri|
obj := (extraRoots at: ri) at: 0.
(obj bitAnd: BytesPerWord - 1) ~= 0
ifTrue:
[self print: 'misaligned extraRoot @ '; printNum: ri; print: ' => '; printHex: obj; cr.
ok := false]
ifFalse:
[(self heapMapAtWord: (self pointerForOop: obj)) = 0
ifTrue:
[self print: 'object leak in extraRoots @ '; printNum: ri; print: ' => '; printHex: obj; cr.
ok := false]]].
^ok!
Item was added:
+ ----- Method: ObjectMemory>>checkOkayYoungReferrer: (in category 'debug support') -----
+ checkOkayYoungReferrer: obj
+ "Verify that the given obj is a valid youngReferrer. Check RootBit is set and
+ is in rootTable. Answer true if OK. Otherwise print reason and answer false.
+ Assumes the object contains young references."
+
+ (self oop: obj isGreaterThanOrEqualTo: youngStart) ifTrue:
+ [^true].
+
+ (self isYoungRoot: obj) ifFalse:
+ [ self print: 'root bit is not set in '; printHex: obj; cr. ^false ].
+
+ 1 to: rootTableCount do:
+ [:i| obj = (rootTable at: i) ifTrue: [^true]].
+
+ self printHex: obj; print: ' has root bit set but is not in rootTable'; cr.
+
+ ^false
+ !
Item was changed:
----- Method: ObjectMemory>>clearRootsTable (in category 'garbage collection') -----
clearRootsTable
+ "Clear the root bits of the current roots, then empty the roots table. "
+ "Caution: This should only be done when the young object space is empty."
+ "reset the roots table (after this, all objects are old so there are no roots)"
+ 1 to: rootTableCount do:
+ [:i | | oop |
+ oop := rootTable at: i.
+ self longAt: oop put: ((self longAt: oop) bitAnd: AllButRootBit).
+ rootTable at: i put: 0].
+ rootTableCount := 0.
+ rootTableOverflowed := false.!
- "Clear the root bits of the current roots, then empty the roots
- table. "
- "Caution: This should only be done when the young object
- space is empty."
- "reset the roots table (after this, all objects are old so there
- are no roots)"
- | oop |
- 1 to: rootTableCount do: [:i |
- "clear root bits of current root table entries"
- oop := rootTable at: i.
- self longAt: oop put: ((self longAt: oop) bitAnd: AllButRootBit).
- rootTable at: i put: 0].
- rootTableCount := 0!
Item was changed:
----- Method: ObjectMemory>>firstFixedField: (in category 'object format') -----
firstFixedField: oop
+ <api>
-
<returnTypeC: #'void *'>
^ self pointerForOop: oop + BaseHeaderSize!
Item was changed:
----- Method: ObjectMemory>>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>
+ rootTableOverflowed ifTrue:
+ ["root table overflow; cannot do an incremental GC because some roots are missing.
+ (this should be very rare)"
+ statRootTableOverflows := statRootTableOverflows + 1.
+ ^self fullGC].
- rootTableCount >= RootTableSize
- ifTrue: ["root table overflow; cannot do an incremental GC (this should be very rare)"
- statRootTableOverflows := statRootTableOverflows + 1.
- ^ self fullGC].
DoAssertionChecks ifTrue:
[self reverseDisplayFrom: 8 to: 15.
self checkHeapIntegrity.
self checkInterpreterIntegrity.
self validate].
self preGCAction: GCModeIncr.
"incremental GC and compaction"
gcStartUsecs := self ioUTCMicrosecondsNow.
statSweepCount := statMarkCount := statMkFwdCount := statCompMoveCount := 0.
self initWeakTableForIncrementalGC: true.
self markPhase.
self assert: weakRootCount <= WeakRootTableSize.
1 to: weakRootCount do:[:i| self finalizeReference: (weakRoots at: i)].
survivorCount := self sweepPhase.
self incrementalCompaction.
statAllocationCount := allocationCount.
allocationCount := 0.
statIncrGCs := statIncrGCs + 1.
statGCEndTime := self ioMicroMSecs.
statIGCDeltaUsecs := self ioUTCMicrosecondsNow - gcStartUsecs.
statIncrGCUsecs := statIncrGCUsecs + statIGCDeltaUsecs.
self capturePendingFinalizationSignals.
self forceInterruptCheck. "Force an an interrupt check ASAP.We could choose to be clever here and only do this under certain time conditions. Keep it simple for now"
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 sizeOfFree: freeBlock) < growHeadroom) and:
[gcBiasToGrow > 0])
ifTrue: [self biasToGrow.
weDidGrow := true].
youngStart := freeBlock].
self postGCAction.
DoAssertionChecks ifTrue:
[self validate.
self checkHeapIntegrity.
self checkInterpreterIntegrity.
self reverseDisplayFrom: 8 to: 15].
weDidGrow ifTrue: [self biasToGrowCheckGCLimit]!
Item was changed:
----- Method: ObjectMemory>>initializeObjectMemory: (in category 'initialization') -----
initializeObjectMemory: bytesToShift
"Initialize object memory variables at startup time. Assume endOfMemory is initially set (by the image-reading code) to the end of the last object in the image. Initialization redefines endOfMemory to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks."
"Assume: image reader initializes the following variables:
memory
endOfMemory
memoryLimit
specialObjectsOop
lastHash
"
"di 11/18/2000 fix slow full GC"
<inline: false>
"set the start of the young object space"
youngStart := endOfMemory.
"image may be at a different address; adjust oops for new location"
totalObjectCount := self adjustAllOopsBy: bytesToShift.
self initializeMemoryFirstFree: endOfMemory. "initializes endOfMemory, freeBlock"
specialObjectsOop := specialObjectsOop + bytesToShift.
"heavily used special objects"
nilObj := self splObj: NilObject.
falseObj := self splObj: FalseObject.
trueObj := self splObj: TrueObject.
rootTableCount := 0.
+ rootTableOverflowed := false.
freeContexts := NilContext.
freeLargeContexts := NilContext.
allocationCount := 0.
lowSpaceThreshold := 0.
signalLowSpace := false.
compStart := 0.
compEnd := 0.
fwdTableNext := 0.
fwdTableLast := 0.
remapBufferCount := 0.
allocationsBetweenGCs := 4000. "do incremental GC after this many allocations"
tenuringThreshold := 2000. "tenure all suriving objects if count is over this threshold"
growHeadroom := 4*1024*1024. "four megabyte of headroom when growing"
shrinkThreshold := 8*1024*1024. "eight megabyte of free space before shrinking"
"garbage collection statistics"
statFullGCs := 0.
statFullGCUsecs := 0.
statIncrGCs := 0.
statIncrGCUsecs := 0.
statTenures := 0.
statRootTableOverflows := 0.
statGrowMemory := 0.
statShrinkMemory := 0.
forceTenureFlag := 0.
gcBiasToGrow := 0.
gcBiasToGrowGCLimit := 0.
extraRootCount := 0.
gcStartUsecs := 0!
Item was changed:
----- Method: ObjectMemory>>isIntegerValue: (in category 'interpreter access') -----
isIntegerValue: intValue
"Answer if the given value can be represented as a Smalltalk integer value.
In C, use a shift and XOR to set the sign bit if and only if the top two bits of the given
value are the same, then test the sign bit. Note that the top two bits are equal for
exactly those integers in the range that can be represented in 31-bits or 63-bits."
+ <api>
-
^self
cCode: [(intValue bitXor: (intValue << 1)) >= 0]
inSmalltalk: [intValue >= 16r-40000000 and: [intValue <= 16r3FFFFFFF]]!
Item was changed:
----- Method: ObjectMemory>>noteAsRoot:headerLoc: (in category 'garbage collection') -----
noteAsRoot: oop headerLoc: headerLoc
+ "Record that the given oop in the old object area points to an object in the young area.
+ HeaderLoc is usually = oop, but may be an addr in a forwarding block."
- "Record that the given oop in the old object area points to an
- object in the young area.
- HeaderLoc is usually = oop, but may be an addr in a
- forwarding block."
| header |
<inline: true>
<asmLabel: false>
header := self longAt: headerLoc.
(self isYoungRootHeader: header) ifFalse:
+ "record oop as root only if not already recorded"
+ [rootTableCount < RootTableSize
+ ifTrue:
+ "record root if there is enough room in the roots table.
+ IMPORTANT: since clearRootsTable is the only thing that clears root bits
+ do *not* set the root bit unless an object is in the root table. checking
+ routines will complain about the root bit being unset instead of the table
+ being full, but that's life"
+ [rootTableCount := rootTableCount + 1.
+ rootTable at: rootTableCount put: oop.
+ self longAt: headerLoc put: (header bitOr: RootBit).
+ rootTableCount >= RootTableRedZone ifTrue:
+ "if we're now in the red zone force an IGC ASAP"
+ [allocationCount := allocationsBetweenGCs + 1]]
+ ifFalse: "note overflow; will need to do a fullGC instead of an incremental."
+ [rootTableOverflowed := true]]!
- ["record oop as root only if not already recorded"
- rootTableCount < RootTableRedZone
- ifTrue: ["record root if there is enough room in the roots table "
- rootTableCount := rootTableCount + 1.
- rootTable at: rootTableCount put: oop.
- self longAt: headerLoc put: (header bitOr: RootBit)]
- ifFalse: ["we're getting in the red zone"
- rootTableCount < RootTableSize
- ifTrue: ["but there's still space to record it"
- rootTableCount := rootTableCount + 1.
- rootTable at: rootTableCount put: oop.
- self longAt: headerLoc put: (header bitOr: RootBit).
- "but force an IGC on the next allocation"
- allocationCount := allocationsBetweenGCs + 1]]]!
Item was changed:
----- Method: ObjectMemory>>removeYoungRoot: (in category 'become') -----
removeYoungRoot: obj
+ "Remove the given young root from the root table (for freeObject: for becomeForward:)."
- "Remove the given young root form the root table (for freeObject: for becomeForward:)."
<inline: false>
1 to: rootTableCount do:
[:i|
obj = (rootTable at: i) ifTrue:"swap obj with last entry"
[rootTable at: i put: (rootTable at: rootTableCount).
+ rootTableCount := rootTableCount - 1.
- rootTableCount := rootTableCount-1.
^true]].
^false "not found"!
Item was removed:
- ----- Method: ObjectMemory>>rootTable: (in category 'accessing') -----
- rootTable: aValue
- ^rootTable := aValue!
Item was added:
+ ----- Method: ObjectMemory>>rootTableObject (in category 'primitive support') -----
+ rootTableObject
+ "Answer an object containing the contents of the rootTable for primitiveRootTable.
+ The allocation can cause a GC itself and if so the return value may be inaccurate
+ - in this case one should guard the read operation by looking at the gc counter statistics."
+ | tableObj sz j |
+ sz := rootTableCount.
+ tableObj := self instantiateClass: self classArray indexableSize: sz. "can cause GC (and hence reduce number of roots)"
+ j := 0.
+ 1 to: rootTableCount do:
+ [:i| "By definition the roots are old and being new, tableObj is young so there is no need to store check."
+ self storePointerUnchecked: j ofObject: tableObj withValue: (rootTable at: i)].
+ rootTableCount < sz ifTrue:
+ [self shorten: tableObj toIndexableSize: rootTableCount].
+ ^tableObj!
Item was changed:
----- Method: SimpleStackBasedCogit>>compileFrameBuild (in category 'compile abstract instructions') -----
compileFrameBuild
"Build a frame for a CogMethod activation. See CoInterpreter class>>initializeFrameIndices.
receiver (in ReceiverResultReg)
arg0
...
argN
caller's saved ip/this stackPage (for a base frame)
fp-> saved fp
method
context (uninitialized?)
receiver
first temp
...
sp-> Nth temp
If there is a primitive and an error code the Nth temp is the error code.
Ensure SendNumArgsReg is set early on (incidentally to nilObj) because
it is the flag determining whether context switch is allowed on stack-overflow."
| methodHeader jumpSkip |
<inline: false>
<var: #jumpSkip type: #'AbstractInstruction *'>
needsFrame ifFalse: [^0].
methodHeader := coInterpreter headerOf: methodObj.
+ backEnd hasLinkRegister ifTrue: [self PushR: LinkReg].
self PushR: FPReg.
self MoveR: SPReg R: FPReg.
methodLabel addDependent: (self annotateAbsolutePCRef:
(self PushCw: methodLabel asInteger)). "method"
self annotate: (self MoveCw: objectMemory nilObject R: SendNumArgsReg)
objRef: objectMemory nilObject.
self PushR: SendNumArgsReg. "context"
self PushR: ReceiverResultReg.
methodOrBlockNumArgs + 1 to: (coInterpreter tempCountOf: methodObj) do:
[:i|
self PushR: SendNumArgsReg].
(primitiveIndex > 0
and: [(coInterpreter longStoreBytecodeForHeader: methodHeader)
= (objectMemory
fetchByte: initialPC + (coInterpreter sizeOfCallPrimitiveBytecode: methodHeader)
ofObject: methodObj)]) ifTrue:
[self compileGetErrorCode.
initialPC := initialPC
+ (coInterpreter sizeOfCallPrimitiveBytecode: methodHeader)
+ (coInterpreter sizeOfLongStoreTempBytecode: methodHeader)].
self MoveAw: coInterpreter stackLimitAddress R: TempReg.
self CmpR: TempReg R: SPReg. "N.B. FLAGS := SPReg - TempReg"
"If we can't context switch for this method, use a slightly
slower overflow check that clears SendNumArgsReg."
(coInterpreter canContextSwitchIfActivating: methodObj header: methodHeader)
ifTrue:
[self JumpBelow: stackOverflowCall.
stackCheckLabel := self Label]
ifFalse:
[jumpSkip := self JumpAboveOrEqual: 0.
self MoveCq: 0 R: SendNumArgsReg.
self Jump: stackOverflowCall.
jumpSkip jmpTarget: (stackCheckLabel := self Label)].
self annotateBytecode: stackCheckLabel!
Item was added:
+ ----- Method: StackInterpreter>>checkAllAccessibleObjectsOkay (in category 'debug support') -----
+ checkAllAccessibleObjectsOkay
+ "Ensure that all accessible objects in the heap are okay."
+ <api>
+ | ok oop |
+ ok := true.
+ oop := objectMemory firstAccessibleObject.
+ [oop = nil] whileFalse:
+ [ok := ok & (self checkOkayFields: oop).
+ oop := objectMemory accessibleObjectAfter: oop].
+ ^ok!
Item was changed:
----- Method: StackInterpreter>>checkForEventsMayContextSwitch: (in category 'process primitive support') -----
checkForEventsMayContextSwitch: mayContextSwitch
"Check for possible interrupts and handle one if necessary.
Answer if a context switch has occurred."
| switched sema now |
<inline: false>
<var: #now type: #usqLong>
statCheckForEvents := statCheckForEvents + 1.
"restore the stackLimit if it has been smashed."
self restoreStackLimit.
self externalWriteBackHeadFramePointers.
self assert: stackPage = stackPages mostRecentlyUsedPage.
"Allow the platform to do anything it needs to do synchronously."
self ioSynchronousCheckForEvents.
self checkCogCompiledCodeCompactionCalledFor.
objectMemory needGCFlag ifTrue:
+ ["sufficientSpaceAfterGC: runs the incremental GC and
- [objectMemory needGCFlag: false.
- "sufficientSpaceAfterGC: runs the incremental GC and
then, if not enough space is available, the fullGC."
(objectMemory sufficientSpaceAfterGC: 0) ifFalse:
[self setSignalLowSpaceFlagAndSaveProcess]].
mayContextSwitch ifFalse: [^false].
switched := false.
(profileProcess ~= objectMemory nilObject
or: [nextProfileTick > 0 and:[self ioHighResClock >= nextProfileTick]]) ifTrue:
["Take a sample (if not already done so) for the profiler if it is active. This
must be done before any of the synchronousSignals below or else we will
attribute a pause in ioRelinquishProcessor to the newly activated process."
profileProcess = objectMemory nilObject ifTrue:
[profileProcess := self activeProcess.
profileMethod := objectMemory nilObject].
"and signal the profiler semaphore if it is present"
(profileSemaphore ~= objectMemory nilObject
and: [self synchronousSignal: profileSemaphore]) ifTrue:
[switched := true].
nextProfileTick := 0].
self checkDeliveryOfLongRunningPrimitiveSignal ifTrue:
[switched := true].
objectMemory signalLowSpace ifTrue:
[objectMemory signalLowSpace: false. "reset flag"
sema := objectMemory splObj: TheLowSpaceSemaphore.
(sema ~= objectMemory nilObject
and: [self synchronousSignal: sema]) ifTrue:
[switched := true]].
"inIOProcessEvents prevents reentrancy into ioProcessEvents and allows disabling
ioProcessEvents e.g. for native GUIs. We would like to manage that here but can't
since the platform code may choose to call ioProcessEvents itself in various places."
false
ifTrue:
[((now := self ioUTCMicroseconds) >= nextPollUsecs
and: [inIOProcessEvents = 0]) ifTrue:
[statIOProcessEvents := statIOProcessEvents + 1.
inIOProcessEvents := inIOProcessEvents + 1.
self ioProcessEvents. "sets interruptPending if interrupt key pressed; may callback"
inIOProcessEvents > 0 ifTrue:
[inIOProcessEvents := inIOProcessEvents - 1].
nextPollUsecs := now + 20000
"msecs to wait before next call to ioProcessEvents. Note that strictly
speaking we might need to update 'now' at this point since
ioProcessEvents could take a very long time on some platforms"]]
ifFalse:
[(now := self ioUTCMicroseconds) >= nextPollUsecs ifTrue:
[statIOProcessEvents := statIOProcessEvents + 1.
self ioProcessEvents. "sets interruptPending if interrupt key pressed; may callback"
nextPollUsecs := now + 20000
"msecs to wait before next call to ioProcessEvents. Note that strictly
speaking we might need to update 'now' at this point since
ioProcessEvents could take a very long time on some platforms"]].
interruptPending ifTrue:
[interruptPending := false.
"reset interrupt flag"
sema := objectMemory splObj: TheInterruptSemaphore.
(sema ~= objectMemory nilObject
and: [self synchronousSignal: sema]) ifTrue:
[switched := true]].
nextWakeupUsecs ~= 0 ifTrue:
[now >= nextWakeupUsecs ifTrue:
[nextWakeupUsecs := 0.
"set timer interrupt to 0 for 'no timer'"
sema := objectMemory splObj: TheTimerSemaphore.
(sema ~= objectMemory nilObject
and: [self synchronousSignal: sema]) ifTrue:
[switched := true]]].
"signal any pending finalizations"
pendingFinalizationSignals > 0 ifTrue:
[sema := objectMemory splObj: TheFinalizationSemaphore.
((objectMemory isClassOfNonImm: sema equalTo: (objectMemory splObj: ClassSemaphore))
and: [self synchronousSignal: sema]) ifTrue:
[switched := true].
pendingFinalizationSignals := 0].
"signal all semaphores in semaphoresToSignal"
self signalExternalSemaphores ifTrue:
[switched := true].
^switched!
Item was added:
+ ----- Method: StackInterpreter>>checkOkayFields: (in category 'debug support') -----
+ checkOkayFields: oop
+ "Check if the argument is an ok object.
+ If this is a pointers object, check that its fields are all okay oops."
+
+ | hasYoung i fieldOop |
+ (oop = nil or: [oop = 0]) ifTrue: [ ^true ]. "?? eem 1/16/2013"
+ (objectMemory isIntegerObject: oop) ifTrue: [ ^true ].
+ (objectMemory checkOkayOop: oop) ifFalse: [ ^false ].
+ (self checkOopHasOkayClass: oop) ifFalse: [ ^false ].
+ hasYoung := objectMemory isYoung: (objectMemory fetchClassOfNonInt: oop).
+ ((objectMemory isPointers: oop) or: [objectMemory isCompiledMethod: oop]) ifTrue:
+ [(objectMemory isCompiledMethod: oop)
+ ifTrue:
+ [i := (self literalCountOf: oop) - 1]
+ ifFalse:
+ [(self isContext: oop)
+ ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1]
+ ifFalse: [i := (objectMemory lengthOf: oop) - 1]].
+ [i >= 0] whileTrue:
+ [fieldOop := objectMemory fetchPointer: i ofObject: oop.
+ (objectMemory isIntegerObject: fieldOop) ifFalse:
+ [hasYoung := hasYoung or: [objectMemory isYoung: fieldOop].
+ (objectMemory checkOkayOop: fieldOop) ifFalse: [ ^false ].
+ (self checkOopHasOkayClass: fieldOop) ifFalse: [ ^false ]].
+ i := i - 1]].
+ hasYoung ifTrue:
+ [^objectMemory checkOkayYoungReferrer: oop].
+ ^true!
Item was added:
+ ----- Method: StackInterpreter>>checkOkayInterpreterObjects: (in category 'debug support') -----
+ checkOkayInterpreterObjects: writeBack
+ <api>
+ | ok oopOrZero oop |
+ ok := true.
+ ok := ok & (self checkOkayFields: objectMemory nilObject).
+ ok := ok & (self checkOkayFields: objectMemory falseObject).
+ ok := ok & (self checkOkayFields: objectMemory trueObject).
+ ok := ok & (self checkOkayFields: objectMemory specialObjectsOop).
+ ok := ok & (self checkOkayFields: messageSelector).
+ ok := ok & (self checkOkayFields: newMethod).
+ ok := ok & (self checkOkayFields: lkupClass).
+ 0 to: MethodCacheEntries - 1 by: MethodCacheEntrySize do:
+ [ :i |
+ oopOrZero := methodCache at: i + MethodCacheSelector.
+ oopOrZero = 0 ifFalse:
+ [ok := ok & (self checkOkayFields: (methodCache at: i + MethodCacheSelector)).
+ ok := ok & (self checkOkayFields: (methodCache at: i + MethodCacheClass)).
+ ok := ok & (self checkOkayFields: (methodCache at: i + MethodCacheMethod))]].
+ 1 to: objectMemory remapBufferCount do:
+ [ :i |
+ oop := objectMemory remapBuffer at: i.
+ (objectMemory isIntegerObject: oop) ifFalse:
+ [ok := ok & (self checkOkayFields: oop)]].
+ ok := ok & (self checkOkayStackZone: writeBack).
+ ^ok!
Item was added:
+ ----- Method: StackInterpreter>>checkOkayStackPage: (in category 'debug support') -----
+ checkOkayStackPage: thePage
+ | theSP theFP ok frameRcvrOffset callerFP oop |
+ <var: #thePage type: #'StackPage *'>
+ <var: #theSP type: #'char *'>
+ <var: #theFP type: #'char *'>
+ <var: #frameRcvrOffset type: #'char *'>
+ <var: #callerFP type: #'char *'>
+ <inline: false>
+ theSP := thePage headSP.
+ theFP := thePage headFP.
+ ok := true.
+ "Skip the instruction pointer on top of stack of inactive pages."
+ thePage = stackPage ifFalse:
+ [theSP := theSP + BytesPerWord].
+ [frameRcvrOffset := self frameReceiverOffset: theFP.
+ [theSP <= frameRcvrOffset] whileTrue:
+ [oop := stackPages longAt: theSP.
+ (objectMemory isIntegerObject: oop) ifFalse:
+ [ok := ok & (self checkOkayFields: oop)].
+ theSP := theSP + BytesPerWord].
+ (self frameHasContext: theFP) ifTrue:
+ [self assert: (self isContext: (self frameContext: theFP)).
+ ok := ok & (self checkOkayFields: (self frameContext: theFP))].
+ ok := ok & (self checkOkayFields: (self frameMethodObject: theFP)).
+ (callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
+ [theSP := theFP + FoxCallerSavedIP + BytesPerWord.
+ theFP := callerFP].
+ theSP := self isCog
+ ifTrue: [theFP + FoxCallerSavedIP + BytesPerWord] "caller ip is ceBaseReturnPC"
+ ifFalse: [theFP + FoxCallerSavedIP]. "caller ip is frameCallerContext in a base frame"
+ [theSP <= thePage baseAddress] whileTrue:
+ [oop := stackPages longAt: theSP.
+ (objectMemory isIntegerObject: oop) ifFalse:
+ [ok := ok & (self checkOkayFields: oop)].
+ theSP := theSP + BytesPerWord].
+ ^ok!
Item was added:
+ ----- Method: StackInterpreter>>checkOkayStackZone: (in category 'debug support') -----
+ checkOkayStackZone: writeBack
+ "Check that all objects in the stack zone are okay"
+ | ok thePage |
+ <var: #thePage type: #'StackPage *'>
+ <inline: false>
+ writeBack ifTrue:
+ [self externalWriteBackHeadFramePointers].
+ ok := true.
+
+ 0 to: numStackPages - 1 do:
+ [:i|
+ thePage := stackPages stackPageAt: i.
+ (stackPages isFree: thePage) ifFalse:
+ [ok := ok & (self checkOkayStackPage: thePage)]].
+
+ ^ok!
Item was changed:
----- Method: StackInterpreter>>checkOopHasOkayClass: (in category 'debug support') -----
+ checkOopHasOkayClass: obj
+ "Attempt to verify that the given obj has a reasonable behavior. The class must be a
+ valid, non-integer oop and must not be nilObj. It must be a pointers object with three
+ or more fields. Finally, the instance specification field of the behavior must match that
+ of the instance. If OK answer true. If not, print reason and answer false."
- checkOopHasOkayClass: oop
- "Attempt to verify that the given oop has a reasonable behavior. The class must be a valid, non-integer oop and must not be nilObj. It must be a pointers object with three or more fields. Finally, the instance specification field of the behavior must match that of the instance. If OK answer true. If not, print reason and answer false."
<api>
<var: #oop type: #usqInt>
+ | objClass formatMask behaviorFormatBits objFormatBits |
- | oopClass formatMask behaviorFormatBits oopFormatBits |
<var: #oopClass type: #usqInt>
+ (objectMemory checkOkayOop: obj) ifFalse:
- (objectMemory checkOkayOop: oop) ifFalse:
[^false].
+ objClass := self cCoerce: (objectMemory fetchClassOfNonInt: obj) to: #usqInt.
- oopClass := self cCoerce: (objectMemory fetchClassOf: oop) to: #usqInt.
+ (objectMemory isIntegerObject: objClass) ifTrue:
+ [self print: 'obj '; printHex: obj; print: ' a SmallInteger is not a valid class or behavior'; cr. ^false].
+ (objectMemory okayOop: objClass) ifFalse:
+ [self print: 'obj '; printHex: obj; print: ' class obj is not ok'; cr. ^false].
+ ((objectMemory isPointers: objClass) and: [(objectMemory lengthOf: objClass) >= 3]) ifFalse:
+ [self print: 'obj '; printHex: obj; print: ' a class (behavior) must be a pointers object of size >= 3'; cr. ^false].
+ formatMask := (objectMemory isBytes: obj)
- (objectMemory isIntegerObject: oopClass) ifTrue:
- [self print: 'a SmallInteger is not a valid class or behavior'; cr. ^false].
- (objectMemory okayOop: oopClass) ifFalse:
- [self print: 'class oop is not ok'; cr. ^false].
- ((objectMemory isPointers: oopClass) and: [(objectMemory lengthOf: oopClass) >= 3]) ifFalse:
- [self print: 'a class (behavior) must be a pointers object of size >= 3'; cr. ^false].
- formatMask := (objectMemory isBytes: oop)
ifTrue: [16rC00] "ignore extra bytes size bits"
ifFalse: [16rF00].
+ behaviorFormatBits := (objectMemory formatOfClass: objClass) bitAnd: formatMask.
+ objFormatBits := (objectMemory baseHeader: obj) bitAnd: formatMask.
+ behaviorFormatBits = objFormatBits ifFalse:
+ [self print: 'obj '; printHex: obj; print: ' and its class (behavior) formats differ'; cr. ^false].
- behaviorFormatBits := (objectMemory formatOfClass: oopClass) bitAnd: formatMask.
- oopFormatBits := (objectMemory baseHeader: oop) bitAnd: formatMask.
- behaviorFormatBits = oopFormatBits ifFalse:
- [self print: 'object and its class (behavior) formats differ'; cr. ^false].
^true!
Item was changed:
----- Method: StackInterpreter>>ensureImageFormatIsUpToDate: (in category 'image save/restore') -----
ensureImageFormatIsUpToDate: swapBytes
"Ensure the image data has been updayed to suit the current VM."
<inline: false>
swapBytes
ifTrue: [self reverseBytesInImage]
+ ifFalse: [self convertFloatsToPlatformOrderFrom: objectMemory firstObject to: objectMemory freeStart]!
- ifFalse: [self convertFloatsToPlatformOrderFrom: objectMemory firstObject to: objectMemory endOfMemory]!
Item was changed:
----- Method: StackInterpreter>>forceInterruptCheck (in category 'process primitive support') -----
forceInterruptCheck
"Force an interrupt check ASAP.
Must set the stack page's limit before stackLimit to avoid
a race condition if this is called from an interrupt handler."
| thePage iccFunc |
<inline: false>
<var: #thePage type: #'StackPage *'>
<var: #iccFunc declareC: 'void (*iccFunc)()'>
"Do _not_ set stackLimit until the stack system has been initialized.
stackLimit is the initialization flag for the stack system."
stackLimit = 0 ifTrue:
[^nil].
thePage := stackPage.
+ (thePage notNil and: [thePage ~= 0]) ifTrue:
- thePage notNil ifTrue:
[thePage stackLimit: (self cCoerceSimple: -1 signedIntToLong to: #'char *')].
stackLimit := self cCoerceSimple: -1 signedIntToLong to: #'char *'.
self sqLowLevelMFence.
"There is a race condition if we test the function and then dereference
it a second time to call it. This is called from interrupt code but at the
same time other code could be clearing the interruptCheckChain via
setInterruptCheckChain:."
(iccFunc := interruptCheckChain) notNil ifTrue:
[self perform: iccFunc].
statForceInterruptCheck := statForceInterruptCheck + 1!
Item was changed:
----- Method: StackInterpreter>>highBit: (in category 'stack pages') -----
highBit: anUnsignedValue
+ "This is a C implementation needed by ioSetMaxExtSemTableSize
+ and e.g. stackPageByteSize."
- "This is a C implementation needed by stackPageByteSize when translated."
| shifted bitNo |
+ <api>
+ <highBit> "so it shows up in senders..."
<var: #anUnsignedValue type: #usqInt>
<var: #shifted type: #usqInt>
shifted := anUnsignedValue.
bitNo := 0.
self cppIf: BytesPerWord > 4
ifTrue:
[shifted < (1 << 32) ifFalse:
[shifted := shifted >> 32.
bitNo := bitNo + 32]].
shifted < (1 << 16) ifFalse:
[shifted := shifted >> 16.
bitNo := bitNo + 16].
shifted < (1 << 8) ifFalse:
[shifted := shifted >> 8.
bitNo := bitNo + 8].
shifted < (1 << 4) ifFalse:
[shifted := shifted >> 4.
bitNo := bitNo + 4].
shifted < (1 << 2) ifFalse:
[shifted := shifted >> 2.
bitNo := bitNo + 2].
shifted < (1 << 1) ifFalse:
[shifted := shifted >> 1.
bitNo := bitNo + 1].
"shifted 0 or 1 now"
^bitNo + shifted!
Item was changed:
----- Method: StackInterpreter>>initStackPages (in category 'initialization') -----
initStackPages
"Initialize the stackPages. This version is only for simulation
because Slang refuses to inline it, which makes the alloca invalid."
| stackPageBytes stackPagesBytes theStackMemory |
stackPageBytes := self stackPageByteSize.
stackPagesBytes := self computeStackZoneSize.
theStackMemory := self
cCode: [self alloca: stackPagesBytes]
inSmalltalk:
[stackPages := self stackPagesClass new.
stackPages initializeWithByteSize: stackPagesBytes for: self].
+ self cCode: [self me: theStackMemory ms: 0 et: stackPagesBytes].
stackPages
initializeStack: theStackMemory
numSlots: stackPagesBytes / BytesPerWord
+ pageSize: stackPageBytes / BytesPerWord!
- pageSize: stackPageBytes / BytesPerWord
- stackLimitOffset: self stackLimitOffset
- stackPageHeadroom: self stackPageHeadroom!
Item was changed:
----- Method: StackInterpreter>>initStackPagesAndInterpret (in category 'initialization') -----
initStackPagesAndInterpret
"Initialize the stack pages and enter interpret. Use alloca'ed memory so that when
we have a JIT its stack pointer will be on the native stack since alloca allocates
memory on the stack. Certain thread systems use the native stack pointer as the
frame ID so putting the stack anywhere else can confuse the thread system."
"This should be in its own initStackPages method but Slang can't inline
C code strings."
| stackPageBytes stackPagesBytes theStackMemory |
<var: #theStackMemory type: #'void *'>
stackPageBytes := self stackPageByteSize.
stackPagesBytes := self computeStackZoneSize.
theStackMemory := self
cCode: [self alloca: stackPagesBytes]
inSmalltalk:
[stackPages := self stackPagesClass new.
stackPages initializeWithByteSize: stackPagesBytes for: self].
+ self cCode: [self me: theStackMemory ms: 0 et: stackPagesBytes].
stackPages
initializeStack: theStackMemory
numSlots: stackPagesBytes / BytesPerWord
+ pageSize: stackPageBytes / BytesPerWord.
- pageSize: stackPageBytes / BytesPerWord
- stackLimitOffset: self stackLimitOffset
- stackPageHeadroom: self stackPageHeadroom.
"Once the stack pages are initialized we can continue to bootstrap the system."
self loadInitialContext.
"We're ready for the heartbeat (poll interrupt)"
self ioInitHeartbeat.
self interpret.
^nil!
Item was changed:
----- Method: StackInterpreter>>interpreterAllocationReserveBytes (in category 'stack pages') -----
interpreterAllocationReserveBytes
"At a rough approximation we may need to allocate up to a couple
of page's worth of contexts when switching stack pages, assigning
to senders, etc. But the snapshot primitive voids all stack pages.
So a safe margin is the size of a large context times the maximum
number of frames per page times the number of pages."
+ | maxUsedBytesPerPage maxFramesPerPage |
+ maxUsedBytesPerPage := self stackPageFrameBytes + self stackLimitOffset.
+ maxFramesPerPage := maxUsedBytesPerPage / BytesPerWord // MFrameSlots.
+ ^maxFramesPerPage * LargeContextSize * numStackPages!
- | availableBytesPerPage maxFramesPerPage |
- availableBytesPerPage := self stackPageByteSize - self stackLimitOffset - self stackPageHeadroom.
- maxFramesPerPage := availableBytesPerPage / BytesPerWord // FrameSlots.
- ^2 raisedTo: (maxFramesPerPage * LargeContextSize * numStackPages) highBit!
Item was changed:
----- Method: StackInterpreter>>longPrintOop: (in category 'debug printing') -----
longPrintOop: oop
<api>
+ | class fmt lastIndex startIP bytecodesPerLine column |
- | 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:
[^self printOop: oop].
+ class := objectMemory fetchClassOfNonInt: oop.
self printHex: oop;
+ print: ': a(n) '; printNameOfClass: class count: 5;
+ print: ' ('; printHex: class; print: ')'.
- 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>>markAndTraceStackPage: (in category 'object memory support') -----
markAndTraceStackPage: thePage
| theSP theFP frameRcvrOffset callerFP oop |
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #frameRcvrOffset type: #'char *'>
<var: #callerFP type: #'char *'>
<inline: false>
self assert: (stackPages isFree: thePage) not.
theSP := thePage headSP.
theFP := thePage headFP.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
[theSP := theSP + BytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
[self assert: (self isContext: (self frameContext: theFP)).
objectMemory markAndTrace: (self frameContext: theFP)].
objectMemory markAndTrace: (self iframeMethod: theFP).
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
+ theSP := theFP + FoxCallerSavedIP. "caller ip is frameCallerContext in a base frame"
- theSP := self isCog
- ifTrue: [theFP + FoxCallerSavedIP + BytesPerWord] "caller ip is ceBaseReturnPC"
- ifFalse: [theFP + FoxCallerSavedIP]. "caller ip is frameCallerContext in a base frame"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
theSP := theSP + BytesPerWord]!
Item was changed:
----- Method: StackInterpreter>>moveFramesIn:through:toPage: (in category 'frame access') -----
moveFramesIn: oldPage through: theFP toPage: newPage
"Move frames from the hot end of oldPage through to theFP to newPage.
This has the effect of making theFP a base frame which can be stored into.
Answer theFP's new location."
| newSP newFP stackedReceiverOffset delta callerFP callerIP fpInNewPage offsetCallerFP theContext |
<inline: false>
<var: #oldPage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #newPage type: #'StackPage *'>
<var: #newSP type: #'char *'>
<var: #newFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #fpInNewPage type: #'char *'>
<var: #offsetCallerFP type: #'char *'>
<var: #source type: #'char *'>
<returnTypeC: 'char *'>
newSP := newPage baseAddress + BytesPerWord.
stackedReceiverOffset := self frameStackedReceiverOffset: theFP.
"First move the data. We will fix up frame pointers later."
theFP + stackedReceiverOffset
to: oldPage headSP
by: BytesPerWord negated
do: [:source|
newSP := newSP - BytesPerWord.
stackPages longAt: newSP put: (stackPages longAt: source)].
"newSP = oldSP + delta => delta = newSP - oldSP"
delta := newSP - oldPage headSP.
newFP := newPage baseAddress - stackedReceiverOffset.
self setHeadFP: oldPage headFP + delta andSP: newSP inPage: newPage.
newPage baseFP: newFP.
callerFP := self frameCallerFP: theFP.
self assert: (self isBaseFrame: theFP) not.
self assert: (self frameHasContext: callerFP).
callerIP := self oopForPointer: (self frameCallerSavedIP: theFP).
stackPages longAt: theFP + stackedReceiverOffset put: callerIP.
+ self assert: (callerFP < oldPage baseAddress
+ and: [callerFP > (oldPage realStackLimit - (LargeContextSize / 2))]).
oldPage
headFP: callerFP;
headSP: theFP + stackedReceiverOffset.
"Mark the new base frame in the new page (FoxCallerContext a.k.a. FoxCallerSavedIP)"
stackPages longAt: newFP + FoxCallerContext put: (self frameContext: callerFP).
stackPages longAt: newFP + FoxSavedFP put: 0.
"Now relocate frame pointers, updating married contexts to refer to their moved spouse frames."
fpInNewPage := newPage headFP.
[offsetCallerFP := self frameCallerFP: fpInNewPage.
offsetCallerFP ~= 0 ifTrue:
[offsetCallerFP := offsetCallerFP + delta].
stackPages longAt: fpInNewPage + FoxSavedFP put: (self oopForPointer: offsetCallerFP).
(self frameHasContext: fpInNewPage) ifTrue:
[theContext := self frameContext: fpInNewPage.
objectMemory storePointerUnchecked: SenderIndex
ofObject: theContext
withValue: (self withSmallIntegerTags: fpInNewPage).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: theContext
withValue: (self withSmallIntegerTags: offsetCallerFP)].
fpInNewPage := offsetCallerFP.
fpInNewPage ~= 0] whileTrue.
^newFP!
Item was changed:
----- Method: StackInterpreter>>print: (in category 'debug printing') -----
print: s
"For testing in Smalltalk, this method should be overridden in a subclass."
<api>
<var: #s type: #'char *'>
+ self cCode: 'fputs(s, stdout)'!
- self cCode: 'printf("%s", s)'.!
Item was changed:
----- Method: StackInterpreter>>printCallStackOf:currentFP: (in category 'debug printing') -----
printCallStackOf: aContext currentFP: currFP
| ctxt theFP thePage |
<inline: false>
<var: #currFP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
ctxt := aContext.
[ctxt = objectMemory nilObject] whileFalse:
[(self isMarriedOrWidowedContext: ctxt)
ifFalse:
[self shortPrintContext: ctxt.
ctxt := objectMemory fetchPointer: SenderIndex ofObject: ctxt]
ifTrue:
[theFP := self frameOfMarriedContext: ctxt.
(self checkIsStillMarriedContext: ctxt currentFP: currFP)
ifTrue:
[thePage := stackPages stackPageFor: theFP.
(stackPages isFree: thePage) ifTrue:
[self printHexPtr: theFP; print: ' is on a free page?!!'; cr.
^nil].
self shortPrintFrameAndCallers: theFP.
theFP := thePage baseFP.
ctxt := self frameCallerContext: theFP]
+ ifFalse: [self print: 'widowed caller frame '; printHexPtr: theFP; cr.
- ifFalse: [self print: 'widowed caller frame '; print: theFP; cr.
^nil]]]!
Item was changed:
----- Method: StackInterpreter>>printHexPtr: (in category 'debug printing') -----
printHexPtr: p
+ "Print p in hex, passed to 10 characters in the form ' 0x1234'"
- "Print n in hex, passed to 10 characters in the form ' 0x1234'"
<inline: true>
<var: #p type: #'void *'>
self printHex: (self oopForPointer: p)!
Item was changed:
----- Method: StackInterpreter>>reverseBytesInImage (in category 'image save/restore') -----
reverseBytesInImage
"Byte-swap all words in memory after reading in the entire image file with bulk read. Contributed by Tim Rowledge."
"First, byte-swap every word in the image. This fixes objects headers."
+ objectMemory reverseBytesFrom: objectMemory startOfMemory to: objectMemory freeStart.
- objectMemory reverseBytesFrom: objectMemory startOfMemory to: objectMemory endOfMemory.
"Second, return the bytes of bytes-type objects to their orginal order, and perform any
other format conversions."
+ self updateObjectsPostByteSwapFrom: objectMemory firstObject to: objectMemory freeStart!
- self updateObjectsPostByteSwapFrom: objectMemory firstObject to: objectMemory endOfMemory!
Item was changed:
----- Method: StackInterpreter>>snapshot: (in category 'image save/restore') -----
snapshot: embedded
"update state of active context"
| activeContext activeProc dataSize rcvr setMacType stackIndex |
<var: #setMacType type: 'void *'>
+ "For nowe the stack munging below doesn't deal with more than omne argument.
+ It can, and should."
+ argumentCount ~= 0 ifTrue:
+ [^self primitiveFailFor: PrimErrBadNumArgs].
+
"Need to convert all frames into contexts since the snapshot file only holds objects."
self push: instructionPointer.
activeContext := self voidVMStateForSnapshot.
"update state of active process"
activeProc := self activeProcess.
objectMemory
storePointer: SuspendedContextIndex
ofObject: activeProc
withValue: activeContext.
objectMemory pushRemappableOop: activeContext.
"compact memory and compute the size of the memory actually in use"
objectMemory incrementalGC.
"maximimize space for forwarding table"
objectMemory fullGC.
self snapshotCleanUp.
"Nothing moves from here on so it is safe to grab the activeContext again."
activeContext := objectMemory popRemappableOop.
dataSize := objectMemory freeStart - objectMemory startOfMemory. "Assume all objects are below the start of the free block"
self successful ifTrue:
["Without contexts or stacks simulate
rcvr := self popStack.
''pop rcvr''
self push: trueObj.
to arrange that the snapshot resumes with true. N.B. stackIndex is one-relative."
stackIndex := self quickFetchInteger: StackPointerIndex ofObject: activeContext.
rcvr := objectMemory fetchPointer: stackIndex + CtxtTempFrameStart - 1 ofObject: activeContext.
+ objectMemory
+ storePointerUnchecked: stackIndex + CtxtTempFrameStart - 1
- objectMemory storePointerUnchecked: stackIndex + CtxtTempFrameStart - 1
ofObject: activeContext
withValue: objectMemory trueObject.
"now attempt to write the snapshot file"
+ self writeImageFileIO: dataSize.
+ (self successful and: [embedded not]) ifTrue:
- self writeImageFile: dataSize.
- embedded ifFalse:
["set Mac file type and creator; this is a noop on other platforms"
setMacType := self ioLoadFunction: 'setMacFileTypeAndCreator' From: 'FilePlugin'.
setMacType = 0 ifFalse:
[self cCode: '((sqInt (*)(char *, char *, char *))setMacType)(imageName, "STim", "FAST")']].
"Without contexts or stacks simulate
self pop: 1"
+ objectMemory
+ storePointerUnchecked: StackPointerIndex
- objectMemory storePointerUnchecked: StackPointerIndex
ofObject: activeContext
withValue: (objectMemory integerObjectOf: stackIndex - 1)].
self marryContextInNewStackPageAndInitializeInterpreterRegisters: activeContext.
self successful
ifTrue: [self push: objectMemory falseObject]
+ ifFalse:
+ [self push: rcvr.
+ self justActivateNewMethod]!
- ifFalse: [self push: rcvr]!
Item was added:
+ ----- Method: StackInterpreter>>stackLimitBytes (in category 'stack pages') -----
+ stackLimitBytes
+ "Answer the actual stackLimit offset in a page. Since stackPageByteSize may have chosen to shrink a page
+ this may be less than stackPageFrameBytes, but it should be no more than stackPageFrameBytes."
+ ^self stackPageFrameBytes min: self stackPageByteSize - self stackLimitOffset - self stackPageHeadroom.!
Item was changed:
----- Method: StackInterpreter>>stackPageByteSize (in category 'stack pages') -----
stackPageByteSize
+ "Answer a page size that is a power-of-two and contains a useful number of frames.
+ Room for 512 bytes of frames gives around 40 frames a page which is a
- "Room for 512 bytes of frames gives around 40 frames a page which is a
good compromise between overflow rate and latency in divorcing a page."
<inline: false>
+ | pageBytes largeSize smallSize |
+ pageBytes := self stackPageFrameBytes + self stackLimitOffset + self stackPageHeadroom.
+ (pageBytes bitAnd: pageBytes - 1) = 0 ifTrue: "= 0 => a power of two"
+ [^pageBytes].
+ "round up or round down; that is the question. If rounding down reduces
+ the size by no more than 1/8th round down, otherwise roundup."
+ largeSize := 1 << pageBytes highBit.
+ smallSize := 1 << (pageBytes highBit - 1).
+ self assert: (largeSize > pageBytes and: [pageBytes > smallSize]).
+ ^(pageBytes - smallSize) <= (smallSize / 8)
+ ifTrue: [smallSize]
+ ifFalse: [largeSize]!
- ^1 << (512 + self stackLimitOffset + self stackPageHeadroom - 1) highBit!
Item was added:
+ ----- Method: StackInterpreter>>stackPageFrameBytes (in category 'stack pages') -----
+ stackPageFrameBytes
+ "Answer a byte size that accomodates a useful number of frames.
+ 512 bytes is room for around 40 frames a page which is a good
+ compromise between overflow rate and latency in divorcing a page."
+ ^512!
Item was changed:
----- Method: StackInterpreter>>writeImageFile: (in category 'image save/restore') -----
writeImageFile: imageBytes
| fn |
<var: #fn type: 'void *'>
self writeImageFileIO: imageBytes.
+ self successful ifTrue:
+ ["set Mac file type and creator; this is a noop on other platforms"
+ fn := self ioLoadFunction: 'setMacFileTypeAndCreator' From: 'FilePlugin'.
+ fn = 0 ifFalse:
+ [self cCode:'((sqInt (*)(char*, char*, char*))fn)(imageName, "STim", "FAST")']]
- "set Mac file type and creator; this is a noop on other platforms"
- fn := self ioLoadFunction: 'setMacFileTypeAndCreator' From: 'FilePlugin'.
- fn = 0 ifFalse:[
- self cCode:'((sqInt (*)(char*, char*, char*))fn)(imageName, "STim", "FAST")'.
- ].
!
Item was changed:
----- Method: StackInterpreterSimulator>>initialize (in category 'initialization') -----
initialize
"Initialize the StackInterpreterSimulator when running the interpreter
inside Smalltalk. The primary responsibility of this method is to allocate
Smalltalk Arrays for variables that will be declared as statically-allocated
global arrays in the translated code."
| objectMemoryClass |
"initialize class variables"
objectMemory ifNotNil:
[^self halt].
objectMemoryClass := self class objectMemoryClass.
objectMemoryClass initBytesPerWord: objectMemoryClass bytesPerWord.
objectMemoryClass initialize.
StackInterpreter initialize.
super initialize.
objectMemory := objectMemoryClass simulatorClass new.
objectMemory coInterpreter: self.
"Note: we must initialize ConstMinusOne differently for simulation,
due to the fact that the simulator works only with +ve 32-bit values"
ConstMinusOne := objectMemory integerObjectOf: -1.
methodCache := Array new: MethodCacheSize.
atCache := Array new: AtCacheTotalSize.
self flushMethodCache.
self flushAtCache.
gcSemaphoreIndex := 0.
externalSemaphoreSignalRequests := externalSemaphoreSignalResponses := #().
externalPrimitiveTable := CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize).
externalPrimitiveTableFirstFreeIndex := 0.
primitiveTable := self class primitiveTable copy.
pluginList := #().
mappedPluginEntries := #().
desiredNumStackPages := desiredEdenBytes := 0.
+ "This is initialized on loading the image, but convenient for testing stack page values..."
+ numStackPages := self defaultNumStackPages.
startMicroseconds := Time totalSeconds * 1000000.
"initialize InterpreterSimulator variables used for debugging"
byteCount := 0.
sendCount := 0.
quitBlock := [^ self].
traceOn := true.
printSends := printReturns := printFrameAtEachStep := printBytecodeAtEachStep := false.
myBitBlt := BitBltSimulator new setInterpreter: self.
transcript := Transcript.
displayForm := 'Display has not yet been installed' asDisplayText form.
suppressHeartbeatFlag := false.
extSemTabSize := 256.
disableBooleanCheat := false!
Item was changed:
----- Method: StackInterpreterSimulator>>internalFindNewMethod (in category 'testing') -----
internalFindNewMethod
"
| cName |
traceOn ifTrue:
[cName := (self sizeBitsOf: class) = 16r20
ifTrue: ['class ' , (self nameOfClass: (self fetchPointer: 6 ofObject: class))]
ifFalse: [(self nameOfClass: class)].
self cr; print: cName , '>>' , (self stringOf: messageSelector)].
"
+ messageSelector = (objectMemory splObj: SelectorDoesNotUnderstand) ifTrue: [self halt].
- (self stringOf: messageSelector) = 'doesNotUnderstand:' ifTrue: [self halt].
sendCount := sendCount + 1.
printSends ifTrue:
[self cr; print: byteCount; space; printStringOf: messageSelector; cr].
"
(sendCount > 1000 and: [sendCount\\10 = 0]) ifTrue:
[Transcript print: sendCount; space.
self validate].
"
"
(sendCount > 100150) ifTrue:
[self qvalidate.
messageQueue == nil ifTrue: [messageQueue := OrderedCollection new].
messageQueue addLast: (self stringOf: messageSelector)].
"
super internalFindNewMethod!
Item was added:
+ ----- Method: StackInterpreterSimulator>>ioRelinquishProcessorForMicroseconds: (in category 'I/O primitive support') -----
+ ioRelinquishProcessorForMicroseconds: microseconds
+ "In the simulator give an indication that we're idling and check for input."
+ Display reverse: (0 at 0 extent: 16 at 16).
+ Sensor peekEvent ifNotNil:
+ [self forceInterruptCheck].
+ Processor activeProcess == Project uiProcess ifTrue:
+ [World doOneCycle].
+ microseconds >= 1000
+ ifTrue: [(Delay forMilliseconds: microseconds + 999 // 1000) wait]
+ ifFalse: [Processor yield]!
Item was removed:
- ----- Method: StackInterpreterSimulator>>primitiveRelinquishProcessor (in category 'I/O primitives support') -----
- primitiveRelinquishProcessor
- "No-op in simulator"
-
- ^ self pop: 1!
Item was changed:
----- Method: StackInterpreterSimulator>>writeImageFileIO: (in category 'image save/restore') -----
writeImageFileIO: numberOfBytesToWrite
"Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."
| headerSize file |
BytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
headerSize := 64.
[
+ file := FileStream fileNamed: imageName.
+ file == nil ifTrue:
+ [self primitiveFail.
+ ^nil].
+ file binary.
- file := (FileStream fileNamed: imageName) binary.
- file == nil ifTrue: [^nil].
{
self imageFormatVersion.
headerSize.
numberOfBytesToWrite.
objectMemory startOfMemory.
(objectMemory specialObjectsOop).
(objectMemory lastHash).
self ioScreenSize.
fullScreenFlag.
extraVMMemory
}
do: [:long | self putLong: long toFile: file].
{ desiredNumStackPages. self unknownShortOrCodeSizeInKs } do:
[:short| self putShort: short toFile: file].
self putLong: desiredEdenBytes toFile: file.
{ maxExtSemTabSizeSet ifTrue: [self ioGetMaxExtSemTableSize] ifFalse: [0]. 0 } do:
[:short| self putShort: short toFile: file].
"Pad the rest of the header."
4 timesRepeat: [self putLong: 0 toFile: file].
"Position the file after the header."
file position: headerSize.
"Write the object memory."
objectMemory startOfMemory // 4 + 1
to: numberOfBytesToWrite // 4
do: [:index |
self
putLong: (objectMemory memory at: index)
toFile: file].
self success: true
]
+ ensure: [file ifNotNil: [file close]]!
- ensure: [file close]!
Item was added:
+ ----- Method: TMethod>>forceExport (in category 'accessing') -----
+ forceExport
+
+ export := true
+ !
Item was changed:
----- Method: VMMaker class>>generateSqueakCogVM (in category 'configurations') -----
generateSqueakCogVM
^VMMaker
generate: (Smalltalk at: ([:choices| choices at: (UIManager default chooseFrom: choices) ifAbsent: [^self]]
value: #(CoInterpreter CoInterpreterMT)))
and: StackToRegisterMappingCogit
with: #( MULTIPLEBYTECODESETS false
NewspeakVM false)
to: (FileDirectory default pathFromURI: 'oscogvm/src')
platformDir: (FileDirectory default pathFromURI: 'oscogvm/platforms')
including:#( ADPCMCodecPlugin AsynchFilePlugin BalloonEnginePlugin B3DAcceleratorPlugin
+ BMPReadWriterPlugin BitBltSimulation BochsIA32Plugin CroquetPlugin DSAPlugin
- BMPReadWriterPlugin BitBltSimulation BochsIA32Plugin GdbARMPlugin CroquetPlugin DSAPlugin
DeflatePlugin DropPlugin FT2Plugin FFTPlugin FileCopyPlugin FilePlugin FloatArrayPlugin
FloatMathPlugin GeniePlugin HostWindowPlugin IA32ABIPlugin InternetConfigPlugin
JPEGReadWriter2Plugin JPEGReaderPlugin JoystickTabletPlugin KlattSynthesizerPlugin
LargeIntegersPlugin LocalePlugin MIDIPlugin MacMenubarPlugin Matrix2x3Plugin
MiscPrimitivePlugin Mpeg3Plugin QuicktimePlugin RePlugin SecurityPlugin SerialPlugin
SocketPlugin SoundCodecPlugin SoundGenerationPlugin SoundPlugin ThreadedIA32FFIPlugin
StarSqueakPlugin UUIDPlugin UnixOSProcessPlugin Win32OSProcessPlugin VMProfileMacSupportPlugin)!
Item was changed:
----- Method: VMMaker class>>generateSqueakStackVM (in category 'configurations') -----
generateSqueakStackVM
"No primitives since we can use those for the Cog VM"
^VMMaker
generate: StackInterpreter
to: (FileDirectory default pathFromURI: 'oscogvm/stacksrc')
+ platformDir: (FileDirectory default pathFromURI: 'oscogvm/platforms')
- platformDir: (FileDirectory default pathFromURI: 'cogvm/platforms')
excluding: (InterpreterPlugin withAllSubclasses collect: [:ea| ea name])!
Item was changed:
----- Method: VMPluginCodeGenerator>>preDeclareInterpreterProxyOn: (in category 'C code generator') -----
preDeclareInterpreterProxyOn: aStream
"Put the necessary #defines needed before interpreterProxy. Basically
internal plugins use the VM's interpreterProxy variable and external plugins
use their own. Override to keep local copies of all functions in external
prims, and link directly in internal plugins."
+ "| pcc |
+ pcc := self new.
+ (InterpreterProxy selectors reject: [:s| #(initialize private) includes: (InterpreterProxy whichCategoryIncludesSelector: s)]) do:
+ [:s| pcc noteUsedPluginFunction: s].
+ pcc preDeclareInterpreterProxyOn: Transcript.
+ Transcript flush"
| pluginsToClone |
(pluginsToClone := self pluginFunctionsToClone) isEmpty ifTrue:
[^super preDeclareInterpreterProxyOn: aStream].
aStream cr; nextPutAll: '#if !!defined(SQUEAK_BUILTIN_PLUGIN)'; cr.
pluginsToClone do:
[:selector| | functionName |
functionName := self cFunctionNameFor: selector.
aStream nextPutAll:
((String streamContents:
[:s|
(self compileToTMethodSelector: selector in: InterpreterProxy)
emitCFunctionPrototype: s generator: self])
copyReplaceAll: functionName
with: '(*', functionName, ')').
aStream nextPut: $;; cr].
aStream nextPutAll: '#else /* !!defined(SQUEAK_BUILTIN_PLUGIN) */'; cr.
pluginsToClone do:
[:selector|
aStream nextPutAll: 'extern '.
(self compileToTMethodSelector: selector in: InterpreterProxy)
static: false;
emitCFunctionPrototype: aStream generator: self.
aStream nextPut: $;; cr].
aStream cr; nextPutAll: 'extern'.
aStream cr; nextPutAll: '#endif'; cr!
More information about the Vm-dev
mailing list