David T. Lewis uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker-dtl.439.mcz
==================== Summary ====================
Name: VMMaker-dtl.439 Author: dtl Time: 15 April 2023, 7:19:26.846 pm UUID: 2c8ef6e2-8460-4120-b973-009902597787 Ancestors: VMMaker-dtl.438
VMMaker 4.20.5 Reorganize to bring the simulator back to life. Fix initialization of simulator classes to reflect separation of object memory from interpreter in the hierarchy. Move methods e.g. classFloat from ObjectMemory to Interpreter because they need to be referenced from plugins in simulation and are part of the InterpreterProxy protocol. Update FilePluginSimulator from oscog branch. Generated C code is unchanged except for minor update to FilePlugin (no functional impact for this VM). Note that opensmalltalk-vm (oscog branch) provides much better simulation support, but basic functionality needs to be maintained here as well.
=============== Diff against VMMaker-dtl.438 ===============
Item was changed: ----- Method: BitBltSimulator>>initialiseModule (in category 'initialize-release') ----- initialiseModule
self class isInitialised ifFalse: [| ivars | ivars := #(opTable maskTable warpBitShiftTable ditherMatrix4x4 ditherThresholds16 ditherValues16 dither8Lookup). super initialiseModule. ivars do: [:symbol | self class instVarNamed: symbol put: (self instVarNamed: symbol)]. self class setInitialised]. opTable := self class opTable. maskTable := self class maskTable. warpBitShiftTable := self class warpBitShiftTable. ditherMatrix4x4 := self class ditherMatrix4x4. ditherThresholds16 := self class ditherThresholds16. ditherValues16 := self class ditherValues16. dither8Lookup := self class dither8Lookup. + ^true. + !
Item was changed: ----- Method: ContextInterpreter>>displayExtent: (in category 'primitive support') ----- displayExtent: screenSizeWord "Answer a Point representing the display extent"
| displayX displayY extent | + extent := objectMemory instantiateClass: self classPoint indexableSize: 0. - extent := objectMemory instantiateClass: objectMemory classPoint indexableSize: 0. displayX := objectMemory positive32BitIntegerFor: (screenSizeWord >> 16). displayY := objectMemory positive32BitIntegerFor: (screenSizeWord bitAnd: 16rFFFF). objectMemory storePointer: 0 ofObject: extent withValue: displayX. objectMemory storePointer: 1 ofObject: extent withValue: displayY. ^extent !
Item was changed: ----- Method: ContextInterpreter>>headerAndSnapshotOfSize:class: (in category 'primitive support') ----- headerAndSnapshotOfSize: size class: class
"Answer a snapshot copy of the current object memory and header information. The object memory will be saved as and object of type class" | bytesPerElement oop start copy ptr result | <var: 'start' type: 'usqInt'> <var: 'end' type: 'usqInt'> <var: 'size' type: 'size_t'> <var: 'copy' type: 'void *'> <var: 'ptr' type: 'void *'> "Expect class Bitmap or ByteArray" + self classByteArray = class - objectMemory classByteArray = class ifTrue: [bytesPerElement := 1] + ifFalse: [self classBitmap = class - ifFalse: [objectMemory classBitmap = class ifTrue: [bytesPerElement := 4] ifFalse: [^interpreterProxy primitiveFail]]. "Get values needed for object memory copy before first allocation" start := objectMemory getMemory. copy := self malloc: size. copy == nil ifTrue: [^ self primitiveFail]. self mem: copy "to temporary allocated space" cp: (objectMemory pointerForOop: start) "from start of memory" y: size. "copy memory to separately allocated space"
objectMemory pushRemappableOop: (self memoryHeaderState: size). "allocation happens here"
"Copy the saved memory image back to a Bitmap" oop := objectMemory instantiateClass: class indexableSize: (size / bytesPerElement). self successful ifFalse: [self free: copy. ^ self primitiveFail]. ptr := objectMemory firstIndexableField: oop. self mem: ptr cp: copy y: size. "copy saved memory back into newly allocated Bitmap" self free: copy. "free the temp space" objectMemory pushRemappableOop: oop.
+ result := objectMemory instantiateClass: self classArray indexableSize: 2. - result := objectMemory instantiateClass: objectMemory classArray indexableSize: 2. objectMemory storePointer: 0 ofObject: result withValue: (objectMemory popRemappableOop). objectMemory storePointer: 1 ofObject: result withValue: (objectMemory popRemappableOop). ^ result
!
Item was changed: ----- Method: ContextInterpreter>>headerAndSnapshotOfSize:class:bytesPerElement: (in category 'primitive support') ----- headerAndSnapshotOfSize: size class: class bytesPerElement: bytesPerElement
"Answer a snapshot copy of the current object memory and header information. The object memory will be saved as and object of type class" | oop start copy ptr result | <var: 'start' type: 'usqInt'> <var: 'end' type: 'usqInt'> <var: 'size' type: 'size_t'> <var: 'copy' type: 'void *'> <var: 'ptr' type: 'void *'>
"Get values needed for object memory copy before first allocation" start := objectMemory getMemory. copy := self malloc: size. copy == nil ifTrue: [^ self primitiveFail]. self mem: copy "to temporary allocated space" cp: (objectMemory pointerForOop: start) "from start of memory" y: size. "copy memory to separately allocated space"
objectMemory pushRemappableOop: (self memoryHeaderState: size). "allocation happens here"
"Copy the saved memory image back to a Bitmap" oop := objectMemory instantiateClass: class indexableSize: (size / bytesPerElement). self successful ifFalse: [self free: copy. ^ self primitiveFail]. ptr := objectMemory firstIndexableField: oop. self mem: ptr cp: copy y: size. "copy saved memory back into newly allocated Bitmap" self free: copy. "free the temp space" objectMemory pushRemappableOop: oop.
+ result := objectMemory instantiateClass: self classArray indexableSize: 2. - result := objectMemory instantiateClass: objectMemory classArray indexableSize: 2. objectMemory storePointer: 0 ofObject: result withValue: (objectMemory popRemappableOop). objectMemory storePointer: 1 ofObject: result withValue: (objectMemory popRemappableOop). ^ result
!
Item was changed: ----- Method: ContextInterpreter>>isFloatObject: (in category 'plugin primitive support') ----- isFloatObject: oop + ^(objectMemory fetchClassOf: oop) == self classFloat! - ^(objectMemory fetchClassOf: oop) == objectMemory classFloat!
Item was changed: ----- Method: ContextInterpreter>>memoryHeaderState: (in category 'primitive support') ----- memoryHeaderState: dataSize "Answer current interpreter and object memory state information."
| splObjsOop oopStart headerSize results hash displayExtent |
"see ContextInterpreter>>writeImageFileIO:"
"self putLong: (self imageFormatVersion) toFile: f. self putLong: headerSize toFile: f. self putLong: imageBytes toFile: f. self putLong: (objectMemory startOfMemory) toFile: f. self putLong: objectMemory getSpecialObjectsOop toFile: f. self putLong: objectMemory getLastHash toFile: f. self putLong: (self ioScreenSize) toFile: f. self putLong: fullScreenFlag toFile: f. self putLong: extraVMMemory toFile: f. 1 to: 7 do: [:i | self putLong: 0 toFile: f]." "fill remaining header words with zeros"
headerSize := 16 * objectMemory bytesPerWord. "header size in bytes; do not change!!" oopStart := objectMemory startOfMemory. splObjsOop := objectMemory getSpecialObjectsOop. hash := objectMemory integerObjectOf: objectMemory getLastHash. "self ioScreenSize." "fullScreenFlag" "extraVMMemory" "Pad the rest of the header." "7 timesRepeat: [self putLong: 0 toFile: file]."
InterpreterProxy pushRemappableOop: (objectMemory + instantiateClass: (self classArray) - instantiateClass: (objectMemory classArray) indexableSize: 16). "results array" displayExtent := self displayExtent: self ioScreenSize. "may trigger GC" results := interpreterProxy popRemappableOop. objectMemory storePointer: 0 ofObject: results withValue: (objectMemory integerObjectOf: self imageFormatVersion). objectMemory storePointer: 1 ofObject: results withValue: (objectMemory integerObjectOf: headerSize). objectMemory storePointer: 2 ofObject: results withValue: (self positive64BitIntegerFor: dataSize). objectMemory storePointer: 3 ofObject: results withValue: (objectMemory integerObjectOf: oopStart). objectMemory storePointer: 4 ofObject: results withValue: (objectMemory integerObjectOf: splObjsOop). objectMemory storePointer: 5 ofObject: results withValue: (objectMemory integerObjectOf: hash). objectMemory storePointer: 6 ofObject: results withValue: displayExtent. objectMemory storePointer: 7 ofObject: results withValue: (objectMemory integerObjectOf: fullScreenFlag).. objectMemory storePointer: 8 ofObject: results withValue: (objectMemory integerObjectOf: extraVMMemory).. objectMemory storePointer: 9 ofObject: results withValue: (objectMemory integerObjectOf: 0). objectMemory storePointer: 10 ofObject: results withValue: (objectMemory integerObjectOf: 0). objectMemory storePointer: 11 ofObject: results withValue: (objectMemory integerObjectOf: 0). objectMemory storePointer: 12 ofObject: results withValue: (objectMemory integerObjectOf: 0). objectMemory storePointer: 13 ofObject: results withValue: (objectMemory integerObjectOf: 0). objectMemory storePointer: 14 ofObject: results withValue: (objectMemory integerObjectOf: 0). objectMemory storePointer: 15 ofObject: results withValue: (objectMemory integerObjectOf: 0). ^ results.!
Item was changed: ----- Method: ContextInterpreter>>memoryImageCopyAsBitmap (in category 'primitive support') ----- memoryImageCopyAsBitmap "Answer a snapshot copy of the current object memory. Answer a Bitmap organized in 32 bit words suitable for interpretation as an ObjectMemory."
+ ^ self memoryImageCopyAs: self classBitmap bytesPerElement: 4 - ^ self memoryImageCopyAs: objectMemory classBitmap bytesPerElement: 4 !
Item was changed: ----- Method: ContextInterpreter>>memoryImageCopyAsBytes (in category 'primitive support') ----- memoryImageCopyAsBytes "Answer a snapshot copy of the current object memory. Answer the raw memory data as a byte array suitable for fast save to disk or write to network."
+ ^ self memoryImageCopyAs: self classByteArray bytesPerElement: 1 - ^ self memoryImageCopyAs: objectMemory classByteArray bytesPerElement: 1 !
Item was changed: ----- Method: ContextInterpreter>>normalizeFloatOrderingInImage (in category 'image save/restore') ----- normalizeFloatOrderingInImage "Float objects were saved in platform word ordering. Reorder them into the traditional object format."
<inline: false> <var: #floatData type: 'unsigned int *'> <var: #val type: 'unsigned int'> self isBigEnder ifFalse: [ | oop | "Swap words within Float objects, taking them out of native platform ordering" oop := objectMemory firstAccessibleObject. [oop = nil] whileFalse: [ | val | (objectMemory isFreeObject: oop) ifFalse: [ + (objectMemory fetchClassOf: oop) = self classFloat - (objectMemory fetchClassOf: oop) = objectMemory classFloat ifTrue: [ | floatData | floatData := self cCoerce: (objectMemory firstIndexableField: oop) to: 'unsigned int *'. val := floatData at: 0. floatData at: 0 put: (floatData at: 1). floatData at: 1 put: val]. oop := objectMemory accessibleObjectAfter: oop]]] !
Item was changed: ----- Method: ContextInterpreter>>primitiveExecuteMethodArgsArray (in category 'control primitives') ----- primitiveExecuteMethodArgsArray "receiver, argsArray, then method are on top of stack. Execute method against receiver and args. Allow for up to two extra arguments (e.g. for mirror primitives). Set primitiveFunctionPointer because no cache lookup has been done for the method, and hence primitiveFunctionPointer is stale." | methodArgument argCnt argumentArray | methodArgument := self stackTop. argumentArray := self stackValue: 1. ((objectMemory isOopCompiledMethod: methodArgument) and: [objectMemory isArray: argumentArray]) ifFalse: [^self primitiveFail]. argCnt := self argumentCountOf: methodArgument. argCnt = (objectMemory fetchWordLengthOf: argumentArray) ifFalse: [^self primitiveFail]. argumentCount > 2 ifTrue: "CompiledMethod class>>receiver:withArguments:executeMethod: SqueakObjectPrimitives class >> receiver:withArguments:apply: VMMirror>>ifFail:object:with:executeMethod: et al" [argumentCount > 4 ifTrue: [^self primitiveFail]. self stackValue: argumentCount put: (self stackValue: 2)]. "replace actual receiver with desired receiver" "and push the actual arguments" self pop: argumentCount. 0 to: argCnt - 1 do: [:i| self push: (objectMemory fetchPointer: i ofObject: argumentArray)]. newMethod := methodArgument. primitiveIndex := self primitiveIndexOf: newMethod. primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: nil. argumentCount := argCnt. "We set the messageSelector for executeMethod below since things like the at cache read messageSelector and so it cannot be left stale." + messageSelector := self nilObject. - messageSelector := objectMemory nilObject. self executeNewMethod. "Recursive xeq affects primFailCode" self initPrimCall!
Item was changed: ----- Method: ContextInterpreter>>primitiveMemorySnapshotBytesWithHeader (in category 'snapshot utility primitives') ----- primitiveMemorySnapshotBytesWithHeader "Primitive. Answer an array with a snapshot copy of the object memory as of the point of entry to this primitive, and with the header information for the image at the point of the snapshot.
The memory snapshot is a ByteArray copy of the object memory, and the header information is an array of the values that would be stored in an image file header if the image was being saved to disk. The header state information along with memory snapshot are sufficient to initialize an an image to be run in an interpreter."
"pop rcvr. A resuming image will see this primitive answering true, otherwise it will answer the expected value of a two element array. Test for result equal to true to determine if the image is being resumed from a saved snapshot.." | result | <export: true> self pop: argumentCount + 1. self push: objectMemory getTrueObj. "resuming image will see this" result := self headerAndSnapshotOfSize: self prepareForSnapshot + class: self classByteArray. - class: objectMemory classByteArray. self pop: 1. "restore stack" self push: result. "normal sender will see this" !
Item was changed: ----- Method: ContextInterpreter>>primitiveMemorySnapshotWithHeader (in category 'snapshot utility primitives') ----- primitiveMemorySnapshotWithHeader "Primitive. Answer an array with a snapshot copy of the object memory as of the point of entry to this primitive, and with the header information for the image at the point of the snapshot.
The memory snapshot is a Bitmap copy of the object memory, and the header information is an array of the values that would be stored in an image file header if the image was being saved to disk. The header state information along with memory snapshot are sufficient to initialize an an image to be run in an interpreter."
"pop rcvr. A resuming image will see this primitive answering true, otherwise it will answer the expected value of a two element array. Test for result equal to true to determine if the image is being resumed from a saved snapshot.." | result | <export: true> self pop: argumentCount + 1. self push: objectMemory getTrueObj. "resuming image will see this" result := self headerAndSnapshotOfSize: self prepareForSnapshot + class: self classBitmap. - class: objectMemory classBitmap. self pop: 1. "restore stack" self push: result. "normal sender will see this" !
Item was changed: ----- Method: ContextInterpreter>>primitiveResume (in category 'process primitives') ----- primitiveResume "Put this process on the scheduler's lists thus allowing it to proceed next time there is a chance for processes of its priority level"
| proc | proc := self stackTop. "rcvr" + "self success: ((self fetchClassOf: proc) = (objectMemory splObj: ClassProcess))." - "self success: ((self fetchClassOf: proc) = (self splObj: ClassProcess))." (self isContext: (objectMemory fetchPointer: SuspendedContextIndex ofObject: proc)) ifFalse: [^self primitiveFail]. self successful ifTrue: [ self resume: proc ].!
Item was changed: ----- Method: ContextInterpreter>>printAllStacks (in category 'debug printing') ----- printAllStacks "Print all the stacks of all running processes, including those that are currently suspended." | oop proc ctx | <export: true> "exported to permit access from plugins" proc := objectMemory fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer. self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5. self cr. self printCallStackOf: activeContext. "first the active context" oop := objectMemory firstObject. [objectMemory oop: oop isLessThan: objectMemory getEndOfMemory] whileTrue:[ + (objectMemory fetchClassOf: oop) == self classSemaphore ifTrue:[ - (objectMemory fetchClassOf: oop) == objectMemory classSemaphore ifTrue:[ self cr. proc := objectMemory fetchPointer: FirstLinkIndex ofObject: oop. + [proc == self nilObject] whileFalse:[ - [proc == objectMemory nilObject] whileFalse:[ self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5. self cr. ctx := objectMemory fetchPointer: SuspendedContextIndex ofObject: proc. ctx == objectMemory nilObject ifFalse:[self printCallStackOf: ctx]. proc := objectMemory fetchPointer: NextLinkIndex ofObject: proc]. ]. oop := objectMemory objectAfter: oop. ].!
Item was changed: ----- Method: ContextInterpreter>>removeProcess:fromList: (in category 'process primitive support') ----- removeProcess: aProcess fromList: aList "Remove a given process from a linked list. May fail if aProcess is not on the list." | firstLink lastLink nextLink tempLink | firstLink := objectMemory fetchPointer: FirstLinkIndex ofObject: aList. lastLink := objectMemory fetchPointer: LastLinkIndex ofObject: aList. aProcess == firstLink ifTrue:[ nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: aProcess . objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: nextLink. aProcess == lastLink ifTrue:[ + objectMemory storePointer: LastLinkIndex ofObject: aList withValue: self nilObject. - objectMemory storePointer: LastLinkIndex ofObject: aList withValue: objectMemory nilObject. ]. ] ifFalse:[ tempLink := firstLink. + [tempLink == self nilObject ifTrue:[^self success: false]. "fail" - [tempLink == objectMemory nilObject ifTrue:[^self success: false]. "fail" nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: tempLink. nextLink == aProcess] whileFalse:[ tempLink := objectMemory fetchPointer: NextLinkIndex ofObject: tempLink. ]. nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: aProcess. objectMemory storePointer: NextLinkIndex ofObject: tempLink withValue: nextLink. aProcess == lastLink ifTrue:[ objectMemory storePointer: LastLinkIndex ofObject: aList withValue: tempLink. ]. ]. + objectMemory storePointer: NextLinkIndex ofObject: aProcess withValue: self nilObject. - objectMemory storePointer: NextLinkIndex ofObject: aProcess withValue: objectMemory nilObject. !
Item was changed: ----- Method: ContextInterpreter>>saveProcessSignalingLowSpace (in category 'process primitive support') ----- saveProcessSignalingLowSpace "The low space semaphore is about to be signaled. Save the currently active process in the special objects array so that the low space handler will be able to determine the process that first triggered a low space condition. The low space handler (in the image) is expected to nil out the special objects array slot when it handles the low space condition."
| lastSavedProcess sched currentProc | lastSavedProcess := objectMemory splObj: ProcessSignalingLowSpace. + (lastSavedProcess == self nilObject) ifTrue: - (lastSavedProcess == objectMemory nilObject) ifTrue: [sched := self schedulerPointer. currentProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched. objectMemory storePointer: ProcessSignalingLowSpace ofObject: objectMemory getSpecialObjectsOop withValue: currentProc]!
Item was changed: ----- Method: ContextInterpreter>>signalExternalSemaphores (in category 'process primitive support') ----- signalExternalSemaphores "Signal all requested semaphores" | xArray xSize index sema | semaphoresUseBufferA := semaphoresUseBufferA not. + xArray := objectMemory splObj: ExternalObjectsArray. - xArray := self splObj: ExternalObjectsArray. xSize := self stSizeOf: xArray. semaphoresUseBufferA ifTrue: ["use opposite buffer during read" 1 to: semaphoresToSignalCountB do: [:i | index := semaphoresToSignalB at: i. index <= xSize ifTrue: [sema := self fetchPointer: index - 1 ofObject: xArray. "Note: semaphore indices are 1-based" (self fetchClassOf: sema) = (self splObj: ClassSemaphore) ifTrue: [self synchronousSignal: sema]]]. semaphoresToSignalCountB := 0] ifFalse: [1 to: semaphoresToSignalCountA do: [:i | index := semaphoresToSignalA at: i. index <= xSize ifTrue: [sema := self fetchPointer: index - 1 ofObject: xArray. "Note: semaphore indices are 1-based" (self fetchClassOf: sema) = (self splObj: ClassSemaphore) ifTrue: [self synchronousSignal: sema]]]. semaphoresToSignalCountA := 0]!
Item was changed: ----- Method: ContextInterpreter>>signed32BitIntegerFor: (in category 'primitive support') ----- signed32BitIntegerFor: integerValue "Return a full 32 bit integer object for the given integer value" | newLargeInteger value largeClass | <inline: false> <var: #integerValue type: 'int'> (objectMemory isIntegerValue: integerValue) ifTrue: [^ objectMemory integerObjectOf: integerValue]. integerValue < 0 + ifTrue:[ largeClass := self classLargeNegativeInteger. - ifTrue:[ largeClass := objectMemory classLargeNegativeInteger. value := 0 - integerValue] + ifFalse:[ largeClass := self classLargePositiveInteger. - ifFalse:[ largeClass := objectMemory classLargePositiveInteger. value := integerValue]. newLargeInteger := objectMemory instantiateClass: largeClass indexableSize: 4. objectMemory storeByte: 3 ofObject: newLargeInteger withValue: ((value >> 24) bitAnd: 16rFF). objectMemory storeByte: 2 ofObject: newLargeInteger withValue: ((value >> 16) bitAnd: 16rFF). objectMemory storeByte: 1 ofObject: newLargeInteger withValue: ((value >> 8) bitAnd: 16rFF). objectMemory storeByte: 0 ofObject: newLargeInteger withValue: (value bitAnd: 16rFF). ^ newLargeInteger!
Item was changed: ----- Method: ContextInterpreter>>signed64BitIntegerFor: (in category 'primitive support') ----- signed64BitIntegerFor: integerValue "Return a Large Integer object for the given integer value" | newLargeInteger magnitude largeClass intValue highWord sz | <inline: false> <var: 'integerValue' type: 'sqLong'> <var: 'magnitude' type: 'unsigned sqLong'> <var: 'highWord' type: 'usqInt'>
integerValue < 0 + ifTrue:[ largeClass := self classLargeNegativeInteger. - ifTrue:[ largeClass := objectMemory classLargeNegativeInteger. magnitude := 0 - integerValue] + ifFalse:[ largeClass := self classLargePositiveInteger. - ifFalse:[ largeClass := objectMemory classLargePositiveInteger. magnitude := integerValue].
magnitude <= 16r7FFFFFFF ifTrue:[^self signed32BitIntegerFor: integerValue].
highWord := self cCode: 'magnitude >> 32' "shift is coerced to usqInt otherwise" inSmalltalk: [magnitude bitShift: -32]. highWord = 0 ifTrue:[sz := 4] ifFalse:[ sz := 5. (highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1]. (highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1]. (highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1]. ]. newLargeInteger := objectMemory instantiateClass: largeClass indexableSize: sz. 0 to: sz-1 do: [:i | intValue := self cCode: '(magnitude >> (i * 8)) & 255' inSmalltalk: [(magnitude bitShift: (i * 8) negated) bitAnd: 16rFF]. objectMemory storeByte: i ofObject: newLargeInteger withValue: intValue]. ^ newLargeInteger!
Item was changed: ----- Method: FilePlugin>>initialiseModule (in category 'initialize-release') ----- initialiseModule <export: true> sCCPfn := interpreterProxy ioLoadFunction: 'secCanCreatePathOfSize' From: 'SecurityPlugin'. sCDPfn := interpreterProxy ioLoadFunction: 'secCanDeletePathOfSize' From: 'SecurityPlugin'. sCGFTfn := interpreterProxy ioLoadFunction: 'secCanGetFileTypeOfSize' From: 'SecurityPlugin'. sCLPfn := interpreterProxy ioLoadFunction: 'secCanListPathOfSize' From: 'SecurityPlugin'. sCSFTfn := interpreterProxy ioLoadFunction: 'secCanSetFileTypeOfSize' From: 'SecurityPlugin'. sDFAfn := interpreterProxy ioLoadFunction: 'secDisableFileAccess' From: 'SecurityPlugin'. sCDFfn := interpreterProxy ioLoadFunction: 'secCanDeleteFileOfSize' From: 'SecurityPlugin'. sCOFfn := interpreterProxy ioLoadFunction: 'secCanOpenFileOfSizeWritable' From: 'SecurityPlugin'. sCRFfn := interpreterProxy ioLoadFunction: 'secCanRenameFileOfSize' From: 'SecurityPlugin'. sHFAfn := interpreterProxy ioLoadFunction: 'secHasFileAccess' From: 'SecurityPlugin'. + ^self sqFileInit.! - ^self cCode: [self sqFileInit] inSmalltalk: [true]!
Item was changed: ----- Method: FilePlugin>>primitiveFileRead (in category 'file primitives') ----- primitiveFileRead <export: true> "self cppIf: SPURVM" self isDefined: 'SPURVM' + inSmalltalk: [ false ] "TODO: will be true for Spur object memory format" - inSmalltalk: [ self primitiveFileReadWithoutPinning ] comment: 'use primitiveFileReadWithPinning for SPUR' ifTrue: [self primitiveFileReadWithPinning] ifFalse: [self primitiveFileReadWithoutPinning]!
Item was changed: FilePlugin subclass: #FilePluginSimulator + instanceVariableNames: 'openFiles states maxOpenFiles' - instanceVariableNames: 'openFiles states' classVariableNames: '' poolDictionaries: '' category: 'VMMaker-InterpreterSimulation'!
!FilePluginSimulator commentStamp: 'tpr 5/5/2003 12:02' prior: 0! File plugin simulation for the VM simulator!
Item was changed: + ----- Method: FilePluginSimulator>>addressOf: (in category 'translation support') ----- + addressOf: anObject + <doNotGenerate> + "Translates into &anObject in C." + ^anObject! - ----- Method: FilePluginSimulator>>addressOf: (in category 'simulation') ----- - addressOf: aCVariableOrDataStructure - "Implemented in support code for primitiveStdioHandles" - ^0!
Item was added: + ----- Method: FilePluginSimulator>>addressOf:put: (in category 'translation support') ----- + addressOf: anObject put: aBlock + <doNotGenerate> + "Simulate a C pointer. Translates into &anObject in C. Provides something + that evaluates aBlock with the new value in response to at:put:" + | thing firstIndex things | + thing := anObject. + ^CPluggableAccessor new + setObject: nil; + atBlock: [:obj :idx| thing] + atPutBlock: + [:obj :idx :val| + "Handle the common case of a single assignment as gracefully as possible" + (firstIndex isNil or: [firstIndex = idx]) + ifTrue: [firstIndex := idx. thing := val] + ifFalse: "handle the rare case of multiple writes through the pointer, a multi-byte assignment from memcpy:_:_: et al" + [self assert: (#(#'memcpy:_:_:' #'memmove:_:_:' #'strncpy:_:_:') includes: thisContext sender sender selector). + things ifNil: [things := OrderedCollection with: thing]. + self assert: things size + firstIndex = idx. + things addLast: val. + thing := (self objectMemory endianness == #little + ifTrue: [things] + ifFalse: [things reverse]) inject: 0 into: [:word :byte| (word bitShift: 8) + byte]]. + aBlock value: thing]!
Item was changed: ----- Method: FilePluginSimulator>>close (in category 'initialize-release') ----- + close + "close any files that ST may have opened" + openFiles do: + [:f | + [f close] + on: Error + do: [:ex| + ex messageText ~= 'primClose: failed' ifTrue: + [ex pass]]]! - close "close any files that ST may have opened" - openFiles do: [:f | f close]!
Item was removed: - ----- Method: FilePluginSimulator>>createDirectory: (in category 'simulation') ----- - createDirectory: aString - ^[FileDirectory default primCreateDirectory: aString. - true] - on: Error - do: [:ex| false] - !
Item was added: + ----- Method: FilePluginSimulator>>dir_Create:_: (in category 'simulation') ----- + dir_Create: dirNameIndex _: dirNameSize + ^[FileDirectory default + primCreateDirectory: (interpreterProxy interpreter + asString: dirNameIndex + size: dirNameSize). + true] + on: Error + do: [:ex| false]!
Item was added: + ----- Method: FilePluginSimulator>>dir_EntryLookup:_:_:_:_:_:_:_:_:_:_:_: (in category 'simulation') ----- + dir_EntryLookup: pathString _: pathStringLength _: entryNameString _: entryNameStringLength _: name _: nameLength _: creationDate _: modificationDate _: isDirectory _: sizeIfFile _: posixPermissions _: isSymlink + "sqInt dir_EntryLookup(char *pathString, sqInt pathStringLength, char *nameString, sqInt nameStringLength, + /* outputs: */ char *name, sqInt *nameLength, sqInt *creationDate, sqInt *modificationDate, + sqInt *isDirectory, squeakFileOffsetType *sizeIfFile, sqInt *posixPermissions, sqInt *isSymlink)" + | result pathName entryName | + pathName := ((0 to: pathStringLength - 1) collect: [:i| (pathString at: i) asCharacter]) as: ByteString. + entryName := ((0 to: entryNameStringLength - 1) collect: [:i| (entryNameString at: i) asCharacter]) as: ByteString. + result := self primLookupEntryIn: pathName name: entryName. + result ifNil: [^DirNoMoreEntries]. + result isInteger ifTrue: + [result > 1 ifTrue: + [interpreterProxy primitiveFailFor: result]. + ^DirBadPath]. + name replaceFrom: 1 to: result first size with: result first startingAt: 1. + nameLength at: 0 put: result first size. + creationDate at: 0 put: (result at: 2). + modificationDate at: 0 put: (result at: 3). + isDirectory at: 0 put: (result at: 4). + sizeIfFile at: 0 put: (result at: 5). + posixPermissions at: 0 put: (result at: 6 ifAbsent: [(result at: 4) ifTrue: [8r755] ifFalse: [8r644]]). + isSymlink at: 0 put: (result at: 7 ifAbsent: [false]). + ^DirEntryFound!
Item was added: + ----- Method: FilePluginSimulator>>dir_Lookup:_:_:_:_:_:_:_:_:_:_: (in category 'simulation') ----- + dir_Lookup: pathString _: pathStringLength _: index _: name _: nameLength _: creationDate _: modificationDate _: isDirectory _: sizeIfFile _: posixPermissions _: isSymlink + "sqInt dir_Lookup( char *pathString, sqInt pathStringLength, sqInt index, + /* outputs: */ char *name, sqInt *nameLength, sqInt *creationDate, sqInt *modificationDate, + sqInt *isDirectory, squeakFileOffsetType *sizeIfFile, sqInt * posixPermissions, sqInt *isSymlink)" + | result pathName | + pathName := ((0 to: pathStringLength - 1) collect: [:i| (pathString at: i) asCharacter]) as: ByteString. + result := self primLookupEntryIn: pathName index: index. + result ifNil: [^DirNoMoreEntries]. + result isInteger ifTrue: + [result > 1 ifTrue: + [interpreterProxy primitiveFailFor: result]. + ^DirBadPath]. + name replaceFrom: 1 to: result first size with: result first startingAt: 1. + nameLength at: 0 put: result first size. + creationDate at: 0 put: (result at: 2). + modificationDate at: 0 put: (result at: 3). + isDirectory at: 0 put: (result at: 4). + sizeIfFile at: 0 put: (result at: 5). + posixPermissions at: 0 put: (result at: 6 ifAbsent: [(result at: 4) ifTrue: [8r755] ifFalse: [8r644]]). + isSymlink at: 0 put: (result at: 7 ifAbsent: [false]). + ^DirEntryFound!
Item was changed: ----- Method: FilePluginSimulator>>fileOpenName:size:write:secure: (in category 'file primitives') ----- fileOpenName: nameIndex size: nameSize write: writeFlag secure: secureFlag "Open the named file, possibly checking security. Answer the file oop." | path f index | + openFiles size >= maxOpenFiles ifTrue: + [^interpreterProxy primitiveFailFor: PrimErrLimitExceeded]. + path := interpreterProxy asString: nameIndex size: nameSize. + (writeFlag + or: [StandardFileStream isAFileNamed: path]) ifFalse: + [^interpreterProxy primitiveFail]. + f := StandardFileStream new open: path forWrite: writeFlag. - path := interpreterProxy interpreter asString: nameIndex size: nameSize. - f := writeFlag - ifTrue: [FileStream fileNamed: path] - ifFalse: - [(StandardFileStream isAFileNamed: path) ifTrue: - [FileStream readOnlyFileNamed: path]]. f ifNil: [^interpreterProxy primitiveFail]. f binary. + self assert: f isReadOnly = writeFlag not. + index := (3 to: openFiles size + 1) detect: [:n| (openFiles includesKey: n) not]. - index := openFiles size + 1. openFiles at: index put: f. ^interpreterProxy integerObjectOf: index!
Item was added: + ----- Method: FilePluginSimulator>>fileOpenNewName:size:secure: (in category 'file primitives') ----- + fileOpenNewName: nameIndex size: nameSize secure: secureFlag + "Open the new named file, possibly checking security. Answer the file oop." + | path f index | + openFiles size >= maxOpenFiles ifTrue: + [^interpreterProxy primitiveFailFor: PrimErrLimitExceeded]. + path := (interpreterProxy interpreter asByteArray: nameIndex size: nameSize) utf8Decoded. + "the #defaultAction for FileExistsException creates a dialog, + so it is caught and resignaled as a generic Error" + [f := StandardFileStream newFileNamed: path] + on: FileExistsException + do: [:error | ^ interpreterProxy primitiveFailFor: PrimErrInappropriate]. + f ifNil: [^interpreterProxy primitiveFail]. + self deny: f isReadOnly. + f binary. + index := (3 to: openFiles size + 1) detect: [:n| (openFiles includesKey: n) not]. + openFiles at: index put: f. + ^interpreterProxy integerObjectOf: index!
Item was changed: ----- Method: FilePluginSimulator>>fileValueOf: (in category 'simulation') ----- fileValueOf: objectPointer | index file | index := (interpreterProxy isIntegerObject: objectPointer) ifTrue: [interpreterProxy integerValueOf: objectPointer] ifFalse: [((interpreterProxy isBytes: objectPointer) and: [(interpreterProxy byteSizeOf: objectPointer) = (self sizeof: #SQFile)]) ifFalse: [interpreterProxy primitiveFail. ^nil]. interpreterProxy longAt: objectPointer + interpreterProxy baseHeaderSize]. + file := openFiles at: index ifAbsent: [ interpreterProxy primitiveFail. ^ nil ]. - file := openFiles at: index. "this attempts to preserve file positions across snapshots when debugging the VM requires saving an image in full flight and pushing it over the cliff time after time..." (file closed and: [states includesKey: file]) ifTrue: [[:pos :isBinary| file reopen; position: pos. isBinary ifTrue: [file binary]] valueWithArguments: (states at: file)]. ^file!
Item was removed: - ----- Method: FilePluginSimulator>>initialiseModule (in category 'initialize-release') ----- - initialiseModule - "See FilePluginSimulator>>sqFileStdioHandlesInto:" - (openFiles := Dictionary new) - at: 0 put: (FakeStdinStream for: interpreterProxy interpreter); "stdin" - at: 1 put: Transcript; "stdout" - at: 2 put: Transcript. "stderr" - states := IdentityDictionary new. - ^super initialiseModule!
Item was changed: + ----- Method: FilePluginSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize: (in category 'file primitives') ----- + makeDirEntryName: entryName size: entryNameSize createDate: createDate modDate: modifiedDate isDir: dirFlag fileSize: fileSize + "In oscog this is done with a <doNotGenerated> directive>" - ----- Method: FilePluginSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize: (in category 'simulation') ----- - makeDirEntryName: entryName size: entryNameSize - createDate: createDate modDate: modifiedDate - isDir: dirFlag fileSize: fileSize
+ ^ interpreterProxy makeDirEntryName: entryName size: entryNameSize createDate: createDate modDate: modifiedDate isDir: dirFlag fileSize: fileSize - ^interpreterProxy - makeDirEntryName: entryName size: entryNameSize - createDate: createDate modDate: modifiedDate - isDir: dirFlag fileSize: fileSize !
Item was added: + ----- Method: FilePluginSimulator>>primLookupEntryIn:index: (in category 'simulation') ----- + primLookupEntryIn: fullPath index: index + "Look up the index-th entry of the directory with the given fully-qualified path (i.e., starting from the root of the file hierarchy) and return an array containing: + + <name> <creationTime> <modificationTime> <dirFlag> <fileSize> + + The empty string enumerates the top-level files or drives. (For example, on Unix, the empty path enumerates the contents of '/'. On Macs and PCs, it enumerates the mounted volumes/drives.) + + The creation and modification times are in seconds since the start of the Smalltalk time epoch. DirFlag is true if the entry is a directory. FileSize the file size in bytes or zero for directories. The primitive returns nil when index is past the end of the directory. It fails if the given path is bad." + + <primitive: 'primitiveDirectoryLookup' module: 'FilePlugin' error: ec> + ^ec isInteger + ifTrue: [ec] + ifFalse: + [Smalltalk primitiveErrorTable + indexOf: ec + ifAbsent: [Smalltalk primitiveErrorTable size + 1]]!
Item was added: + ----- Method: FilePluginSimulator>>primLookupEntryIn:name: (in category 'simulation') ----- + primLookupEntryIn: fullPath name: fName + "Look up <fName> (a simple file name) in the directory identified by <fullPath> + and return an array containing: + + <fName> <creationTime> <modificationTime> <dirFlag> <fileSize> + + On Unix, the empty path denotes '/'. + On Macs and PCs, it is the container of the system volumes.) + + The creation and modification times are in seconds since the start of the Smalltalk time epoch. DirFlag is true if the entry is a directory. FileSize the file size in bytes or zero for directories. The primitive returns nil when index is past the end of the directory. It fails if the given path is bad." + + <primitive: 'primitiveDirectoryEntry' module: 'FilePlugin' error: ec> + ^ec isInteger + ifTrue: [ec] + ifFalse: + [Smalltalk primitiveErrorTable + indexOf: ec + ifAbsent: [Smalltalk primitiveErrorTable size + 1]]!
Item was removed: - ----- Method: FilePluginSimulator>>primitiveDirectoryEntry (in category 'simulation') ----- - primitiveDirectoryEntry - ^interpreterProxy interpreter primitiveDirectoryEntry!
Item was removed: - ----- Method: FilePluginSimulator>>primitiveDirectoryLookup (in category 'simulation') ----- - primitiveDirectoryLookup - ^interpreterProxy interpreter primitiveDirectoryLookup!
Item was added: + ----- Method: FilePluginSimulator>>primitiveFileGetPosition (in category 'file primitives') ----- + primitiveFileGetPosition + super primitiveFileGetPosition. + interpreterProxy failed ifTrue: + [self halt]!
Item was removed: - ----- Method: FilePluginSimulator>>primitiveFileRename (in category 'simulation') ----- - primitiveFileRename - ^interpreterProxy primitiveFileRename!
Item was changed: ----- Method: FilePluginSimulator>>sizeof: (in category 'simulation') ----- + sizeof: memoryThing + + #SQFile = memoryThing + ifTrue: [ ^interpreterProxy bytesPerWord * 5]. + + #squeakFileOffsetType = memoryThing + ifTrue: [ "Value can be known only at compile time. With large file support + enabled, it probably will be 64 bits, so use that value here" + ^ 8 ]. + self halt: 'sizeOf: ', memoryThing asString.! - sizeof: objectSymbolOrClass - "In the simulator file handles are just integer indices into openFiles and so need only be BytesPerWord big." - ^objectSymbolOrClass == #SQFile - ifTrue: [self bytesPerWord] - ifFalse: [super sizeof: objectSymbolOrClass]!
Item was changed: ----- Method: FilePluginSimulator>>sqFile:Read:Into:At: (in category 'simulation') ----- + sqFile: file Read: count Into: byteArrayIndexArg At: startIndex + | byteArrayIndex | + (file isKindOf: FakeStdinStream) ifTrue: + [^file sqFile: file Read: count Into: byteArrayIndexArg At: startIndex]. + byteArrayIndex := byteArrayIndexArg asInteger. "Coerces CArray et al correctly" - sqFile: file Read: count Into: byteArrayIndex At: startIndex - | interpreter | - interpreter := interpreterProxy interpreter. [[startIndex to: startIndex + count - 1 do: [ :i | + interpreterProxy byteAt: byteArrayIndex + i put: (file next ifNil: [^i - startIndex] ifNotNil: [:charOrByte| charOrByte asInteger])]] - file atEnd ifTrue: - [(file isKindOf: FakeStdinStream) ifTrue: [file atEnd: false]. - ^i - startIndex]. - interpreter - byteAt: byteArrayIndex + i - put: file next asInteger]] on: Error do: [:ex| + (file isStream and: [file isTranscriptStream]) ifFalse: + [ex pass]. - (file isKindOf: TranscriptStream) ifFalse: [ex pass]. ^0]] ensure: [self recordStateOf: file]. ^count!
Item was changed: ----- Method: FilePluginSimulator>>sqFile:Write:From:At: (in category 'simulation') ----- + sqFile: file Write: count From: byteArrayIndexArg At: startIndex + | byteArrayIndex | + byteArrayIndex := byteArrayIndexArg asInteger. "Coerces CArray et al correctly" - sqFile: file Write: count From: byteArrayIndex At: startIndex - | interpreter | - interpreter := interpreterProxy interpreter. file isBinary ifTrue: [startIndex to: startIndex + count - 1 do: + [ :i | file nextPut: (interpreterProxy byteAt: byteArrayIndex + i)]] - [ :i | file nextPut: (interpreter byteAt: byteArrayIndex + i)]] ifFalse: [startIndex to: startIndex + count - 1 do: [ :i | | byte | + byte := interpreterProxy byteAt: byteArrayIndex + i. - byte := interpreter byteAt: byteArrayIndex + i. file nextPut: (Character value: (byte == 12 "lf" ifTrue: [15"cr"] ifFalse: [byte]))]]. self recordStateOf: file. ^count!
Item was changed: ----- Method: FilePluginSimulator>>sqFileClose: (in category 'simulation') ----- sqFileClose: file + | index | + index := openFiles keyAtValue: file. + openFiles removeKey: index. + states removeKey: file ifAbsent: []. + file close! - file close. - self recordStateOf: file!
Item was changed: ----- Method: FilePluginSimulator>>sqFileDeleteName:Size: (in category 'simulation') ----- sqFileDeleteName: nameIndex Size: nameSize | path | + path := (interpreterProxy asString: nameIndex size: nameSize) "asByteArray utf8Decoded". - path := interpreterProxy interpreter asString: nameIndex size: nameSize. (StandardFileStream isAFileNamed: path) ifFalse: [^interpreterProxy primitiveFail]. + (InitializationOptions at: #haltOnFileDelete ifAbsent: [true]) + ifTrue: [self halt: 'Deleting ', (path contractTo: 64)] + ifFalse: [interpreterProxy transcript cr; show: 'Deleting ', (path contractTo: 64); cr]. [FileDirectory deleteFilePath: path] on: Error do: [:ex| interpreterProxy primitiveFail]!
Item was added: + ----- Method: FilePluginSimulator>>sqFileDescriptorType: (in category 'simulation') ----- + sqFileDescriptorType: fd + "Allow to test if the standard input/output files are from a console or not + Return values: + -1 - Error + 0 - no console (windows only) + 1 - normal terminal (unix terminal / windows console) + 2 - pipe + 3 - file + 4 - cygwin terminal (windows only)" + ^fd < 0 + ifTrue: [-1] + ifFalse: + [fd <= 2 "i.e. stdio,stdout,stderr" + ifTrue: [1] + ifFalse: [3]]!
Item was added: + ----- Method: FilePluginSimulator>>sqFileInit (in category 'initialize-release') ----- + sqFileInit + "See FilePluginSimulator>>sqFileStdioHandlesInto:" + (openFiles := Dictionary new) + at: 0 put: (FakeStdinStream for: interpreterProxy interpreter); "stdin" + at: 1 put: interpreterProxy interpreter transcript; "stdout" + at: 2 put: interpreterProxy interpreter transcript. "stderr" + states := IdentityDictionary new. + maxOpenFiles := VMClass initializationOptions at: #MaxFileDescriptors ifAbsent: [1024]. + ^true!
Item was added: + ----- Method: FilePluginSimulator>>sqFileShutdown (in category 'initialize-release') ----- + sqFileShutdown + self close. + ^true!
Item was added: + ----- Method: Interpreter>>characterTable (in category 'plugin support') ----- + characterTable + <api> + ^objectMemory splObj: CharacterTable!
Item was added: + ----- Method: Interpreter>>classAlien (in category 'plugin support') ----- + classAlien + ^objectMemory splObj: ClassAlien!
Item was added: + ----- Method: Interpreter>>classArray (in category 'plugin support') ----- + classArray + ^objectMemory splObj: ClassArray!
Item was added: + ----- Method: Interpreter>>classBitmap (in category 'plugin support') ----- + classBitmap + ^objectMemory splObj: ClassBitmap!
Item was added: + ----- Method: Interpreter>>classByteArray (in category 'plugin support') ----- + classByteArray + ^objectMemory splObj: ClassByteArray!
Item was added: + ----- Method: Interpreter>>classCharacter (in category 'plugin support') ----- + classCharacter + ^objectMemory splObj: ClassCharacter!
Item was added: + ----- Method: Interpreter>>classExternalAddress (in category 'plugin support') ----- + classExternalAddress + ^objectMemory splObj: ClassExternalAddress!
Item was added: + ----- Method: Interpreter>>classExternalData (in category 'plugin support') ----- + classExternalData + ^objectMemory splObj: ClassExternalData!
Item was added: + ----- Method: Interpreter>>classExternalFunction (in category 'plugin support') ----- + classExternalFunction + ^objectMemory splObj: ClassExternalFunction!
Item was added: + ----- Method: Interpreter>>classExternalLibrary (in category 'plugin support') ----- + classExternalLibrary + ^objectMemory splObj: ClassExternalLibrary!
Item was added: + ----- Method: Interpreter>>classExternalStructure (in category 'plugin support') ----- + classExternalStructure + ^objectMemory splObj: ClassExternalStructure!
Item was added: + ----- Method: Interpreter>>classFloat (in category 'plugin support') ----- + classFloat + ^objectMemory splObj: ClassFloat!
Item was added: + ----- Method: Interpreter>>classLargeNegativeInteger (in category 'plugin support') ----- + classLargeNegativeInteger + ^objectMemory splObj: ClassLargeNegativeInteger!
Item was added: + ----- Method: Interpreter>>classLargePositiveInteger (in category 'plugin support') ----- + classLargePositiveInteger + ^objectMemory splObj: ClassLargePositiveInteger!
Item was added: + ----- Method: Interpreter>>classMutex (in category 'plugin support') ----- + classMutex + "Used by StackInterpreter>>printAllStacks, but see initializeSpecialObjectsArray + for initialization of CassMutex. Slot 39 in the array is presently used for class + PseudoContext, which is obsolete but may be needed for running older images." + + self flag: #FIXME. "ClassMutex is not initialized." + ^objectMemory splObj: ClassMutex!
Item was added: + ----- Method: Interpreter>>classPoint (in category 'plugin support') ----- + classPoint + ^objectMemory splObj: ClassPoint!
Item was added: + ----- Method: Interpreter>>classSemaphore (in category 'plugin support') ----- + classSemaphore + ^objectMemory splObj: ClassSemaphore!
Item was added: + ----- Method: Interpreter>>classSmallInteger (in category 'plugin support') ----- + classSmallInteger + ^objectMemory splObj: ClassInteger!
Item was added: + ----- Method: Interpreter>>classString (in category 'plugin support') ----- + classString + ^objectMemory splObj: ClassString!
Item was added: + ----- Method: Interpreter>>classUnsafeAlien (in category 'plugin support') ----- + classUnsafeAlien + ^objectMemory splObj: ClassUnsafeAlien!
Item was added: + ----- Method: Interpreter>>displayObject (in category 'plugin support') ----- + displayObject + ^objectMemory splObj: TheDisplay!
Item was added: + ----- Method: Interpreter>>falseObject (in category 'plugin support') ----- + falseObject + ^objectMemory falseObj!
Item was added: + ----- Method: Interpreter>>nilObject (in category 'plugin support') ----- + nilObject + ^objectMemory nilObj!
Item was added: + ----- Method: Interpreter>>trueObject (in category 'plugin support') ----- + trueObject + ^objectMemory trueObj!
Item was changed: ----- Method: InterpreterPrimitives>>addLastLink:toList: (in category 'process primitive support') ----- addLastLink: proc toList: aList "Add the given process to the end of the given linked list and set the backpointer of process to its new list." | lastLink | + self assert: (objectMemory fetchPointer: NextLinkIndex ofObject: proc) = self nilObject. - self assert: (objectMemory fetchPointer: NextLinkIndex ofObject: proc) = objectMemory nilObject. (self isEmptyList: aList) ifTrue: [objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: proc] ifFalse: [lastLink := objectMemory fetchPointer: LastLinkIndex ofObject: aList. self assert: lastLink ~= proc. objectMemory storePointer: NextLinkIndex ofObject: lastLink withValue: proc]. objectMemory storePointer: LastLinkIndex ofObject: aList withValue: proc. objectMemory storePointer: MyListIndex ofObject: proc withValue: aList!
Item was changed: ----- Method: InterpreterPrimitives>>primitiveEnterCriticalSection (in category 'process primitives') ----- primitiveEnterCriticalSection "Attempt to enter a CriticalSection/Mutex. If not owned, set the owner to the current process and answer false. If owned by the current process answer true. Otherwise suspend the process. Answer if the receiver is owned by the current process. For simulation if there is an argument it is taken to be the effective activeProcess (see Process>>effectiveProcess)." | criticalSection owningProcessIndex owningProcess activeProc | argumentCount > 0 ifTrue: [criticalSection := self stackValue: 1. "rcvr" activeProc := self stackTop] ifFalse: [criticalSection := self stackTop. "rcvr" activeProc := self activeProcess]. owningProcessIndex := ExcessSignalsIndex. "CriticalSections are laid out like Semaphores" owningProcess := objectMemory fetchPointer: owningProcessIndex ofObject: criticalSection. owningProcess = objectMemory nilObject ifTrue: [objectMemory storePointer: owningProcessIndex ofObject: criticalSection withValue: activeProc. + ^self pop: argumentCount + 1 thenPush: self falseObject]. - ^self pop: argumentCount + 1 thenPush: objectMemory falseObject]. owningProcess = activeProc ifTrue: + [^self pop: argumentCount + 1 thenPush: self trueObject]. - [^self pop: argumentCount + 1 thenPush: objectMemory trueObject]. "Arrange to answer false (unowned) when the process is resumed." self pop: argumentCount + 1 thenPush: objectMemory falseObject. self addLastLink: activeProc toList: criticalSection. self transferTo: self wakeHighestPriority!
Item was changed: ----- Method: InterpreterPrimitives>>primitiveExitCriticalSection (in category 'process primitives') ----- primitiveExitCriticalSection "Exit the critical section. This may change the active process as a result." | criticalSection owningProcessIndex owningProcess | criticalSection := self stackTop. "rcvr" owningProcessIndex := ExcessSignalsIndex. "CriticalSections are laid out like Semaphores" (self isEmptyList: criticalSection) ifTrue: [objectMemory storePointerUnchecked: owningProcessIndex ofObject: criticalSection + withValue: self nilObject] - withValue: objectMemory nilObject] ifFalse: [owningProcess := self removeFirstLinkOfList: criticalSection. "store check unnecessary because criticalSection referred to owningProcess via its FirstLinkIndex slot before owningProcess was removed." objectMemory storePointerUnchecked: owningProcessIndex ofObject: criticalSection withValue: owningProcess. "Note that resume: isn't fair; it won't suspend the active process. For fairness we must do the equivalent of a primitiveYield, but that may break old code, so we stick with unfair resume:." self resume: owningProcess preemptedYieldingIf: preemptionYields]!
Item was changed: ----- Method: InterpreterPrimitives>>primitiveInterpreterSourceVersion (in category 'other primitives') ----- primitiveInterpreterSourceVersion "Answer a string corresponding to the version of the interpreter source. This represents the version level of the Smalltalk source code (interpreter and various plugins) that is translated to C by a CCodeGenerator, as distinct from the external platform source code, typically written in C and managed separately for each platform. This is a named (not numbered) primitive in the null module (ie the VM)" | len versionString p cString | <export: true> <var: #p type: 'char *'> <var: #cString type: 'char *'> cString := InterpreterSourceVersion. len := self cCode: 'strlen(cString)' inSmalltalk: [0]. + versionString := objectMemory instantiateClass: self classString indexableSize: len. - versionString := objectMemory instantiateClass: objectMemory classString indexableSize: len. p := self arrayValueOf: versionString. self cCode: 'strncpy(p, cString, len)'. self pop: 1 thenPush: versionString !
Item was changed: ----- Method: InterpreterPrimitives>>primitiveIsBigEnder (in category 'other primitives') ----- primitiveIsBigEnder "Answer true if running on a big endian machine." <export: true> self isBigEnder + ifTrue: [self pop: 1 thenPush: self trueObject] + ifFalse: [self pop: 1 thenPush: self falseObject] - ifTrue: [self pop: 1 thenPush: objectMemory trueObject] - ifFalse: [self pop: 1 thenPush: objectMemory falseObject] !
Item was changed: ----- Method: InterpreterPrimitives>>primitiveListBuiltinModule (in category 'plugin primitives') ----- primitiveListBuiltinModule "Primitive. Return the n-th builtin module name." | moduleName index length nameOop | <var: #moduleName type: 'char *'> self methodArgumentCount = 1 ifFalse:[^self primitiveFail]. index := self stackIntegerValue: 0. index <= 0 ifTrue:[^self primitiveFail]. moduleName := self ioListBuiltinModule: index. moduleName == nil ifTrue:[ self pop: 2. "arg+rcvr" + ^self push: self nilObject]. - ^self push: objectMemory nilObject]. length := self strlen: moduleName. + nameOop := objectMemory instantiateClass: self classString indexableSize: length. - nameOop := objectMemory instantiateClass: objectMemory classString indexableSize: length. 0 to: length-1 do:[:i| objectMemory storeByte: i ofObject: nameOop withValue: (moduleName at: i)]. self forceInterruptCheck. self pop: 2 thenPush: nameOop!
Item was changed: ----- Method: InterpreterPrimitives>>primitiveListExternalModule (in category 'plugin primitives') ----- primitiveListExternalModule "Primitive. Return the n-th loaded external module name." | moduleName index length nameOop | <var: #moduleName type: 'char *'> self methodArgumentCount = 1 ifFalse:[^self primitiveFail]. index := self stackIntegerValue: 0. index <= 0 ifTrue:[^self primitiveFail]. moduleName := self ioListLoadedModule: index. moduleName == nil ifTrue:[ self pop: 2. "arg+rcvr" + ^self push: self nilObject]. - ^self push: objectMemory nilObject]. length := self strlen: moduleName. + nameOop := objectMemory instantiateClass: self classString indexableSize: length. - nameOop := objectMemory instantiateClass: objectMemory classString indexableSize: length. 0 to: length-1 do:[:i| objectMemory storeByte: i ofObject: nameOop withValue: (moduleName at: i)]. self forceInterruptCheck. self pop: 2 thenPush: nameOop!
Item was changed: ----- Method: InterpreterPrimitives>>primitivePlatformSourceVersion (in category 'other primitives') ----- primitivePlatformSourceVersion "Answer a string corresponding to the version of the external platform source code, typically written in C and managed separately for each platform. This is a named (not numbered) primitive in the null module (ie the VM)" | len versionString p | <export: true> <var: #p type: 'char *'> self isDefined: 'PLATFORM_SOURCE_VERSION' inSmalltalk: [versionString := ''] comment: 'version level of platform support code' ifTrue: [len := self cCode: 'strlen(PLATFORM_SOURCE_VERSION)' inSmalltalk: [0]. + versionString := objectMemory instantiateClass: self classString indexableSize: len. - versionString := objectMemory instantiateClass: objectMemory classString indexableSize: len. p := self arrayValueOf: versionString. self cCode: 'strncpy(p, PLATFORM_SOURCE_VERSION, len)'] ifFalse: [^self primitiveFail]. self pop: 1 thenPush: versionString!
Item was changed: ----- Method: InterpreterPrimitives>>primitiveRootTable (in category 'memory space primitives') ----- primitiveRootTable "Primitive. Answer a copy (snapshot) element of the root table. The primitive can cause GC itself and if so the return value may be inaccurate - in this case one should guard the read operation by looking at the gc counter statistics." | oop sz | <export: true> sz := objectMemory getRootTableCount. + oop := objectMemory instantiateClass: self classArray indexableSize: sz. "can cause GC" - oop := objectMemory instantiateClass: objectMemory classArray indexableSize: sz. "can cause GC" sz > objectMemory getRootTableCount ifTrue:[sz := objectMemory getRootTableCount]. 1 to: sz do:[:i| objectMemory storePointer: i-1 ofObject: oop withValue: (objectMemory rootTableAt: i). ]. self pop: argumentCount + 1. self push: oop.!
Item was changed: ----- Method: InterpreterPrimitives>>primitiveScanCharacters (in category 'I/O primitives') ----- primitiveScanCharacters "The character scanner primitive." | kernDelta stops sourceString scanStopIndex scanStartIndex rcvr scanDestX scanLastIndex scanXTable scanMap maxGlyph ascii stopReason glyphIndex sourceX sourceX2 nextDestX scanRightX nilOop |
self methodArgumentCount = 6 ifFalse: [^ self primitiveFail].
"Load the arguments" kernDelta := self stackIntegerValue: 0. stops := self stackObjectValue: 1. (objectMemory isArray: stops) ifFalse: [^ self primitiveFail]. (objectMemory slotSizeOf: stops) >= 258 ifFalse: [^ self primitiveFail]. scanRightX := self stackIntegerValue: 2. sourceString := self stackObjectValue: 3. (objectMemory isBytes: sourceString) ifFalse: [^ self primitiveFail]. scanStopIndex := self stackIntegerValue: 4. scanStartIndex := self stackIntegerValue: 5. (scanStartIndex > 0 and: [scanStopIndex > 0 and: [scanStopIndex <= (objectMemory byteSizeOf: sourceString)]]) ifFalse: [^ self primitiveFail].
"Load receiver and required instVars" rcvr := self stackObjectValue: 6. ((objectMemory isPointers: rcvr) and: [(objectMemory slotSizeOf: rcvr) >= 4]) ifFalse: [^ self primitiveFail]. scanDestX := self fetchInteger: 0 ofObject: rcvr. scanLastIndex := self fetchInteger: 1 ofObject: rcvr. scanXTable := objectMemory fetchPointer: 2 ofObject: rcvr. scanMap := objectMemory fetchPointer: 3 ofObject: rcvr. ((objectMemory isArray: scanXTable) and: [objectMemory isArray: scanMap]) ifFalse: [^ self primitiveFail]. (objectMemory slotSizeOf: scanMap) = 256 ifFalse: [^ self primitiveFail]. self successful ifFalse: [^ nil]. maxGlyph := (objectMemory slotSizeOf: scanXTable) - 2.
"Okay, here we go. We have eliminated nearly all failure conditions, to optimize the inner fetches." scanLastIndex := scanStartIndex. + nilOop := self nilObject. - nilOop := objectMemory nilObject. [scanLastIndex <= scanStopIndex] whileTrue: [ "Known to be okay since scanStartIndex > 0 and scanStopIndex <= sourceString size" ascii := objectMemory fetchByte: scanLastIndex - 1 ofObject: sourceString. "Known to be okay since stops size >= 258" (stopReason := objectMemory fetchPointer: ascii ofObject: stops) = nilOop ifFalse: ["Store everything back and get out of here since some stop conditionn needs to be checked" (objectMemory isIntegerValue: scanDestX) ifFalse: [^ self primitiveFail]. self storeInteger: 0 ofObject: rcvr withValue: scanDestX. self storeInteger: 1 ofObject: rcvr withValue: scanLastIndex. self pop: 7. "args+rcvr" ^ self push: stopReason]. "Known to be okay since scanMap size = 256" glyphIndex := self fetchInteger: ascii ofObject: scanMap. "fail if the glyphIndex is out of range" (self failed or: [glyphIndex < 0 or: [glyphIndex > maxGlyph]]) ifTrue: [^ self primitiveFail]. sourceX := self fetchInteger: glyphIndex ofObject: scanXTable. sourceX2 := self fetchInteger: glyphIndex + 1 ofObject: scanXTable. "Above may fail if non-integer entries in scanXTable" self failed ifTrue: [^ nil]. nextDestX := scanDestX + sourceX2 - sourceX. nextDestX > scanRightX ifTrue: ["Store everything back and get out of here since we got to the right edge" (objectMemory isIntegerValue: scanDestX) ifFalse: [^ self primitiveFail]. self storeInteger: 0 ofObject: rcvr withValue: scanDestX. self storeInteger: 1 ofObject: rcvr withValue: scanLastIndex. self pop: 7. "args+rcvr" ^ self push: (objectMemory fetchPointer: CrossedX - 1 ofObject: stops)]. scanDestX := nextDestX + kernDelta. scanLastIndex := scanLastIndex + 1]. (objectMemory isIntegerValue: scanDestX) ifFalse: [^ self primitiveFail]. self storeInteger: 0 ofObject: rcvr withValue: scanDestX. self storeInteger: 1 ofObject: rcvr withValue: scanStopIndex. self pop: 7. "args+rcvr" ^ self push: (objectMemory fetchPointer: EndOfRun - 1 ofObject: stops)!
Item was changed: ----- Method: InterpreterPrimitives>>primitiveTestAndSetOwnershipOfCriticalSection (in category 'process primitives') ----- primitiveTestAndSetOwnershipOfCriticalSection "Attempt to test-and-set the ownership of the critical section. If not owned, set the owner to the current process and answer false. If owned by the current process answer true. If owned by some other process answer nil. For simulation if there is an argument it is taken to be the effective activeProcess (see Process>>effectiveProcess)." | criticalSection owningProcessIndex owningProcess activeProc | argumentCount > 0 ifTrue: [criticalSection := self stackValue: 1. "rcvr" activeProc := self stackTop] ifFalse: [criticalSection := self stackTop. "rcvr" activeProc := self activeProcess]. owningProcessIndex := ExcessSignalsIndex. "CriticalSections are laid out like Semaphores" owningProcess := objectMemory fetchPointer: owningProcessIndex ofObject: criticalSection. + owningProcess = self nilObject ifTrue: - owningProcess = objectMemory nilObject ifTrue: [objectMemory storePointer: owningProcessIndex ofObject: criticalSection withValue: activeProc. + ^self pop: argumentCount + 1 thenPush: self falseObject]. - ^self pop: argumentCount + 1 thenPush: objectMemory falseObject]. owningProcess = activeProc ifTrue: + [^self pop: argumentCount + 1 thenPush: self trueObject]. - [^self pop: argumentCount + 1 thenPush: objectMemory trueObject]. self pop: argumentCount + 1 thenPush: objectMemory nilObject!
Item was changed: ----- Method: InterpreterPrimitives>>primitiveUtcWithOffset (in category 'system control primitives') ----- primitiveUtcWithOffset "Answer an array with UTC microseconds since the Posix epoch and the current seconds offset from GMT in the local time zone. An empty two element array (or any object with two or more slots) may be supplied as a parameter. This is a named (not numbered) primitive in the null module (ie the VM)" | clock offset resultArray |
<export: true> <var: #clock type: 'sqLong'> <var: #offset type: 'int'> argumentCount > 1 ifTrue: [^self primitiveFailFor: PrimErrBadNumArgs]. (self cCode: 'ioUtcWithOffset(&clock, &offset)' inSmalltalk: [-1]) = -1 ifTrue: [^ self primitiveFail]. objectMemory pushRemappableOop: (self positive64BitIntegerFor: clock). argumentCount > 0 ifTrue: [resultArray := self popStack. ((objectMemory isPointers: resultArray) and: [(objectMemory lengthOf: resultArray) >= 2]) ifFalse: [^self primitiveFailFor: PrimErrBadArgument]] + ifFalse: [resultArray := objectMemory instantiateClass: self classArray indexableSize: 2]. - ifFalse: [resultArray := objectMemory instantiateClass: objectMemory classArray indexableSize: 2]. objectMemory storePointer: 0 ofObject: resultArray withValue: objectMemory popRemappableOop. objectMemory storePointerUnchecked: 1 ofObject: resultArray withValue: (objectMemory integerObjectOf: offset). self pop: 1 thenPush: resultArray !
Item was changed: ----- Method: InterpreterPrimitives>>primitiveVMVersion (in category 'other primitives') ----- primitiveVMVersion "Answer a string corresponding to the version of virtual machine. This represents the version level of the Smalltalk source code (interpreter and various plugins) that is translated to C by a CCodeGenerator, in addition to the external platform source code, typically written in C and managed separately for each platform. By convention, this is a string composed of the interpreter source version and the platform source version, e.g. '4.0.2-2172'. This is a named (not numbered) primitive in the null module (ie the VM)" | len versionString p | <export: true> <var: #p type: 'char *'> self isDefined: 'VM_VERSION' inSmalltalk: [versionString := ''] comment: 'version level of interpreter plus platform support code' ifTrue: [len := self cCode: 'strlen(VM_VERSION)' inSmalltalk: [0]. + versionString := objectMemory instantiateClass: self classString indexableSize: len. - versionString := objectMemory instantiateClass: objectMemory classString indexableSize: len. p := self arrayValueOf: versionString. self cCode: 'strncpy(p, VM_VERSION, len)'] ifFalse: [^self primitiveFail]. self pop: 1 thenPush: versionString !
Item was changed: ----- Method: InterpreterPrimitives>>signed32BitValueOf: (in category 'primitive support') ----- signed32BitValueOf: oop "Convert the given object into an integer value. The object may be either a positive ST integer or a four-byte LargeInteger." | value largeClass negative | <inline: false> <returnTypeC: 'int'> <var: 'value' type: 'int'> (objectMemory isIntegerObject: oop) ifTrue: [^objectMemory integerValueOf: oop]. (objectMemory lengthOf: oop) > 4 ifTrue: [^ self primitiveFail]. largeClass := objectMemory fetchClassOf: oop. + largeClass = self classLargePositiveInteger - largeClass = objectMemory classLargePositiveInteger ifTrue:[negative := false] + ifFalse:[largeClass = self classLargeNegativeInteger - ifFalse:[largeClass = objectMemory classLargeNegativeInteger ifTrue:[negative := true] ifFalse:[^self primitiveFail]]. (objectMemory lengthOf: oop) ~= 4 ifTrue: [^ self primitiveFail]. value := (objectMemory fetchByte: 0 ofObject: oop) + ((objectMemory fetchByte: 1 ofObject: oop) << 8) + ((objectMemory fetchByte: 2 ofObject: oop) << 16) + ((objectMemory fetchByte: 3 ofObject: oop) << 24). "Fail if value exceeds range of a 32-bit twos-complement signed integer." negative ifTrue:["perform subtraction using unsigned int to prevent undefined result for optimizing C compilers in the case of value = 16r80000000" value := 0 - (self cCoerce: value to: 'unsigned int'). value >= 0 ifTrue: [^ self primitiveFail]] ifFalse:[value < 0 ifTrue:[^ self primitiveFail]]. ^ value!
Item was changed: ----- Method: InterpreterPrimitives>>signed64BitValueOf: (in category 'primitive support') ----- signed64BitValueOf: oop "Convert the given object into an integer value. The object may be either a positive ST integer or a eight-byte LargeInteger." | sz value largeClass negative szsqLong | <inline: false> <returnTypeC: 'sqLong'> <var: 'value' type: 'sqLong'> (objectMemory isIntegerObject: oop) ifTrue: [^self cCoerce: (objectMemory integerValueOf: oop) to: 'sqLong']. sz := objectMemory lengthOf: oop. sz > 8 ifTrue: [^ self primitiveFail]. largeClass := objectMemory fetchClassOf: oop. + largeClass = self classLargePositiveInteger - largeClass = objectMemory classLargePositiveInteger ifTrue:[negative := false] + ifFalse:[largeClass = self classLargeNegativeInteger - ifFalse:[largeClass = objectMemory classLargeNegativeInteger ifTrue:[negative := true] ifFalse:[^self primitiveFail]]. szsqLong := self cCode: 'sizeof(sqLong)' inSmalltalk: [8]. sz > szsqLong ifTrue: [^ self primitiveFail]. value := 0. 0 to: sz - 1 do: [:i | value := value + ((self cCoerce: (objectMemory fetchByte: i ofObject: oop) to: 'sqLong') << (i*8))]. "Fail if value exceeds range of a 64-bit twos-complement signed integer." negative ifTrue:["perform subtraction using unsigned usqLong to prevent undefined result for optimizing C compilers in the case of value = 16r8000000000000000" value := 0 - (self cCoerce: value to: 'usqLong'). value >= 0 ifTrue: [^ self primitiveFail]] ifFalse:[value < 0 ifTrue:[^ self primitiveFail]]. ^ value!
Item was changed: ContextInterpreter subclass: #InterpreterSimulator + instanceVariableNames: 'bytesPerWord byteCount sendCount traceOn myBitBlt displayForm filesOpen imageName pluginList mappedPluginEntries inputSem quitBlock transcript displayView logging startMicroseconds' - instanceVariableNames: 'bytesPerWord byteCount sendCount traceOn myBitBlt displayForm filesOpen imageName pluginList mappedPluginEntries inputSem quitBlock transcript displayView logging' classVariableNames: '' poolDictionaries: 'VMObjectIndices VMSqueakV3ObjectRepresentationConstants' category: 'VMMaker-InterpreterSimulation'!
!InterpreterSimulator commentStamp: 'dtl 5/5/2011 19:42' prior: 0! This class defines basic memory access and primitive simulation so that the Interpreter 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
(InterpreterSimulator 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. You will probably have more luck using InterpreterSimulatorLSB or InterpreterSimulatorMSB as befits your machine.!
Item was changed: ----- Method: InterpreterSimulator class>>new (in category 'instance creation') ----- new + self objectMemoryClass initialize. + ^ self on: self objectMemoryClass new - | objectMemory | - objectMemory := self == InterpreterSimulator - ifTrue: [SmalltalkImage current endianness == #big - ifTrue: [ObjectMemorySimulatorMSB basicNew] - ifFalse: [ObjectMemorySimulatorLSB basicNew]]. - ^ self on: objectMemory !
Item was added: + ----- Method: InterpreterSimulator class>>objectMemoryClass (in category 'instance creation') ----- + objectMemoryClass + "Default type of object memory to use with this type of interpreter" + ^ObjectMemorySimulator + + !
Item was added: + ----- Method: InterpreterSimulator>>asByteArray:size: (in category 'plugin interpreter proxy') ----- + asByteArray: aCArray size: size + "aCArray represents a C array of char, e.g. first indexable field of a String object containing a file path" + ^ ((0 to: size) collect: [ :i | aCArray at: i]) asByteArray + !
Item was added: + ----- Method: InterpreterSimulator>>asString:size: (in category 'plugin interpreter proxy') ----- + asString: aCArray size: size + "aCArray represents a C array of char, e.g. first indexable field of a String object containing a file path" + ^(self asByteArray: aCArray size: size) asString + !
Item was added: + ----- Method: InterpreterSimulator>>byteAt: (in category 'plugin interpreter proxy') ----- + byteAt: byteAddress + ^ objectMemory byteAt: byteAddress + !
Item was added: + ----- Method: InterpreterSimulator>>byteAt:put: (in category 'plugin interpreter proxy') ----- + byteAt: byteAddress put: byte + ^ objectMemory byteAt: byteAddress put: byte + !
Item was added: + ----- Method: InterpreterSimulator>>byteSizeOf: (in category 'plugin interpreter proxy') ----- + byteSizeOf: oop + ^ objectMemory byteSizeOf: oop + !
Item was removed: - ----- Method: InterpreterSimulator>>bytesPerWord (in category 'memory access') ----- - bytesPerWord - ^bytesPerWord!
Item was changed: + ----- Method: InterpreterSimulator>>cCoerce:to: (in category 'plugin interpreter proxy') ----- - ----- Method: InterpreterSimulator>>cCoerce:to: (in category 'memory access') ----- cCoerce: value to: cTypeString "Type coercion for translation only; just return the value when running in Smalltalk."
^value == nil ifTrue: [value] ifFalse: [value coerceTo: cTypeString sim: self]!
Item was added: + ----- Method: InterpreterSimulator>>fetchClassOf: (in category 'plugin interpreter proxy') ----- + fetchClassOf: oop + + ^ objectMemory fetchClassOf: oop + !
Item was added: + ----- Method: InterpreterSimulator>>firstIndexableField: (in category 'plugin interpreter proxy') ----- + firstIndexableField: oop + ^ objectMemory firstIndexableField: oop!
Item was changed: ----- Method: InterpreterSimulator>>initialize (in category 'initialization') ----- initialize
"Initialize the InterpreterSimulator 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."
"copy of bytesPerWord to avoid extra indirection that may affect performance" bytesPerWord := objectMemory bytesPerWord.
"initialize class variables" ObjectMemory initializeConstants. ContextInterpreter initialize.
"Note: we must initialize ConstMinusOne differently for simulation, due to the fact that the simulator works only with +ve 32-bit values" ConstMinusOne := objectMemory integerObjectOf: -1.
methodCache := Array new: MethodCacheSize. atCache := Array new: AtCacheTotalSize. self flushMethodCache. objectMemory setRootTable: (Array new: ObjectMemory rootTableSize). objectMemory setWeakRoots: (Array new: ObjectMemory rootTableSize + ObjectMemory remapBufferSize + 100). objectMemory setRemapBuffer: (Array new: ObjectMemory remapBufferSize). semaphoresUseBufferA := true. semaphoresToSignalA := Array new: SemaphoresToSignalSize. semaphoresToSignalB := Array new: SemaphoresToSignalSize. externalPrimitiveTable := CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize). primitiveTable := self class primitiveTable. pluginList := #(). mappedPluginEntries := #().
"initialize InterpreterSimulator variables used for debugging" byteCount := 0. sendCount := 0. quitBlock := [^ self]. traceOn := true. myBitBlt := BitBltSimulator new setInterpreter: self. filesOpen := OrderedCollection new. objectMemory setHeaderTypeBytes: (CArrayAccessor on: (Array with: bytesPerWord * 2 with: bytesPerWord with: 0 with: 0)). transcript := Transcript. objectMemory transcript: Transcript. displayForm := 'Display has not yet been installed' asDisplayText form. + startMicroseconds := Time totalSeconds * 1000000. + !
Item was added: + ----- Method: InterpreterSimulator>>instantiateClass:indexableSize: (in category 'plugin interpreter proxy') ----- + instantiateClass: classPointer indexableSize: size + ^ objectMemory instantiateClass: classPointer indexableSize: size + !
Item was added: + ----- Method: InterpreterSimulator>>integerObjectOf: (in category 'plugin interpreter proxy') ----- + integerObjectOf: value + ^ objectMemory integerObjectOf: value!
Item was added: + ----- Method: InterpreterSimulator>>integerValueOf: (in category 'plugin interpreter proxy') ----- + integerValueOf: objectPointer + ^ objectMemory integerValueOf: objectPointer!
Item was added: + ----- Method: InterpreterSimulator>>ioUTCMicroseconds (in category 'I/O primitives support') ----- + ioUTCMicroseconds + "Return the value of the microsecond clock." + "NOT. Actually, we want something a lot slower and, for exact debugging, + something more repeatable than real time. Dan had an idea: use the byteCount..." + + ^byteCount + startMicroseconds + + "At 20k bytecodes per second, this gives us aobut 200 ticks per second, or about 1/5 of what you'd expect for the real time clock. This should still service events at one or two per second"!
Item was added: + ----- Method: InterpreterSimulator>>isBytes: (in category 'plugin interpreter proxy') ----- + isBytes: oop + ^ objectMemory isBytes: oop + !
Item was added: + ----- Method: InterpreterSimulator>>isPointers: (in category 'plugin interpreter proxy') ----- + isPointers: oop + ^ objectMemory isPointers: oop + !
Item was added: + ----- Method: InterpreterSimulator>>isWords: (in category 'plugin interpreter proxy') ----- + isWords: oop + ^ objectMemory isWords: oop + !
Item was added: + ----- Method: InterpreterSimulator>>isWordsOrBytes: (in category 'plugin interpreter proxy') ----- + isWordsOrBytes: oop + ^ objectMemory isWordsOrBytes: oop + !
Item was added: + ----- Method: InterpreterSimulator>>longAt:put: (in category 'plugin interpreter proxy') ----- + longAt: byteAddress put: a32BitValue + ^ objectMemory longAt: byteAddress put: a32BitValue + !
Item was changed: ----- Method: InterpreterSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize: (in category 'file primitives') ----- makeDirEntryName: entryName size: entryNameSize createDate: createDate modDate: modifiedDate isDir: dirFlag fileSize: fileSize
| modDateOop createDateOop nameString results | <var: 'entryName' type: 'char *'>
"allocate storage for results, remapping newly allocated oops in case GC happens during allocation" self pushRemappableOop: + (self instantiateClass: (objectMemory splObj: ClassArray) indexableSize: 5). - (self instantiateClass: (self splObj: ClassArray) indexableSize: 5). self pushRemappableOop: + (self instantiateClass: (objectMemory splObj: ClassByteString) indexableSize: entryNameSize). - (self instantiateClass: (self splObj: ClassByteString) indexableSize: entryNameSize). self pushRemappableOop: (self positive32BitIntegerFor: createDate). self pushRemappableOop: (self positive32BitIntegerFor: modifiedDate).
modDateOop := self popRemappableOop. createDateOop := self popRemappableOop. nameString := self popRemappableOop. results := self popRemappableOop.
1 to: entryNameSize do: [ :i | + objectMemory storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue. - self storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue. ].
+ objectMemory storePointer: 0 ofObject: results withValue: nameString. + objectMemory storePointer: 1 ofObject: results withValue: createDateOop. + objectMemory storePointer: 2 ofObject: results withValue: modDateOop. - self storePointer: 0 ofObject: results withValue: nameString. - self storePointer: 1 ofObject: results withValue: createDateOop. - self storePointer: 2 ofObject: results withValue: modDateOop. dirFlag + ifTrue: [ objectMemory storePointer: 3 ofObject: results withValue: self trueObject ] + ifFalse: [ objectMemory storePointer: 3 ofObject: results withValue: self falseObject ]. + objectMemory storePointer: 4 ofObject: results + withValue: (objectMemory integerObjectOf: fileSize). - ifTrue: [ self storePointer: 3 ofObject: results withValue: objectMemory trueObject ] - ifFalse: [ self storePointer: 3 ofObject: results withValue: objectMemory falseObject ]. - self storePointer: 4 ofObject: results - withValue: (self integerObjectOf: fileSize). ^ results !
Item was added: + ----- Method: InterpreterSimulator>>popRemappableOop (in category 'plugin interpreter proxy') ----- + popRemappableOop + ^ objectMemory popRemappableOop + !
Item was changed: ----- Method: InterpreterSimulator>>primitiveDirectoryEntry (in category 'file primitives') ----- primitiveDirectoryEntry | name pathName array result | name := self stringOf: self stackTop. pathName := self stringOf: (self stackValue: 1). self successful ifFalse: [^self primitiveFail].
array := FileDirectory default primLookupEntryIn: pathName name: name. array == nil ifTrue: + [self pop: 3 thenPush: self nilObject. - [self pop: 3 thenPush: objectMemory nilObj. ^array]. array == #badDirectoryPath ifTrue: [self halt. ^self primitiveFail]. array == #primFailed ifTrue: [self halt. ^self primitiveFail].
result := self makeDirEntryName: (array at: 1) size: (array at: 1) size createDate: (array at: 2) modDate: (array at: 3) isDir: (array at: 4) fileSize: (array at: 5). self pop: 3. self push: result!
Item was added: + ----- Method: InterpreterSimulator>>pushRemappableOop: (in category 'plugin interpreter proxy') ----- + pushRemappableOop: oop + ^ objectMemory pushRemappableOop: oop!
Item was changed: + ----- Method: InterpreterSimulator>>signalSemaphoreWithIndex: (in category 'plugin interpreter proxy') ----- - ----- Method: InterpreterSimulator>>signalSemaphoreWithIndex: (in category 'memory access') ----- signalSemaphoreWithIndex: index "Record the given semaphore index in the double buffer semaphores array to be signaled at the next convenient moment. Force a real interrupt check as soon as possible."
^ index ifNotNil: [super signalSemaphoreWithIndex: index]!
Item was added: + ----- Method: InterpreterSimulator>>slotSizeOf: (in category 'plugin interpreter proxy') ----- + slotSizeOf: oop + ^ objectMemory slotSizeOf: oop + + !
Item was added: + ----- Method: InterpreterSimulator>>transcript (in category 'accessing') ----- + transcript + ^transcript + !
Item was added: + ----- Method: InterpreterSimulatorLSB class>>objectMemoryClass (in category 'instance creation') ----- + objectMemoryClass + "Default type of object memory to use with this type of interpreter" + ^ObjectMemorySimulatorLSB!
Item was added: + ----- Method: InterpreterSimulatorLSB64 class>>objectMemoryClass (in category 'as yet unclassified') ----- + objectMemoryClass + "Default type of object memory to use with this type of interpreter" + ^ObjectMemorySimulatorLSB64!
Item was added: + ----- Method: InterpreterSimulatorMSB class>>objectMemoryClass (in category 'instance creation') ----- + objectMemoryClass + "Default type of object memory to use with this type of interpreter" + ^ObjectMemorySimulatorMSB!
Item was added: + ----- Method: InterpreterSimulatorMSB64 class>>objectMemoryClass (in category 'instance creation') ----- + objectMemoryClass + "Default type of object memory to use with this type of interpreter" + ^ObjectMemorySimulatorMSB64!
Item was changed: ----- Method: ObjectMemory class>>initialize (in category 'initialization') ----- initialize "ObjectMemory initialize"
self initializeConstants. self initializePrimitiveErrorCodes. self initializeCompactClassIndices. self initializePrimitiveErrorCodes. self initializeSmallIntegers. + self initializeSpecialObjectIndices. + self initializeObjectHeaderConstants. !
Item was changed: ----- Method: ObjectMemory class>>initializeSpecialObjectIndices (in category 'initialization') ----- initializeSpecialObjectIndices "Initialize indices into specialObjects array."
NilObject := 0. FalseObject := 1. TrueObject := 2. SchedulerAssociation := 3. ClassBitmap := 4. ClassInteger := 5. + ClassByteString := ClassString := 6. "N.B. Actually class ByteString" - ClassString := 6. ClassArray := 7. "SmalltalkDictionary := 8." "Do not delete!!" ClassFloat := 9. ClassMethodContext := 10. ClassBlockContext := 11. ClassPoint := 12. ClassLargePositiveInteger := 13. TheDisplay := 14. ClassMessage := 15. ClassCompiledMethod := 16. TheLowSpaceSemaphore := 17. ClassSemaphore := 18. ClassCharacter := 19. SelectorDoesNotUnderstand := 20. SelectorCannotReturn := 21. ProcessSignalingLowSpace := 22. "was TheInputSemaphore" SpecialSelectors := 23. CharacterTable := 24. SelectorMustBeBoolean := 25. ClassByteArray := 26. ClassProcess := 27. CompactClasses := 28. TheTimerSemaphore := 29. TheInterruptSemaphore := 30. SelectorCannotInterpret := 34. "Was MethodContextProto := 35." ClassBlockClosure := 36. "Was BlockContextProto := 37." ExternalObjectsArray := 38. ClassPseudoContext := 39. ClassTranslatedMethod := 40. TheFinalizationSemaphore := 41. ClassLargeNegativeInteger := 42.
ClassExternalAddress := 43. ClassExternalStructure := 44. ClassExternalData := 45. ClassExternalFunction := 46. ClassExternalLibrary := 47.
SelectorAboutToReturn := 48. SelectorRunWithIn := 49. SelectorAttemptToAssign := 50.
"PrimErrTableIndex := 51. in Interpreter class>>initializePrimitiveErrorCodes"
ClassAlien := 52. InvokeCallbackSelector := 53. ClassUnsafeAlien := 54.
ClassWeakFinalizer := 55 !
Item was changed: ----- Method: ObjectMemory>>allObjects (in category 'primitive support') ----- allObjects "Attempt to answer an array of all objects, excluding those that may be garbage collected as a side effect of allocating the result array. If no memory is available answer 0." | count obj resultArray newCount | "Count the currently accessible objects" count := 0. obj := self firstAccessibleObject. [obj = nil] whileFalse: [count := count + 1. obj := self accessibleObjectAfter: obj]. "Allocate result array, may cause GC" + resultArray := self instantiateClass: (self splObj: ClassArray) indexableSize: count. - resultArray := self instantiateClass: self classArray indexableSize: count. resultArray = nil ifTrue: [^0]. "Store all objects in result array, excluding any reference to the result array itself, as may happen if garbage collection occurred during allocation of the array. No store check is necessary; the result array will be the last object in memory and hence new." newCount := 0. obj := self firstAccessibleObject. [obj = nil or: [newCount >= count]] whileFalse: [obj == resultArray ifFalse: [newCount := newCount + 1. self stObject: resultArray at: newCount put: obj ]. obj := self accessibleObjectAfter: obj]. "If GC occurred during result array allocation, truncate unused portion of result array" newCount < count ifTrue: [self shorten: resultArray toIndexableSize: newCount]. ^resultArray!
Item was changed: ----- Method: ObjectMemory>>characterObjectOf: (in category 'object access') ----- characterObjectOf: characterCode <api> ^(characterCode between: 0 and: 255) + ifTrue: [self fetchPointer: characterCode ofObject: (self splObj: CharacterTable)] - ifTrue: [self fetchPointer: characterCode ofObject: self characterTable] ifFalse: [nilObj]!
Item was removed: - ----- Method: ObjectMemory>>characterTable (in category 'plugin support') ----- - characterTable - <api> - ^self splObj: CharacterTable!
Item was removed: - ----- Method: ObjectMemory>>classAlien (in category 'plugin support') ----- - classAlien - ^self splObj: ClassAlien!
Item was removed: - ----- Method: ObjectMemory>>classArray (in category 'plugin support') ----- - classArray - ^self splObj: ClassArray!
Item was removed: - ----- Method: ObjectMemory>>classBitmap (in category 'plugin support') ----- - classBitmap - ^self splObj: ClassBitmap!
Item was removed: - ----- Method: ObjectMemory>>classByteArray (in category 'plugin support') ----- - classByteArray - ^self splObj: ClassByteArray!
Item was removed: - ----- Method: ObjectMemory>>classCharacter (in category 'plugin support') ----- - classCharacter - ^self splObj: ClassCharacter!
Item was removed: - ----- Method: ObjectMemory>>classExternalAddress (in category 'plugin support') ----- - classExternalAddress - ^self splObj: ClassExternalAddress!
Item was removed: - ----- Method: ObjectMemory>>classExternalData (in category 'plugin support') ----- - classExternalData - ^self splObj: ClassExternalData!
Item was removed: - ----- Method: ObjectMemory>>classExternalFunction (in category 'plugin support') ----- - classExternalFunction - ^self splObj: ClassExternalFunction!
Item was removed: - ----- Method: ObjectMemory>>classExternalLibrary (in category 'plugin support') ----- - classExternalLibrary - ^self splObj: ClassExternalLibrary!
Item was removed: - ----- Method: ObjectMemory>>classExternalStructure (in category 'plugin support') ----- - classExternalStructure - ^self splObj: ClassExternalStructure!
Item was removed: - ----- Method: ObjectMemory>>classFloat (in category 'plugin support') ----- - classFloat - ^self splObj: ClassFloat!
Item was removed: - ----- Method: ObjectMemory>>classLargeNegativeInteger (in category 'plugin support') ----- - classLargeNegativeInteger - ^self splObj: ClassLargeNegativeInteger!
Item was removed: - ----- Method: ObjectMemory>>classLargePositiveInteger (in category 'plugin support') ----- - classLargePositiveInteger - ^self splObj: ClassLargePositiveInteger!
Item was removed: - ----- Method: ObjectMemory>>classMutex (in category 'plugin support') ----- - classMutex - "Used by StackInterpreter>>printAllStacks, but see initializeSpecialObjectsArray - for initialization of CassMutex. Slot 39 in the array is presently used for class - PseudoContext, which is obsolete but may be needed for running older images." - - self flag: #FIXME. "ClassMutex is not initialized." - ^self splObj: ClassMutex!
Item was removed: - ----- Method: ObjectMemory>>classPoint (in category 'plugin support') ----- - classPoint - ^self splObj: ClassPoint!
Item was removed: - ----- Method: ObjectMemory>>classSemaphore (in category 'plugin support') ----- - classSemaphore - ^self splObj: ClassSemaphore!
Item was removed: - ----- Method: ObjectMemory>>classSmallInteger (in category 'plugin support') ----- - classSmallInteger - ^self splObj: ClassInteger!
Item was removed: - ----- Method: ObjectMemory>>classString (in category 'plugin support') ----- - classString - ^self splObj: ClassString!
Item was removed: - ----- Method: ObjectMemory>>classUnsafeAlien (in category 'plugin support') ----- - classUnsafeAlien - ^self splObj: ClassUnsafeAlien!
Item was removed: - ----- Method: ObjectMemory>>displayObject (in category 'plugin support') ----- - displayObject - ^self splObj: TheDisplay!
Item was added: + ----- Method: ObjectMemory>>falseObj (in category 'plugin support') ----- + falseObj + ^falseObj!
Item was removed: - ----- Method: ObjectMemory>>falseObject (in category 'plugin support') ----- - falseObject - ^falseObj!
Item was added: + ----- Method: ObjectMemory>>nilObj (in category 'plugin support') ----- + nilObj + ^ nilObj!
Item was removed: - ----- Method: ObjectMemory>>nilObject (in category 'interpreter access') ----- - nilObject - "For access from BitBlt module" - ^ nilObj!
Item was added: + ----- Method: ObjectMemory>>trueObj (in category 'plugin support') ----- + trueObj + ^trueObj!
Item was removed: - ----- Method: ObjectMemory>>trueObject (in category 'plugin support') ----- - trueObject - ^trueObj!
Item was changed: ----- Method: StackInterpreter class>>objectMemoryClass (in category 'accessing class hierarchy') ----- objectMemoryClass + "Default type of object memory to use with this type of interpreter" ^NewObjectMemory!
Item was changed: ----- Method: StackInterpreter>>printAllStacks (in category 'debug printing') ----- printAllStacks "Print all the stacks of all running processes, including those that are currently suspended." <api> | oop classObj proc semaphoreClass mutexClass schedLists p processList | <inline: false> proc := self activeProcess. self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5; space; printHex: proc. self print: ' priority '; printNum: (self quickFetchInteger: PriorityIndex ofObject: proc); cr. self printCallStackFP: framePointer. "first the current activation" + semaphoreClass := self classSemaphore. + mutexClass := self classMutex. - semaphoreClass := objectMemory classSemaphore. - mutexClass := objectMemory classMutex. oop := objectMemory firstObject. [self oop: oop isLessThan: objectMemory freeStart] whileTrue: [classObj := objectMemory fetchClassOfNonInt: oop. (classObj = semaphoreClass or: [classObj = mutexClass]) ifTrue: [self printProcsOnList: oop]. oop := objectMemory objectAfter: oop]. schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer. highestRunnableProcessPriority = 0 ifTrue: [p := objectMemory fetchWordLengthOf: schedLists] ifFalse: [p := highestRunnableProcessPriority]. p - 1 to: 0 by: -1 do: [:pri| processList := objectMemory fetchPointer: pri ofObject: schedLists. (self isEmptyList: processList) ifFalse: [self cr; print: 'processes at priority '; printNum: pri + 1. self printProcsOnList: processList]]!
Item was changed: Object subclass: #VMClass instanceVariableNames: '' + classVariableNames: 'InitializationOptions' - classVariableNames: '' poolDictionaries: 'VMBasicConstants' category: 'VMMaker-Support'! VMClass class instanceVariableNames: 'timeStamp'!
!VMClass commentStamp: '<historical>' prior: 0! I am an abstract superclass for all classes in the VM that want to maintain a source timeStamp.! VMClass class instanceVariableNames: 'timeStamp'!
Item was added: + ----- Method: VMClass class>>initializationOptions (in category 'initialization') ----- + initializationOptions + ^InitializationOptions!
Item was added: + ----- Method: VMClass class>>initialize (in category 'initialization') ----- + initialize + InitializationOptions ifNil: [InitializationOptions := Dictionary new]. + !
Item was changed: ----- Method: VMMaker class>>versionString (in category 'version testing') ----- versionString
"VMMaker versionString"
+ ^'4.20.5'! - ^'4.20.4'!
vm-dev@lists.squeakfoundation.org