[Vm-dev] VM Maker: VMMaker.oscog-eem.3075.mcz
commits at source.squeak.org
commits at source.squeak.org
Tue Sep 28 17:49:22 UTC 2021
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.3075.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.3075
Author: eem
Time: 28 September 2021, 10:49:06.44924 am
UUID: 094f2144-ced1-4fff-a1c0-c2949bf186b4
Ancestors: VMMaker.oscog-eem.3074
StackInterpreter:
Major change to debug printing so that the platform error handlers can print the call stack to a specific FILE * stream, not simply hack stdout via pushOutputFile.
transcript now becomes a FILE * inst var of StackInterpreter; all printing goes to this file. withRedirectedOutputTo:do: is used to switch it to another stream and implement printCallStackOn: et al. See protocol "debug printing redirected".
Platform changes to follow.
P.S. this commit may be broken because it will be followed by one for ThreasdedFFIPlugin failure codes which is saved for the subsequent commit using the Ignore facility.
=============== Diff against VMMaker.oscog-eem.3074 ===============
Item was added:
+ ----- Method: CArray>>copyFrom:to: (in category 'converting') -----
+ copyFrom: start to: stop
+ "Coercion support for Printf"
+ | string n |
+ unitSize = 1 ifTrue:
+ [string := ByteString new: (n := stop - start + 1).
+ interpreter strncpy: string _: self _: n.
+ ^string].
+ unitSize = 4 ifTrue:
+ [string := WideString new: (n := stop - start + 1).
+ interpreter strncpy: string _: self _: n * 4.
+ ^string].
+ self halt!
Item was changed:
----- Method: CCodeGenerator>>cLiteralFor: (in category 'C code generator') -----
cLiteralFor: anObject
"Return a string representing the C literal value for the given object."
anObject isNumber
ifTrue:
[anObject isInteger ifTrue:
[| hex dec useHexa |
hex := anObject printStringBase: 16.
dec := anObject printStringBase: 10.
useHexa := (anObject > 255
and: [(hex asSet size * 3) <= (dec asSet size * 2)
or: [((hex as: RunArray) runs size * 4) < ((dec as: RunArray) runs size * 3)]])
or: [anObject > 0
and: [(anObject >> anObject lowBit + 1) isPowerOfTwo
and: [(anObject highBit = anObject lowBit and: [anObject > 65536])
or: [anObject highBit - anObject lowBit >= 4]]]].
^self cLiteralForInteger: anObject hex: useHexa].
anObject isFloat ifTrue:
[^anObject printString]]
ifFalse:
[anObject isSymbol ifTrue:
[^self cFunctionNameFor: anObject].
anObject isString ifTrue:
[^'"', (anObject copyReplaceAll: (String with: Character cr) with: '\n') , '"'].
anObject == nil ifTrue: [^ 'null' ].
anObject == true ifTrue: [^ '1' ].
anObject == false ifTrue: [^ '0' ].
anObject isCharacter ifTrue:
+ [anObject == $' ifTrue: [^'''\''''']. "i.e. '\''"
+ anObject asInteger = 9 ifTrue: [^'''\t'''].
+ anObject asInteger = 13 ifTrue: [^'''\n'''].
+ ^anObject asString printString]].
- [^anObject == $'
- ifTrue: ['''\'''''] "i.e. '\''"
- ifFalse: [anObject asString printString]]].
self error: 'Warning: A Smalltalk literal could not be translated into a C constant: ', anObject printString.
^'"XXX UNTRANSLATABLE CONSTANT XXX"'!
Item was changed:
----- Method: CCodeGenerator>>cLiteralForPrintfString: (in category 'C code generator') -----
cLiteralForPrintfString: aString
+ ^(((('"', (PrintfFormatString new setFormat: aString) transformForVMMaker, '"')
+ copyReplaceAll: '16r%p' with: '%p')
+ copyReplaceAll: '16r%' with: '0x%')
+ copyReplaceAll: (String with: Character cr) with: '\n')
+ copyReplaceAll: (String with: Character tab) with: '\t'!
- ^(('"', (PrintfFormatString new setFormat: aString) transformForVMMaker, '"')
- copyReplaceAll: (String with: Character cr) with: '\n')
- copyReplaceAll: (String with: Character tab) with: '\t'!
Item was added:
+ ----- Method: CoInterpreter>>dumpPrimTraceLogOn: (in category 'debug printing redirected') -----
+ dumpPrimTraceLogOn: aStdioStream
+ "Print the prim trace log on a specific output stream."
+ <export: true> "essential for writing crash.dmp; use export: not api, so it will be accessible on win32 and won't be written to cointerp.h"
+ <var: 'aStdioStream' type: #'FILE *'>
+ self
+ withRedirectedOutputTo: aStdioStream
+ do: [self dumpPrimTraceLog]!
Item was removed:
- ----- Method: CoInterpreter>>dumpTraceLog (in category 'debug support') -----
- dumpTraceLog
- <api>
- "The trace log is a circular buffer of pairs of entries. If there is
- an entry at traceLogIndex - 3 \\ TraceBufferSize it has entries.
- If there is something at traceLogIndex it has wrapped."
- <inline: false>
- (traceLog at: (self safe: traceLogIndex - 3 mod: TraceBufferSize)) = 0 ifTrue: [^self].
- (traceLog at: traceLogIndex) ~= 0 ifTrue:
- [traceLogIndex to: TraceBufferSize - 3 by: 3 do:
- [:i| self printLogEntryAt: i]].
-
- 0 to: traceLogIndex - 3 by: 3 do:
- [:i| self printLogEntryAt: i]!
Item was changed:
----- Method: CoInterpreter>>printCogMethod: (in category 'debug printing') -----
printCogMethod: cogMethod
<export: true> "useful for VM debugging; use export: so it will be accessible on win32"
<api>
<var: #cogMethod type: #'CogMethod *'>
| address primitive |
self cCode: ''
inSmalltalk:
+ [transcript ensureCr.
- [self transcript ensureCr.
cogMethod isInteger ifTrue:
[^self printCogMethod: (self cCoerceSimple: cogMethod to: #'CogMethod *')]].
address := cogMethod asInteger.
self printHex: address;
print: ' <-> ';
printHex: address + cogMethod blockSize.
cogMethod cmType = CMMethod ifTrue:
[self print: ': method: ';
printHex: cogMethod methodObject.
primitive := self primitiveIndexOfMethod: cogMethod methodObject
header: cogMethod methodHeader.
primitive ~= 0 ifTrue:
[self print: ' prim '; printNum: primitive].
(objectMemory addressCouldBeObj: cogMethod methodObject) ifTrue:
[cogMethod cmIsFullBlock
ifTrue: [self print: ' [full]']
ifFalse:
[(objectMemory addressCouldBeObj: (self methodClassOf: cogMethod methodObject)) ifTrue:
[self space; printNameOfClass: (self methodClassOf: cogMethod methodObject) count: 2]]]].
cogMethod cmType = CMBlock ifTrue:
[self print: ': block home: ';
printHex: (self cCoerceSimple: cogMethod to: #'CogBlockMethod *') cmHomeMethod asUnsignedInteger].
cogMethod cmType = CMClosedPIC ifTrue:
[self print: ': Closed PIC N: ';
printHex: cogMethod cPICNumCases].
cogMethod cmType = CMOpenPIC ifTrue:
[self print: ': Open PIC '].
self print: ' selector: '; printHex: cogMethod selector.
cogMethod selector = objectMemory nilObject
ifTrue: [| s |
(cogMethod cmType = CMMethod
and: [(s := self maybeSelectorOfMethod: cogMethod methodObject) notNil])
ifTrue: [self print: ' (nil: '; printStringOf: s; print: ')']
ifFalse: [self print: ' (nil)']]
ifFalse: [self space; printStringOf: cogMethod selector].
self cr!
Item was changed:
----- Method: CoInterpreter>>printFrame:WithSP: (in category 'debug printing') -----
printFrame: theFP WithSP: theSP
<export: true> "useful for VM debugging; use export: not api, so it will be accessible on win32 and won't be written to cointerp.h"
| theMethod theMethodEnd numArgs numTemps rcvrAddress topThing |
<inline: false>
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
<var: #addr type: #'char *'>
<var: #rcvrAddress type: #'char *'>
<var: #cogMethod type: #'CogBlockMethod *'>
<var: #homeMethod type: #'CogMethod *'>
+ self cCode: '' inSmalltalk: [transcript ensureCr].
- self cCode: '' inSmalltalk: [self transcript ensureCr].
(stackPages couldBeFramePointer: theFP) ifNil:
[self printHexPtr: theFP; print: ' is not in the stack zone?!!'; cr.
^nil].
(self isMachineCodeFrame: theFP)
ifTrue:
[| cogMethod homeMethod |
cogMethod := self mframeCogMethod: theFP.
homeMethod := self mframeHomeMethod: theFP.
theMethod := homeMethod asInteger.
theMethodEnd := homeMethod asInteger + homeMethod blockSize.
numArgs := cogMethod cmNumArgs.
numTemps := self temporaryCountOfMethodHeader: homeMethod methodHeader]
ifFalse:
[theMethod := self frameMethodObject: theFP.
theMethodEnd := theMethod + (objectMemory sizeBitsOfSafe: theMethod).
numArgs := self iframeNumArgs: theFP.
numTemps := self tempCountOf: theMethod].
(self frameIsBlockActivation: theFP) ifTrue:
[| rcvrOrClosure |
"No BlockLocalTempCounter in the Cogit's C code, so quick hack is to use numCopied + numArgs"
rcvrOrClosure := self pushedReceiverOrClosureOfFrame: theFP.
((objectMemory isNonImmediate: rcvrOrClosure)
and: [(objectMemory addressCouldBeObj: rcvrOrClosure)
and: [(objectMemory fetchClassOfNonImm: rcvrOrClosure) = (objectMemory splObj: ClassBlockClosure)]])
ifTrue: [numTemps := numArgs + (self stSizeOf: rcvrOrClosure)]
ifFalse: [numTemps := numArgs]].
self shortPrintFrame: theFP.
(self isBaseFrame: theFP) ifTrue:
[self printFrameOop: '(caller ctxt'
at: theFP + (self frameStackedReceiverOffset: theFP) + (2 * objectMemory wordSize).
self printFrameOop: '(saved ctxt'
at: theFP + (self frameStackedReceiverOffset: theFP) + (1 * objectMemory wordSize)].
self printFrameOop: 'rcvr/clsr'
at: theFP + FoxCallerSavedIP + ((numArgs + 1) * objectMemory wordSize).
numArgs to: 1 by: -1 do:
[:i|
self printFrameOop: 'arg' index: numArgs - i at: theFP + FoxCallerSavedIP + (i * objectMemory wordSize)].
self printFrameThing: 'caller ip'
at: theFP + FoxCallerSavedIP
extraString: ((stackPages longAt: theFP + FoxCallerSavedIP) = cogit ceReturnToInterpreterPC ifTrue:
['ceReturnToInterpreter']).
self printFrameThing: 'saved fp' at: theFP + FoxSavedFP.
self printFrameMethodFor: theFP.
(self isMachineCodeFrame: theFP) ifTrue:
[self printFrameFlagsForFP: theFP].
self printFrameOop: 'context' at: theFP + FoxThisContext.
(self isMachineCodeFrame: theFP) ifFalse:
[self printFrameFlagsForFP: theFP].
(self isMachineCodeFrame: theFP)
ifTrue: [rcvrAddress := theFP + FoxMFReceiver]
ifFalse:
[self printFrameThing: 'saved ip'
at: theFP + FoxIFSavedIP
extra: ((self iframeSavedIP: theFP) = 0
ifTrue: [0]
ifFalse: [(self iframeSavedIP: theFP) - theMethod + 2 - objectMemory baseHeaderSize]).
rcvrAddress := theFP + FoxIFReceiver].
self printFrameOop: 'receiver' at: rcvrAddress.
topThing := stackPages longAt: theSP.
(self oop: topThing isGreaterThanOrEqualTo: theMethod andLessThan: theMethodEnd)
ifTrue:
[rcvrAddress - objectMemory wordSize to: theSP + objectMemory wordSize by: objectMemory wordSize negated do:
[:addr| | index |
index := rcvrAddress - addr / objectMemory wordSize + numArgs.
index <= numTemps
ifTrue: [self printFrameOop: 'temp' index: index - 1 at: addr]
ifFalse: [self printFrameOop: ((self frameIsBlockActivation: theFP)
ifTrue: ['temp/stck']
ifFalse: ['stck'])
at: addr]].
self printFrameThing: 'frame ip'
at: theSP
extra: ((self isMachineCodeFrame: theFP)
ifTrue: [topThing - theMethod]
ifFalse: [topThing - theMethod + 2 - objectMemory baseHeaderSize])]
ifFalse:
[rcvrAddress - objectMemory wordSize to: theSP by: objectMemory wordSize negated do:
[:addr| | index |
index := rcvrAddress - addr / objectMemory wordSize + numArgs.
index <= numTemps
ifTrue: [self printFrameOop: 'temp' index: index - 1 at: addr]
ifFalse: [self printFrameOop: ((self frameIsBlockActivation: theFP)
ifTrue: ['temp/stck']
ifFalse: ['stck'])
at: addr]]]!
Item was removed:
- ----- Method: CoInterpreter>>printLogEntryAt: (in category 'debug support') -----
- printLogEntryAt: i
- <inline: false>
- | intOrClass selectorMethodOrProcess source |
- intOrClass := traceLog at: i.
- selectorMethodOrProcess := traceLog at: i + 1.
- source := traceLog at: i + 2.
- source <= TraceIsFromInterpreter ifTrue:
- [self print: (traceSources at: source); space].
- (objectMemory isIntegerObject: intOrClass)
- ifTrue:
- [intOrClass = TraceStackOverflow ifTrue:
- [self print: 'stack overflow'].
- intOrClass = TraceContextSwitch ifTrue:
- [self print: 'context switch from '; printHex: selectorMethodOrProcess].
- intOrClass = TraceBlockActivation ifTrue:
- [self print: ' [] in '; printHex: selectorMethodOrProcess].
- intOrClass = TraceBlockCreation ifTrue:
- [self print: 'create [] '; printHex: selectorMethodOrProcess].
- intOrClass = TraceIncrementalGC ifTrue:
- [self print: 'incrementalGC'].
- intOrClass = TraceFullGC ifTrue:
- [self print: 'fullGC'].
- intOrClass = TraceCodeCompaction ifTrue:
- [self print: 'compactCode'].
- intOrClass = TraceVMCallback ifTrue:
- [self print: 'callback'].
- intOrClass = TraceVMCallbackReturn ifTrue:
- [self print: 'return from callback']]
- ifFalse:
- [self space; printNameOfClass: intOrClass count: 5; print: '>>'; printStringOf: selectorMethodOrProcess].
- source > TraceIsFromInterpreter ifTrue:
- [self space; print: (traceSources at: source)].
- self cr!
Item was changed:
----- Method: CoInterpreter>>printMethodCacheFor: (in category 'debug printing') -----
printMethodCacheFor: thing
<export: true> "useful for VM debugging; use export: not api, so it will be accessible on win32 and won't be written to cointerp.h"
| n |
n := 0.
0 to: MethodCacheSize - 1 by: MethodCacheEntrySize do:
[:i | | s c m p |
s := methodCache at: i + MethodCacheSelector.
c := methodCache at: i + MethodCacheClass.
m := methodCache at: i + MethodCacheMethod.
p := methodCache at: i + MethodCachePrimFunction.
((thing = -1 or: [s = thing or: [c = thing or: [p = thing or: [m = thing
or: [(objectMemory addressCouldBeObj: m)
and: [(self maybeMethodHasCogMethod: m)
and: [(self cogMethodOf: m) asInteger = thing]]]]]]])
and: [(objectMemory addressCouldBeOop: s)
and: [c ~= 0
and: [(self addressCouldBeClassObj: c)
or: [self addressCouldBeClassObj: (objectMemory classForClassTag: c)]]]]) ifTrue:
[n := n + 1.
self cCode: [] inSmalltalk: [self transcript ensureCr].
self printNum: i; space; printHexnp: i; cr; tab.
(objectMemory isBytesNonImm: s)
+ ifTrue: ['%p %.*s\n' f: transcript printf: { s. objectMemory numBytesOfBytes: s. objectMemory firstIndexableField: s }]
- ifTrue: [self cCode: 'printf("%" PRIxSQPTR " %.*s\n", s, (int)(numBytesOf(s)), (char *)firstIndexableField(s))'
- inSmalltalk: [self printHex: s; space; print: (self stringOf: s); cr]]
ifFalse: [self shortPrintOop: s].
self tab.
(self addressCouldBeClassObj: c)
ifTrue: [self shortPrintOop: c]
ifFalse: [self printNum: c; space; printHexnp: c; space; shortPrintOop: (objectMemory classForClassTag: c)].
self tab; shortPrintOop: m; tab.
self cCode:
[p > 1024
ifTrue: [self printHexnp: p]
ifFalse: [self printNum: p]]
inSmalltalk:
[p isSymbol ifTrue: [self print: p] ifFalse: [self printNum: p]].
self cr]].
n > 1 ifTrue:
[self printNum: n; cr]!
Item was changed:
----- Method: CoInterpreter>>printPrimLogEntryAt: (in category 'debug support') -----
printPrimLogEntryAt: i
<inline: false>
| intOrSelector |
intOrSelector := primTraceLog at: i.
(objectMemory isImmediate: intOrSelector)
ifTrue:
[intOrSelector = TraceIncrementalGC ifTrue:
[self print: '**IncrementalGC**'. ^nil].
intOrSelector = TraceFullGC ifTrue:
[self print: '**FullGC**'. ^nil].
intOrSelector = TraceCodeCompaction ifTrue:
[self print: '**CompactCode**'. ^nil].
intOrSelector = TraceStackOverflow ifTrue:
[self print: '**StackOverflow**'. ^nil].
intOrSelector = TracePrimitiveFailure ifTrue:
[self print: '**PrimitiveFailure**'. ^nil].
intOrSelector = TracePrimitiveRetry ifTrue:
[self print: '**PrimitiveRetry**'. ^nil].
self print: '???']
ifFalse:
[intOrSelector = 0
+ ifTrue: ['%d!!!!!!' f: transcript printf: i]
- ifTrue: [self printNum: i; print: '!!!!!!']
ifFalse: [objectMemory safePrintStringOf: intOrSelector]]!
Item was changed:
----- Method: CoInterpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') -----
readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
"Read an image from the given file stream, allocating an amount of memory to its object heap.
V3: desiredHeapSize is the total size of the heap. Fail if the image has an unknown format or
requires more than the specified amount of memory.
Spur: desiredHeapSize is ignored; this routine will attempt to provide at least extraVMMemory's
ammount of free space after the image is loaded, taking any free space in the image into account.
extraVMMemory is stored in the image header and is accessible as vmParameterAt: 23. If
extraVMMemory is 0, the value defaults to the default grow headroom. Fail if the image has an
unknown format or if sufficient memory cannot be allocated.
Details: This method detects when the image was stored on a machine with the opposite byte
ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header
information to start 512 bytes into the file, since some file transfer programs for the Macintosh
apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix
area could also be used to store an exec command on Unix systems, allowing one to launch
Smalltalk by invoking the image name as a command."
| swapBytes headerStart headerSize headerFlags dataSize bytesRead bytesToShift heapSize
oldBaseAddr minimumMemory allocationReserve cogCodeBase
firstSegSize hdrNumStackPages hdrEdenBytes hdrCogCodeSize hdrMaxExtSemTabSize |
<var: #f type: #sqImageFile>
<var: #heapSize type: #usqInt>
<var: #dataSize type: #'size_t'>
<var: #minimumMemory type: #usqInt>
<var: #desiredHeapSize type: #usqInt>
<var: #allocationReserve type: #usqInt>
<var: #headerStart type: #squeakFileOffsetType>
<var: #imageOffset type: #squeakFileOffsetType>
+ transcript := #stdout. "stdout is not available at compile time. this is the earliest available point."
metaclassNumSlots := 6. "guess Metaclass instSize"
classNameIndex := 6. "guess (Class instVarIndexFor: 'name' ifAbsent: []) - 1"
swapBytes := self checkImageVersionFrom: f startingAt: imageOffset.
headerStart := (self sqImageFilePosition: f) - 4. "record header start position"
headerSize := self getWord32FromFile: f swap: swapBytes.
dataSize := self getLongFromFile: f swap: swapBytes.
oldBaseAddr := self getLongFromFile: f swap: swapBytes.
objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes).
objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "N.B. not used."
savedWindowSize := self getLongFromFile: f swap: swapBytes.
headerFlags := self getLongFromFile: f swap: swapBytes.
self setImageHeaderFlagsFrom: headerFlags.
extraVMMemory := self getWord32FromFile: f swap: swapBytes. "N.B. ignored in V3."
hdrNumStackPages := self getShortFromFile: f swap: swapBytes.
"4 stack pages is small. Should be able to run with as few as
three. 4 should be comfortable but slow. 8 is a reasonable
default. Can be changed via vmParameterAt: 43 put: n.
Can be set as a preference (Info.plist, VM.ini, command line etc).
If desiredNumStackPages is already non-zero then it has been
set as a preference. Ignore (but preserve) the header's default."
numStackPages := desiredNumStackPages ~= 0
ifTrue: [desiredNumStackPages]
ifFalse: [hdrNumStackPages = 0
ifTrue: [self defaultNumStackPages]
ifFalse: [hdrNumStackPages]].
desiredNumStackPages := hdrNumStackPages.
"This slot holds the size of the native method zone in 1k units. (pad to word boundary)."
hdrCogCodeSize := (self getShortFromFile: f swap: swapBytes) * 1024.
cogCodeSize := desiredCogCodeSize ~= 0
ifTrue: [desiredCogCodeSize]
ifFalse:
[hdrCogCodeSize = 0
ifTrue: [cogit defaultCogCodeSize]
ifFalse: [desiredCogCodeSize := hdrCogCodeSize]]. "set for vmParameter 47"
cogCodeSize > cogit maxCogCodeSize ifTrue:
[cogCodeSize := cogit maxCogCodeSize].
hdrEdenBytes := self getWord32FromFile: f swap: swapBytes.
objectMemory edenBytes: (desiredEdenBytes ~= 0
ifTrue: [desiredEdenBytes]
ifFalse:
[hdrEdenBytes = 0
ifTrue: [objectMemory defaultEdenBytes]
ifFalse: [hdrEdenBytes]]).
desiredEdenBytes := hdrEdenBytes.
hdrMaxExtSemTabSize := self getShortFromFile: f swap: swapBytes.
hdrMaxExtSemTabSize ~= 0 ifTrue:
[self setMaxExtSemSizeTo: hdrMaxExtSemTabSize].
"pad to word boundary. This slot can be used for anything else that will fit in 16 bits.
Preserve it to be polite to other VMs."
the2ndUnknownShort := self getShortFromFile: f swap: swapBytes.
firstSegSize := self getLongFromFile: f swap: swapBytes.
objectMemory firstSegmentSize: firstSegSize.
"compare memory requirements with availability"
allocationReserve := self interpreterAllocationReserveBytes.
minimumMemory := cogCodeSize "no need to include the stackZone; this is alloca'ed"
+ dataSize
+ objectMemory newSpaceBytes
+ allocationReserve.
"Compute how much space is needed for the initial heap allocation.
no need to include the stackZone; this is alloca'ed.
no need to include the JIT code zone size; this is allocated separately."
objectMemory hasSpurMemoryManagerAPI
ifTrue:
[| freeOldSpaceInImage headroom |
freeOldSpaceInImage := self getLongFromFile: f swap: swapBytes.
headroom := objectMemory
initialHeadroom: extraVMMemory
givenFreeOldSpaceInImage: freeOldSpaceInImage.
heapSize := objectMemory roundUpHeapSize:
dataSize
+ headroom
+ objectMemory newSpaceBytes
+ (headroom > allocationReserve
ifTrue: [0]
ifFalse: [allocationReserve])]
ifFalse:
[heapSize := desiredHeapSize
+ objectMemory newSpaceBytes
+ (desiredHeapSize - dataSize > allocationReserve
ifTrue: [0]
ifFalse: [allocationReserve]).
heapSize < minimumMemory ifTrue:
[self insufficientMemorySpecifiedError]].
"allocateJITMemory will assign the actual size allocated, which is rounded up to a page boundary."
cogCodeBase := self allocateJITMemory: (self addressOf: cogCodeSize).
"allocate a contiguous block of memory for the Squeak heap and ancilliary data structures"
(self
allocateMemory: heapSize
minimum: minimumMemory
imageFile: f
headerSize: headerSize) asUnsignedInteger
ifNil: [self insufficientMemoryAvailableError]
ifNotNil:
[:mem| "cannot clash with the variable memory still in use in NewCoObjectMemory and superclasses"
objectMemory
setHeapBase: (heapBase := mem)
memoryLimit: mem + heapSize
endOfMemory: mem + dataSize].
"position file after the header"
self sqImageFile: f Seek: headerStart + headerSize.
"read in the image in bulk, then swap the bytes if necessary"
bytesRead := objectMemory readHeapFromImageFile: f dataBytes: dataSize.
bytesRead ~= dataSize ifTrue: [self unableToReadImageError].
self ensureImageFormatIsUpToDate: swapBytes.
"compute difference between old and new memory base addresses"
bytesToShift := objectMemory memoryBaseForImageRead - oldBaseAddr.
self initializeInterpreter: bytesToShift. "adjusts all oops to new location"
cogit initializeCodeZoneFrom: cogCodeBase upTo: cogCodeBase + cogCodeSize.
^dataSize!
Item was changed:
----- Method: CoInterpreter>>reportMinimumUnusedHeadroom (in category 'debug support') -----
reportMinimumUnusedHeadroom
"Report the stack page size and minimum unused headroom to stdout."
+ <export: true>
+ 'stack page bytes %ld available headroom %ld minimum unused headroom %ld\n'
+ f: transcript
+ printf: {self stackPageByteSize.
+ self stackPageByteSize - self stackLimitBytes - self stackLimitOffset.
+ self minimumUnusedHeadroom }!
- <api>
- self cCode:
- [self pri: 'stack page bytes %lld available headroom %lld minimum unused headroom %lld\n'
- n: self stackPageByteSize asUnsignedLongLong
- t: (self stackPageByteSize - self stackLimitBytes - self stackLimitOffset) asUnsignedLongLong
- f: self minimumUnusedHeadroom asUnsignedLongLong]
- 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 added:
+ ----- Method: CoInterpreter>>reportMinimumUnusedHeadroomOn: (in category 'debug printing redirected') -----
+ reportMinimumUnusedHeadroomOn: aStdioStream
+ "Report the stack page size and minimum unused headroom to a stream."
+ <export: true>
+ <var: 'aStdioStream' type: #'FILE *'>
+ self
+ withRedirectedOutputTo: aStdioStream
+ do: [self reportMinimumUnusedHeadroom]!
Item was changed:
----- Method: CoInterpreter>>shortPrintFrame: (in category 'debug printing') -----
shortPrintFrame: theFP
<inline: false>
<var: #theFP type: #'char *'>
| rcvr mthd |
(stackPages couldBeFramePointer: theFP) ifFalse:
[self print: 'invalid frame pointer'; cr.
^nil].
rcvr := self frameReceiver: theFP.
mthd := self frameMethodObject: theFP.
+ self printHexPtrnp: theFP.
- self printHexPtr: theFP.
self space.
self printChar: ((self isMachineCodeFrame: theFP) ifTrue: [$M] ifFalse: [$I]).
self space.
self printActivationNameFor: mthd
receiver: rcvr
isBlock: (self frameIsBlockActivation: theFP)
firstTemporary: (self temporary: 0 in: theFP).
self space.
self shortPrintOop: rcvr "shortPrintOop: adds a cr"!
Item was removed:
- ----- Method: CoInterpreter>>transcript (in category 'simulation') -----
- transcript
- <doNotGenerate>
- ^Transcript!
Item was removed:
- ----- Method: CoInterpreter>>warning: (in category 'cog jit support') -----
- warning: aString
- <api: 'extern void warning(const char *s)'>
- <doNotGenerate>
- self transcript cr; nextPutAll: aString; flush!
Item was removed:
- ----- Method: CoInterpreterMT>>printLogEntryAt: (in category 'debug support') -----
- printLogEntryAt: i
- <inline: false>
- | intOrClass selectorOrMethod source |
- intOrClass := traceLog at: i.
- selectorOrMethod := traceLog at: i + 1.
- self printNum: ((traceLog at: i + 2) bitShift: -16); space.
- source := (traceLog at: i + 2) bitAnd: 16rFFFF.
- source <= TraceIsFromInterpreter ifTrue:
- [self print: (traceSources at: source); space].
- (objectMemory isIntegerObject: intOrClass)
- ifTrue:
- [| value |
- value := objectMemory integerValueOf: selectorOrMethod.
- intOrClass = TraceContextSwitch ifTrue:
- [self print: 'context switch'].
- intOrClass = TraceBlockActivation ifTrue:
- [self print: ' [] in '; printHex: selectorOrMethod].
- intOrClass = TraceBlockCreation ifTrue:
- [self print: 'create [] '; printHex: selectorOrMethod].
- intOrClass = TraceIncrementalGC ifTrue:
- [self print: 'incrementalGC'].
- intOrClass = TraceFullGC ifTrue:
- [self print: 'fullGC'].
- intOrClass = TraceCodeCompaction ifTrue:
- [self print: 'compactCode'].
- intOrClass = TraceVMCallback ifTrue:
- [self print: 'callback'].
- intOrClass = TraceVMCallbackReturn ifTrue:
- [self print: 'return from callback'].
- intOrClass = TraceThreadSwitch ifTrue:
- [self print: 'thread switch '; printNum: (value bitAnd: 16rFFFF); print: '->'; printNum: (value >> 16)].
- intOrClass = TracePreemptDisowningThread ifTrue:
- [self print: 'preempt thread '; printNum: value].
- intOrClass = TraceOwnVM ifTrue:
- [self print: 'ownVM '; printNum: value].
- intOrClass = TraceDisownVM ifTrue:
- [self print: 'disownVM '; printHex: value]]
- ifFalse:
- [self space; printNameOfClass: intOrClass count: 5; print: '>>'; printStringOf: selectorOrMethod].
- source > TraceIsFromInterpreter ifTrue:
- [self space; print: (traceSources at: source)].
- self cr!
Item was changed:
CoInterpreterMT subclass: #CogVMSimulator
+ instanceVariableNames: 'parent enableCog byteCount lastPollCount lastExtPC sendCount lookupCount printSends myBitBlt displayForm fakeForm imageName pluginList mappedPluginEntries quitBlock displayView eventTransformer printFrameAtEachStep printBytecodeAtEachStep systemAttributes uniqueIndices uniqueIndex breakCount atEachStepBlock startMicroseconds lastYieldMicroseconds externalSemaphoreSignalRequests externalSemaphoreSignalResponses extSemTabSize debugStackDepthDictionary performFilters eventQueue effectiveCogCodeSize expectedSends expecting inputSemaphoreIndex zeroNextProfileTickCount perMethodProfile'
- instanceVariableNames: 'parent enableCog byteCount lastPollCount lastExtPC sendCount lookupCount printSends traceOn myBitBlt displayForm fakeForm imageName pluginList mappedPluginEntries quitBlock transcript displayView eventTransformer printFrameAtEachStep printBytecodeAtEachStep systemAttributes uniqueIndices uniqueIndex breakCount atEachStepBlock startMicroseconds lastYieldMicroseconds externalSemaphoreSignalRequests externalSemaphoreSignalResponses extSemTabSize debugStackDepthDictionary performFilters eventQueue effectiveCogCodeSize expectedSends expecting inputSemaphoreIndex zeroNextProfileTickCount perMethodProfile'
classVariableNames: 'ByteCountsPerMicrosecond ExpectedSends NLRFailures NLRSuccesses StackAlteringPrimitives'
poolDictionaries: ''
category: 'VMMaker-JITSimulation'!
!CogVMSimulator commentStamp: 'eem 9/3/2013 11:16' prior: 0!
This class defines basic memory access and primitive simulation so that the CoInterpreter can run simulated in the Squeak environment. It also defines a number of handy object viewing methods to facilitate pawing around in the object memory. Remember that you can test the Cogit using its class-side in-image compilation facilities.
To see the thing actually run, you could (after backing up this image and changes), execute
(CogVMSimulator new openOn: Smalltalk imageName) test
and be patient both to wait for things to happen, and to accept various things that may go wrong depending on how large or unusual your image may be. We usually do this with a small and simple benchmark image.
Here's an example to launch the simulator in a window. The bottom-right window has a menu packed with useful stuff:
(CogVMSimulator newWithOptions: #(Cogit StackToRegisterMappingCogit))
desiredNumStackPages: 8;
openOn: '/Users/eliot/Cog/startreader.image';
openAsMorph;
run
Here's a hairier example that I (Eliot) actually use in daily development with some of the breakpoint facilities commented out.
| cos proc opts |
CoInterpreter initializeWithOptions: (opts := Dictionary newFromPairs: #(Cogit StackToRegisterMappingCogit)).
CogVMSimulator chooseAndInitCogitClassWithOpts: opts.
cos := CogVMSimulator new.
"cos initializeThreadSupport." "to test the multi-threaded VM"
cos desiredNumStackPages: 8. "to set the size of the stack zone"
"cos desiredCogCodeSize: 8 * 1024 * 1024." "to set the size of the Cogit's code zone"
cos openOn: '/Users/eliot/Squeak/Squeak4.4/trunk44.image'. "choose your favourite image"
"cos setBreakSelector: 'r:degrees:'." "set a breakpoint at a specific selector"
proc := cos cogit processor.
"cos cogit sendTrace: 7." "turn on tracing"
"set a complex breakpoint at a specific point in machine code"
"cos cogit singleStep: true; breakPC: 16r56af; breakBlock: [:cg| cos framePointer > 16r101F3C and: [(cos longAt: cos framePointer - 4) = 16r2479A and: [(cos longAt: 16r101F30) = (cos longAt: 16r101F3C) or: [(cos longAt: 16r101F2C) = (cos longAt: 16r101F3C)]]]]; sendTrace: 1".
"[cos cogit compilationTrace: -1] on: MessageNotUnderstood do: [:ex|]." "turn on compilation tracing in the StackToRegisterMappingCogit"
"cos cogit setBreakMethod: 16rB38880."
cos
openAsMorph;
"toggleTranscript;" "toggleTranscript will send output to the Transcript instead of the morph's rather small window"
halt;
run!
Item was removed:
- ----- Method: CogVMSimulator>>cr (in category 'debug printing') -----
- cr
-
- traceOn ifTrue: [ transcript cr; flush ].!
Item was changed:
----- Method: CogVMSimulator>>ensureDebugAtEachStepBlock (in category 'testing') -----
ensureDebugAtEachStepBlock
atEachStepBlock := [printFrameAtEachStep ifTrue:
[self printFrame: localFP WithSP: localSP].
printBytecodeAtEachStep ifTrue:
+ [self printCurrentBytecodeOn: transcript].
- [self printCurrentBytecodeOn: transcript.
- transcript cr; flush].
byteCount = breakCount ifTrue:
["printFrameAtEachStep :=" printBytecodeAtEachStep := true]]!
Item was changed:
----- Method: CogVMSimulator>>flush (in category 'debug printing') -----
flush
+ transcript flush.
+ "We *always* want to make transcript visible on flush"
+ TranscriptStream forceUpdate ifFalse:
+ [transcript changed: #appendEntry]!
- traceOn ifTrue:
- [transcript flush.
- "We *always* want to make output visible on flush"
- TranscriptStream forceUpdate ifFalse:
- [transcript changed: #appendEntry]]!
Item was changed:
----- Method: CogVMSimulator>>initialize (in category 'initialize-release') -----
initialize
"Initialize the CogVMSimulator 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."
super initialize.
transcript := Transcript.
objectMemory ifNil:
[objectMemory := InitializationOptions
at: #ObjectMemorySimulator
ifPresent: [:className| (Smalltalk classNamed: className) new]
ifAbsent: [self class objectMemoryClass simulatorClass new]].
cogit ifNil:
[cogit := self class cogitClass new setInterpreter: self].
objectMemory coInterpreter: self cogit: cogit.
(cogit numRegArgs > 0
and: [VMClass initializationOptions at: #CheckStackDepth ifAbsent: [true]]) ifTrue:
[debugStackDepthDictionary := Dictionary new].
cogThreadManager ifNotNil:
[super initialize].
self assert: ConstMinusOne = (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.
nsMethodCache := Array new: NSMethodCacheSize.
atCache := nil.
self flushMethodCache.
cogCompiledCodeCompactionCalledFor := false.
gcSemaphoreIndex := 0.
externalSemaphoreSignalRequests := externalSemaphoreSignalResponses := #().
externalPrimitiveTable := CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize).
externalPrimitiveTableFirstFreeIndex := 0.
primitiveTable := self class primitiveTable copy.
self initializePluginEntries.
desiredNumStackPages := InitializationOptions at: #desiredNumStackPages ifAbsent: [0].
desiredEdenBytes := InitializationOptions at: #desiredEdenBytes ifAbsent: [0].
desiredCogCodeSize := InitializationOptions at: #desiredCogCodeSize ifAbsent: [0].
"This is initialized on loading the image, but convenient for testing stack page values..."
numStackPages := self defaultNumStackPages.
startMicroseconds := lastYieldMicroseconds := self ioUTCStartMicroseconds.
maxLiteralCountForCompile := MaxLiteralCountForCompile.
minBackwardJumpCountForCompile := MinBackwardJumpCountForCompile.
flagInterpretedMethods := false.
"initialize InterpreterSimulator variables used for debugging"
byteCount := lastPollCount := sendCount := lookupCount := 0.
quitBlock := [^self close].
- traceOn := true.
printSends := printFrameAtEachStep := printBytecodeAtEachStep := false.
myBitBlt := BitBltSimulator new setInterpreter: self.
displayForm := fakeForm := '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.
zeroNextProfileTickCount := 0!
Item was changed:
----- Method: CogVMSimulator>>logOfBytesVerify:fromFileNamed:fromStart: (in category 'testing') -----
logOfBytesVerify: nBytes fromFileNamed: fileName fromStart: loggingStart
"Verify a questionable interpreter against a successful run"
"self logOfBytesVerify: 10000 fromFileNamed: 'clone32Bytecodes.log' "
| logFile rightWord prevCtxt |
logFile := (FileStream readOnlyFileNamed: fileName) binary.
transcript clear.
byteCount := 0.
quitBlock := [^self close].
self initStackPages.
self loadInitialContext.
self internalizeIPandSP.
self fetchNextBytecode.
prevCtxt := 0. prevCtxt := prevCtxt.
[byteCount < nBytes] whileTrue:
[
"
byteCount > 14560 ifTrue:
[self externalizeIPandSP.
prevCtxt = activeContext ifFalse:
+ [prevCtxt := activeContext.
+ transcript cr; nextPutAll: (self printTop: 2); endEntry].
+ transcript
+ cr; print: byteCount; nextPutAll: ': ' , (activeContext hex); space;
+ print: (instructionPointer - method - (BaseHeaderSize - 2));
+ nextPutAll: ': <' , (self byteAt: localIP) hex , '>'; space;
+ nextPutAll: (self symbolic: currentBytecode at: localIP inMethod: method); space;
+ print: (self stackPointerIndex - CtxtTempFrameStart + 1); endEntry.
- [prevCtxt := activeContext.
- transcript cr; nextPutAll: (self printTop: 2); endEntry].
- transcript cr; print: byteCount; nextPutAll: ': ' , (activeContext hex); space;
- print: (instructionPointer - method - (BaseHeaderSize - 2));
- nextPutAll: ': <' , (self byteAt: localIP) hex , '>'; space;
- nextPutAll: (self symbolic: currentBytecode at: localIP inMethod: method); space;
- print: (self stackPointerIndex - TempFrameStart + 1); endEntry.
byteCount = 14590 ifTrue: [self halt]].
"
loggingStart >= byteCount ifTrue:
[rightWord := logFile nextWord.
currentBytecode = rightWord ifFalse:
[self halt: 'halt at ', byteCount printString]].
self dispatchOn: currentBytecode in: BytecodeTable.
self incrementByteCount].
self externalizeIPandSP.
logFile close.
self inform: nBytes printString , ' bytecodes verfied.'!
Item was changed:
----- Method: CogVMSimulator>>logOfSendsVerify:fromFileNamed:fromStart: (in category 'testing') -----
logOfSendsVerify: nSends fromFileNamed: fileName fromStart: loggingStart
"Write a log file for testing a flaky interpreter on the same image"
"self logOfSendsWrite: 10000 toFileNamed: 'clone32Messages.log' "
| logFile priorFrame rightSelector prevCtxt |
logFile := FileStream readOnlyFileNamed: fileName.
transcript clear.
byteCount := 0.
sendCount := 0.
priorFrame := localFP.
quitBlock := [^self close].
self initStackPages.
self loadInitialContext.
self internalizeIPandSP.
self fetchNextBytecode.
prevCtxt := 0. prevCtxt := prevCtxt.
[sendCount < nSends] whileTrue:
[
"
byteCount>500 ifTrue:
[byteCount>550 ifTrue: [self halt].
self externalizeIPandSP.
prevCtxt = localFP ifFalse:
[prevCtxt := localFP.
transcript cr; nextPutAll: (self printTop: 2); endEntry].
transcript cr; print: byteCount; nextPutAll: ': ' , (localFP hex); space;
print: (instructionPointer - method - (BaseHeaderSize - 2));
nextPutAll: ': <' , (self byteAt: localIP) hex , '>'; space;
nextPutAll: (self symbolic: currentBytecode at: localIP inMethod: method); space;
+ print: (self stackPointerIndex - CtxtTempFrameStart + 1); endEntry.
- print: (self stackPointerIndex - TempFrameStart + 1); endEntry.
].
"
self dispatchOn: currentBytecode in: BytecodeTable.
localFP = priorFrame ifFalse:
[sendCount := sendCount + 1.
loggingStart >= sendCount ifTrue:
[rightSelector := logFile nextLine.
(self stringOf: messageSelector) = rightSelector ifFalse:
[self halt: 'halt at ', sendCount printString]].
priorFrame := localFP].
self incrementByteCount].
self externalizeIPandSP.
logFile close.
self inform: nSends printString , ' sends verfied.'!
Item was removed:
- ----- Method: CogVMSimulator>>print: (in category 'debug printing') -----
- print: it
-
- traceOn ifTrue:
- [it isString ifTrue: [transcript nextPutAll: it] ifFalse: [it printOn: transcript]]!
Item was removed:
- ----- Method: CogVMSimulator>>printChar: (in category 'debug printing') -----
- printChar: aByte
-
- traceOn ifTrue:
- [(aByte between: 0 and: 255)
- ifTrue: [transcript nextPut: aByte asCharacter]
- ifFalse: [transcript nextPutAll: 'BAD CHARACTER '.
- aByte printOn: transcript base: 16]]!
Item was changed:
----- Method: CogVMSimulator>>printCogMethod:on: (in category 'simulation only') -----
printCogMethod: cogMethod on: aStream
<doNotGenerate>
+ ^self
+ evaluatePrinter: [self printCogMethod: cogMethod]
+ on: aStream!
- | oldTranscript |
- oldTranscript := transcript.
- transcript := aStream.
- [self printCogMethod: cogMethod] ensure:
- [transcript := oldTranscript]!
Item was removed:
- ----- Method: CogVMSimulator>>printFloat: (in category 'debug printing') -----
- printFloat: f
-
- traceOn ifTrue: [ transcript print: f ]!
Item was removed:
- ----- Method: CogVMSimulator>>printHex: (in category 'debug printing') -----
- printHex: anInteger
- traceOn ifTrue:
- [self printHex: anInteger on: transcript]!
Item was removed:
- ----- Method: CogVMSimulator>>printHexnp: (in category 'debug printing') -----
- printHexnp: anInteger
-
- traceOn ifTrue:
- [transcript nextPutAll: ((anInteger ifNil: [0]) asInteger storeStringBase: 16)]!
Item was removed:
- ----- Method: CogVMSimulator>>printHexnpnp: (in category 'debug printing') -----
- printHexnpnp: anInteger
- "Print n in hex, in the form '1234', unpadded"
- traceOn ifTrue:
- [transcript nextPutAll: ((anInteger ifNil: [0]) printStringBase: 16)]!
Item was removed:
- ----- Method: CogVMSimulator>>printLogEntryAt: (in category 'multi-threading simulation switch') -----
- printLogEntryAt: i
- "This method includes or excludes CoInterpreterMT methods as required.
- Auto-generated by CogVMSimulator>>ensureMultiThreadingOverridesAreUpToDate"
-
- ^self perform: #printLogEntryAt:
- withArguments: {i}
- inSuperclass: (cogThreadManager ifNil: [CoInterpreterPrimitives] ifNotNil: [CoInterpreterMT])!
Item was removed:
- ----- Method: CogVMSimulator>>printNum: (in category 'debug printing') -----
- printNum: anInteger
-
- traceOn ifTrue: [ transcript print: anInteger ].!
Item was changed:
----- Method: CogVMSimulator>>printRumpCStackForThread: (in category 'rump c stack') -----
printRumpCStackForThread: thread
| range start coldTop |
range := self cStackRangeForThreadIndex: thread index.
+
start := range first bitClear: objectMemory tagMask.
coldTop := range last.
[start < coldTop and: [(objectMemory longAt: start) = 0]] whileTrue:
[start := start + objectMemory wordSize].
(start = coldTop and: [(objectMemory longAt: start) = 0]) ifTrue:
[^self].
start := start - (2 * objectMemory wordSize) max: range start.
transcript nextPutAll: 'thread '; print: thread index.
thread index = cogThreadManager getVMOwner ifTrue: [transcript nextPut: $*].
transcript cr.
self printRumpCStackFrom: start to: coldTop cfp: thread cFramePointer csp: thread cStackPointer.
range first < start ifTrue:
[self print: 'zeros...'; cr]!
Item was removed:
- ----- Method: CogVMSimulator>>printStringForCurrentBytecode (in category 'debug printing') -----
- printStringForCurrentBytecode
- ^String streamContents: [:str| self printCurrentBytecodeOn: str]!
Item was removed:
- ----- Method: CogVMSimulator>>space (in category 'debug printing') -----
- space
-
- traceOn ifTrue: [ transcript space ]!
Item was removed:
- ----- Method: CogVMSimulator>>sqShrinkMemory:By: (in category 'memory access') -----
- sqShrinkMemory: oldLimit By: delta
- transcript show: 'shrink memory from ', oldLimit printString, ' by ', delta printString, ' remember it doesn''t actually shrink in simulation'; cr.
-
- ^ oldLimit!
Item was removed:
- ----- Method: CogVMSimulator>>tab (in category 'debug printing') -----
- tab
-
- traceOn ifTrue: [ transcript tab ].!
Item was removed:
- ----- Method: CogVMSimulator>>transcript (in category 'simulation only') -----
- transcript
- ^transcript!
Item was removed:
- ----- Method: CogVMSimulator>>transcript: (in category 'simulation only') -----
- transcript: aTranscript
- transcript := aTranscript!
Item was changed:
----- Method: Cogit>>print: (in category 'printing') -----
print: aString
+ <doNotGenerate>
+ coInterpreter print: aString!
- <cmacro: '(aString) printf("%s", aString)'>
- coInterpreter transcript print: aString!
Item was changed:
----- Method: Cogit>>printPCMapPairsFor: (in category 'method map') -----
printPCMapPairsFor: cogMethod
<doNotGenerate>
"<api>
<var: 'cogMethod' type: #'CogMethod *'>
<var: 'mapByte' type: #'unsigned char'>"
| mcpc map mapByte annotation value |
mcpc := self firstMappedPCFor: cogMethod.
map := self mapStartFor: cogMethod.
[(mapByte := objectMemory byteAt: map) ~= MapEnd] whileTrue:
[annotation := mapByte >> AnnotationShift.
annotation = IsAnnotationExtension
ifTrue:
[value := (mapByte bitAnd: DisplacementMask) + IsSendCall]
ifFalse:
[value := annotation.
mcpc := mcpc + (backEnd codeGranularity
* (annotation = IsDisplacementX2N
ifTrue: [mapByte - DisplacementX2N << AnnotationShift]
ifFalse: [mapByte bitAnd: DisplacementMask]))].
+ ((NewspeakVM
- coInterpreter
- printHexnp: map;
- print: ': '.
- self
- cCode: [self print: '%02x' f: mapByte]
- inSmalltalk:
- [mapByte < 16 ifTrue:
- [coInterpreter putchar: $0].
- coInterpreter printHexnp: mapByte].
- coInterpreter
- printChar: $ ;
- printNum: annotation;
- print: ' ('.
- (NewspeakVM
and: [value = IsNSSendCall
+ or: [value between: IsNSSendCall and: IsNSImplicitReceiverSend]])
+ ifTrue:
+ [value caseOf: {
+ [IsNSSendCall] -> ['NSSendCall'].
+ [IsNSSelfSend] -> ['NSSelfSend'].
+ [IsNSDynamicSuperSend] -> ['NSDynamicSuperSend'].
+ [IsNSImplicitReceiverSend] -> ['NSImplicitReceiverSend'] }
+ otherwise: [nil]]
+ ifFalse:
+ [(BytecodeSetHasDirectedSuperSend
+ and: [value between: IsDirectedSuperSend and: IsDirectedSuperBindingSend])
+ ifTrue:
+ [value = IsDirectedSuperSend
+ ifTrue: ['DirectedSuperSend']
+ ifFalse: ['DirectedSuperBindingSend']]
+ ifFalse:
+ [value
+ caseOf: {
+ [IsDisplacementX2N] -> ['DisplacementX2N'].
+ [IsAnnotationExtension] -> ['AnnotationExtension'].
+ [IsObjectReference] -> ['ObjectReference'].
+ [IsAbsPCReference] -> ['AbsPCReference'].
+ [HasBytecodePC] -> ['HasBytecodePC'].
+ [IsRelativeCall] -> ['RelativeCall'].
+ [IsSendCall] -> ['SendCall'].
+ [IsSuperSend] -> ['SuperSend'] }
+ otherwise: [nil]]])
+ ifNil: ['%lx: %02x %ld (??? %d) 16r%x @ 16r%lx\n'
+ f: coInterpreter getTranscript
+ printf: { map. mapByte. annotation. value. mapByte bitAnd: DisplacementMask. mcpc }]
+ ifNotNil:
+ [:type|
+ '%lx: %02x %ld (%s) 16r%x @ 16r%lx\n'
+ f: coInterpreter getTranscript
+ printf: { map. mapByte. annotation. type. mapByte bitAnd: DisplacementMask. mcpc }].
- or: [value between: IsNSSendCall and: IsNSImplicitReceiverSend]]) ifTrue:
- [value
- caseOf: {
- [IsNSSendCall] -> [coInterpreter print: 'NSSendCall'].
- [IsNSSelfSend] -> [coInterpreter print: 'NSSelfSend'].
- [IsNSDynamicSuperSend] -> [coInterpreter print: 'NSDynamicSuperSend'].
- [IsNSImplicitReceiverSend] -> [coInterpreter print: 'NSImplicitReceiverSend'] }] ifFalse:
- [(BytecodeSetHasDirectedSuperSend
- and: [value between: IsDirectedSuperSend and: IsDirectedSuperBindingSend]) ifTrue:
- [value
- caseOf: {
- [IsDirectedSuperSend] -> [coInterpreter print: 'DirectedSuperSend'].
- [IsDirectedSuperBindingSend] -> [coInterpreter print: 'DirectedSuperBindingSend'] }] ifFalse:
- [value
- caseOf: {
- [IsDisplacementX2N] -> [coInterpreter print: 'DisplacementX2N'].
- [IsAnnotationExtension] -> [coInterpreter print: 'AnnotationExtension'].
- [IsObjectReference] -> [coInterpreter print: 'ObjectReference'].
- [IsAbsPCReference] -> [coInterpreter print: 'AbsPCReference'].
- [HasBytecodePC] -> [coInterpreter print: 'HasBytecodePC'].
- [IsRelativeCall] -> [coInterpreter print: 'RelativeCall'].
- [IsSendCall] -> [coInterpreter print: 'SendCall'].
- [IsSuperSend] -> [coInterpreter print: 'SuperSend'] }
- otherwise: [coInterpreter print: '??? '; printHexnp: value]]].
- coInterpreter
- print: ') ';
- printHexnp: (mapByte bitAnd: DisplacementMask);
- printChar: $ ;
- putchar: $@;
- printHex: mcpc;
- cr;
- flush.
map := map - 1]!
Item was changed:
----- Method: CurrentImageCoInterpreterFacade>>printChar: (in category 'printing') -----
printChar: aCharacter
+ coInterpreter printChar: aCharacter!
- coInterpreter transcript nextPut: aCharacter!
Item was removed:
- ----- Method: CurrentImageCoInterpreterFacade>>putchar: (in category 'printing') -----
- putchar: aCharacter
- coInterpreter transcript nextPut: aCharacter!
Item was changed:
VMClass subclass: #InterpreterPrimitives
+ instanceVariableNames: 'objectMemory messageSelector argumentCount newMethod primFailCode secondaryErrorCode exceptionPC inFFIFlags profileMethod profileProcess profileSemaphore nextProfileTick preemptionYields sHEAFn ffiExceptionResponse eventTraceMask'
- instanceVariableNames: 'objectMemory messageSelector argumentCount newMethod primFailCode osErrorCode exceptionPC inFFIFlags profileMethod profileProcess profileSemaphore nextProfileTick preemptionYields newFinalization sHEAFn ffiExceptionResponse eventTraceMask'
classVariableNames: 'CrossedX EndOfRun MillisecondClockMask'
poolDictionaries: 'VMBasicConstants VMBytecodeConstants VMMethodCacheConstants VMObjectIndices VMSqueakClassIndices VMStackFrameOffsets'
category: 'VMMaker-Interpreter'!
+ !InterpreterPrimitives commentStamp: 'eem 9/23/2021 13:20' prior: 0!
- !InterpreterPrimitives commentStamp: 'eem 8/24/2018 11:05' prior: 0!
InterpreterPrimitives implements most of the VM's core primitives. It is the root of the interpreter hierarchy so as to share the core primitives amongst the varioius interpreters.
Instance Variables
argumentCount <Integer>
+ eventTraceMask <Integer>
+ exceptionPC <Integer>
ffiExceptionResponse <Integer>
inFFIFlags <Integer>
messageSelector <Integer>
newMethod <Integer>
nextProfileTick <Integer>
objectMemory <ObjectMemory> (simulation only)
preemptionYields <Boolean>
primFailCode <Integer>
+ secondaryErrorCode <Integer>
- osErrorCode <Integer>
profileMethod <Integer>
profileProcess <Integer>
profileSemaphore <Integer>
+ sHEAFn <Integer>
- secHasEnvironmentAccess <Integer>
argumentCount
- the number of arguments of the current message
+ eventTraceMask
+ - a bit mask corresponding to the Event type codes in sq.h that decides what events are printed in primitiveGetNextEvent
+
+ exceptionPC
+ - the pc of an exception for an exception reporting primitive failure such as PrimErrFFIException
+
ffiExceptionResponse
- controls system response to exceptions during FFI calls. See primitiveFailForFFIException:at:
inFFIFlags
- flags recording currently only whether the system is in an FFI call
messageSelector
- the oop of the selector of the current message
newMethod
- the oop of the result of looking up the current message
nextProfileTick
- the millisecond clock value of the next profile tick (if profiling is in effect)
objectMemory
- the memory manager and garbage collector that manages the heap
preemptionYields
- a boolean controlling the process primitives. If true (old, incorrect, blue-book semantics) a preempted process is sent to the back of its run-queue. If false, a process preempted by a higher-priority process is put back at the head of its run queue, hence preserving cooperative scheduling within priorities.
primFailCode
- primitive success/failure flag, 0 for success, otherwise the reason code for failure
+ profileMethod
+ - the primitive method active when the last profile sample was taken (if any)
- osErrorCode
- - a 64-bit value settable by external primitives conveying arbitrary error codes from the operating system and/or system libraries
+ profileProcess
+ - the process active when the last profile sample was taken
+
+ profileSemaphore
+ - the semaphore to be signalled when a profile sample is taken; if nil disables profiling
+
+ secondaryErrorCode
+ - a 64-bit value settable for clonable primitive failures (PrimErrOSError, PrimErrFFIException et al)
+
profileMethod
- the oop of the method at the time nextProfileTick was reached
profileProcess
- the oop of the activeProcess at the time nextProfileTick was reached
profileSemaphore
- the oop of the semaphore to signal when nextProfileTick is reached
+ secondaryErrorCode
+ - an additional value associated with various primitive failures
+
+ sHEAFn
+ - the function to call to check if access to the envronment should be granted to primitiveGetenv!
- secHasEnvironmentAccess
- - the function to call to check if access to the envronment should be granted to primitiveGetenv
- !
Item was changed:
----- Method: InterpreterPrimitives class>>declareCVarsIn: (in category 'C translation') -----
declareCVarsIn: aCCodeGen
aCCodeGen
+ var: 'secondaryErrorCode' type: #sqLong;
- var: 'osErrorCode' type: #sqLong;
var: 'exceptionPC' type: #usqInt;
var: 'sHEAFn' declareC: 'int (*sHEAFn)() = 0' "the hasEnvironmentAccess function"!
Item was changed:
----- Method: InterpreterPrimitives>>initialize (in category 'initialization') -----
initialize
"Here we can initialize the variables C initializes to zero. #initialize methods do /not/ get translated."
+ argumentCount := primFailCode := nextProfileTick := secondaryErrorCode := exceptionPC := inFFIFlags := ffiExceptionResponse := eventTraceMask := 0!
- argumentCount := primFailCode := nextProfileTick := osErrorCode := exceptionPC := inFFIFlags := ffiExceptionResponse := eventTraceMask := 0.
- newFinalization := false!
Item was added:
+ ----- Method: InterpreterPrimitives>>primitiveFailFor:withSecondary: (in category 'primitive support') -----
+ primitiveFailFor: reasonCode withSecondary: extraErrorCode
+ <var: 'extraErrorCode' type: #sqLong>
+ "Set primFailCode primitive failure and associated secondaryErrorCode."
+ <api>
+ secondaryErrorCode := extraErrorCode.
+ ^primFailCode := reasonCode!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveFailForFFIException:at: (in category 'primitive support') -----
primitiveFailForFFIException: exceptionCode at: pc
<var: 'exceptionCode' type: #usqLong>
<var: 'pc' type: #usqInt>
"Set PrimErrFFIException primitive failure and associated exceptionCode (a.k.a.
+ secondaryErrorCode) and exceptionPC. Under control of the ffiExceptionResponse flag,
- osErrorCode) and exceptionPC. Under control of the ffiExceptionResponse flag,
if in a primitive with an error code and the inFFIFlags indicate we're in an FFI call,
then fail the primitive.
ffiExceptionResponse < 0 never fail
ffiExceptionResponse = 0 fail if method has a primitive error code (default)
ffiExceptionResponse > 0 always fail"
<api>
((inFFIFlags noMask: DisownVMForFFICall) "i.e. not in an FFI call"
or: [ffiExceptionResponse < 0]) ifTrue: "i.e. never fail"
[^self].
+ secondaryErrorCode := self cCoerceSimple: exceptionCode to: #sqLong.
- osErrorCode := self cCoerceSimple: exceptionCode to: #sqLong.
exceptionPC := pc.
primFailCode := PrimErrFFIException.
(ffiExceptionResponse > 0 "always fail..."
or: [(objectMemory isOopCompiledMethod: newMethod)
and: [self methodUsesPrimitiveErrorCode: newMethod]]) ifTrue:
[self ownVM: DisownVMForFFICall. "To take ownership but importantly to reset inFFIFlags"
self activateFailingPrimitiveMethod]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveFailForOSError: (in category 'primitive support') -----
+ primitiveFailForOSError: osErrorCode
+ <var: 'osErrorCode' type: #sqLong>
- primitiveFailForOSError: osError
- <var: 'osError' type: #sqLong>
"Set PrimErrOSError primitive failure and associated osErrorCode."
<api>
+ secondaryErrorCode := osErrorCode.
- osErrorCode := osError.
^primFailCode := PrimErrOSError!
Item was added:
+ ----- Method: NewObjectMemory>>printCantBeObject:on: (in category 'debug printing interpreter support') -----
+ printCantBeObject: oop on: aStream
+ <var: 'aStream' type: #'FILE *'>
+ '16r%lx%s\n'
+ f: aStream
+ printf: {oop.
+ ((oop bitAnd: self allocationUnit - 1) ~= 0
+ ifTrue: [' is misaligned']
+ ifFalse: [coInterpreter whereIs: oop])}!
Item was removed:
- ----- Method: NewObjectMemory>>printHeaderTypeOf: (in category 'debug printing') -----
- printHeaderTypeOf: obj
- (self headerType: obj) caseOf: {
- [HeaderTypeFree] -> [coInterpreter print: ' HeaderTypeFree (4 bytes)'].
- [HeaderTypeShort] -> [coInterpreter print: ' HeaderTypeShort (4 bytes)'].
- [HeaderTypeClass] -> [coInterpreter print: ' HeaderTypeClass (8 bytes)'].
- [HeaderTypeSizeAndClass] -> [coInterpreter print: ' HeaderTypeSizeAndClass (12 bytes)'] }!
Item was added:
+ ----- Method: NewObjectMemory>>printHeaderTypeOf:on: (in category 'debug printing interpreter support') -----
+ printHeaderTypeOf: obj on: aStream
+ <var: 'aStream' type: #'FILE *'>
+ <inline: true>
+ (self headerType: obj) caseOf: {
+ [HeaderTypeFree] -> [aStream printf: ' HeaderTypeFree (4 bytes)'].
+ [HeaderTypeShort] -> [aStream printf: ' HeaderTypeShort (4 bytes)'].
+ [HeaderTypeClass] -> [aStream printf: ' HeaderTypeClass (8 bytes)'].
+ [HeaderTypeSizeAndClass] -> [aStream printf: ' HeaderTypeSizeAndClass (12 bytes)'] }!
Item was changed:
+ ----- Method: NewObjectMemory>>safePrintStringOf: (in category 'debug printing interpreter support') -----
- ----- Method: NewObjectMemory>>safePrintStringOf: (in category 'debug printing') -----
safePrintStringOf: oop
"Version of printStringOf: that copes with forwarding during garbage collection."
| fmt header cnt i |
<inline: false>
(self isIntegerObject: oop) ifTrue:
[^nil].
(self oop: oop isGreaterThanOrEqualTo: self startOfMemory andLessThan: freeStart) ifFalse:
[^nil].
(oop bitAnd: (self wordSize - 1)) ~= 0 ifTrue:
[^nil].
header := self headerWhileForwardingOf: oop.
fmt := self formatOfHeader: header.
fmt < 8 ifTrue: [ ^nil ].
cnt := 100 min: (self lengthOf: oop baseHeader: header format: fmt).
i := 0.
[i < cnt] whileTrue:
[self printChar: (self fetchByte: i ofObject: oop).
i := i + 1].
coInterpreter flush.
^oop!
Item was changed:
+ ----- Method: NewObjectMemory>>whereIsMaybeHeapThing: (in category 'debug printing interpreter support') -----
- ----- Method: NewObjectMemory>>whereIsMaybeHeapThing: (in category 'debug printing') -----
whereIsMaybeHeapThing: anOop
<returnTypeC: 'char *'>
(self oop: anOop isGreaterThanOrEqualTo: self startOfMemory andLessThan: endOfMemory) ifTrue:
[(self oop: anOop isLessThan: freeStart) ifTrue:
[^' is in old space'].
(self oop: anOop isLessThan: reserveStart) ifTrue:
[^' is in new space'].
^' is above reserve start'].
^nil!
Item was changed:
+ ----- Method: NullStream>>crtab (in category '*VMMaker-debug printing interpreter support') -----
- ----- Method: NullStream>>crtab (in category '*VMMaker-translation support') -----
crtab!
Item was added:
+ ----- Method: NullStream>>fputc: (in category '*VMMaker-debug printing interpreter support') -----
+ fputc: aCharacterOrCode!
Item was added:
+ ----- Method: ObjectMemory>>printCantBeObject:on: (in category 'debug printing interpreter support') -----
+ printCantBeObject: oop on: aStream
+ <var: 'aStream' type: #'FILE *'>
+ '16r%lx%s\n'
+ f: aStream
+ printf: {oop.
+ ((oop bitAnd: self allocationUnit - 1) ~= 0
+ ifTrue: [' is misaligned']
+ ifFalse: [self whereIs: oop])}!
Item was added:
+ ----- Method: ObjectMemory>>printFreeObject:on: (in category 'debug printing') -----
+ printFreeObject: oop on: aStream
+ <var: 'aStream' type: #'FILE *'>
+ '16r%lx is a free chunk of size %ld\n'
+ f: aStream
+ printf: {oop. self sizeOfFree: oop}!
Item was added:
+ ----- Method: ObjectMemory>>printImmediateObject:on: (in category 'debug printing interpreter support') -----
+ printImmediateObject: oop on: aStream
+ <var: 'aStream' type: #'FILE *'>
+ self assert: (self isIntegerObject: oop).
+ '16r%lx=%ld\n' f: aStream printf: {oop. (self integerValueOf: oop) asInteger}!
Item was added:
+ ----- Method: ObjectMemory>>printNonPointerDataOf:on: (in category 'debug printing interpreter support') -----
+ printNonPointerDataOf: oop on: aStream
+ <var: 'aStream' type: #'FILE *'>
+ | elementsPerLine format lastIndex sixteenSpaces |
+ format := self formatOf: oop.
+ self assert: (format between: self sixtyFourBitIndexableFormat and: self firstCompiledMethodFormat - 1).
+ lastIndex := self lengthOf: oop format: format.
+ lastIndex = 0 ifTrue:
+ [^self].
+ sixteenSpaces := ' '.
+ format = self sixtyFourBitIndexableFormat ifTrue:
+ [lastIndex := 32 min: lastIndex.
+ elementsPerLine := 4. "0x/16r0123456789ABCDEF<space|cr> x 4 = 76/80"
+ 1 to: lastIndex do:
+ [:index| | v64 |
+ v64 := self cCoerceSimple: (self fetchLong64: index - 1 ofObject: oop) to: #usqLong.
+ '%.*s16r%lx%c' f: aStream printf: {
+ 64 - (v64 highBit max: 1) // 4.
+ sixteenSpaces.
+ v64.
+ (index \\ elementsPerLine = 0 or: [index = lastIndex])
+ ifTrue: [Character cr] ifFalse: [Character space] }].
+ ^self].
+ format < self firstByteFormat ifTrue:
+ [lastIndex := 128 min: lastIndex.
+ elementsPerLine := 10. "0x/16r1234<space|cr> x 10 = 70/80"
+ 1 to: lastIndex do:
+ [:index| | v16 |
+ v16 := self fetchShort16: index - 1 ofObject: oop.
+ '%.*s16r%lx%c' f: aStream printf: {
+ 16 - (v16 highBit max: 1) // 4.
+ sixteenSpaces.
+ v16.
+ (index \\ elementsPerLine = 0 or: [index = lastIndex])
+ ifTrue: [Character cr] ifFalse: [Character space] }].
+ ^self].
+ lastIndex := 256 min: lastIndex.
+ elementsPerLine := 16. "0x/16r12<space|cr> x 16 = 80/96"
+ 1 to: lastIndex do:
+ [:index| | v8 |
+ v8 := self fetchByte: index - 1 ofObject: oop.
+ '%.*s16r%lx%c' f: aStream printf: {
+ 8 - (v8 highBit max: 1) // 4.
+ sixteenSpaces.
+ v8.
+ (index \\ elementsPerLine = 0 or: [index = lastIndex])
+ ifTrue: [Character cr] ifFalse: [Character space] }]!
Item was added:
+ ----- Method: ObjectMemory>>printStringDataOf:on: (in category 'debug printing interpreter support') -----
+ printStringDataOf: oop on: aStream
+ <var: 'aStream' type: #'FILE *'>
+ | i limit n |
+ (self isBytesNonImm: oop)
+ ifTrue:
+ [| buffer byte |
+ buffer := self alloca: 256 * 4.
+ n := i := 0.
+ limit := (self numBytesOfBytes: oop) min: 256.
+ [i < limit] whileTrue:
+ [byte := self fetchByte: i ofObject: oop.
+ (byte < 32 "space" and: [byte ~= 9 "tab"])
+ ifTrue:
+ [buffer at: n put: $<. n := n + 1.
+ (byte = 10 or: [byte = 13])
+ ifTrue:
+ [byte = 10
+ ifTrue: [buffer at: n put: $L; at: n + 1 put: $F]
+ ifFalse: [buffer at: n put: $C; at: n + 1 put: $R].
+ n := n + 2]
+ ifFalse:
+ [byte >= 10 ifTrue:
+ [buffer at: n put: byte // 10 + $0 asInteger. n := n + 1].
+ buffer at: n put: byte \\ 10 + $0 asInteger. n := n + 1].
+ buffer at: n put: $>. n := n + 1]
+ ifFalse: [buffer at: n put: byte. n := n + 1]].
+ '%.*s%s\n' f: aStream printf: { n. buffer. (self numBytesOfBytes: oop) > limit ifTrue: ['...'] ifFalse: [''] }]
+ ifFalse:
+ [| wideBuffer word |
+ self assert: (self isWordsNonImm: oop).
+ wideBuffer := self cCoerce: (self alloca: 1024 * 4) to: 'int *'.
+ n := i := 0.
+ limit := (self lengthOf: oop) min: 256.
+ [i < limit] whileTrue:
+ [word := self fetchLong32: i ofObject: oop.
+ (word < 32 "space" and: [word ~= 9 "tab"])
+ ifTrue:
+ [wideBuffer at: n put: $<. n := n + 1.
+ (word = 10 or: [word = 13])
+ ifTrue:
+ [word = 10
+ ifTrue: [wideBuffer at: n put: $L; at: n + 1 put: $F]
+ ifFalse: [wideBuffer at: n put: $C; at: n + 1 put: $R].
+ n := n + 2]
+ ifFalse:
+ [word >= 10 ifTrue:
+ [wideBuffer at: n put: word // 10 + $0 asInteger. n := n + 1].
+ wideBuffer at: n put: word \\ 10 + $0 asInteger. n := n + 1].
+ wideBuffer at: n put: $>. n := n + 1]
+ ifFalse: [wideBuffer at: n put: word. n := n + 1]].
+ '%.*s%s\n' f: aStream wprintf: { n. wideBuffer. (self lengthOf: oop) > limit ifTrue: ['...'] ifFalse: [''] }]!
Item was changed:
+ ----- Method: ObjectMemory>>safePrintStringOf: (in category 'debug printing interpreter support') -----
- ----- Method: ObjectMemory>>safePrintStringOf: (in category 'debug printing') -----
safePrintStringOf: oop
"Version of printStringOf: that copes with forwarding during garbage collection."
| fmt header cnt i |
<inline: false>
(self isIntegerObject: oop) ifTrue:
[^nil].
(self oop: oop isGreaterThanOrEqualTo: self startOfMemory andLessThan: freeBlock) ifFalse:
[^nil].
(oop bitAnd: (self wordSize - 1)) ~= 0 ifTrue:
[^nil].
header := self headerWhileForwardingOf: oop.
fmt := self formatOfHeader: header.
fmt < self firstByteFormat ifTrue: [^nil].
cnt := 100 min: (self lengthOf: oop baseHeader: header format: fmt).
i := 0.
[i < cnt] whileTrue:
[self printChar: (self fetchByte: i ofObject: oop).
i := i + 1].
self flush.
^oop!
Item was changed:
+ ----- Method: ObjectMemory>>whereIsMaybeHeapThing: (in category 'debug printing interpreter support') -----
- ----- Method: ObjectMemory>>whereIsMaybeHeapThing: (in category 'debug printing') -----
whereIsMaybeHeapThing: anOop
<returnTypeC: 'char *'>
(self oop: anOop isGreaterThanOrEqualTo: self startOfMemory andLessThan: endOfMemory) ifTrue:
[(self oop: anOop isLessThan: freeBlock) ifTrue:
[^' is in old space'].
^' is in new space'].
^nil!
Item was changed:
----- Method: PrintfNumberFormatDescriptor>>transformForVMMaker (in category '*VMMaker-C code generation') -----
transformForVMMaker
+ ('duxX' includes: operator) ifTrue:
+ [^'%" PRI', (String with: operator), 'SQINT "'].
+ ('pP' includes: operator) ifTrue:
+ [^'%" PRI', (String with: (operator = $p ifTrue: [$x] ifFalse: [$X])), 'SQPTR "'].
+ ^super transformForVMMaker!
- ('duxX' includes: operator) ifFalse:
- [^super transformForVMMaker].
- ^'%" PRI', (String with: operator), 'SQINT "'!
Item was changed:
----- Method: Spur32BitMMLECoSimulator>>globalGarbageCollect (in category 'gc - global') -----
globalGarbageCollect
"If we're /not/ a clone, clone the VM and push it over the cliff.
If it survives, destroy the clone and continue. We should be OK until next time."
parent ifNil:
+ [coInterpreter cr; print: 'GC number '; printNum: statFullGCs; tab; flush.
- [coInterpreter cr; print: 'GC number '; print: statFullGCs; tab; flush.
CloneOnGC ifTrue:
[coInterpreter cloneSimulation objectMemory globalGarbageCollect.
Smalltalk garbageCollect]].
^super globalGarbageCollect!
Item was changed:
----- Method: Spur32BitMMLESimulator>>globalGarbageCollect (in category 'gc - global') -----
globalGarbageCollect
"If we're /not/ a clone, clone the VM and push it over the cliff.
If it survives, destroy the clone and continue. We should be OK until next time."
parent ifNil:
+ [coInterpreter cr; print: 'GC number '; printNum: statFullGCs; tab; flush.
- [coInterpreter cr; print: 'GC number '; print: statFullGCs; tab; flush.
CloneOnGC ifTrue:
[coInterpreter cloneSimulation objectMemory globalGarbageCollect.
Smalltalk garbageCollect]].
^super globalGarbageCollect!
Item was changed:
----- Method: Spur64BitMMLECoSimulator>>globalGarbageCollect (in category 'gc - global') -----
globalGarbageCollect
"If we're /not/ a clone, clone the VM and push it over the cliff.
If it survives, destroy the clone and continue. We should be OK until next time."
parent ifNil:
+ [coInterpreter cr; print: 'GC number '; printNum: statFullGCs; tab; flush.
- [coInterpreter cr; print: 'GC number '; print: statFullGCs; tab; flush.
CloneOnGC ifTrue:
[coInterpreter cloneSimulation objectMemory globalGarbageCollect.
Smalltalk garbageCollect]].
^super globalGarbageCollect!
Item was changed:
----- Method: Spur64BitMMLESimulator>>globalGarbageCollect (in category 'gc - global') -----
globalGarbageCollect
"If we're /not/ a clone, clone the VM and push it over the cliff.
If it survives, destroy the clone and continue. We should be OK until next time."
parent ifNil:
+ [coInterpreter cr; print: 'GC number '; printNum: statFullGCs; tab; flush.
- [coInterpreter cr; print: 'GC number '; print: statFullGCs; tab; flush.
CloneOnGC ifTrue:
[coInterpreter cloneSimulation objectMemory globalGarbageCollect.
Smalltalk garbageCollect]].
^super globalGarbageCollect!
Item was added:
+ ----- Method: SpurMemoryManager>>printCantBeObject:on: (in category 'debug printing interpreter support') -----
+ printCantBeObject: oop on: aStream
+ <var: 'aStream' type: #'FILE *'>
+ ((oop bitAnd: self allocationUnit - 1) = 0
+ and: [(self isInNewSpace: oop)
+ and: [self isForwarded: oop]]) ifTrue:
+ [^self printForwarder: oop on: aStream].
+ '16r%lx%s\n'
+ f: aStream
+ printf: {oop.
+ ((oop bitAnd: self allocationUnit - 1) ~= 0
+ ifTrue: [' is misaligned']
+ ifFalse: [coInterpreter whereIs: oop])}!
Item was added:
+ ----- Method: SpurMemoryManager>>printForwarder:on: (in category 'debug printing interpreter support') -----
+ printForwarder: oop on: aStream
+ <var: 'aStream' type: #'FILE *'>
+ '16r%lx is a forwarded hdr%d slot size %ud object to 16r%lx\n'
+ f: aStream
+ printf: { oop.
+ (self rawNumSlotsOf: oop) = self numSlotsMask ifTrue: [16] ifFalse: [8].
+ self numSlotsOfAny: oop.
+ self objectMemory followForwarded: oop}!
Item was added:
+ ----- Method: SpurMemoryManager>>printFreeObject:on: (in category 'debug printing') -----
+ printFreeObject: oop on: aStream
+ <var: 'aStream' type: #'FILE *'>
+ '16r%lx is a free chunk of size %ld 0th field:16r%lx\n'
+ f: aStream
+ printf: {oop. self bytesInBody: oop. self fetchPointer: 0 ofFreeChunk: oop }!
Item was removed:
- ----- Method: SpurMemoryManager>>printHeaderTypeOf: (in category 'debug printing') -----
- printHeaderTypeOf: objOop
- coInterpreter
- print: ((self numSlotsOfAny: objOop) >= self numSlotsMask
- ifTrue: [' hdr16 ']
- ifFalse: [' hdr8 ']);
- printChar: ((self isImmutable: objOop) ifTrue: [$i] ifFalse: [$.]);
- printChar: ((self isRemembered: objOop) ifTrue: [$r] ifFalse: [$.]);
- printChar: ((self isPinned: objOop) ifTrue: [$p] ifFalse: [$.]);
- printChar: ((self isMarked: objOop) ifTrue: [$m] ifFalse: [$.]);
- printChar: ((self isGrey: objOop) ifTrue: [$g] ifFalse: [$.])!
Item was added:
+ ----- Method: SpurMemoryManager>>printHeaderTypeOf:on: (in category 'debug printing interpreter support') -----
+ printHeaderTypeOf: obj on: aStream
+ <var: 'aStream' type: #'FILE *'>
+ <inline: true>
+ ' hdr%d %c%c%c%c%c' f: aStream printf: {
+ (self rawNumSlotsOf: obj) = self numSlotsMask ifTrue: [16] ifFalse: [8].
+ (self isImmutable: obj) ifTrue: [$i] ifFalse: [$.].
+ (self isRemembered: obj) ifTrue: [$r] ifFalse: [$.].
+ (self isPinned: obj) ifTrue: [$p] ifFalse: [$.].
+ (self isMarked: obj) ifTrue: [$m] ifFalse: [$.].
+ (self isGrey: obj) ifTrue: [$g] ifFalse: [$.] }!
Item was added:
+ ----- Method: SpurMemoryManager>>printImmediateObject:on: (in category 'debug printing interpreter support') -----
+ printImmediateObject: oop on: aStream
+ <var: 'aStream' type: #'FILE *'>
+ self assert: (self isImmediate: oop).
+ (self isIntegerObject: oop) ifTrue:
+ ['16r%lx=%ld\n' f: aStream printf: {oop. (self integerValueOf: oop) asInteger}].
+ (self isImmediateCharacter: oop) ifTrue:
+ ['16r%lx=$%ld ($%lc)\n' f: aStream printf: {oop.
+ (self characterValueOf: oop) asLong.
+ self cCoerce: (self characterValueOf: oop) to: 'wint_t'}].
+ (self isImmediateFloat: oop) ifTrue:
+ ['16r%lx=%g\n' f: aStream printf: {oop. self floatValueOf: oop}]!
Item was added:
+ ----- Method: SpurMemoryManager>>printNonPointerDataOf:on: (in category 'debug printing interpreter support') -----
+ printNonPointerDataOf: oop on: aStream
+ <var: 'aStream' type: #'FILE *'>
+ | elementsPerLine format lastIndex sixteenSpaces |
+ format := self formatOf: oop.
+ self assert: (format between: self sixtyFourBitIndexableFormat and: self firstCompiledMethodFormat - 1).
+ lastIndex := self lengthOf: oop format: format.
+ lastIndex = 0 ifTrue:
+ [^self].
+ sixteenSpaces := ' '.
+ format = self sixtyFourBitIndexableFormat ifTrue:
+ [lastIndex := 32 min: lastIndex.
+ elementsPerLine := 4. "0x/16r0123456789ABCDEF<space|cr> x 4 = 76/80"
+ 1 to: lastIndex do:
+ [:index| | v64 |
+ v64 := self cCoerceSimple: (self fetchLong64: index - 1 ofObject: oop) to: #usqLong.
+ '%.*s16r%lx%c' f: aStream printf: {
+ 64 - (v64 highBit max: 1) // 4.
+ sixteenSpaces.
+ v64.
+ (index \\ elementsPerLine = 0 or: [index = lastIndex])
+ ifTrue: [Character cr] ifFalse: [Character space] }].
+ ^self].
+ format < self firstShortFormat ifTrue:
+ [lastIndex := 64 min: lastIndex.
+ elementsPerLine := 8. "0x/16r12345678<space|cr> x 8 = 80/88"
+ 1 to: lastIndex do:
+ [:index| | v32 |
+ v32 := self cCoerceSimple: (self fetchLong32: index - 1 ofObject: oop) to: #unsigned.
+ '%.*s16r%lx%c' f: aStream printf: {
+ 32 - (v32 highBit max: 1) // 4.
+ sixteenSpaces.
+ v32.
+ (index \\ elementsPerLine = 0 or: [index = lastIndex])
+ ifTrue: [Character cr] ifFalse: [Character space] }].
+ ^self].
+ format < self firstByteFormat ifTrue:
+ [lastIndex := 128 min: lastIndex.
+ elementsPerLine := 10. "0x/16r1234<space|cr> x 10 = 70/80"
+ 1 to: lastIndex do:
+ [:index| | v16 |
+ v16 := self fetchShort16: index - 1 ofObject: oop.
+ '%.*s16r%lx%c' f: aStream printf: {
+ 16 - (v16 highBit max: 1) // 4.
+ sixteenSpaces.
+ v16.
+ (index \\ elementsPerLine = 0 or: [index = lastIndex])
+ ifTrue: [Character cr] ifFalse: [Character space] }].
+ ^self].
+ lastIndex := 256 min: lastIndex.
+ elementsPerLine := 16. "0x/16r12<space|cr> x 16 = 80/96"
+ 1 to: lastIndex do:
+ [:index| | v8 |
+ v8 := self fetchByte: index - 1 ofObject: oop.
+ '%.*s16r%lx%c' f: aStream printf: {
+ 8 - (v8 highBit max: 1) // 4.
+ sixteenSpaces.
+ v8.
+ (index \\ elementsPerLine = 0 or: [index = lastIndex])
+ ifTrue: [Character cr] ifFalse: [Character space] }]!
Item was changed:
----- Method: SpurMemoryManager>>printObjectsWithHash: (in category 'debug printing') -----
printObjectsWithHash: hash
"Scan the heap printing the oops of any and all objects whose hash equals the argument."
<export: true> "useful for VM debugging; use export: not api, so it will be accessible on win32 and won't be written to cointerp.h"
self allHeapEntitiesDo:
[:obj|
(self rawHashBitsOf: obj) = hash ifTrue:
+ [coInterpreter shortPrintOop: obj]]!
- [coInterpreter shortPrintOop: obj; cr]]!
Item was added:
+ ----- Method: SpurMemoryManager>>printStringDataOf:on: (in category 'debug printing interpreter support') -----
+ printStringDataOf: oop on: aStream
+ <var: 'aStream' type: #'FILE *'>
+ | i limit n |
+ <var: 'buffer' type: #'char *'>
+ <var: 'wideBuffer' type: #'unsigned int *'>
+ (self isBytesNonImm: oop)
+ ifTrue:
+ [| buffer byte |
+ buffer := self alloca: 256 * 4.
+ n := i := 0.
+ limit := (self numBytesOfBytes: oop) min: 256.
+ [i < limit] whileTrue:
+ [byte := self fetchByte: i ofObject: oop.
+ (byte < 32 "space" and: [byte ~= 9 "tab"])
+ ifTrue:
+ [buffer at: n put: $<. n := n + 1.
+ (byte = 10 or: [byte = 13])
+ ifTrue:
+ [byte = 10
+ ifTrue: [buffer at: n put: $L; at: n + 1 put: $F]
+ ifFalse: [buffer at: n put: $C; at: n + 1 put: $R].
+ n := n + 2]
+ ifFalse:
+ [byte >= 10 ifTrue:
+ [buffer at: n put: byte // 10 + $0 asInteger. n := n + 1].
+ buffer at: n put: byte \\ 10 + $0 asInteger. n := n + 1].
+ buffer at: n put: $>. n := n + 1]
+ ifFalse: [buffer at: n put: byte. n := n + 1]].
+ '%.*s%s\n' f: aStream printf: { n. buffer. (self numBytesOfBytes: oop) > limit ifTrue: ['...'] ifFalse: [''] }]
+ ifFalse:
+ [| wideBuffer word |
+ self assert: (self isWordsNonImm: oop).
+ wideBuffer := self cCoerce: (self alloca: 1024 * 4) to: 'int *'.
+ n := i := 0.
+ limit := (self lengthOf: oop) min: 256.
+ [i < limit] whileTrue:
+ [word := self fetchLong32: i ofObject: oop.
+ (word < 32 "space" and: [word ~= 9 "tab"])
+ ifTrue:
+ [wideBuffer at: n put: $<. n := n + 1.
+ (word = 10 or: [word = 13])
+ ifTrue:
+ [word = 10
+ ifTrue: [wideBuffer at: n put: $L; at: n + 1 put: $F]
+ ifFalse: [wideBuffer at: n put: $C; at: n + 1 put: $R].
+ n := n + 2]
+ ifFalse:
+ [word >= 10 ifTrue:
+ [wideBuffer at: n put: word // 10 + $0 asInteger. n := n + 1].
+ wideBuffer at: n put: word \\ 10 + $0 asInteger. n := n + 1].
+ wideBuffer at: n put: $>. n := n + 1]
+ ifFalse: [wideBuffer at: n put: word. n := n + 1]].
+ '%.*s%s\n' f: aStream wprintf: { n. wideBuffer. (self lengthOf: oop) > limit ifTrue: ['...'] ifFalse: [''] }]!
Item was changed:
+ ----- Method: SpurMemoryManager>>safePrintStringOf: (in category 'debug printing interpreter support') -----
- ----- Method: SpurMemoryManager>>safePrintStringOf: (in category 'debug printing') -----
safePrintStringOf: oop
| target |
(self isOopForwarded: oop)
ifTrue: [target := self followForwarded: oop]
ifFalse: [target := oop].
^coInterpreter printStringOf: target!
Item was changed:
+ ----- Method: SpurMemoryManager>>whereIsMaybeHeapThing: (in category 'debug printing interpreter support') -----
- ----- Method: SpurMemoryManager>>whereIsMaybeHeapThing: (in category 'debug printing') -----
whereIsMaybeHeapThing: anOop
<returnTypeC: 'char *'>
(self isInNewSpace: anOop) ifTrue:
[(self isInEden: anOop) ifTrue: [^' is in eden'].
(self isInFutureSpace: anOop) ifTrue: [^' is in future space'].
(self isInPastSpace: anOop) ifTrue: [^' is in past space'].
^' is in new space'].
(self isInOldSpace: anOop) ifTrue:
[(segmentManager segmentContainingObj: anOop) ifNotNil:
[^' is in old space'].
^' is between old space segments'].
^nil!
Item was changed:
----- Method: StackInterpreter class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
| vmClass |
self class == thisContext methodClass ifFalse: [^self]. "Don't duplicate decls in subclasses"
vmClass := aCCodeGenerator vmClass. "Generate primitiveTable etc based on vmClass, not just StackInterpreter"
aCCodeGenerator
addHeaderFile: '<stdio.h> /* for printf */';
addHeaderFile: '<stdlib.h> /* for e.g. alloca */';
addHeaderFile: '<setjmp.h>';
addHeaderFile: '<wchar.h> /* for wint_t */';
addHeaderFile: '"vmCallback.h"';
addHeaderFile: '"sqMemoryFence.h"';
addHeaderFile: '"sqImageFileAccess.h"';
addHeaderFile: '"sqSetjmpShim.h"';
addHeaderFile: '"dispdbg.h"'.
LowcodeVM ifTrue:
[aCCodeGenerator addHeaderFile: '"sqLowcodeFFI.h"'].
vmClass declareInterpreterVersionIn: aCCodeGenerator defaultName: 'Stack'.
aCCodeGenerator
var: #interpreterProxy type: #'struct VirtualMachine*'.
aCCodeGenerator
declareVar: #sendTrace type: 'volatile int';
declareVar: #byteCount type: #usqLong. "see dispdbg.h"
"These need to be pointers or unsigned."
self declareC: #(instructionPointer method newMethod)
as: #usqInt
in: aCCodeGenerator.
"These are all pointers; char * because Slang has no support for C pointer arithmetic."
self declareC: #(localIP localSP localFP stackPointer framePointer stackLimit breakSelector)
as: #'char *'
in: aCCodeGenerator.
aCCodeGenerator
var: #breakSelectorLength
declareC: 'sqInt breakSelectorLength = MinSmallInteger'.
self declareC: #(stackPage overflowedPage)
as: #'StackPage *'
in: aCCodeGenerator.
+ aCCodeGenerator
+ var: #transcript type: #'FILE *'.
aCCodeGenerator removeVariable: 'stackPages'. "this is an implicit receiver in the translated code."
"This defines bytecodeSetSelector as 0 if MULTIPLEBYTECODESETS
is not defined, for the benefit of the interpreter on slow machines."
aCCodeGenerator addConstantForBinding: (self bindingOf: #MULTIPLEBYTECODESETS).
MULTIPLEBYTECODESETS == false ifTrue:
[aCCodeGenerator
removeVariable: 'bytecodeSetSelector'].
BytecodeSetHasExtensions == false ifTrue:
[aCCodeGenerator
removeVariable: 'extA';
removeVariable: 'extB'].
aCCodeGenerator
var: #methodCache
declareC: 'sqIntptr_t methodCache[MethodCacheSize + 1 /* ', (MethodCacheSize + 1) printString, ' */]'.
NewspeakVM
ifTrue:
[aCCodeGenerator
var: #nsMethodCache
declareC: 'sqIntptr_t nsMethodCache[NSMethodCacheSize + 1 /* ', (NSMethodCacheSize + 1) printString, ' */]']
ifFalse:
[aCCodeGenerator
removeVariable: #nsMethodCache;
removeVariable: 'localAbsentReceiver';
removeVariable: 'localAbsentReceiverOrZero'].
AtCacheTotalSize isInteger ifTrue:
[aCCodeGenerator
var: #atCache
declareC: 'sqInt atCache[AtCacheTotalSize + 1 /* ', (AtCacheTotalSize + 1) printString, ' */]'].
aCCodeGenerator
var: #primitiveTable
declareC: 'void (*primitiveTable[MaxPrimitiveIndex + 2 /* ', (MaxPrimitiveIndex + 2) printString, ' */])(void) = ', vmClass primitiveTableString.
vmClass primitiveTable do:
[:symbolOrNot|
(symbolOrNot isSymbol
and: [symbolOrNot ~~ #primitiveFail]) ifTrue:
[(aCCodeGenerator methodNamed: symbolOrNot) ifNotNil:
[:tMethod| tMethod returnType: #void]]].
vmClass objectMemoryClass hasSpurMemoryManagerAPI
ifTrue:
[aCCodeGenerator
var: #primitiveAccessorDepthTable
type: 'signed char'
sizeString: 'MaxPrimitiveIndex + 2 /* ', (MaxPrimitiveIndex + 2) printString, ' */'
array: vmClass primitiveAccessorDepthTable]
ifFalse:
[aCCodeGenerator removeVariable: #primitiveAccessorDepthTable].
aCCodeGenerator
+ var: #displayBits type: #'void *';
+ var: #primitiveCalloutPointer declareC: 'void *primitiveCalloutPointer = (void *)-1'.
- var: #displayBits type: #'void *'.
self declareC: #(displayWidth displayHeight displayDepth) as: #int in: aCCodeGenerator.
aCCodeGenerator
var: #primitiveFunctionPointer
declareC: 'void (*primitiveFunctionPointer)()';
var: #externalPrimitiveTable
declareC: 'void (*externalPrimitiveTable[MaxExternalPrimitiveTableSize + 1 /* ', (MaxExternalPrimitiveTableSize + 1) printString, ' */])(void)';
var: #interruptCheckChain
declareC: 'void (*interruptCheckChain)(void) = 0';
var: #showSurfaceFn
declareC: 'int (*showSurfaceFn)(sqIntptr_t, int, int, int, int)';
var: #jmpBuf
declareC: 'jmp_buf jmpBuf[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]';
var: #suspendedCallbacks
declareC: 'usqInt suspendedCallbacks[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]';
var: #suspendedMethods
declareC: 'usqInt suspendedMethods[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'.
self declareCAsUSqLong: #(nextPollUsecs nextWakeupUsecs longRunningPrimitiveGCUsecs
longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs
"these are high-frequency enough that they're overflowing quite quickly on modern hardware"
statProcessSwitch statIOProcessEvents statForceInterruptCheck
statCheckForEvents statStackOverflow statStackPageDivorce
statIdleUsecs)
in: aCCodeGenerator.
aCCodeGenerator var: #nextProfileTick type: #sqLong.
aCCodeGenerator var: #reenterInterpreter type: 'jmp_buf'.
LowcodeVM
ifTrue:
[aCCodeGenerator
var: #lowcodeCalloutState type: #'sqLowcodeCalloutState*'.
self declareC: #(nativeSP nativeStackPointer shadowCallStackPointer)
as: #'char *'
in: aCCodeGenerator]
ifFalse:
[#(lowcodeCalloutState nativeSP nativeStackPointer shadowCallStackPointer) do:
+ [:var| aCCodeGenerator removeVariable: var]]!
- [:var| aCCodeGenerator removeVariable: var]].
-
- aCCodeGenerator
- var: #primitiveDoMixedArithmetic
- declareC: 'char primitiveDoMixedArithmetic = 1'.!
Item was changed:
----- Method: StackInterpreter>>abstractDetailedSymbolicMethod: (in category 'debug support') -----
abstractDetailedSymbolicMethod: aMethod
<doNotGenerate>
+ | prim |
+ transcript ensureCr.
- | ts prim |
- (ts := self transcript) ensureCr.
(prim := self primitiveIndexOf: aMethod) > 0 ifTrue:
+ [transcript nextPutAll: '<primitive: '; print: prim; nextPut: $>.
- [ts nextPutAll: '<primitive: '; print: prim; nextPut: $>.
(self isQuickPrimitiveIndex: prim) ifTrue:
+ [transcript nextPutAll: ' quick method'; cr; flush.
- [ts nextPutAll: ' quick method'; cr; flush.
^self].
+ transcript cr].
- ts cr].
(RelativeDetailedInstructionPrinter
on: (VMCompiledMethodProxy new
for: aMethod
coInterpreter: self
objectMemory: objectMemory))
indent: 0;
+ printInstructionsOn: transcript.
+ transcript flush!
- printInstructionsOn: ts.
- ts flush!
Item was changed:
----- Method: StackInterpreter>>codeGeneratorToComputeAccessorDepth (in category 'primitive support') -----
codeGeneratorToComputeAccessorDepth
^(VMMaker new
buildCodeGeneratorForInterpreter: self class primitivesClass
includeAPIMethods: false
initializeClasses: false)
+ logger: transcript;
- logger: self transcript;
yourself!
Item was changed:
----- Method: StackInterpreter>>cr (in category 'debug printing') -----
cr
+ "Append a newline to transcript.
+ This is a bit weird because, at least for me, fputc has its parameters backwards..."
+ <cmacro: '() fputc(''\n'',transcript)'>
+ transcript fputc: Character cr!
- "For testing in Smalltalk, this method should be overridden in a subclass."
- <inline: true>
- self printf: '\n'!
Item was changed:
----- Method: StackInterpreter>>detailedSymbolicMethod: (in category 'debug support') -----
detailedSymbolicMethod: aMethod
<doNotGenerate>
+ transcript
- self transcript
ensureCr;
nextPutAll:
((String streamContents:
[:ts| | prim proxy |
(prim := self primitiveIndexOf: aMethod) > 0 ifTrue:
[ts nextPutAll: '<primitive: '; print: prim; nextPut: $>.
(self isQuickPrimitiveIndex: prim) ifTrue:
[ts nextPutAll: ' quick method'; cr; flush.
^self].
ts cr].
proxy := VMCompiledMethodProxy new
for: aMethod
coInterpreter: self
objectMemory: objectMemory.
(DetailedInstructionPrinter on: proxy)
stackHeightComputer: (StackDepthFinder on: proxy);
indent: 0;
printInstructionsOn: ts]) copyReplaceAll: 'a VMObjectProxy for ' with: '');
flush!
Item was changed:
----- Method: StackInterpreter>>flush (in category 'debug printing') -----
flush
<api>
+ <inline: true>
+ transcript fflush!
- <cmacro: '() fflush(stdout)'>!
Item was added:
+ ----- Method: StackInterpreter>>getTranscript (in category 'debug printing redirected') -----
+ getTranscript
+ <api>
+ <returnTypeC: #'FILE *'>
+ ^transcript!
Item was changed:
----- Method: StackInterpreter>>initialize (in category 'initialization') -----
initialize
"Here we can initialize the variables C initializes to zero. #initialize methods do /not/ get translated."
super initialize.
+ primitiveDoMixedArithmetic := true. "whether we authorize primitives to perform mixed arithmetic or not".
+ newFinalization := false.
- primitiveDoMixedArithmetic := true. "whether we authorize primitives to perform mixed arithmetic or not"
stackLimit := 0. "This is also the initialization flag for the stack system."
stackPage := overflowedPage := 0.
extraFramesToMoveOnOverflow := 0.
bytecodeSetSelector := 0.
highestRunnableProcessPriority := 0.
nextPollUsecs := 0.
nextWakeupUsecs := 0.
tempOop := tempOop2 := theUnknownShort := 0.
interruptPending := false.
inIOProcessEvents := 0.
fullScreenFlag := 0.
sendWheelEvents := deferDisplayUpdates := false.
displayBits := displayWidth := displayHeight := displayDepth := 0.
pendingFinalizationSignals := statPendingFinalizationSignals := 0.
globalSessionID := 0.
jmpDepth := 0.
maxExtSemTabSizeSet := false.
debugCallbackInvokes := debugCallbackPath := debugCallbackReturns := 0.
+ primitiveCalloutPointer := -1. "initialized in declaration in declareCVarsIn:"
+ transcript := Transcript. "initialized to stdout in readImageFromFile:HeapSize:StartingAt:"
statForceInterruptCheck := statStackOverflow := statCheckForEvents :=
statProcessSwitch := statIOProcessEvents := statStackPageDivorce :=
statIdleUsecs := 0!
Item was changed:
----- Method: StackInterpreter>>initializeInterpreter: (in category 'initialization') -----
initializeInterpreter: bytesToShift
"Initialize Interpreter state before starting execution of a new image."
interpreterProxy := self sqGetInterpreterProxy.
self dummyReferToProxy.
objectMemory initializeObjectMemory: bytesToShift.
self checkAssumedCompactClasses.
self initializeExtraClassInstVarIndices.
method := newMethod := objectMemory nilObject.
self cCode: '' inSmalltalk:
[breakSelectorLength ifNil:
[breakSelectorLength := objectMemory minSmallInteger].
breakLookupClassTag ifNil: [breakLookupClassTag := -1].
reenterInterpreter := ReenterInterpreter new].
methodDictLinearSearchLimit := 8.
self initialCleanup.
+ primitiveDoMixedArithmetic := true.
LowcodeVM ifTrue: [ self setupNativeStack ].
profileSemaphore := profileProcess := profileMethod := objectMemory nilObject.
self cCode: '' inSmalltalk:
[InitializationOptions at: #profiling ifPresent:
[:profiling| "hack turn on profiling, for testing in the simulator."
profiling ifTrue:
[profileSemaphore := objectMemory cloneObject: (objectMemory splObj: TheInterruptSemaphore).
objectMemory
storePointerUnchecked: FirstLinkIndex ofObject: profileSemaphore withValue: objectMemory nilObject;
storePointerUnchecked: NextLinkIndex ofObject: profileSemaphore withValue: objectMemory nilObject;
storePointerUnchecked: ExcessSignalsIndex ofObject: profileSemaphore withValue: (objectMemory integerObjectOf: 0)]]].
interruptKeycode := 2094. "cmd-. as used for Mac but no other OS"
[globalSessionID = 0] whileTrue:
[globalSessionID := self
cCode: [((self time: #NULL) + self ioMSecs) bitAnd: 16r7FFFFFFF]
inSmalltalk: [(Random new next * (SmallInteger maxVal min: 16r7FFFFFFF)) asInteger]].
metaAccessorDepth := -2.
super initializeInterpreter: bytesToShift!
Item was changed:
----- Method: StackInterpreter>>longPrintOop: (in category 'debug printing') -----
longPrintOop: oop
<export: true> "useful for VM debugging; use export: not api, so it will be accessible on win32 and won't be written to cointerp.h"
+ | fmt lastIndex startIP column cls |
- | fmt lastIndex startIP bytecodesPerLine column |
<var: 'field16' type: #'unsigned short'>
<var: 'field32' type: #'unsigned int'>
<var: 'field64' type: #usqLong>
+
+ (objectMemory isImmediate: oop) ifTrue:
+ [^objectMemory printImmediateObject: oop on: transcript].
+ (objectMemory addressCouldBeObj: oop) ifFalse:
+ [^objectMemory printCantBeObject: oop on: transcript].
+ (objectMemory isFreeObject: oop) ifTrue:
+ [^objectMemory printFreeObject: oop on: transcript].
+ (objectMemory isForwarded: oop) ifTrue:
+ [^objectMemory printForwarder: oop on: transcript].
+
+ (cls := objectMemory fetchClassOfNonImm: oop)
+ ifNil: ['16r%lx has a nil class!!!!\n' f: transcript printf: oop]
+ ifNotNil:
+ [| className length |
+ className := self nameOfClass: cls lengthInto: (self addressOf: length put: [:v| length := v]).
+ '16r%lx: a(n) %.*s' f: transcript printf: {oop. length. className }.
- ((objectMemory isImmediate: oop)
- or: [(objectMemory addressCouldBeObj: oop) not
- or: [(oop bitAnd: objectMemory allocationUnit - 1) ~= 0
- or: [(objectMemory isFreeObject: oop)
- or: [objectMemory isForwarded: oop]]]]) ifTrue:
- [self printOop: oop.
- ^self].
- self printHex: oop.
- (objectMemory fetchClassOfNonImm: oop)
- ifNil: [self print: ' has a nil class!!!!']
- ifNotNil: [:class|
- self print: ': a(n) '; printNameOfClass: class count: 5;
- print: ' ('.
objectMemory hasSpurMemoryManagerAPI ifTrue:
+ ['(%lx=>16r%lx)' f: transcript printf: { objectMemory compactClassIndexOf: oop. cls }]].
- [self printHexnp: (objectMemory compactClassIndexOf: oop); print: '=>'].
- self printHexnp: class; print: ')'].
fmt := objectMemory formatOf: oop.
+ ' format %lx' f: transcript printf: fmt.
- self print: ' format '; printHexnp: fmt.
fmt > objectMemory lastPointerFormat
+ ifTrue: [' nbytes %ld' f: transcript printf: (objectMemory numBytesOf: oop)]
- ifTrue: [self print: ' nbytes '; printNum: (objectMemory numBytesOf: oop)]
ifFalse: [(objectMemory isIndexableFormat: fmt) ifTrue:
[| len |
len := objectMemory lengthOf: oop.
+ ' size %ld' f: transcript printf: len - (objectMemory fixedFieldsOf: oop format: fmt length: len)]].
+ objectMemory printHeaderTypeOf: oop on: transcript.
- self print: ' size '; printNum: len - (objectMemory fixedFieldsOf: oop format: fmt length: len)]].
- objectMemory printHeaderTypeOf: oop.
self print: ' hash '; printHexnp: (objectMemory rawHashBitsOf: oop).
self cr.
+ (fmt between: objectMemory firstLongFormat and: objectMemory firstCompiledMethodFormat - 1) ifTrue:
+ ["This will answer false if splObj: ClassAlien is nilObject"
+ (self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifTrue:
+ [^' datasize %ld %s @ %p\n' f: transcript printf:
+ {objectMemory sizeFieldOfAlien: oop.
+ (self isIndirectAlien: oop)
+ ifTrue: ['indirect']
+ ifFalse:
+ [(self isPointerAlien: oop)
+ ifTrue: ['pointer']
+ ifFalse: ['direct']].
+ (self startOfAlienData: oop) asUnsignedInteger }].
+ (self is: oop KindOfClass: (self superclassOf: (objectMemory splObj: ClassString))) ifTrue:
+ [^objectMemory printStringDataOf: oop on: transcript].
+ ^objectMemory printNonPointerDataOf: oop on: transcript].
- (fmt between: objectMemory firstByteFormat and: objectMemory firstCompiledMethodFormat - 1) ifTrue:
- [^self printStringOf: oop; cr].
- (fmt between: objectMemory firstLongFormat and: objectMemory firstByteFormat - 1) ifTrue:
- [0 to: ((objectMemory num32BitUnitsOf: oop) min: 256) - 1 do:
- [:i| | field32 |
- field32 := objectMemory fetchLong32: i ofObject: oop.
- self space; printNum: i; space; printHex: field32; space; cr].
- ^self].
- objectMemory hasSpurMemoryManagerAPI ifTrue:
- [fmt = objectMemory sixtyFourBitIndexableFormat ifTrue:
- [0 to: ((objectMemory num64BitUnitsOf: oop) min: 256) - 1 do:
- [:i| | field64 |
- field64 := objectMemory fetchLong64: i ofObject: oop.
- self space; printNum: i; space; printHex: field64; space; cr].
- ^self].
- (fmt between: objectMemory firstShortFormat and: objectMemory firstShortFormat + 1) ifTrue:
- [0 to: ((objectMemory num16BitUnitsOf: oop) min: 256) - 1 do:
- [:i| | field16 |
- field16 := objectMemory fetchShort16: i ofObject: oop.
- self space; printNum: i; space; printHex: field16; space; cr].
- ^self]].
"this is nonsense. apologies."
startIP := (objectMemory lastPointerOf: oop) + objectMemory bytesPerOop - objectMemory baseHeaderSize / objectMemory bytesPerOop.
lastIndex := 256 min: startIP.
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 printOopShortInner: fieldOop].
- ifFalse: [self cCode: [self printOopShort: fieldOop]
- inSmalltalk: [self print: (self shortPrint: fieldOop)]].
self cr]].
(objectMemory isCompiledMethod: oop)
ifFalse:
[startIP > lastIndex ifTrue: [self print: '...'; cr]]
ifTrue:
[startIP := startIP * objectMemory wordSize + 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:
+ ['16r%08p: ' f: transcript printf: (oop + BaseHeaderSize + index - 1) asVoidPointer].
- [self cCode: 'printf("0x%08" PRIxSQPTR ": ", (usqIntptr_t)(oop+BaseHeaderSize+index-1))'
- inSmalltalk: [self print: (oop+objectMemory baseHeaderSize+index-1) hex; print: ': ']].
byte := objectMemory fetchByte: index - 1 ofObject: oop.
+ '%02x/%-3d%c'
+ f: transcript
+ printf: { byte. byte. column = 8 ifTrue: [Character cr] ifFalse: [Character space] }.
+ (column := column + 1) > 8 ifTrue: [column := 1]].
+ (column between: 2 and: 7) ifTrue:
- self cCode: 'printf(" %02x/%-3d", (int)byte,(int)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 added:
+ ----- Method: StackInterpreter>>nameOfClass:lengthInto: (in category 'debug printing') -----
+ nameOfClass: classOop lengthInto: lengthPtr
+ "Brain-damaged nameOfClass: for C VM. Does *not* answer Foo class for metaclasses.
+ Use e.g. classIsMeta: to avoid being fooled."
+ <returnTypeC: #'char *'>
+ <var: 'lengthPtr' type: 'sqInt *'>
+ <inline: false>
+ | numSlots maybeNameOop maybeThisClassOop |
+ numSlots := objectMemory numSlotsOf: classOop.
+ numSlots = metaclassNumSlots ifTrue:
+ [maybeThisClassOop := objectMemory fetchPointer: thisClassIndex ofObject: classOop.
+ (self addressCouldBeClassObj: maybeThisClassOop) ifTrue:
+ [^self nameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop) lengthInto: lengthPtr].
+ lengthPtr at: 0 put: 9.
+ ^'bad class'].
+ (numSlots > classNameIndex
+ and: [maybeNameOop := objectMemory fetchPointer: classNameIndex ofObject: classOop.
+ objectMemory isBytes: maybeNameOop]) ifTrue:
+ [lengthPtr at: 0 put: (objectMemory numBytesOfBytes: maybeNameOop).
+ ^objectMemory firstIndexableField: maybeNameOop].
+ lengthPtr at: 0 put: 9.
+ ^'bad class'!
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 *'>
+ transcript fprintf: s!
- self cCode: 'fputs(s, stdout)'!
Item was changed:
----- Method: StackInterpreter>>printActivationNameFor:receiver:isBlock:firstTemporary: (in category 'debug printing') -----
printActivationNameFor: aMethod receiver: anObject isBlock: isBlock firstTemporary: maybeMessage
| methClass methodSel classObj |
<inline: false>
isBlock ifTrue:
[self print: '[] in '].
methClass := self findClassOfMethod: aMethod forReceiver: anObject.
methodSel := self findSelectorOfMethod: aMethod.
((objectMemory addressCouldBeOop: anObject)
and: [(objectMemory isOopForwarded: anObject) not
and: [self addressCouldBeClassObj: (classObj := objectMemory fetchClassOf: anObject)]])
ifTrue:
[(classObj = methClass or: [methClass isNil or: [methClass = objectMemory nilObject] "i.e. doits"])
ifTrue: [self printNameOfClass: classObj count: 5]
ifFalse:
[self printNameOfClass: classObj count: 5.
+ self printChar: $(.
- self print: '('.
self printNameOfClass: methClass count: 5.
+ self printChar: $)]]
- self print: ')']]
ifFalse:
[self print: 'INVALID RECEIVER'].
+ self printChar: $>.
- self print: '>'.
(objectMemory addressCouldBeOop: methodSel)
ifTrue:
[methodSel = objectMemory nilObject
ifTrue: [self print: '(nil)']
ifFalse: [self printStringOf: methodSel]]
ifFalse: [self print: 'INVALID SELECTOR'].
(methodSel = (objectMemory splObj: SelectorDoesNotUnderstand)
and: [(objectMemory addressCouldBeObj: maybeMessage)
and: [(objectMemory fetchClassOfNonImm: maybeMessage) = (objectMemory splObj: ClassMessage)]]) ifTrue:
["print arg message selector"
methodSel := objectMemory fetchPointer: MessageSelectorIndex ofObject: maybeMessage.
+ self space.
- self print: ' '.
self printStringOf: methodSel]!
Item was added:
+ ----- Method: StackInterpreter>>printAllStacksOn: (in category 'debug printing redirected') -----
+ printAllStacksOn: aStdioStream
+ "Print all the stacks of all running processes, including those that are currently suspended."
+ <export: true> "essential for writing crash.dmp; use export: not api, so it will be accessible on win32 and won't be written to cointerp.h"
+ <var: 'aStdioStream' type: #'FILE *'>
+ self withRedirectedOutputTo: aStdioStream do: [self printAllStacks]!
Item was changed:
----- Method: StackInterpreter>>printAtCache (in category 'debug printing') -----
printAtCache
0 to: AtCacheTotalSize - 1 by: 4 do:
[:i | | obj sz fmt fixed |
obj := atCache at: i + AtCacheOop.
sz := atCache at: i + AtCacheSize.
fmt := atCache at: i + AtCacheFmt.
fixed := atCache at: i + AtCacheFixedFields.
(objectMemory addressCouldBeObj: obj) ifTrue:
+ [transcript ensureCr.
- [self transcript ensureCr.
self print: i; tab; print: (i < AtPutBase ifTrue: ['at '] ifFalse: ['put ']);
tab; printNum: sz; tab; printNum: fmt; tab; printNum: fixed; tab;
shortPrintOop: obj]]!
Item was added:
+ ----- Method: StackInterpreter>>printCallStackOn: (in category 'debug printing redirected') -----
+ printCallStackOn: aStdioStream
+ "Print the call stack on a specific output stream."
+ <export: true> "essential for writing crash.dmp; use export: not api, so it will be accessible on win32 and won't be written to cointerp.h"
+ <var: 'aStdioStream' type: #'FILE *'>
+ self withRedirectedOutputTo: aStdioStream do: [self printCallStack]!
Item was changed:
----- Method: StackInterpreter>>printChar: (in category 'debug printing') -----
+ printChar: aCharacter
+ "Write aCharacter to transcript.
+ This is a bit weird because, at least for me, fputc has its parameters backwards..."
+ <cmacro: '(aCharacter) fputc(aCharacter,transcript)'>
+ transcript fputc: aCharacter!
- printChar: aByte
- <api>
- "For testing in Smalltalk, this method should be overridden in a subclass."
- self putchar: aByte.!
Item was changed:
----- Method: StackInterpreter>>printFloat: (in category 'debug printing') -----
printFloat: f
+ '%g' f: transcript printf: f!
- "For testing in Smalltalk, this method should be overridden in a subclass."
- <cmacro: '(f) printf("%g", f)'>
- self print: f!
Item was removed:
- ----- Method: StackInterpreter>>printForwarder: (in category 'debug printing') -----
- printForwarder: oop
- <inline: false>
- self
- print: ' is a forwarded object to '; printHex: (objectMemory followForwarded: oop);
- print: ' of slot size '; printNum: (objectMemory numSlotsOfAny: oop).
- objectMemory printHeaderTypeOf: oop.
- self cr.
- ^0!
Item was changed:
----- Method: StackInterpreter>>printHex: (in category 'debug printing') -----
printHex: n
"Print n in hex, in the form ' 0x1234', padded to a width of 10 characters
+ in 32-bits ('0x' + 8 nibbles) or 18 characters in 64-bits ('0x' + 16 nibbles).
+ In the simulator use 16r as the prefix, padding to 11 characters in 32-bits
+ or 19 characters in 64-bits."
- in 32-bits ('0x' + 8 nibbles) or 18 characters in 64-bits ('0x' + 16 nibbles)"
<api>
<var: #n type: #usqInt>
+ <inline: false>
+ '%.*s16r%lx' f: transcript printf: { BytesPerWord * 8 - (n highBit max: 1) // 4. ' '. n }!
- | len buf |
- <var: #buf declareC: 'char buf[37]'> "large enough for a 64-bit value in hex plus the null plus 16 spaces"
- self cCode: 'memset(buf,'' '',36)' inSmalltalk: [buf := 'doh!!'].
- len := self cCode: 'sprintf(buf + 2 + 2 * BytesPerWord, "0x%" PRIxSQPTR, (usqIntptr_t)(n))'.
- self cCode: 'printf("%s", buf + len)'.
- len touch: buf!
Item was changed:
----- Method: StackInterpreter>>printHexPtrnp: (in category 'debug printing') -----
printHexPtrnp: p
+ "Print p in hex, unpadded, in the form 0x1234 (C)/16r1234 (here)"
- "Print p in hex, unpadded, in the form '0x1234'"
<inline: true>
<var: #p type: #'void *'>
+ ^'16r%lx' f: transcript printf: p asUnsignedInteger!
- self printHexnp: (self oopForPointer: p)!
Item was changed:
----- Method: StackInterpreter>>printHexnp: (in category 'debug printing') -----
printHexnp: n
<api>
<var: #n type: #usqInt>
"Print n in hex, in the form '0x1234', unpadded"
+ ^'16r%lx' f: transcript printf: n!
- ^'0x%lx' printf: n!
Item was changed:
----- Method: StackInterpreter>>printHexnpnp: (in category 'debug printing') -----
printHexnpnp: n
<var: #n type: #usqInt>
+ "Print n in hex, in the form '1234' (no prefix), unpadded"
+ ^'%lx' f: transcript printf: n!
- "Print n in hex, in the form '1234', unpadded"
- ^'%lx' printf: n!
Item was changed:
----- Method: StackInterpreter>>printMethodCacheFor: (in category 'debug printing') -----
printMethodCacheFor: thing
<export: true> "useful for VM debugging; use export: not api, so it will be accessible on win32 and won't be written to cointerp.h"
| n |
n := 0.
0 to: MethodCacheSize - 1 by: MethodCacheEntrySize do:
[:i | | s c m p |
s := methodCache at: i + MethodCacheSelector.
c := methodCache at: i + MethodCacheClass.
m := methodCache at: i + MethodCacheMethod.
p := methodCache at: i + MethodCachePrimFunction.
((thing = -1 or: [s = thing or: [c = thing or: [p = thing or: [m = thing]]]])
and: [(objectMemory addressCouldBeOop: s)
and: [c ~= 0
and: [(self addressCouldBeClassObj: c)
or: [self addressCouldBeClassObj: (objectMemory classForClassTag: c)]]]]) ifTrue:
+ [n := n + 1.
+ self cCode: [] inSmalltalk: [self transcript ensureCr].
- [self cCode: [] inSmalltalk: [self transcript ensureCr].
self printNum: i; space; printHexnp: i; cr; tab.
(objectMemory isBytesNonImm: s)
+ ifTrue: ['%p %.*s\n' f: transcript printf: { s. objectMemory numBytesOfBytes: s. objectMemory firstIndexableField: s }]
- ifTrue: [self cCode: 'printf("%" PRIxSQPTR " %.*s\n", s, (int)(numBytesOf(s)), (char *)firstIndexableField(s))'
- inSmalltalk: [self printHex: s; space; print: (self stringOf: s); cr]]
ifFalse: [self shortPrintOop: s].
self tab.
(self addressCouldBeClassObj: c)
ifTrue: [self shortPrintOop: c]
ifFalse: [self printNum: c; space; shortPrintOop: (objectMemory classForClassTag: c)].
self tab; shortPrintOop: m; tab.
self cCode:
[p > 1024
ifTrue: [self printHexnp: p]
ifFalse: [self printNum: p]]
inSmalltalk:
[p isSymbol ifTrue: [self print: p] ifFalse: [self printNum: p]].
self cr]].
n > 1 ifTrue:
[self printNum: n; cr]!
Item was changed:
----- Method: StackInterpreter>>printMethodDictionary: (in category 'debug printing') -----
printMethodDictionary: dictionary
<export: true> "useful for VM debugging; use export: not api, so it will be accessible on win32 and won't be written to cointerp.h"
| methodArray |
methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dictionary.
SelectorStart to: (objectMemory numSlotsOf: dictionary) - 1 do:
[:index | | selector meth |
selector := objectMemory fetchPointer: index ofObject: dictionary.
selector ~= objectMemory nilObject ifTrue:
[meth := objectMemory fetchPointer: index - SelectorStart ofObject: methodArray.
self
printOopShort: selector;
print: ' => ';
printOopShort: meth;
print: ' (';
printHex: selector;
print: ' => ';
printHex: meth;
+ print: ')\n']]!
- putchar: $);
- cr]]!
Item was changed:
----- Method: StackInterpreter>>printNum: (in category 'debug printing') -----
printNum: n
+ '%ld' f: transcript printf: n asInteger!
- "For testing in Smalltalk, this method should be overridden in a subclass."
-
- self cCode: 'printf("%ld", (long) n)'.!
Item was changed:
----- Method: StackInterpreter>>printOop: (in category 'debug printing') -----
printOop: oop
<export: true> "use export: not api, so it won't be written to cointerp.h"
+ | cls fmt lastIndex startIP bytecodesPerLine column className length |
- | cls fmt lastIndex startIP bytecodesPerLine column |
<inline: false>
(objectMemory isImmediate: oop) ifTrue:
+ [^objectMemory printImmediateObject: oop on: transcript].
- [^self shortPrintOop: oop].
- self printHex: oop.
(objectMemory addressCouldBeObj: oop) ifFalse:
+ [^objectMemory printCantBeObject: oop on: transcript].
- [(oop bitAnd: objectMemory allocationUnit - 1) ~= 0 ifTrue: [^self print: ' is misaligned'; cr].
- ((objectMemory isInNewSpace: oop)
- and: [objectMemory isForwarded: oop]) ifTrue:
- [self printForwarder: oop].
- ^self print: (self whereIs: oop); cr].
(objectMemory isFreeObject: oop) ifTrue:
+ [^objectMemory printFreeObject: oop on: transcript].
+ (objectMemory isForwarded: oop) ifTrue:
+ [^objectMemory printForwarder: oop on: transcript].
+
+ (cls := objectMemory fetchClassOfNonImm: oop) ifNil:
+ [^'16r%lx has a nil class!!!!\n' f: transcript printf: oop].
+ className := self nameOfClass: cls lengthInto: (self addressOf: length put: [:v| length := v]).
+ '16r%lx: a(n) %.*s' f: transcript printf: {oop. length. className }.
- [self print: ' is a free chunk of size '; printNum: (objectMemory sizeOfFree: oop).
- objectMemory hasSpurMemoryManagerAPI ifTrue:
- [self print: ' 0th: '; printHex: (objectMemory fetchPointer: 0 ofFreeChunk: oop).
- objectMemory printHeaderTypeOf: oop].
- ^self cr].
- (objectMemory isForwarded: oop) ifTrue:
- [^self printForwarder: oop].
- self print: ': a(n) '.
- self printNameOfClass: (cls := objectMemory fetchClassOfNonImm: oop) count: 5.
cls = (objectMemory splObj: ClassFloat) ifTrue:
+ [^'\n%g\n' f: transcript printf: (objectMemory dbgFloatValueOf: oop)].
- [^self cr; printFloat: (objectMemory dbgFloatValueOf: oop); cr].
fmt := objectMemory formatOf: oop.
fmt > objectMemory lastPointerFormat ifTrue:
+ [' nbytes %ld' f: transcript printf: (objectMemory numBytesOf: oop)].
- [self print: ' nbytes '; printNum: (objectMemory numBytesOf: oop)].
self cr.
(fmt between: objectMemory firstLongFormat and: objectMemory firstCompiledMethodFormat - 1) ifTrue:
["This will answer false if splObj: ClassAlien is nilObject"
(self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifTrue:
+ [^' datasize %ld %s @ %p\n' f: transcript printf:
+ {objectMemory sizeFieldOfAlien: oop.
+ (self isIndirectAlien: oop)
+ ifTrue: ['indirect']
- [self print: ' datasize '; printNum: (objectMemory sizeFieldOfAlien: oop).
- self print: ((self isIndirectAlien: oop)
- ifTrue: [' indirect @ ']
ifFalse:
[(self isPointerAlien: oop)
+ ifTrue: ['pointer']
+ ifFalse: ['direct']].
+ (self startOfAlienData: oop) asUnsignedInteger }].
+ (self is: oop KindOfClass: (self superclassOf: (objectMemory splObj: ClassString))) ifTrue:
+ [^objectMemory printStringDataOf: oop on: transcript].
+ ^objectMemory printNonPointerDataOf: oop on: transcript].
- ifTrue: [' pointer @ ']
- ifFalse: [' direct @ ']]).
- ^self printHex: (self startOfAlienData: oop) asUnsignedInteger; cr].
- (objectMemory isWordsNonImm: oop) ifTrue:
- [lastIndex := 64 min: ((objectMemory numBytesOf: oop) / objectMemory wordSize).
- lastIndex > 0 ifTrue:
- [1 to: lastIndex do:
- [:index|
- self space; printHex: (self cCoerceSimple: (objectMemory fetchLong32: index - 1 ofObject: oop)
- to: #'unsigned int').
- (index \\ self elementsPerPrintOopLine) = 0 ifTrue:
- [self cr]].
- (lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
- [self cr]].
- ^self].
- ^self printStringOf: oop; cr].
"this is nonsense. apologies."
startIP := (objectMemory lastPointerOf: oop) + objectMemory bytesPerOop - objectMemory baseHeaderSize / objectMemory bytesPerOop.
lastIndex := 256 min: startIP.
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self cCode: [self printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space]
inSmalltalk: [self space; printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space.
self print: (self shortPrint: (objectMemory fetchPointer: index - 1 ofObject: oop))].
(index \\ self elementsPerPrintOopLine) = 0 ifTrue:
[self cr]].
(lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
[self cr]].
(objectMemory isCompiledMethod: oop)
ifFalse:
[startIP > 64 ifTrue: [self print: '...'; cr]]
ifTrue:
[startIP := startIP * objectMemory wordSize + 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:
+ ['0x%08p: ' f: transcript printf: (oop+BaseHeaderSize+index-1) asUnsignedIntegerPtr].
- [self cCode: 'printf("0x%08" PRIxSQPTR ": ", (usqIntptr_t)(oop+BaseHeaderSize+index-1))'
- inSmalltalk: [self print: (oop+objectMemory baseHeaderSize+index-1) hex; print: ': ']].
byte := objectMemory fetchByte: index - 1 ofObject: oop.
self cCode: 'printf(" %02x/%-3d", (int)byte,(int)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>>printOopShort: (in category 'debug printing') -----
printOopShort: oop
+ <inline: true>
- <inline: false>
self printOopShortInner: oop.
self flush!
Item was changed:
----- Method: StackInterpreter>>printOopShortInner: (in category 'debug printing') -----
printOopShortInner: oop
| classOop name nameLen |
<var: #name type: #'char *'>
+ <inline: false>
- <inline: true>
(objectMemory isImmediate: oop) ifTrue:
[(objectMemory isImmediateCharacter: oop) ifTrue:
+ [^'$%c(%x)' f: transcript printf: { objectMemory characterValueOf: oop. objectMemory characterValueOf: oop }].
- [^self
- printChar: $$;
- printChar: (objectMemory characterValueOf: oop);
- printChar: $(;
- printHexnp: (objectMemory characterValueOf: oop);
- printChar: $)].
(objectMemory isIntegerObject: oop) ifTrue:
+ [^'%ld(16r%lx)' f: transcript printf: { objectMemory integerValueOf: oop. objectMemory integerValueOf: oop }].
- [^self
- printNum: (objectMemory integerValueOf: oop);
- printChar: $(;
- printHexnp: (objectMemory integerValueOf: oop);
- printChar: $)].
(objectMemory isImmediateFloat: oop) ifTrue:
+ ['%g(16r%lx)' f: transcript printf: {objectMemory dbgFloatValueOf: oop. oop}].
+ ^'unknown immediate 16r%lx' f: transcript printf: oop].
- [^self
- printFloat: (objectMemory dbgFloatValueOf: oop);
- printChar: $(;
- printHexnp: oop;
- printChar: $)].
- ^self print: 'unknown immediate '; printHexnp: oop].
(objectMemory addressCouldBeObj: oop) ifFalse:
[^self print: ((oop bitAnd: objectMemory allocationUnit - 1) ~= 0
ifTrue: [' is misaligned']
ifFalse: [self whereIs: oop])].
(objectMemory isFreeObject: oop) ifTrue:
[^self print: ' is a free chunk'].
(objectMemory isForwarded: oop) ifTrue:
+ [| target |
+ target := objectMemory followForwarded: oop.
+ ^' is a forwarder to 16r%lx' f: transcript printf: target].
- [^self print: ' is a forwarder to '; printHexnp: (objectMemory followForwarded: oop)].
(self isFloatObject: oop) ifTrue:
[^self printFloat: (objectMemory dbgFloatValueOf: oop)].
classOop := objectMemory fetchClassOfNonImm: oop.
(objectMemory addressCouldBeObj: classOop) ifFalse:
[^self print: 'a ??'].
(objectMemory numSlotsOf: classOop) = metaclassNumSlots ifTrue:
[^self printNameOfClass: oop count: 5].
oop = objectMemory nilObject ifTrue: [^self print: 'nil'].
oop = objectMemory trueObject ifTrue: [^self print: 'true'].
oop = objectMemory falseObject ifTrue: [^self print: 'false'].
nameLen := self lengthOfNameOfClass: classOop.
nameLen = 0 ifTrue: [^self print: 'a ??'].
name := self nameOfClass: classOop.
nameLen = 10 ifTrue:
[(self strncmp: name _: 'ByteString' _: 10) = 0 "strncmp is weird" ifTrue:
[^self printChar: $'; printStringOf: oop; printChar: $'].
(self strncmp: name _: 'ByteSymbol' _: 10) = 0 "strncmp is weird" ifTrue:
[self printChar: $#; printStringOf: oop. ^self]].
(nameLen = 9 and: [(self strncmp: name _: 'Character' _: 9) = 0]) ifTrue:
[^self printChar: $$; printChar: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop))].
+ 'a(n) %.*s' f: transcript printf: { nameLen. name }.
- self print: 'a(n) '.
- self
- cCode: [0 to: nameLen - 1 do: [:i| self printChar: (name at: i)]]
- inSmalltalk:
- [name isString
- ifTrue: [self print: name]
- ifFalse: [0 to: nameLen - 1 do: [:i| self printChar: (name at: i)]]].
"Try to spot association-like things; they're all subclasses of LookupKey"
((objectMemory isPointersNonImm: oop)
and: [(objectMemory instanceSizeOf: classOop) = (ValueIndex + 1)
and: [(objectMemory isBytes: (objectMemory fetchPointer: KeyIndex ofObject: oop))]]) ifTrue:
[| classLookupKey |
classLookupKey := objectMemory fetchClassOfNonImm: (objectMemory splObj: SchedulerAssociation).
[classLookupKey = objectMemory nilObject ifTrue:
[^self].
(objectMemory instanceSizeOf: classLookupKey) = (KeyIndex + 1)] whileFalse:
[classLookupKey := self superclassOf: classLookupKey].
(self includesBehavior: classOop ThatOf: classLookupKey) ifTrue:
[self space;
+ printOopShortInner: (objectMemory fetchPointer: KeyIndex ofObject: oop);
- printOopShort: (objectMemory fetchPointer: KeyIndex ofObject: oop);
print: ' -> ';
printHexnp: (objectMemory fetchPointer: ValueIndex ofObject: oop)]]!
Item was changed:
----- Method: StackInterpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') -----
readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
"Read an image from the given file stream, allocating an amount of memory to its object heap.
V3: desiredHeapSize is the total size of the heap. Fail if the image has an unknown format or
requires more than the specified amount of memory.
Spur: desiredHeapSize is ignored; this routine will attempt to provide at least extraVMMemory's
ammount of free space after the image is loaded, taking any free space in teh image into account.
extraVMMemory is stored in the image header and is accessible as vmParameterAt: 23. If
extraVMMemory is 0, the value defaults to the default grow headroom. Fail if the image has an
unknown format or if sufficient memory cannot be allocated.
Details: This method detects when the image was stored on a machine with the opposite byte
ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header
information to start 512 bytes into the file, since some file transfer programs for the Macintosh
apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix
area could also be used to store an exec command on Unix systems, allowing one to launch
Smalltalk by invoking the image name as a command."
| headerStart headerSize headerFlags dataSize oldBaseAddr swapBytes
minimumMemory bytesRead bytesToShift heapSize firstSegSize
hdrEdenBytes hdrMaxExtSemTabSize hdrNumStackPages allocationReserve |
<var: #f type: #sqImageFile>
<var: #heapSize type: #usqInt>
<var: #dataSize type: #'size_t'>
<var: #minimumMemory type: #usqInt>
<var: #desiredHeapSize type: #usqInt>
<var: #allocationReserve type: #usqInt>
<var: #headerStart type: #squeakFileOffsetType>
<var: #imageOffset type: #squeakFileOffsetType>
+ transcript := #stdout. "stdout is not available at compile time. this is the earliest available point."
metaclassNumSlots := 6. "guess Metaclass instSize"
classNameIndex := 6. "guess (Class instVarIndexFor: 'name' ifAbsent: []) - 1"
swapBytes := self checkImageVersionFrom: f startingAt: imageOffset.
headerStart := (self sqImageFilePosition: f) - 4. "record header start position"
headerSize := self getWord32FromFile: f swap: swapBytes.
dataSize := self getLongFromFile: f swap: swapBytes.
oldBaseAddr := self getLongFromFile: f swap: swapBytes.
objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes).
objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "N.B. not used."
savedWindowSize := self getLongFromFile: f swap: swapBytes.
headerFlags := self getLongFromFile: f swap: swapBytes.
self setImageHeaderFlagsFrom: headerFlags.
extraVMMemory := self getWord32FromFile: f swap: swapBytes.
hdrNumStackPages := self getShortFromFile: f swap: swapBytes.
"4 stack pages is small. Should be able to run with as few as
three. 4 should be comfortable but slow. 8 is a reasonable
default. Can be changed via vmParameterAt: 43 put: n.
Can be set as a preference (Info.plist, VM.ini, command line etc).
If desiredNumStackPages is already non-zero then it has been
set as a preference. Ignore (but preserve) the header's default."
numStackPages := desiredNumStackPages ~= 0
ifTrue: [desiredNumStackPages]
ifFalse: [hdrNumStackPages = 0
ifTrue: [self defaultNumStackPages]
ifFalse: [hdrNumStackPages]].
desiredNumStackPages := hdrNumStackPages.
"pad to word boundary. This slot can be used for anything else that will fit in 16 bits.
It is used for the cog code size in Cog. Preserve it to be polite to other VMs."
theUnknownShort := self getShortFromFile: f swap: swapBytes.
hdrEdenBytes := self getWord32FromFile: f swap: swapBytes.
objectMemory edenBytes: (desiredEdenBytes ~= 0
ifTrue: [desiredEdenBytes]
ifFalse:
[hdrEdenBytes = 0
ifTrue: [objectMemory defaultEdenBytes]
ifFalse: [hdrEdenBytes]]).
desiredEdenBytes := hdrEdenBytes.
hdrMaxExtSemTabSize := self getShortFromFile: f swap: swapBytes.
hdrMaxExtSemTabSize ~= 0 ifTrue:
[self setMaxExtSemSizeTo: hdrMaxExtSemTabSize].
"pad to word boundary. This slot can be used for anything else that will fit in 16 bits.
Preserve it to be polite to other VMs."
the2ndUnknownShort := self getShortFromFile: f swap: swapBytes.
firstSegSize := self getLongFromFile: f swap: swapBytes.
objectMemory firstSegmentSize: firstSegSize.
"compare memory requirements with availability"
allocationReserve := self interpreterAllocationReserveBytes.
minimumMemory := dataSize
+ objectMemory newSpaceBytes
+ allocationReserve.
objectMemory hasSpurMemoryManagerAPI
ifTrue:
[| freeOldSpaceInImage headroom |
freeOldSpaceInImage := self getLongFromFile: f swap: swapBytes.
headroom := objectMemory
initialHeadroom: extraVMMemory
givenFreeOldSpaceInImage: freeOldSpaceInImage.
heapSize := objectMemory roundUpHeapSize:
dataSize
+ headroom
+ objectMemory newSpaceBytes
+ (headroom > allocationReserve
ifTrue: [0]
ifFalse: [allocationReserve])]
ifFalse:
[heapSize := desiredHeapSize
+ objectMemory newSpaceBytes
+ (desiredHeapSize - dataSize > allocationReserve
ifTrue: [0]
ifFalse: [allocationReserve]).
heapSize < minimumMemory ifTrue:
[self insufficientMemorySpecifiedError]].
"allocate a contiguous block of memory for the Squeak heap"
(self
allocateMemory: heapSize
minimum: minimumMemory
imageFile: f
headerSize: headerSize) asUnsignedInteger
ifNil: [self insufficientMemoryAvailableError]
ifNotNil:
[:mem|
objectMemory
setHeapBase: mem
memoryLimit: mem + heapSize
endOfMemory: mem + dataSize].
"position file after the header"
self sqImageFile: f Seek: headerStart + headerSize.
"read in the image in bulk, then swap the bytes if necessary"
bytesRead := objectMemory readHeapFromImageFile: f dataBytes: dataSize.
bytesRead ~= dataSize ifTrue: [self unableToReadImageError].
self ensureImageFormatIsUpToDate: swapBytes.
"compute difference between old and new memory base addresses"
bytesToShift := objectMemory memoryBaseForImageRead - oldBaseAddr.
self initializeInterpreter: bytesToShift. "adjusts all oops to new location"
^dataSize!
Item was changed:
----- Method: StackInterpreter>>shortPrint: (in category 'simulation') -----
shortPrint: oop
<doNotGenerate>
| name classOop key |
(objectMemory isImmediate: oop) ifTrue:
[(objectMemory isImmediateCharacter: oop) ifTrue:
[^(objectMemory characterValueOf: oop) < 256
ifTrue:
['=$', (objectMemory characterValueOf: oop) printString,
' ($', (String with: (Character value: (objectMemory characterValueOf: oop))), ')']
ifFalse:
['=$', (objectMemory characterValueOf: oop) printString, '($???)']].
(objectMemory isIntegerObject: oop) ifTrue:
[^'=', (objectMemory integerValueOf: oop) printString,
' (', (objectMemory integerValueOf: oop) hex, ')'].
(objectMemory isImmediateFloat: oop) ifTrue:
[^ '=', (objectMemory floatValueOf: oop) printString, ' (', oop hex, ')'].
^'= UNKNOWN IMMEDIATE', ' (', (objectMemory integerValueOf: oop) hex, ')'].
(objectMemory addressCouldBeObj: oop) ifFalse:
[^(oop bitAnd: objectMemory allocationUnit - 1) ~= 0
ifTrue: [' is misaligned']
ifFalse: [self whereIs: oop]].
(objectMemory isFreeObject: oop) ifTrue:
[^' is a free chunk of size ', (objectMemory sizeOfFree: oop) printString,
(objectMemory hasSpurMemoryManagerAPI
ifTrue: [' 0th: ', (objectMemory fetchPointer: 0 ofFreeChunk: oop) hex]
ifFalse: [''])].
(objectMemory isForwarded: oop) ifTrue:
[^' is a forwarded object to ', (objectMemory followForwarded: oop) hex,
' of slot size ', (objectMemory numSlotsOfAny: oop) printString].
(objectMemory isFloatInstance: oop) ifTrue:
[^'=', (objectMemory dbgFloatValueOf: oop) printString].
oop = objectMemory nilObject ifTrue:
[^'nil'].
oop = objectMemory falseObject ifTrue:
[^'false'].
oop = objectMemory trueObject ifTrue:
[^'true'].
classOop := objectMemory fetchClassOfNonImm: oop.
((self objCouldBeClassObj: oop)
and: [(objectMemory numSlotsOf: classOop) = metaclassNumSlots]) ifTrue:
[^'class ', (self nameOfClass: oop)].
name := self nameOfClass: classOop.
name size = 0 ifTrue: [name := '??'].
+ (self is: oop KindOfClass: (self superclassOf: (objectMemory splObj: ClassString))) ifTrue:
+ [(name endsWith: #Symbol) ifTrue:
+ [^'#', (self stringOf: oop)].
+ ^(self stringOf: oop) printString].
- (#('String' 'ByteString') includes: name) ifTrue:
- [^(self stringOf: oop) printString].
- (#('Symbol' 'ByteSymbol') includes: name) ifTrue:
- [^'#', (self stringOf: oop)].
name = 'Character' ifTrue: "SpurMemoryManager has immediate Characters (see above); ObjectMemory does not"
[^'=', (Character value: (objectMemory integerValueOf:
(objectMemory fetchPointer: 0 ofObject: oop))) printString].
"Try to spot association-like things; they're all subclasses of LookupKey"
((objectMemory isPointersNonImm: oop)
and: [classOop ~= objectMemory nilObject
and: [((objectMemory instanceSizeOf: classOop) between: ValueIndex + 1 and: ValueIndex + 2)
and: [(objectMemory addressCouldBeObj: (key := objectMemory fetchPointer: KeyIndex ofObject: oop))
and: [(key = objectMemory nilObject and: [self addressCouldBeClassObj: (objectMemory fetchPointer: ValueIndex ofObject: oop)])
or: [objectMemory isBytesNonImm: key]]]]]) ifTrue:
[| classLookupKey |
classLookupKey := objectMemory fetchClassOfNonImm: (objectMemory splObj: SchedulerAssociation).
[classLookupKey = objectMemory nilObject ifTrue:
[^(('AEIOU' includes: name first) ifTrue: ['an '] ifFalse: ['a ']), name].
(objectMemory instanceSizeOf: classLookupKey) = (KeyIndex + 1)] whileFalse:
[classLookupKey := self superclassOf: classLookupKey].
[(objectMemory instanceSizeOf: (self superclassOf: classLookupKey)) = (KeyIndex + 1)] whileTrue:
[classLookupKey := self superclassOf: classLookupKey].
(self includesBehavior: classOop ThatOf: classLookupKey) ifTrue:
[^(('AEIOU' includes: name first) ifTrue: ['an '] ifFalse: ['a ']), name,
' ', (self shortPrint: (objectMemory fetchPointer: KeyIndex ofObject: oop)),
' -> ',
(objectMemory fetchPointer: ValueIndex ofObject: oop) hex8]].
^(('AEIOU' includes: name first) ifTrue: ['an '] ifFalse: ['a ']), name!
Item was changed:
----- Method: StackInterpreter>>shortPrintOop: (in category 'debug printing') -----
shortPrintOop: oop
<inline: false>
+ | className length |
- self printHexnp: oop.
(objectMemory isImmediate: oop) ifTrue:
+ [^objectMemory printImmediateObject: oop on: transcript].
- [(objectMemory isIntegerObject: oop) ifTrue:
- [self
- cCode: ['=%ld\n' printf: {(objectMemory integerValueOf: oop) asLong}]
- inSmalltalk: [self print: (self shortPrint: oop); cr]].
- (objectMemory isImmediateCharacter: oop) ifTrue:
- [self
- cCode: ['=$%ld ($%lc)\n' printf: {(objectMemory characterValueOf: oop) asLong.
- self cCoerce: (objectMemory characterValueOf: oop) to: 'wint_t'}]
- inSmalltalk: [self print: (self shortPrint: oop); cr]].
- (objectMemory isImmediateFloat: oop) ifTrue:
- [self
- cCode: ['=%g\n' printf: (objectMemory floatValueOf: oop)]
- inSmalltalk: [self print: '='; printFloat: (objectMemory floatValueOf: oop); cr]].
- ^self].
(objectMemory addressCouldBeObj: oop) ifFalse:
+ [^objectMemory printCantBeObject: oop on: transcript].
+ (objectMemory isFreeObject: oop) ifTrue:
+ [^objectMemory printFreeObject: oop on: transcript].
+ (objectMemory isForwarded: oop) ifTrue:
+ [^objectMemory printForwarder: oop on: transcript].
+ className := self
+ nameOfClass: (objectMemory fetchClassOfNonImm: oop)
+ lengthInto: (self addressOf: length put: [:v| length := v]).
+ '16r%lx: a(n) %.*s\n' f: transcript printf: {oop. length. className }!
- [^self print: ((oop bitAnd: objectMemory allocationUnit - 1) ~= 0
- ifTrue: [' is misaligned']
- ifFalse: [self whereIs: oop]); cr].
- ((objectMemory isFreeObject: oop)
- or: [objectMemory isForwarded: oop]) ifTrue:
- [^self printOop: oop].
- self print: ': a(n) '.
- self printNameOfClass: (objectMemory fetchClassOfNonImm: oop) count: 5.
- self cr!
Item was added:
+ ----- Method: StackInterpreter>>transcript (in category 'debug printing redirected') -----
+ transcript
+ <doNotGenerate>
+ "N.B. can't use this as the C getter because C's namespace rules
+ don't allow a variable and a function to share the same name."
+ ^transcript!
Item was added:
+ ----- Method: StackInterpreter>>transcript: (in category 'debug printing redirected') -----
+ transcript: aStream
+ <doNotGenerate>
+ transcript := aStream!
Item was added:
+ ----- Method: StackInterpreter>>warning: (in category 'cog jit support') -----
+ warning: aString
+ <api: 'extern void warning(const char *s)'>
+ <doNotGenerate>
+ self transcript cr; nextPutAll: aString; flush!
Item was added:
+ ----- Method: StackInterpreter>>withRedirectedOutputTo:do: (in category 'debug printing redirected') -----
+ withRedirectedOutputTo: aStreamOrNil do: aBlock
+ <inline: #always>
+ | savedTranscript |
+ savedTranscript := transcript.
+ transcript := aStreamOrNil ifNil: [#stdout] ifNotNil: [aStreamOrNil].
+ aBlock value.
+ transcript := savedTranscript!
Item was changed:
StackInterpreterPrimitives subclass: #StackInterpreterSimulator
+ instanceVariableNames: 'parent bootstrapping byteCount breakCount sendCount lookupCount printSends printReturns myBitBlt displayForm fakeForm filesOpen imageName pluginList mappedPluginEntries quitBlock displayView eventTransformer printFrameAtEachStep printBytecodeAtEachStep systemAttributes startMicroseconds lastYieldMicroseconds externalSemaphoreSignalRequests externalSemaphoreSignalResponses extSemTabSize atEachStepBlock disableBooleanCheat performFilters eventQueue assertVEPAES primTraceLog breakBlock inputSemaphoreIndex perMethodProfile'
- instanceVariableNames: 'parent bootstrapping byteCount breakCount sendCount lookupCount printSends printReturns traceOn myBitBlt displayForm fakeForm filesOpen imageName pluginList mappedPluginEntries quitBlock transcript displayView eventTransformer printFrameAtEachStep printBytecodeAtEachStep systemAttributes startMicroseconds lastYieldMicroseconds externalSemaphoreSignalRequests externalSemaphoreSignalResponses extSemTabSize atEachStepBlock disableBooleanCheat performFilters eventQueue assertVEPAES primTraceLog breakBlock inputSemaphoreIndex perMethodProfile'
classVariableNames: 'ByteCountsPerMicrosecond'
poolDictionaries: ''
category: 'VMMaker-InterpreterSimulation'!
!StackInterpreterSimulator commentStamp: 'eem 9/3/2013 11:05' prior: 0!
This class defines basic memory access and primitive simulation so that the StackInterpreter can run simulated in the Squeak environment. It also defines a number of handy object viewing methods to facilitate pawing around in the object memory.
To see the thing actually run, you could (after backing up this image and changes), execute
(StackInterpreterSimulator new openOn: Smalltalk imageName) test
((StackInterpreterSimulator newWithOptions: #(NewspeakVM true MULTIPLEBYTECODESETS true))
openOn: 'ns101.image') test
and be patient both to wait for things to happen, and to accept various things that may go wrong depending on how large or unusual your image may be. We usually do this with a small and simple benchmark image.
Here's an example of what Eliot uses to launch the simulator in a window. The bottom-right window has a menu packed with useful stuff:
| vm |
vm := StackInterpreterSimulator newWithOptions: #().
vm openOn: '/Users/eliot/Squeak/Squeak4.4/trunk44.image'.
vm setBreakSelector: #&.
vm openAsMorph; run!
Item was removed:
- ----- Method: StackInterpreterSimulator>>cr (in category 'debug printing') -----
- cr
-
- traceOn ifTrue: [ transcript cr; flush ].!
Item was changed:
----- Method: StackInterpreterSimulator>>ensureDebugAtEachStepBlock (in category 'testing') -----
ensureDebugAtEachStepBlock
atEachStepBlock := [printFrameAtEachStep ifTrue:
[self printFrame: localFP WithSP: localSP].
printBytecodeAtEachStep ifTrue:
+ [self printCurrentBytecodeOn: transcript].
- [self printCurrentBytecodeOn: transcript.
- transcript cr; flush].
byteCount = breakCount ifTrue:
["printFrameAtEachStep :=" printBytecodeAtEachStep := true].
breakBlock ifNotNil:
[breakBlock value ifTrue: [self halt]]]!
Item was removed:
- ----- Method: StackInterpreterSimulator>>flush (in category 'debug printing') -----
- flush
- traceOn ifTrue:
- [transcript flush.
- "We *always* want to make output visible on flush"
- TranscriptStream forceUpdate ifFalse:
- [transcript changed: #appendEntry]]!
Item was changed:
----- Method: StackInterpreterSimulator>>initialize (in category 'initialize-release') -----
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."
super initialize.
bootstrapping := false.
transcript := Transcript.
objectMemory ifNil:
[objectMemory := self class objectMemoryClass simulatorClass new].
objectMemory coInterpreter: self.
self assert: ConstMinusOne = (objectMemory integerObjectOf: -1).
methodCache := Array new: MethodCacheSize.
nsMethodCache := Array new: NSMethodCacheSize.
atCache := Array new: AtCacheTotalSize.
self flushMethodCache.
gcSemaphoreIndex := 0.
externalSemaphoreSignalRequests := externalSemaphoreSignalResponses := #().
externalPrimitiveTable := CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize).
externalPrimitiveTableFirstFreeIndex := 0.
primitiveTable := self class primitiveTable copy.
self initializePluginEntries.
desiredNumStackPages := desiredEdenBytes := 0.
"This is initialized on loading the image, but convenient for testing stack page values..."
numStackPages := self defaultNumStackPages.
startMicroseconds := lastYieldMicroseconds := self ioUTCStartMicroseconds.
"initialize InterpreterSimulator variables used for debugging"
byteCount := sendCount := lookupCount := 0.
quitBlock := [^self close].
- traceOn := true.
printSends := printReturns := printFrameAtEachStep := printBytecodeAtEachStep := false.
myBitBlt := BitBltSimulator new setInterpreter: self.
displayForm := fakeForm := 'Display has not yet been installed' asDisplayText form.
suppressHeartbeatFlag := false.
systemAttributes := Dictionary new.
extSemTabSize := 256.
disableBooleanCheat := false.
assertVEPAES := false. "a flag so the assertValidExecutionPointers can be disabled for simulation speed and enabled when necessary."!
Item was removed:
- ----- Method: StackInterpreterSimulator>>print: (in category 'debug printing') -----
- print: it
-
- traceOn ifTrue:
- [it isString ifTrue: [transcript nextPutAll: it] ifFalse: [it printOn: transcript]]!
Item was removed:
- ----- Method: StackInterpreterSimulator>>printChar: (in category 'debug printing') -----
- printChar: aByte
-
- traceOn ifTrue: [ transcript nextPut: aByte asCharacter ].!
Item was changed:
----- Method: StackInterpreterSimulator>>printCurrentBytecodeOn: (in category 'debug printing') -----
printCurrentBytecodeOn: aStream
| code |
code := currentBytecode radix: 16.
aStream ensureCr; print: localIP - method - 3; tab.
bytecodeSetSelector > 0 ifTrue:
[aStream nextPutAll: 'ALT '].
aStream
nextPut: (code size < 2
ifTrue: [$0]
ifFalse: [code at: 1]);
nextPut: code last; space;
nextPutAll: (BytecodeTable at: currentBytecode + 1);
space;
+ nextPut: $(; print: byteCount + 1; nextPut: $);
+ cr;
+ flush!
- nextPut: $(; print: byteCount + 1; nextPut: $)!
Item was removed:
- ----- Method: StackInterpreterSimulator>>printHex: (in category 'debug printing') -----
- printHex: anInteger
-
- traceOn ifTrue:
- [transcript
- next: 8 - (anInteger digitLength * 2) put: Character space;
- nextPutAll: (anInteger storeStringBase: 16)]!
Item was removed:
- ----- Method: StackInterpreterSimulator>>printHexnp: (in category 'debug printing') -----
- printHexnp: anInteger
-
- traceOn ifTrue:
- [transcript nextPutAll: ((anInteger ifNil: [0]) storeStringBase: 16)]!
Item was removed:
- ----- Method: StackInterpreterSimulator>>printHexnpnp: (in category 'debug printing') -----
- printHexnpnp: anInteger
- "Print n in hex, in the form '1234', unpadded"
- traceOn ifTrue:
- [transcript nextPutAll: ((anInteger ifNil: [0]) printStringBase: 16)]!
Item was removed:
- ----- Method: StackInterpreterSimulator>>printNum: (in category 'debug printing') -----
- printNum: anInteger
-
- traceOn ifTrue: [ transcript print: anInteger ].!
Item was removed:
- ----- Method: StackInterpreterSimulator>>printStringForCurrentBytecode (in category 'debug printing') -----
- printStringForCurrentBytecode
- ^String streamContents: [:str| self printCurrentBytecodeOn: str]!
Item was removed:
- ----- Method: StackInterpreterSimulator>>redirectTranscriptToHost (in category 'debug support') -----
- redirectTranscriptToHost
- "Sometimes you need the capability to see the transcript output of the image into the
- local transcript (for debugging when bootstrapping, for example). "
- transcript := Transcript!
Item was changed:
----- Method: StackInterpreterSimulator>>shortPrintContext: (in category 'debug printing') -----
shortPrintContext: aContext
transcript ensureCr.
^super shortPrintContext: aContext!
Item was removed:
- ----- Method: StackInterpreterSimulator>>space (in category 'debug printing') -----
- space
-
- traceOn ifTrue: [ transcript space ]!
Item was removed:
- ----- Method: StackInterpreterSimulator>>sqShrinkMemory:By: (in category 'memory access') -----
- sqShrinkMemory: oldLimit By: delta
- transcript show: 'shrink memory from ', oldLimit printString, ' by ', delta printString, ' remember it doesn''t actually shrink in simulation'; cr.
-
- ^ oldLimit!
Item was removed:
- ----- Method: StackInterpreterSimulator>>tab (in category 'debug printing') -----
- tab
-
- traceOn ifTrue: [ transcript tab ].!
Item was changed:
----- Method: StackInterpreterSimulator>>test (in category 'testing') -----
test
self initStackPages.
self loadInitialContext.
transcript clear.
byteCount := 0.
breakCount := -1.
quitBlock := [^self close].
printSends := printReturns := true.
self internalizeIPandSP.
self fetchNextBytecode.
[true] whileTrue:
[self assertValidExecutionPointers.
printFrameAtEachStep ifTrue:
[self printFrame: localFP WithSP: localSP].
printBytecodeAtEachStep ifTrue:
+ [self printCurrentBytecodeOn: transcript].
- [self printCurrentBytecodeOn: Transcript.
- Transcript cr; flush].
self dispatchOn: currentBytecode in: BytecodeTable.
self incrementByteCount.
byteCount = breakCount ifTrue:
["printFrameAtEachStep :=" printBytecodeAtEachStep := true.
self halt: 'hit breakCount break-point']].
self externalizeIPandSP!
Item was changed:
----- Method: StackInterpreterSimulator>>test1 (in category 'testing') -----
test1
self initStackPages.
self loadInitialContext.
transcript clear.
byteCount := 0.
breakCount := -1.
self setBreakSelector: #blockCopy:.
quitBlock := [^self close].
printSends := printReturns := true.
self internalizeIPandSP.
self fetchNextBytecode.
[true] whileTrue:
[self assertValidExecutionPointers.
"byteCount >= 22283 ifTrue:
[(self checkIsStillMarriedContext: 22186072 currentFP: localFP) ifFalse:
[self halt]]."
(printBytecodeAtEachStep
"and: [self isMarriedOrWidowedContext: 22189568]") ifTrue:
["| thePage |
thePage := stackPages stackPageFor: (self frameOfMarriedContext: 22189568).
thePage == stackPage
ifTrue: [self shortPrintFrameAndCallers: localFP SP: localSP]
ifFalse: [self shortPrintFrameAndCallers: thePage headFrameFP SP: thePage headFrameSP]."
+ self printCurrentBytecodeOn: transcript].
- self printCurrentBytecodeOn: Transcript.
- Transcript cr; flush].
self dispatchOn: currentBytecode in: BytecodeTable.
self incrementByteCount.
byteCount = breakCount ifTrue:
["printFrameAtEachStep := true."
printSends := printBytecodeAtEachStep := true.
self halt: 'hit breakCount break-point']].
self externalizeIPandSP!
Item was changed:
----- Method: StackInterpreterSimulator>>testBreakCount:printSends:printFrames:printBytecodes: (in category 'testing') -----
testBreakCount: breakCount printSends: shouldPrintSends printFrames: shouldPrintFrames printBytecodes: shouldPrintBytecodes
self initStackPages.
self loadInitialContext.
transcript clear.
byteCount := 0.
quitBlock := [^self close].
printSends := true & shouldPrintSends. "true & foo allows evaluating printFoo := true in the debugger"
printFrameAtEachStep := true & shouldPrintFrames.
printBytecodeAtEachStep := true & shouldPrintBytecodes.
self internalizeIPandSP.
self fetchNextBytecode.
[true] whileTrue:
[self assertValidExecutionPointers.
printFrameAtEachStep ifTrue:
[self printFrame: localFP WithSP: localSP].
printBytecodeAtEachStep ifTrue:
+ [self printCurrentBytecodeOn: transcript].
- [self printCurrentBytecodeOn: Transcript.
- Transcript cr; flush].
self dispatchOn: currentBytecode in: BytecodeTable.
self incrementByteCount.
byteCount = breakCount ifTrue:
["printFrameAtEachStep :=" printBytecodeAtEachStep := true.
self halt: 'hit breakCount break-point']].
self externalizeIPandSP!
Item was removed:
- ----- Method: StackInterpreterSimulator>>transcript (in category 'accessing') -----
- transcript
- ^transcript!
Item was removed:
- ----- Method: StackInterpreterSimulator>>transcript: (in category 'accessing') -----
- transcript: aTranscript
- transcript := aTranscript!
Item was removed:
- ----- Method: StackInterpreterSimulator>>warning: (in category 'debug support') -----
- warning: aString
- transcript cr; nextPutAll: aString; flush!
Item was changed:
----- Method: TConstantNode>>printOn:level: (in category 'printing') -----
printOn: aStream level: level
value isSymbol
ifTrue: [aStream nextPutAll: (value copyWithout: $:)]
+ ifFalse: [value isLiteral
+ ifTrue: [value printAsLiteralOn: aStream]
+ ifFalse: [value storeOn: aStream]]!
- ifFalse: [value storeOn: aStream]!
Item was changed:
----- Method: TMethod>>prepareMethodIn: (in category 'transformations') -----
prepareMethodIn: aCodeGen
"Record sends of builtin operators, map sends of the special selector dispatchOn:in:
with case statement nodes, and map sends of caseOf:[otherwise:] to switch statements.
Declare limit variables for to:[by:]do: loops with limits that potentially have side-effects.
As a hack also update the types of variables introduced to implement cascades correctly.
This has to be done at the same time as this is done, so why not piggy back here?"
extraVariableNumber ifNotNil:
[declarations keysAndValuesDo:
[:varName :decl|
decl isBlock ifTrue:
[self assert: ((varName beginsWith: 'cascade') and: [varName last isDigit]).
locals add: varName.
self declarationAt: varName
put: (decl value: self value: aCodeGen), ' ', varName]]].
aCodeGen
pushScope: declarations
while:"N.B. nodesWithParentsDo: is bottom-up, hence replacement is destructive and conserved."
[parseTree nodesWithParentsDo:
[:node :parent|
node isSend ifTrue:
[aCodeGen ifStaticallyResolvedPolymorphicReceiverThenUpdateSelectorIn: node.
(aCodeGen isBuiltinSelector: node selector)
ifTrue:
[node isBuiltinOperator: true.
"If a to:by:do:'s limit has side-effects, declare the limit variable, otherwise delete it from the args"
node selector = #to:by:do: ifTrue:
[self ensureToByDoLoopLimitIsSafeAndEfficient: node in: aCodeGen]]
ifFalse:
[(StackInterpreter isStackAccessor: node selector)
ifTrue: "compute and cache the accessor depth early, before inlining destroys the accessor chains"
[self export ifTrue:
[aCodeGen accessorDepthForMethod: self]]
ifFalse:
[(CaseStatements includes: node selector) ifTrue:
[parent replaceNodesIn: (Dictionary newFromPairs: { node. self buildCaseStmt: node in: aCodeGen})].
(#(caseOf: #caseOf:otherwise:) includes: node selector) ifTrue:
[parent replaceNodesIn: (Dictionary newFromPairs: { node. self buildSwitchStmt: node parent: parent })].
+ (#(printf: fprintf: f:printf: f:wprintf:) includes: node selector) ifTrue:
+ [self transformPrintf: node].
+ (node receiver isVariable
+ and: [node receiver name = #Character
+ and: [node selector isUnary]]) ifTrue:
+ [parent replaceNodesIn: (Dictionary newFromPairs: { node. TConstantNode new setValue: (Character perform: node selector) })]]]]]]!
- (#(printf: f:printf:) includes: node selector) ifTrue:
- [self transformPrintf: node]]]]]]!
Item was changed:
----- Method: TMethod>>transformPrintf: (in category 'transformations') -----
transformPrintf: sendNode
"Handle forms of f:printf: & printf:. f:printf: is either
logFile f: formatLiteral printf: args
or
formatLiteral f: streamName printf: args
printf is
formatLiteral printf: args"
| map newArgs |
newArgs := OrderedCollection new.
+ sendNode changeClassTo: TVarArgsSendNode.
sendNode args do:
[:arg|
arg isBrace
ifTrue: [newArgs addAllLast: arg elements]
ifFalse: [newArgs addLast: arg]].
(sendNode receiver isConstant
and: [sendNode receiver value isString]) ifTrue:
[| format |
format := sendNode receiver asPrintfFormatStringNode.
sendNode selector first == $f ifTrue: "fprintf et al..."
[sendNode receiver: (TVariableNode new setName: 'self').
sendNode arguments: {sendNode args first. format}, newArgs allButFirst.
^sendNode].
sendNode receiver: format.
sendNode arguments: newArgs.
^sendNode].
map := Dictionary new.
sendNode nodesDo:
[:subNode|
(subNode isConstant and: [subNode value isString and: [subNode value includes: $%]]) ifTrue:
[map at: subNode put: subNode asPrintfFormatStringNode]].
sendNode arguments: newArgs.
sendNode replaceNodesIn: map.
^sendNode!
Item was added:
+ ----- Method: TSendNode>>argumentSeparationBlockFor:numArgs:level: (in category 'C code generation') -----
+ argumentSeparationBlockFor: aStream numArgs: numArgs level: level
+ ^[aStream nextPut: $,; space]!
Item was changed:
----- Method: TSendNode>>emitCCodeAsFunctionCallOn:level:generator: (in category 'C code generation') -----
emitCCodeAsFunctionCallOn: aStream level: level generator: aCodeGen
"Translate this message send into a C function call"
selector == #break ifTrue:
[aStream nextPutAll: '/* send of break elided */'.
^self].
"Special case for pluggable modules. Replace messages to interpreterProxy
by interpreterProxy->message(..) if the message is not builtin"
(aCodeGen shouldGenerateAsInterpreterProxySend: self) ifTrue:
[(aCodeGen noteUsedPluginFunction: selector) ifTrue:
[aStream nextPutAll: 'interpreterProxy->']].
aStream nextPutAll: (aCodeGen cFunctionNameFor: selector); nextPut: $(.
"Only include the receiver as the first argument in certain cases.
The receiver is always included if it is an expression.
If it is a variable:
If the vmClass says it is an implicit variable, don't include it.
If the variable is 'self' and the method being called is not in
the method set (i.e. it is some external code), don't include it."
(self shouldExcludeReceiverAsFirstArgument: aCodeGen) ifFalse:
[(receiver structTargetKindIn: aCodeGen) == #struct ifTrue:
[aStream nextPut: $&].
receiver emitCCodeOn: aStream level: level generator: aCodeGen.
arguments isEmpty ifFalse:
[aStream nextPutAll: ', ']].
arguments
do: [ :arg| arg emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen]
+ separatedBy: (self argumentSeparationBlockFor: aStream numArgs: arguments size level: level).
- separatedBy: [aStream nextPut: $,; space].
aStream nextPut: $)!
Item was added:
+ ----- Method: TSendNode>>isVarArgsSendNode (in category 'testing') -----
+ isVarArgsSendNode
+ ^false!
Item was changed:
----- Method: TSendNode>>printOn:level: (in category 'printing') -----
printOn: aStream level: level
+ self printParenthetically: receiver on: aStream level: level + 1.
- | possiblyParenthesize |
- possiblyParenthesize :=
- [:node :newLevel|
- node
- ifNil: [aStream print: node]
- ifNotNil:
- [(node isSend
- and: [node selector precedence >= 3]) ifTrue:
- [aStream nextPut: $(].
- node printOn: aStream level: newLevel.
- (node isSend
- and: [node selector precedence >= 3]) ifTrue:
- [aStream nextPut: $)]]].
-
- possiblyParenthesize value: receiver value: level.
arguments size = 0 ifTrue:
[aStream space; nextPutAll: selector.
^self].
selector keywords with: (arguments first: selector numArgs) do:
[:keyword :arg |
aStream space; nextPutAll: keyword; space.
+ self printParenthetically: arg on: aStream level: level + 1]!
- possiblyParenthesize value: arg value: level + 1]!
Item was added:
+ ----- Method: TSendNode>>printParenthetically:on:level: (in category 'printing') -----
+ printParenthetically: node on: aStream level: level
+ node
+ ifNil: [aStream print: node]
+ ifNotNil:
+ [(node isSend
+ and: [node selector precedence >= 3])
+ ifTrue:
+ [aStream nextPut: $(.
+ node printOn: aStream level: level.
+ aStream nextPut: $)]
+ ifFalse: [node printOn: aStream level: level]]!
Item was added:
+ TSendNode subclass: #TVarArgsSendNode
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-Translation to C'!
Item was added:
+ ----- Method: TVarArgsSendNode>>argumentSeparationBlockFor:numArgs:level: (in category 'C code generation') -----
+ argumentSeparationBlockFor: aStream numArgs: numArgs level: level
+ ^numArgs <= 2
+ ifTrue: [super argumentSeparationBlockFor: aStream numArgs: numArgs level: level]
+ ifFalse: [[aStream nextPut: $,; crtab: level + 2]]!
Item was added:
+ ----- Method: TVarArgsSendNode>>isVarArgsSendNode (in category 'testing') -----
+ isVarArgsSendNode
+ ^true!
Item was added:
+ ----- Method: TVarArgsSendNode>>printOn:level: (in category 'printing') -----
+ printOn: aStream level: level
+ | keywords |
+ keywords := selector keywords.
+ keywords size = arguments size ifTrue:
+ [^super printOn: aStream level: level].
+ keywords allButLast with: (arguments first: keywords size - 1) do:
+ [:keyword :arg |
+ aStream space; nextPutAll: keyword; space.
+ self printParenthetically: arg on: aStream level: level + 1].
+ aStream space; nextPutAll: keywords last; space; nextPut: ${; space.
+ (arguments allButFirst: keywords size - 1)
+ do: [:arg| arg printOn: aStream level: level + 1]
+ separatedBy: [aStream nextPutAll: '. '].
+ aStream nextPutAll: ' }'!
Item was changed:
+ ----- Method: WriteStream>>fflush (in category '*VMMaker-debug printing interpreter support') -----
- ----- Method: WriteStream>>fflush (in category '*VMMaker-logging') -----
fflush
"compatibility to map the stdio fflush(FILE *) routine onto flush"
self flush!
Item was added:
+ ----- Method: WriteStream>>fputc: (in category '*VMMaker-debug printing interpreter support') -----
+ fputc: aCharacterOrCode
+ self nextPut: aCharacterOrCode asCharacter.
+ aCharacterOrCode asCharacter == Character cr ifTrue:
+ [self flush]!
More information about the Vm-dev
mailing list