[Vm-dev] VM Maker: VMMaker.oscog-eem.3151.mcz
commits at source.squeak.org
commits at source.squeak.org
Fri Feb 11 00:36:20 UTC 2022
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.3151.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.3151
Author: eem
Time: 10 February 2022, 4:36:05.908056 pm
UUID: ee3d31a3-ee4b-4205-87cc-be78d1879c79
Ancestors: VMMaker.oscog-eem.3150
Primitive suspend: revert the semantics of #88 to Andreas' revision in the early 2000's. #88 removes a process from a condition variable, allowing subsequently resumed processes to get past their condition variable. This is a bug, but there are images (noably Qwaq/Teleplace/Virtend) which depend on this behaviour. Provide #568 (primitiveSuspendBackingUpV1) which backs up a process waiting on a condition variable to the send that invoked the wait primitive, and which answers that list. Provide #578 (primitiveSuspendBackingUpV2) which backs up a process waiting on a condition variable to the send that invoked the wait primitive, but in which case answers nil. The presence of the three primitives is indicated by bit 5 of the cogVMFeatureFlags.
DeflatePlugin: the update primitives can run on the Smalltalk stack.
Add the FileDialogPlugin from Qwaq/Teleplace/Virtend.
=============== Diff against VMMaker.oscog-eem.3150 ===============
Item was changed:
----- Method: CoInterpreterPrimitives>>primitiveSuspend (in category 'process primitives') -----
primitiveSuspend
+ "Primitive #88. Suspend the receiver, aProcess, such that it can be executed again
- "Primitive. Suspend the receiver, aProcess, such that it can be executed again
by sending #resume. If the given process is not the active process, take it off
+ its corresponding list. The primitive returns the list the receiver was previously on.
+ c.f. primitiveSuspendBackingUpV1,#568 & primitiveSuspendBackingUpV2,#578"
- its corresponding list. If the list was not its run queue assume it was on some
- condition variable (Semaphore, Mutex) and back up its pc to the send that
- invoked the wait state the process entered. Hence when the process resumes
- it will reenter the wait state. Answer the list the receiver was previously on,
- unless it was the activ eProcess, in which case answer nil."
| process myList myContext ok |
process := self stackTop.
process = self activeProcess ifTrue:
[| inInterpreter |
"We're going to switch process, either to an interpreted frame or a machine
code frame. To know whether to return or enter machine code we have to
know from whence we came. We could have come from the interpreter,
either directly or via a machine code primitive. We could have come from
machine code. The instructionPointer tells us where from:"
+ self stackTopPut: objectMemory nilObject.
- self pop: 1 thenPush: objectMemory nilObject.
inInterpreter := instructionPointer >= objectMemory startOfMemory.
self transferTo: self wakeHighestPriority from: CSSuspend.
^self forProcessPrimitiveReturnToExecutivePostContextSwitch: inInterpreter].
myList := objectMemory fetchPointer: MyListIndex ofObject: process.
myContext := objectMemory fetchPointer: SuspendedContextIndex ofObject: process.
- ((objectMemory isPointers: myList)
- and: [(objectMemory numSlotsOf: myList) > LastLinkIndex
- and: [(objectMemory isContext: myContext)
- and: [self isResumableContext: myContext]]]) ifFalse:
- [^self primitiveFailFor: PrimErrBadReceiver].
ok := self removeProcess: process fromList: myList.
ok ifFalse:
[^self primitiveFailFor: PrimErrOperationFailed].
objectMemory storePointerUnchecked: MyListIndex ofObject: process withValue: objectMemory nilObject.
+ self stackTopPut: myList!
- self assert: RevisedSuspend.
- (RevisedSuspend
- and: [(objectMemory fetchClassTagOfNonImm: myList) ~= classLinkedListClassTag]) ifTrue:
- [self backupContext: myContext toBlockingSendTo: myList].
- self pop: 1 thenPush: myList!
Item was added:
+ ----- Method: CoInterpreterPrimitives>>primitiveSuspendBackingUpV1 (in category 'process primitives') -----
+ primitiveSuspendBackingUpV1
+ "Primitive #568. Suspend the receiver, aProcess, such that it can be executed again
+ by sending #resume. If the given process is not the active process, take it off
+ its corresponding list. If the list was not its run queue assume it was on some
+ condition variable (Semaphore, Mutex) and back up its pc to the send that
+ invoked the wait state the process entered. Hence when the process resumes
+ it will reenter the wait state. Answer the list the receiver was previously on,
+ unless it was the activeProcess, in which case answer nil.
+ c.f. primitiveSuspend,#88 & primitiveSuspendBackingUpV2,#578"
+ | process myList myContext ok |
+ process := self stackTop.
+ process = self activeProcess ifTrue:
+ [| inInterpreter |
+ "We're going to switch process, either to an interpreted frame or a machine
+ code frame. To know whether to return or enter machine code we have to
+ know from whence we came. We could have come from the interpreter,
+ either directly or via a machine code primitive. We could have come from
+ machine code. The instructionPointer tells us where from:"
+ self stackTopPut: objectMemory nilObject.
+ inInterpreter := instructionPointer >= objectMemory startOfMemory.
+ self transferTo: self wakeHighestPriority from: CSSuspend.
+ ^self forProcessPrimitiveReturnToExecutivePostContextSwitch: inInterpreter].
+ myList := objectMemory fetchPointer: MyListIndex ofObject: process.
+ myContext := objectMemory fetchPointer: SuspendedContextIndex ofObject: process.
+ ((objectMemory isPointers: myList)
+ and: [(objectMemory numSlotsOf: myList) > LastLinkIndex
+ and: [(objectMemory isContext: myContext)
+ and: [self isResumableContext: myContext]]]) ifFalse:
+ [^self primitiveFailFor: PrimErrBadReceiver].
+ ok := self removeProcess: process fromList: myList.
+ ok ifFalse:
+ [^self primitiveFailFor: PrimErrOperationFailed].
+ objectMemory storePointerUnchecked: MyListIndex ofObject: process withValue: objectMemory nilObject.
+ (objectMemory fetchClassTagOfNonImm: myList) ~= classLinkedListClassTag ifTrue:
+ [self backupContext: myContext toBlockingSendTo: myList].
+ self stackTopPut: myList!
Item was added:
+ ----- Method: CoInterpreterPrimitives>>primitiveSuspendBackingUpV2 (in category 'process primitives') -----
+ primitiveSuspendBackingUpV2
+ "Primitive #578. Suspend the receiver, aProcess, such that it can be executed again
+ by sending #resume. If the given process is not the active process, take it off
+ its corresponding list. If the list was not its run queue assume it was on some
+ condition variable (Semaphore, Mutex) and back up its pc to the send that
+ invoked the wait state the process entered. Hence when the process resumes
+ it will reenter the wait state. Answer the list the receiver was previously on iff
+ it was not active and not blocked, otherwise answer nil.
+ c.f. primitiveSuspend,#88 & primitiveSuspendBackingUpV1,#568,
+ which always answer the list the process was on, even if blocked."
+ <export: true>
+ | process myList myContext ok |
+ process := self stackTop.
+ process = self activeProcess ifTrue:
+ [| inInterpreter |
+ "We're going to switch process, either to an interpreted frame or a machine
+ code frame. To know whether to return or enter machine code we have to
+ know from whence we came. We could have come from the interpreter,
+ either directly or via a machine code primitive. We could have come from
+ machine code. The instructionPointer tells us where from:"
+ self stackTopPut: objectMemory nilObject.
+ inInterpreter := instructionPointer >= objectMemory startOfMemory.
+ self transferTo: self wakeHighestPriority from: CSSuspend.
+ ^self forProcessPrimitiveReturnToExecutivePostContextSwitch: inInterpreter].
+ myList := objectMemory fetchPointer: MyListIndex ofObject: process.
+ myContext := objectMemory fetchPointer: SuspendedContextIndex ofObject: process.
+ ((objectMemory isPointers: myList)
+ and: [(objectMemory numSlotsOf: myList) > LastLinkIndex
+ and: [(objectMemory isContext: myContext)
+ and: [self isResumableContext: myContext]]]) ifFalse:
+ [^self primitiveFailFor: PrimErrBadReceiver].
+ ok := self removeProcess: process fromList: myList.
+ ok ifFalse:
+ [^self primitiveFailFor: PrimErrOperationFailed].
+ objectMemory storePointerUnchecked: MyListIndex ofObject: process withValue: objectMemory nilObject.
+ (objectMemory fetchClassTagOfNonImm: myList) ~= classLinkedListClassTag
+ ifTrue:
+ [self backupContext: myContext toBlockingSendTo: myList.
+ self stackTopPut: objectMemory nilObject]
+ ifFalse:
+ [self stackTopPut: myList]!
Item was removed:
- ----- Method: CoInterpreterPrimitives>>primitiveSuspendV2 (in category 'process primitives') -----
- primitiveSuspendV2
- "Primitive. Suspend the receiver, aProcess, such that it can be executed again
- by sending #resume. If the given process is not the active process, take it off
- its corresponding list. If the list was not its run queue assume it was on some
- condition variable (Semaphore, Mutex) and back up its pc to the send that
- invoked the wait state the process entered. Hence when the process resumes
- it will reenter the wait state. Answer the list the receiver was previously on iff
- it was not active and not blocked, otherwise answer nil.
- c.f. primitiveSuspend, which always answers the list the process was on, if blocked."
- <export: true>
- | process myList myContext ok |
- process := self stackTop.
- process = self activeProcess ifTrue:
- [| inInterpreter |
- "We're going to switch process, either to an interpreted frame or a machine
- code frame. To know whether to return or enter machine code we have to
- know from whence we came. We could have come from the interpreter,
- either directly or via a machine code primitive. We could have come from
- machine code. The instructionPointer tells us where from:"
- self pop: 1 thenPush: objectMemory nilObject.
- inInterpreter := instructionPointer >= objectMemory startOfMemory.
- self transferTo: self wakeHighestPriority from: CSSuspend.
- ^self forProcessPrimitiveReturnToExecutivePostContextSwitch: inInterpreter].
- myList := objectMemory fetchPointer: MyListIndex ofObject: process.
- myContext := objectMemory fetchPointer: SuspendedContextIndex ofObject: process.
- ((objectMemory isPointers: myList)
- and: [(objectMemory numSlotsOf: myList) > LastLinkIndex
- and: [(objectMemory isContext: myContext)
- and: [self isResumableContext: myContext]]]) ifFalse:
- [^self primitiveFailFor: PrimErrBadReceiver].
- ok := self removeProcess: process fromList: myList.
- ok ifFalse:
- [^self primitiveFailFor: PrimErrOperationFailed].
- objectMemory storePointerUnchecked: MyListIndex ofObject: process withValue: objectMemory nilObject.
- self assert: RevisedSuspend.
- (RevisedSuspend
- and: [(objectMemory fetchClassTagOfNonImm: myList) ~= classLinkedListClassTag])
- ifTrue:
- [self backupContext: myContext toBlockingSendTo: myList.
- self pop: 1 thenPush: objectMemory nilObject]
- ifFalse:
- [self pop: 1 thenPush: myList]!
Item was changed:
----- Method: CogVMSimulator class>>initialize (in category 'class initialization') -----
initialize
"These are primitives that alter the state of the stack. They are here simply for assert checking.
After invocation the Cogit should not check for the expected stack delta when these primitives
succeed, because the stack will usually have been modified."
StackAlteringPrimitives := #( primitiveClosureValue primitiveClosureValueWithArgs primitiveClosureValueNoContextSwitch
primitiveClone primitiveInstVarAt primitiveSlotAt "because these can cause code compactions..."
primitiveEnterCriticalSection primitiveExitCriticalSection
primitiveFullClosureValue primitiveFullClosureValueWithArgs primitiveFullClosureValueNoContextSwitch
+ primitiveSignal primitiveWait primitiveResume primitiveYield
+ primitiveSuspend primitiveSuspendBackingUpV1 primitiveSuspendBackingUpV2
- primitiveSignal primitiveWait primitiveResume primitiveSuspend primitiveSuspendV2 primitiveYield
primitiveExecuteMethodArgsArray primitiveExecuteMethod
primitivePerform primitivePerformWithArgs primitivePerformInSuperclass
primitiveTerminateTo primitiveStoreStackp primitiveDoPrimitiveWithArgs) asIdentitySet!
Item was changed:
----- Method: DeflatePlugin>>primitiveDeflateUpdateHashTable (in category 'primitives') -----
primitiveDeflateUpdateHashTable
"Primitive. Update the hash tables after data has been moved by delta."
- | delta table tableSize tablePtr entry |
<export: true>
+ <primitiveMetadata: #(FastCPrimitive FastCPrimitiveAlignForFloatsFlag)> "Using AlignForFloats since the arithmetic is potentially vectorizable..."
+ | delta table tableSize tablePtr entry |
<var: #tablePtr type:'int *'>
- interpreterProxy methodArgumentCount = 2
- ifFalse:[^interpreterProxy primitiveFail].
delta := interpreterProxy stackIntegerValue: 0.
+ table := interpreterProxy stackValue: 1.
- table := interpreterProxy stackObjectValue: 1.
interpreterProxy failed ifTrue:[^nil].
+ (interpreterProxy isWords: table) ifFalse:
+ [^interpreterProxy primitiveFail].
- (interpreterProxy isWords: table)
- ifFalse:[^interpreterProxy primitiveFail].
tableSize := interpreterProxy slotSizeOf: table.
tablePtr := interpreterProxy firstIndexableField: table.
0 to: tableSize-1 do:[:i|
entry := tablePtr at: i.
entry >= delta
ifTrue:[tablePtr at: i put: entry - delta]
ifFalse:[tablePtr at: i put: 0]].
+ interpreterProxy pop: 2 "Leave rcvr on stack"!
- interpreterProxy pop: 2. "Leave rcvr on stack"!
Item was changed:
----- Method: DeflatePlugin>>primitiveUpdateAdler32 (in category 'primitives') -----
primitiveUpdateAdler32
"Primitive. Update a 32bit CRC value."
- | collection stopIndex startIndex length bytePtr s1 adler32 s2 b |
<export: true>
+ <primitiveMetadata: #(FastCPrimitive FastCPrimitiveAlignForFloatsFlag)> "Using AlignForFloats since the arithmetic is potentially vectorizable..."
+ | collection stopIndex startIndex length bytePtr s1 adler32 s2 b |
<var: #adler32 type:'unsigned int '>
<var: #bytePtr type:'unsigned char *'>
+ collection := interpreterProxy stackValue: 0.
- interpreterProxy methodArgumentCount = 4
- ifFalse:[^interpreterProxy primitiveFail].
- collection := interpreterProxy stackObjectValue: 0.
stopIndex := interpreterProxy stackIntegerValue: 1.
startIndex := interpreterProxy stackIntegerValue: 2.
adler32 := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 3).
+ interpreterProxy failed ifTrue: [^nil].
- interpreterProxy failed ifTrue:[^0].
((interpreterProxy isBytes: collection) and:[stopIndex >= startIndex and:[startIndex > 0]])
ifFalse:[^interpreterProxy primitiveFail].
length := interpreterProxy byteSizeOf: collection.
(stopIndex <= length) ifFalse:[^interpreterProxy primitiveFail].
bytePtr := interpreterProxy firstIndexableField: collection.
startIndex := startIndex - 1.
stopIndex := stopIndex - 1.
s1 := adler32 bitAnd: 16rFFFF.
+ s2 := adler32 >> 16 bitAnd: 16rFFFF.
- s2 := (adler32 >> 16) bitAnd: 16rFFFF.
startIndex to: stopIndex do:[:i|
b := bytePtr at: i.
s1 := (s1 + b) \\ 65521.
s2 := (s2 + s1) \\ 65521.
].
adler32 := (s2 bitShift: 16) + s1.
+ interpreterProxy methodReturnValue: (interpreterProxy positive32BitIntegerFor: adler32)!
- interpreterProxy
- pop: 5 "args + rcvr"
- thenPush: (interpreterProxy positive32BitIntegerFor: adler32)!
Item was changed:
----- Method: DeflatePlugin>>primitiveUpdateGZipCrc32 (in category 'primitives') -----
primitiveUpdateGZipCrc32
"Primitive. Update a 32bit CRC value."
- | collection stopIndex startIndex crc length bytePtr |
<export: true>
+ <primitiveMetadata: #(FastCPrimitive FastCPrimitiveAlignForFloatsFlag)> "Using AlignForFloats since the arithmetic is potentially vectorizable..."
+ | collection stopIndex startIndex crc length bytePtr |
<var: #bytePtr type: #'unsigned char *'>
+ collection := interpreterProxy stackValue: 0.
- interpreterProxy methodArgumentCount = 4
- ifFalse:[^interpreterProxy primitiveFail].
- collection := interpreterProxy stackObjectValue: 0.
stopIndex := interpreterProxy stackIntegerValue: 1.
startIndex := interpreterProxy stackIntegerValue: 2.
crc := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 3).
interpreterProxy failed ifTrue: [^self].
((interpreterProxy isBytes: collection) and:[stopIndex >= startIndex and:[startIndex > 0]])
ifFalse:[^interpreterProxy primitiveFail].
length := interpreterProxy byteSizeOf: collection.
(stopIndex <= length) ifFalse:[^interpreterProxy primitiveFail].
bytePtr := interpreterProxy firstIndexableField: collection.
self cCode:'' inSmalltalk:[zipCrcTable := CArrayAccessor on: GZipWriteStream crcTable].
startIndex := startIndex - 1.
stopIndex := stopIndex - 1.
startIndex to: stopIndex do:
[:i|
+ crc := (zipCrcTable at: ((crc bitXor: (bytePtr at: i)) bitAnd: 255)) bitXor: crc >> 8].
+ interpreterProxy methodReturnValue: (interpreterProxy positive32BitIntegerFor: crc)!
- crc := (zipCrcTable at: ((crc bitXor: (bytePtr at: i)) bitAnd: 255)) bitXor: (crc >> 8)].
- interpreterProxy
- pop: 5 "args + rcvr"
- thenPush: (interpreterProxy positive32BitIntegerFor: crc)!
Item was added:
+ InterpreterPlugin subclass: #FileDialogPlugin
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-Plugins'!
+
+ !FileDialogPlugin commentStamp: '<historical>' prior: 0!
+ A plugin supporting various bits and pieces for native file dialogs.!
Item was added:
+ ----- Method: FileDialogPlugin class>>hasHeaderFile (in category 'compiling') -----
+ hasHeaderFile
+ "If there is a single intrinsic header file to be associated with the plugin, here is where you want to flag"
+ ^true!
Item was added:
+ ----- Method: FileDialogPlugin class>>requiresPlatformFiles (in category 'compiling') -----
+ requiresPlatformFiles
+ "default is ok for most, any plugin needing platform specific files must say so"
+ ^true!
Item was added:
+ ----- Method: FileDialogPlugin class>>simulatorClass (in category 'simulation') -----
+ simulatorClass
+ ^FileDialogPluginSimulator!
Item was added:
+ ----- Method: FileDialogPlugin>>initialiseModule (in category 'initialize') -----
+ initialiseModule
+ <export: true>
+ ^self fileDialogInitialize "inSmalltalk: true"!
Item was added:
+ ----- Method: FileDialogPlugin>>primitiveFileDialogAddFilter (in category 'file dialogs') -----
+ primitiveFileDialogAddFilter
+ "Primitive. Add a filter to an existing file dialog.
+ Arguments:
+ dlgHandle: Handle for the file dialog.
+ filterDesc: Description for the filter ('Text Files (*.txt)')
+ filterPattern: Filter pattern (*.txt)
+ Returns: Nothing."
+ | dlgHandle filterDesc filterPattern |
+ <export: true>
+ interpreterProxy methodArgumentCount = 3 ifFalse:
+ [^interpreterProxy primitiveFail].
+ filterPattern := self stackEphemeralStringValue: 0.
+ filterDesc := self stackEphemeralStringValue: 1.
+ dlgHandle := self stackDialogHandle: 2.
+ interpreterProxy failed ifTrue:
+ [^self primitiveFailFor: PrimErrBadArgument].
+ self fileDialogAddFilter: dlgHandle _: filterDesc _: filterPattern "inSmalltalk: filterPattern".
+ interpreterProxy methodReturnReceiver!
Item was added:
+ ----- Method: FileDialogPlugin>>primitiveFileDialogCallbackReturn (in category 'file dialogs') -----
+ primitiveFileDialogCallbackReturn
+ "Primitive. Reap the return value from the dialog callback.
+ This is unimplemented (stubbed out) on all current platforms and so it is obsolete."
+ <export: true>
+ <legacy>
+ interpreterProxy methodReturnReceiver!
Item was added:
+ ----- Method: FileDialogPlugin>>primitiveFileDialogCreate (in category 'file dialogs') -----
+ primitiveFileDialogCreate
+ "Primitive. Create a new file dialog handle and answer the result.
+ Arguments: None.
+ Return value: File dialog handle."
+ | dlgHandle |
+ <export: true>
+ interpreterProxy methodArgumentCount = 0 ifFalse:
+ [^interpreterProxy primitiveFailFor: PrimErrBadNumArgs].
+ dlgHandle := self fileDialogCreate.
+ dlgHandle < 0 ifTrue:
+ [^interpreterProxy primitiveFailFor: PrimErrOperationFailed].
+ interpreterProxy methodReturnInteger: dlgHandle!
Item was added:
+ ----- Method: FileDialogPlugin>>primitiveFileDialogDestroy (in category 'file dialogs') -----
+ primitiveFileDialogDestroy
+ "Primitive. Hide/destroy the file dialog after it is done.
+ Arguments:
+ dlgHandle: Handle of the file dialog.
+ Return value: Nothing.
+ Notes: This primitive may fail if the dialog wasn't completed and platform
+ doesn't support destroying existing dialogs. Generally it is assumed that
+ the dialog has been closed by the user before calling this method."
+ | dlgHandle ok |
+ <export: true>
+ interpreterProxy methodArgumentCount = 1 ifFalse:
+ [^interpreterProxy primitiveFail].
+ dlgHandle := self stackDialogHandle: 0.
+ interpreterProxy failed ifTrue:[^nil].
+ ok := self fileDialogDestroy: dlgHandle "inSmalltalk: false".
+ ok ifFalse:[^interpreterProxy primitiveFail].
+ interpreterProxy methodReturnReceiver!
Item was added:
+ ----- Method: FileDialogPlugin>>primitiveFileDialogDone (in category 'file dialogs') -----
+ primitiveFileDialogDone
+ "Primitive. Answer whether the file dialog completed or not.
+ Arguments:
+ dlgHandle: Handle of the file dialog.
+ Return value: Boolean indicating whether the dialog completed."
+ | dlgHandle |
+ <export: true>
+ interpreterProxy methodArgumentCount = 1 ifFalse:
+ [^interpreterProxy primitiveFail].
+ dlgHandle := self stackDialogHandle: 0.
+ interpreterProxy failed ifFalse:
+ [interpreterProxy methodReturnBool: (self fileDialogDone: dlgHandle)]!
Item was added:
+ ----- Method: FileDialogPlugin>>primitiveFileDialogDoneSemaphore (in category 'file dialogs') -----
+ primitiveFileDialogDoneSemaphore
+ "Primitive. Set the semaphore to be signaled when the file dialog completes.
+ Arguments:
+ dlgHandle: Handle of the file dialog.
+ semaIndex: External semaphore index.
+ Return value: Nothing."
+ | dlgHandle semaIndex |
+ <export: true>
+ interpreterProxy methodArgumentCount = 2 ifFalse:
+ [^interpreterProxy primitiveFail].
+ semaIndex := interpreterProxy stackIntegerValue: 0.
+ dlgHandle := self stackDialogHandle: 1.
+ interpreterProxy failed ifTrue:[^nil].
+ self fileDialogDoneSemaphore: dlgHandle _: semaIndex "inSmalltalk: semaIndex".
+ interpreterProxy methodReturnReceiver!
Item was added:
+ ----- Method: FileDialogPlugin>>primitiveFileDialogGetFilterIndex (in category 'file dialogs') -----
+ primitiveFileDialogGetFilterIndex
+ "Primitive. Get the current filter index from one of the previously chosen filters.
+ Arguments:
+ dlgHandle: Handle for the file dialog.
+ Return value: Filter index."
+ | dlgHandle result |
+ <export: true>
+ interpreterProxy methodArgumentCount = 1 ifFalse:
+ [^interpreterProxy primitiveFail].
+ dlgHandle := self stackDialogHandle: 0.
+ interpreterProxy failed ifTrue:[^nil].
+ result := self fileDialogGetFilterIndex: dlgHandle "inSmalltalk: 0".
+ result = 0 ifTrue:[^interpreterProxy primitiveFail].
+ interpreterProxy methodReturnInteger: result!
Item was added:
+ ----- Method: FileDialogPlugin>>primitiveFileDialogGetResult (in category 'file dialogs') -----
+ primitiveFileDialogGetResult
+ "Primitive. Retrieve the result of the file dialog.
+ Arguments:
+ dlgHandle: Handle of the file dialog.
+ Return value: String for choosen file, or nil if canceled"
+ | dlgHandle cString |
+ <export: true>
+ <var: 'cString' type: #'char *'>
+ interpreterProxy methodArgumentCount = 1 ifFalse:
+ [^interpreterProxy primitiveFail].
+ dlgHandle := self stackDialogHandle: 0.
+ interpreterProxy failed ifFalse:
+ [cString := self fileDialogGetResult: dlgHandle.
+ interpreterProxy failed ifFalse:
+ [self methodReturnStringOrNil: cString]]!
Item was added:
+ ----- Method: FileDialogPlugin>>primitiveFileDialogSetCallbackSemaphore (in category 'file dialogs') -----
+ primitiveFileDialogSetCallbackSemaphore
+ "Primitive. Set the callback semaphore to be used for running modal dialogs.
+ This is unimplemented (stubbed out) on all current platforms and so it is obsolete."
+ <export: true>
+ <legacy>
+ interpreterProxy methodReturnReceiver!
Item was added:
+ ----- Method: FileDialogPlugin>>primitiveFileDialogSetFile (in category 'file dialogs') -----
+ primitiveFileDialogSetFile
+ "Primitive. Set the initial file name/path for the dialog.
+ Arguments:
+ dlgHandle: Handle for the file dialog.
+ filePath: Initial path for open dialog
+ Returns: Nothing."
+ | dlgHandle filePath |
+ <export: true>
+ interpreterProxy methodArgumentCount = 2 ifFalse:
+ [^interpreterProxy primitiveFail].
+ filePath := self stackEphemeralStringValue: 0.
+ dlgHandle := self stackDialogHandle: 1.
+ interpreterProxy failed ifTrue:
+ [^self primitiveFailFor: PrimErrBadArgument].
+ self fileDialogSetFile: dlgHandle _: filePath "inSmalltalk: false".
+ interpreterProxy methodReturnReceiver!
Item was added:
+ ----- Method: FileDialogPlugin>>primitiveFileDialogSetFilterIndex (in category 'file dialogs') -----
+ primitiveFileDialogSetFilterIndex
+ "Primitive. Set the current filter index from one of the previously chosen filters.
+ Arguments:
+ dlgHandle: Handle for the file dialog.
+ index: Current filter index.
+ Return value: Nothing."
+ | dlgHandle index |
+ <export: true>
+ interpreterProxy methodArgumentCount = 2 ifFalse:
+ [^interpreterProxy primitiveFail].
+ index := interpreterProxy stackIntegerValue: 0.
+ dlgHandle := self stackDialogHandle: 1.
+ interpreterProxy failed ifFalse:
+ [self fileDialogSetFilterIndex: dlgHandle _: index "inSmalltalk: index".
+ interpreterProxy methodReturnReceiver]!
Item was added:
+ ----- Method: FileDialogPlugin>>primitiveFileDialogSetLabel (in category 'file dialogs') -----
+ primitiveFileDialogSetLabel
+ "Primitive. Set the label for the dialog.
+ Arguments:
+ dlgHandle: Handle for the file dialog.
+ dlgLabel: Dialog label.
+ Returns: Nothing."
+ | dlgHandle dlgLabel |
+ <export: true>
+ interpreterProxy methodArgumentCount = 2 ifFalse:
+ [^interpreterProxy primitiveFail].
+ dlgLabel := self stackEphemeralStringValue: 0.
+ dlgHandle := self stackDialogHandle: 1.
+ interpreterProxy failed ifTrue:
+ [^self primitiveFailFor: PrimErrBadArgument].
+ self fileDialogSetLabel: dlgHandle _: dlgLabel "inSmalltalk: dlgLabel".
+ interpreterProxy methodReturnReceiver!
Item was added:
+ ----- Method: FileDialogPlugin>>primitiveFileDialogSetProperty (in category 'file dialogs') -----
+ primitiveFileDialogSetProperty
+ "Primitive. Set additional properties for a file dialog.
+ Arguments:
+ dlgHandle: Handle of the file dialog.
+ propName: Property name.
+ propValue: Boolean indication whether to turn it on or off.
+ Return value: Boolean, indicating whether the property is supported."
+ | dlgHandle propName propValue |
+ <export: true>
+ interpreterProxy methodArgumentCount = 3 ifFalse:
+ [^interpreterProxy primitiveFail].
+ dlgHandle := self stackDialogHandle: 2.
+ propName := self stackEphemeralStringValue: 1.
+ propValue := self stackBooleanValue: 0.
+ interpreterProxy failed ifTrue:
+ [^self primitiveFailFor: PrimErrBadArgument].
+ interpreterProxy methodReturnBool: (self fileDialogSetProperty: dlgHandle _: propName _: propValue)!
Item was added:
+ ----- Method: FileDialogPlugin>>primitiveFileDialogShow (in category 'file dialogs') -----
+ primitiveFileDialogShow
+ "Primitive. Show the file dialog.
+ Arguments:
+ dlgHandle: Handle of the file dialog.
+ fSaveAs: Whether to show an 'open' or a 'save' style dialog.
+ Return value: Nothing."
+ | dlgHandle fSaveAs |
+ <export: true>
+ interpreterProxy methodArgumentCount = 2 ifFalse:
+ [^interpreterProxy primitiveFail].
+ fSaveAs := self stackBooleanValue: 0.
+ dlgHandle := self stackDialogHandle: 1.
+ interpreterProxy failed ifTrue:
+ [^nil].
+ (self fileDialogShow: dlgHandle _: fSaveAs) ifFalse:
+ [^interpreterProxy primitiveFail].
+ interpreterProxy methodReturnReceiver!
Item was added:
+ ----- Method: FileDialogPlugin>>primitiveGetFileLocation (in category 'file dialogs') -----
+ primitiveGetFileLocation
+ "Primitive. Query for a common file location.
+ Arguments:
+ location: String describing the common file location.
+ Return value: The path to the designated location.
+ Known locations:
+ 'home' - the user's home directory
+ 'desktop' - the user's desktop directory
+
+ 'temp' - the temp directory to use
+ 'preferences' - the place to store (per user) app preferences
+ 'applications' - the directory for installing applications
+ 'fonts' - the directory to install fonts in the system
+
+ 'documents' - the users documents folder
+ 'music' - the users default location for music
+ 'pictures' - the users default location for pictures
+ 'videos' - the users default location for videos
+ "
+ | location |
+ <export: true>
+ interpreterProxy methodArgumentCount = 1 ifFalse:
+ [^interpreterProxy primitiveFail].
+ location := self stackEphemeralStringValue: 0.
+ interpreterProxy failed ifTrue:
+ [^self primitiveFailFor: PrimErrBadArgument].
+ self methodReturnStringOrNil: (self fileDialogGetLocation: location)!
Item was added:
+ ----- Method: FileDialogPlugin>>stackDialogHandle: (in category 'support') -----
+ stackDialogHandle: index
+ <returnTypeC: #int>
+ <inline: #always>
+ ^self cCoerce: (interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: index))
+ to: #int!
Item was changed:
----- Method: StackInterpreter class>>initializeMiscConstants (in category 'initialization') -----
initializeMiscConstants
super initializeMiscConstants.
STACKVM := true.
+ RevisedSuspend := true. "primitiveSuspendBackingUpV1/2 no longer allow a process waiting on a condition variable to go past the condition variable"
- RevisedSuspend := true. "primitiveSuspend no longer allows a process waiting on a condition variable to go past the condition variable"
"These flags identify a GC operation (& hence a reason to leak check),
or just operations the leak checker can be run for."
GCModeFull := 1. "stop-the-world global GC"
GCModeNewSpace := 2. "Spur's scavenge, or V3's incremental"
GCModeIncremental := 4. "incremental global gc (Dijkstra tri-colour marking); as yet unimplemented"
GCModeBecome := 8. "v3 post-become sweeping/Spur forwarding"
GCCheckImageSegment := 16. "just a flag for leak checking image segments"
GCCheckFreeSpace := 32. "just a flag for leak checking free space; Spur only"
GCCheckShorten := 64. "just a flag for leak checking object shortening operations; Spur only"
GCCheckPrimCall := 128. "just a flag for leak checking external primitive calls"
StackPageTraceInvalid := -1.
StackPageUnreached := 0.
StackPageReachedButUntraced := 1.
StackPageTraced := 2.
MillisecondClockMask := 16r1FFFFFFF.
"Note: The external primitive table should actually be dynamically sized but for the sake of inferior platforms (e.g., Mac :-) who cannot allocate memory in any reasonable way, we keep it static (and cross our fingers...)"
MaxExternalPrimitiveTableSize := 4096. "entries"
FailImbalancedPrimitives := InitializationOptions at: #FailImbalancedPrimitives ifAbsentPut: [true].
EnforceAccessControl := InitializationOptions at: #EnforceAccessControl ifAbsent: [true].
ReturnToInterpreter := 1. "setjmp/longjmp code."
"Because of a hack with callbacks in the non-threaded VM they must not conflct with the VM's tag bits."
DisownVMForFFICall := 16.
DisownVMForThreading := 32
!
Item was changed:
----- Method: StackInterpreter class>>initializePrimitiveTable (in category 'initialization') -----
(excessive size, no diff calculated)
Item was changed:
----- Method: StackInterpreter>>getCogVMFeatureFlags (in category 'internal interpreter access') -----
getCogVMFeatureFlags
"Answer an array of flags indicating various optional features of the Cog VM.
If the bit is set then...
Bit 0: supports two bytecode sets (MULTIPLEBYTECODESETS)
Bit 1: supports immutablity (IMMUTABILITY)
Bit 2: suffers from a UNIX setitimer signal-based heartbeat
Bit 3: the VM provides cross-platform bit-identical floating point
Bit 4: the VM can catch exceptions in FFI calls and answer them as primitive failures
+ Bit 5: the VM has suspend primitives 568 & 578 which back up a process to before the wait if it was waiting on a condition variable"
- Bit 5: the suspend primitive backs up a process to before the wait if it was waiting on a condition variable"
^objectMemory integerObjectOf: (MULTIPLEBYTECODESETS ifTrue: [1] ifFalse: [0])
+ (IMMUTABILITY ifTrue: [2] ifFalse: [0])
+ (self cppIf: #'ITIMER_HEARTBEAT' ifTrue: [4] ifFalse: [0])
+ (self cppIf: #'BIT_IDENTICAL_FLOATING_POINT' ifTrue: [8] ifFalse: [0])
+ (self ioCanCatchFFIExceptions ifTrue: [16] ifFalse: [0])
+ (RevisedSuspend ifTrue: [32] ifFalse: [0])!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveSuspend (in category 'process primitives') -----
primitiveSuspend
+ "Primitive #88. Suspend the receiver, aProcess, such that it can be executed again
- "Primitive. Suspend the receiver, aProcess, such that it can be executed again
by sending #resume. If the given process is not the active process, take it off
+ its corresponding list. The primitive returns the list the receiver was previously on.
+ c.f. primitiveSuspendBackingUpV1,#568 & primitiveSuspendBackingUpV2,#578"
- its corresponding list. If the list was not its run queue assume it was on some
- condition variable (Semaphore, Mutex) and back up its pc to the send that
- invoked the wait state the process entered. Hence when the process resumes
- it will reenter the wait state. Answer the list the receiver was previously on,
- unless it was the activ eProcess, in which case answer nil."
| process myList myContext ok |
process := self stackTop.
process = self activeProcess ifTrue:
+ [self stackTopPut: objectMemory nilObject.
- [self pop: 1 thenPush: objectMemory nilObject.
^self transferTo: self wakeHighestPriority].
myList := objectMemory fetchPointer: MyListIndex ofObject: process.
myContext := objectMemory fetchPointer: SuspendedContextIndex ofObject: process.
((objectMemory isPointers: myList)
and: [(objectMemory numSlotsOf: myList) > LastLinkIndex
and: [(objectMemory isContext: myContext)
and: [self isResumableContext: myContext]]]) ifFalse:
[^self primitiveFailFor: PrimErrBadReceiver].
ok := self removeProcess: process fromList: myList.
ok ifFalse:
[^self primitiveFailFor: PrimErrOperationFailed].
objectMemory storePointerUnchecked: MyListIndex ofObject: process withValue: objectMemory nilObject.
+ self stackTopPut: myList!
- self assert: RevisedSuspend.
- (RevisedSuspend
- and: [(objectMemory fetchClassTagOfNonImm: myList) ~= classLinkedListClassTag]) ifTrue:
- [self backupContext: myContext toBlockingSendTo: myList].
- self pop: 1 thenPush: myList!
Item was added:
+ ----- Method: StackInterpreterPrimitives>>primitiveSuspendBackingUpV1 (in category 'process primitives') -----
+ primitiveSuspendBackingUpV1
+ "Primitive #568. Suspend the receiver, aProcess, such that it can be executed again
+ by sending #resume. If the given process is not the active process, take it off
+ its corresponding list. If the list was not its run queue assume it was on some
+ condition variable (Semaphore, Mutex) and back up its pc to the send that
+ invoked the wait state the process entered. Hence when the process resumes
+ it will reenter the wait state. Answer the list the receiver was previously on,
+ unless it was the activeProcess, in which case answer nil.
+ c.f. primitiveSuspend,#88 & primitiveSuspendBackingUpV2,#578"
+ | process myList myContext ok |
+ process := self stackTop.
+ process = self activeProcess ifTrue:
+ [self stackTopPut: objectMemory nilObject.
+ ^self transferTo: self wakeHighestPriority].
+ myList := objectMemory fetchPointer: MyListIndex ofObject: process.
+ myContext := objectMemory fetchPointer: SuspendedContextIndex ofObject: process.
+ ((objectMemory isPointers: myList)
+ and: [(objectMemory numSlotsOf: myList) > LastLinkIndex
+ and: [(objectMemory isContext: myContext)
+ and: [self isResumableContext: myContext]]]) ifFalse:
+ [^self primitiveFailFor: PrimErrBadReceiver].
+ ok := self removeProcess: process fromList: myList.
+ ok ifFalse:
+ [^self primitiveFailFor: PrimErrOperationFailed].
+ objectMemory storePointerUnchecked: MyListIndex ofObject: process withValue: objectMemory nilObject.
+ (objectMemory fetchClassTagOfNonImm: myList) ~= classLinkedListClassTag ifTrue:
+ [self backupContext: myContext toBlockingSendTo: myList].
+ self stackTopPut: myList!
Item was added:
+ ----- Method: StackInterpreterPrimitives>>primitiveSuspendBackingUpV2 (in category 'process primitives') -----
+ primitiveSuspendBackingUpV2
+ "Primitive #578. Suspend the receiver, aProcess, such that it can be executed again
+ by sending #resume. If the given process is not the active process, take it off
+ its corresponding list. If the list was not its run queue assume it was on some
+ condition variable (Semaphore, Mutex) and back up its pc to the send that
+ invoked the wait state the process entered. Hence when the process resumes
+ it will reenter the wait state. Answer the list the receiver was previously on iff
+ it was not active and not blocked, otherwise answer nil.
+ c.f. primitiveSuspend,#88 & primitiveSuspendBackingUpV1,#568,
+ which always answer the list the process was on, even if blocked."
+ <export: true>
+ | process myList myContext ok |
+ process := self stackTop.
+ process = self activeProcess ifTrue:
+ [self stackTopPut: objectMemory nilObject.
+ ^self transferTo: self wakeHighestPriority].
+ myList := objectMemory fetchPointer: MyListIndex ofObject: process.
+ myContext := objectMemory fetchPointer: SuspendedContextIndex ofObject: process.
+ ((objectMemory isPointers: myList)
+ and: [(objectMemory numSlotsOf: myList) > LastLinkIndex
+ and: [(objectMemory isContext: myContext)
+ and: [self isResumableContext: myContext]]]) ifFalse:
+ [^self primitiveFailFor: PrimErrBadReceiver].
+ ok := self removeProcess: process fromList: myList.
+ ok ifFalse:
+ [^self primitiveFailFor: PrimErrOperationFailed].
+ objectMemory storePointerUnchecked: MyListIndex ofObject: process withValue: objectMemory nilObject.
+ (objectMemory fetchClassTagOfNonImm: myList) ~= classLinkedListClassTag
+ ifTrue:
+ [self backupContext: myContext toBlockingSendTo: myList.
+ self stackTopPut: objectMemory nilObject]
+ ifFalse:
+ [self stackTopPut: myList]!
Item was removed:
- ----- Method: StackInterpreterPrimitives>>primitiveSuspendV2 (in category 'process primitives') -----
- primitiveSuspendV2
- "Primitive. Suspend the receiver, aProcess, such that it can be executed again
- by sending #resume. If the given process is not the active process, take it off
- its corresponding list. If the list was not its run queue assume it was on some
- condition variable (Semaphore, Mutex) and back up its pc to the send that
- invoked the wait state the process entered. Hence when the process resumes
- it will reenter the wait state. Answer the list the receiver was previously on iff
- it was not active and not blocked, otherwise answer nil.
- c.f. primitiveSuspend, which always answers the list the process was on, if blocked."
- <export: true>
- | process myList myContext ok |
- process := self stackTop.
- process = self activeProcess ifTrue:
- [self pop: 1 thenPush: objectMemory nilObject.
- ^self transferTo: self wakeHighestPriority].
- myList := objectMemory fetchPointer: MyListIndex ofObject: process.
- myContext := objectMemory fetchPointer: SuspendedContextIndex ofObject: process.
- ((objectMemory isPointers: myList)
- and: [(objectMemory numSlotsOf: myList) > LastLinkIndex
- and: [(objectMemory isContext: myContext)
- and: [self isResumableContext: myContext]]]) ifFalse:
- [^self primitiveFailFor: PrimErrBadReceiver].
- ok := self removeProcess: process fromList: myList.
- ok ifFalse:
- [^self primitiveFailFor: PrimErrOperationFailed].
- objectMemory storePointerUnchecked: MyListIndex ofObject: process withValue: objectMemory nilObject.
- self assert: RevisedSuspend.
- (RevisedSuspend
- and: [(objectMemory fetchClassTagOfNonImm: myList) ~= classLinkedListClassTag])
- ifTrue:
- [self backupContext: myContext toBlockingSendTo: myList.
- self pop: 1 thenPush: objectMemory nilObject]
- ifFalse:
- [self pop: 1 thenPush: myList]!
Item was removed:
- ----- Method: StackInterpreterSimulator>>primitiveSuspend (in category 'debugging traps') -----
- primitiveSuspend
- "Catch errors before we start the whole morphic error process"
-
- "byteCount > 1000000 ifTrue: [self halt]." "Ignore early process activity"
- "self stackTop = (objectMemory fetchPointer: FirstLinkIndex ofObject: (objectMemory splObj: TheFinalizationSemaphore)) ifTrue:
- [self halt]."
- ^ super primitiveSuspend!
Item was changed:
----- Method: VMMaker class>>generateVMPlugins (in category 'configurations') -----
generateVMPlugins
^VMMaker
generatePluginsTo: self sourceTree, '/src'
options: #()
platformDir: self sourceTree, '/platforms'
including:#(ADPCMCodecPlugin AsynchFilePlugin
BalloonEnginePlugin B3DAcceleratorPlugin B3DEnginePlugin BMPReadWriterPlugin BitBltSimulation
BochsIA32Plugin BochsX64Plugin GdbARMv6Plugin GdbARMv8Plugin
CameraPlugin ClipboardExtendedPlugin CroquetPlugin DeflatePlugin DropPlugin
"Cryptography Plugins:" DESPlugin DSAPlugin MD5Plugin SHA2Plugin
+ FileDialogPlugin "FT2Plugin" FFTPlugin FileCopyPlugin FilePlugin FileAttributesPlugin Float64ArrayPlugin FloatArrayPlugin FloatMathPlugin
- "FT2Plugin" FFTPlugin FileCopyPlugin FilePlugin FileAttributesPlugin Float64ArrayPlugin FloatArrayPlugin FloatMathPlugin
GeniePlugin HostWindowPlugin IA32ABIPlugin ImmX11Plugin InternetConfigPlugin
JPEGReadWriter2Plugin JPEGReaderPlugin JoystickTabletPlugin KlattSynthesizerPlugin
LargeIntegersPlugin LocalePlugin MIDIPlugin MacMenubarPlugin Matrix2x3Plugin
MiscPrimitivePlugin Mpeg3Plugin QuicktimePlugin RePlugin
ScratchPlugin SecurityPlugin SerialPlugin SocketPlugin
SoundCodecPlugin SoundGenerationPlugin SoundPlugin SqueakSSLPlugin StarSqueakPlugin
ThreadedFFIPlugin ThreadedARM32FFIPlugin ThreadedARM64FFIPlugin ThreadedIA32FFIPlugin
ThreadedX64SysVFFIPlugin ThreadedX64Win64FFIPlugin
UnicodePlugin UnixAioPlugin UUIDPlugin UnixOSProcessPlugin
Win32OSProcessPlugin VMProfileLinuxSupportPlugin VMProfileMacSupportPlugin WeDoPlugin
XDisplayControlPlugin)!
More information about the Vm-dev
mailing list