[Vm-dev] VM Maker: VMMaker.oscog-eem.3267.mcz
commits at source.squeak.org
commits at source.squeak.org
Tue Nov 8 19:43:42 UTC 2022
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.3267.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.3267
Author: eem
Time: 8 November 2022, 11:43:22.924447 am
UUID: adcc856d-4794-4149-93af-5ae6cb3d31ce
Ancestors: VMMaker.oscog-eem.3266
Fix issues with spur primitive metadata in plugin primitives. stackFloatValue: stackStringValue: et al look inside the object on the stack. stackValue: stackIntegerValue: et al do not. So extend StackInterpreter class>>isObjectAccessor: to include those stack accessors that look inside the object on the stack. This fixes the metadata calculations for things like B3DAcceleratorPlugin>>primitiveSetLights, FileDialogPlugin>>primitiveFileDialogAddFilter, etc.
=============== Diff against VMMaker.oscog-eem.3264 ===============
Item was added:
+ ----- Method: BitBltSimulation class>>selectorDoesntNeedMetadata: (in category 'spur primitive compilation') -----
+ selectorDoesntNeedMetadata: aSelector
+ ^(aSelector beginsWith: 'prim') not!
Item was added:
+ ----- Method: CCodeGenerator>>isStackAccessor: (in category 'spur primitive compilation') -----
+ isStackAccessor: selector
+ ^self isStackAccessor: selector given: (vmClass ifNil: [StackInterpreter])!
Item was removed:
- ----- Method: CogVMSimulator>>primitiveGetAttribute (in category 'other primitives') -----
- primitiveGetAttribute
- "Fetch the system attribute with the given integer ID. The result is a string, which will be empty if the attribute is not defined."
-
- | index s attribute |
- index := self stackIntegerValue: 0.
- self successful ifTrue: [
- attribute := systemAttributes at: index ifAbsent: [Smalltalk vm getSystemAttribute: index].
- attribute ifNil: [ ^self primitiveFail ].
- s := objectMemory instantiateClass: (objectMemory splObj: ClassByteString) indexableSize: attribute size.
- 1 to: attribute size do: [ :i |
- objectMemory storeByte: i-1 ofObject: s withValue: (attribute at: i) asciiValue].
- self pop: 2 "rcvr, attr" thenPush: s]!
Item was added:
+ ----- Method: FilePlugin class>>selectorDoesntNeedMetadata: (in category 'spur primitive compilation') -----
+ selectorDoesntNeedMetadata: aSelector
+ ^(aSelector beginsWith: 'prim') not!
Item was added:
+ ----- Method: InterpreterPlugin class>>selectorDoesntNeedMetadata: (in category 'spur primitive compilation') -----
+ selectorDoesntNeedMetadata: aSelector
+ "Hmph. Most primitives begin with 'prim', but those in the B3DPlugin begin with b3d,
+ those in the ClipboardExtendedPlugin begin with io, etc. So we can't use beginning with
+ prim as a test to include metadata. But there are enough exceptions, e.g. the SecurityPlugin's
+ secCan* api, that we'd like to filter out some. It's better to filter out than filter in, cuz
+ plugin writers could reasonably be unaware of Spur metadata. Those anal enough to
+ filter out can put in the effort. So fail safe here and err on including metadata."
+ ^false!
Item was added:
+ ----- Method: InterpreterPrimitives>>getAttributeString: (in category 'system control primitives') -----
+ getAttributeString: index
+ "Fetch the system attribute with the given integer ID. The result is a string, or nil if the attribute is not defined."
+ <doNotGenerate>
+ self systemAttributes ifNotNil:
+ [:systemAttributes|
+ (systemAttributes at: index ifAbsent: []) ifNotNil:
+ [:attributeString| ^attributeString]].
+ ^Smalltalk vm getSystemAttribute: index!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveBeDisplay (in category 'I/O primitives') -----
primitiveBeDisplay
"Record the system Display object in the specialObjectsTable,
and if possible pin the display bitmap. Further, invoke ioBeDisplay
to alow the VM to record the location, width heigth & depth of the bitmap."
| rcvr bitsOop depthOop heightOop widthOop |
rcvr := self stackTop.
((objectMemory isPointers: rcvr)
and: [(objectMemory lengthOf: rcvr) >= 4
and: [bitsOop := objectMemory fetchPointer: 0 ofObject: rcvr.
((objectMemory isWordsOrBytes: bitsOop)
or: [objectMemory isIntegerObject: bitsOop]) "for surface plugin handles"
and: [(objectMemory isIntegerObject: (widthOop := objectMemory fetchPointer: 1 ofObject: rcvr))
and: [(objectMemory isIntegerObject: (heightOop := objectMemory fetchPointer: 2 ofObject: rcvr))
and: [(objectMemory isIntegerObject: (depthOop := objectMemory fetchPointer: 3 ofObject: rcvr))]]]]]) ifFalse:
[^self primitiveFailFor: PrimErrBadReceiver].
objectMemory splObj: TheDisplay put: rcvr.
(objectMemory hasSpurMemoryManagerAPI
and: [(objectMemory isNonImmediate: bitsOop)
and: [(objectMemory isPinned: bitsOop) not]]) ifTrue:
+ [rcvr := objectMemory pinObject: bitsOop. "Answers 0 if memory required to pin but not enough memory available."
- [rcvr := objectMemory pinObject: bitsOop. "Answers 0 if memory required to pin bit not enough memory available."
rcvr ~= 0 ifTrue: [bitsOop := rcvr]].
self ioBeDisplay: ((objectMemory isNonImmediate: bitsOop)
ifTrue: [objectMemory firstIndexableField: bitsOop]
ifFalse: [bitsOop asVoidPointer])
width: (objectMemory integerValueOf: widthOop)
height: (objectMemory integerValueOf: heightOop)
depth: (objectMemory integerValueOf: depthOop)!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveGetAttribute (in category 'system control primitives') -----
primitiveGetAttribute
+ "Fetch the system attribute with the given integer ID. The result is a string, or nil if the attribute is not defined."
+ | attr |
+ <var: 'attributeString' type: #'const char *'>
+ attr := self stackTop.
+ (objectMemory isIntegerObject: attr) ifFalse:
+ [^self primitiveFailFor: PrimErrBadArgument].
+ (self getAttributeString: (objectMemory integerValueOf: attr))
+ ifNil: [self methodReturnValue: objectMemory nilObject]
+ ifNotNil: [:attributeString| self methodReturnString: attributeString]!
- "Fetch the system attribute with the given integer ID. The
- result is a string, which will be empty if the attribute is not
- defined."
- | attr sz s |
- attr := self stackIntegerValue: 0.
- self successful
- ifTrue: [sz := self attributeSize: attr].
- self successful
- ifTrue: [s := objectMemory
- instantiateClass: (objectMemory splObj: ClassByteString)
- indexableSize: sz.
- self
- getAttribute: attr
- Into: s + objectMemory baseHeaderSize
- Length: sz.
- self pop: 2 thenPush: s]!
Item was added:
+ ----- Method: InterpreterPrimitives>>systemAttributes (in category 'system control primitives') -----
+ systemAttributes
+ <doNotGenerate>
+ ^nil!
Item was added:
+ ----- Method: SecurityPlugin class>>selectorDoesntNeedMetadata: (in category 'spur primitive compilation') -----
+ selectorDoesntNeedMetadata: aSelector
+ ^aSelector beginsWith: 'sec'!
Item was changed:
----- Method: StackInterpreter class>>isObjectAccessor: (in category 'spur compilation support') -----
isObjectAccessor: selector
"Answer if selector is one of fetchPointer:ofObject: storePointer:ofObject:withValue:
+ et al, or stackFloatValue:, stackStringValue: et al.
- et al."
- ^(InterpreterProxy whichCategoryIncludesSelector: selector) = #'object access'
- or: [(SpurMemoryManager whichCategoryIncludesSelector: selector) = #'object access']
+ stackValue: and stackIntegerValue: look no further than the oop (stackIntegerValue: does a
+ tag test). But stackFloatValue: stackStringValue: et al look inside the object fetched from the stack."
+ ^(selector beginsWith: 'stack')
+ ifTrue:
+ [selector last = $: "we would like to use endsWith: 'Value:' here, but e.g. stackDialogHandle: in FileDialogPlugin is an exception"
+ and: [(#(stackValue: stackIntegerValue: stackObjectValue:) includes: selector) not]]
+ ifFalse:
+ [(InterpreterProxy whichCategoryIncludesSelector: selector) = #'object access'
+ or: [(SpurMemoryManager whichCategoryIncludesSelector: selector) = #'object access']]
+
"This for checking. The above two protocols are somewhat disjoint."
"(InterpreterProxy allMethodsInCategory: #'object access') copyWithoutAll: (SpurMemoryManager allMethodsInCategory: #'object access')"
"(SpurMemoryManager allMethodsInCategory: #'object access') copyWithoutAll: (InterpreterProxy allMethodsInCategory: #'object access')"!
Item was removed:
- ----- Method: StackInterpreterSimulator>>primitiveGetAttribute (in category 'other primitives') -----
- primitiveGetAttribute
- "Fetch the system attribute with the given integer ID. The result is a string, which will be empty if the attribute is not defined."
-
- | index s attribute |
- index := self stackIntegerValue: 0.
- self successful ifTrue: [
- attribute := systemAttributes at: index ifAbsent: [Smalltalk vm getSystemAttribute: index].
- attribute ifNil: [ ^self primitiveFail ].
- s := objectMemory instantiateClass: (objectMemory splObj: ClassByteString) indexableSize: attribute size.
- 1 to: attribute size do: [ :i |
- objectMemory storeByte: i-1 ofObject: s withValue: (attribute at: i) asciiValue].
- self pop: 2 "rcvr, attr" thenPush: s]!
Item was changed:
----- Method: TMethod>>prepareMethodIn: (in category 'transformations') -----
prepareMethodIn: aCodeGen
"Record sends of builtin operators, map sends of the special selector dispatchOn:in:
with case statement nodes, and map sends of caseOf:[otherwise:] to switch statements.
Declare limit variables for to:[by:]do: loops with limits that potentially have side-effects.
As a hack also update the types of variables introduced to implement cascades correctly.
This has to be done at the same time as this is done, so why not piggy back here?"
aCodeGen maybeBreakForTestToInline: selector in: self.
extraVariableNumber ifNotNil:
[declarations keysAndValuesDo:
[:varName :decl|
decl isBlock ifTrue:
[self assert: ((varName beginsWith: 'cascade') and: [varName last isDigit]).
locals add: varName.
self declarationAt: varName
put: (decl value: self value: aCodeGen), ' ', varName]]].
aCodeGen
pushScope: declarations
while:"N.B. nodesWithParentsDo: is bottom-up, hence replacement is destructive and conserved."
[parseTree nodesWithParentsDo:
[:node :parent|
node isSend ifTrue:
[aCodeGen ifStaticallyResolvedPolymorphicReceiverThenUpdateSelectorIn: node.
(aCodeGen isBuiltinSelector: node selector)
ifTrue:
[node isBuiltinOperator: true.
"If a to:by:do:'s limit has side-effects, declare the limit variable, otherwise delete it from the args"
node selector = #to:by:do: ifTrue:
[self ensureToByDoLoopLimitIsSafeAndEfficient: node in: aCodeGen]]
ifFalse:
+ [(aCodeGen isStackAccessor: node selector)
- [(StackInterpreter isStackAccessor: node selector)
ifTrue: "compute and cache the accessor depth early, before inlining destroys the accessor chains"
[self export ifTrue:
[aCodeGen accessorDepthForMethod: self]]
ifFalse:
[(CaseStatements includes: node selector) ifTrue:
[parent replaceNodesIn: (Dictionary newFromPairs: { node. self buildCaseStmt: node in: aCodeGen})].
(#(caseOf: #caseOf:otherwise:) includes: node selector) ifTrue:
[parent replaceNodesIn: (Dictionary newFromPairs: { node. self buildSwitchStmt: node parent: parent })].
(#(printf: fprintf: f:printf: f:wprintf:) includes: node selector) ifTrue:
[self transformPrintf: node in: aCodeGen].
(node receiver isVariable
and: [node receiver name = #Character
and: [node selector isUnary]]) ifTrue:
[parent replaceNodesIn: (Dictionary newFromPairs: { node. TConstantNode new setValue: (Character perform: node selector) })]]]]]]!
Item was added:
+ ----- Method: ThreadedFFIPlugin class>>selectorDoesntNeedMetadata: (in category 'spur primitive compilation') -----
+ selectorDoesntNeedMetadata: aSelector
+ ^(aSelector beginsWith: 'prim') not!
Item was changed:
----- Method: VMPluginCodeGenerator>>methodNeedsMetadata: (in category 'spur primitive compilation') -----
methodNeedsMetadata: aTMethod
"Answer if aTMethod really needs primitive metadata. This is a hack to filter out some functions that definitely don't need metadata."
| selector |
selector := aTMethod smalltalkSelector.
(#(initialiseModule shutdownModule moduleUnloaded:) includes: selector) ifTrue:
[^false].
(InterpreterPlugin includesSelector: selector) ifTrue:
[^false].
+ "Hmph. Most primitives begin with 'prim', but those in the B3DPlugin begin with b3d,
+ those in the ClipboardExtendedPlugin begin with io, etc. So we can't use beginning with
+ prim as a test to include metadata. But there are enough exceptions, e.g. the SecurityPlugin's
+ secCan* api, that we'd like to filter out some. It's better to filter out than filter in, cuz
+ plugin writers could reasonably be unaware of Spur metadata. Those anal enough to
+ filter out can put in the effort. So fail safe here and err on including metadata."
+ (pluginClass selectorDoesntNeedMetadata: selector) ifTrue:
+ [^false].
^true!
Item was added:
+ ----- Method: VMProfileLinuxSupportPlugin class>>preambleCCode (in category 'translation') -----
+ preambleCCode
+ ^'extern const char *getAttributeString(sqInt);'!
Item was added:
+ ----- Method: VMProfileLinuxSupportPlugin class>>structTargetKindForDeclaration: (in category 'translation') -----
+ structTargetKindForDeclaration: decl "<String>"
+
+ decl last = $* ifTrue: [^#pointer].
+ ^(decl beginsWith: 'struct dl_phdr_info') ifTrue: [#struct]!
Item was changed:
----- Method: VMProfileLinuxSupportPlugin>>primitiveDLSymInLibrary (in category 'primitives') -----
primitiveDLSymInLibrary
"Answer the address of the symbol whose name is the first argument
in the library whose name is the second argument, or nil if none."
| nameObj symName libName lib sz addr ok |
<export: true>
<var: #symName type: #'char *'>
<var: #libName type: #'char *'>
<var: #lib type: #'void *'>
<var: #addr type: #'void *'>
nameObj := interpreterProxy stackValue: 0.
(interpreterProxy isBytes: nameObj) ifFalse:
[^interpreterProxy primitiveFailFor: PrimErrBadArgument].
sz := interpreterProxy byteSizeOf: nameObj.
libName := self malloc: sz+1.
self strncpy: libName _: (interpreterProxy firstIndexableField: nameObj) _: sz.
libName at: sz put: 0.
nameObj := interpreterProxy stackValue: 1.
(interpreterProxy isBytes: nameObj) ifFalse:
[self free: libName.
^interpreterProxy primitiveFailFor: PrimErrBadArgument].
sz := interpreterProxy byteSizeOf: nameObj.
symName := self malloc: sz+1.
self strncpy: symName _: (interpreterProxy firstIndexableField: nameObj) _: sz.
symName at: sz put: 0.
lib := self dl: libName open: (#'RTLD_LAZY' bitOr: #'RTLD_NODELETE').
lib ifNil:
[self free: libName; free: symName.
^interpreterProxy primitiveFailFor: PrimErrInappropriate].
self dlerror. "clear dlerror"
addr := self dl: lib sym: symName.
ok := self dlerror isNil.
self free: symName.
self free: libName.
self dlclose: lib.
ok ifFalse:
[^interpreterProxy primitiveFailFor: PrimErrNotFound].
+ ^interpreterProxy methodReturnValue: (self positiveMachineIntegerFor: addr asUnsignedIntegerPtr)!
- ^interpreterProxy methodReturnValue: (interpreterProxy positiveMachineIntegerFor: addr asUnsignedIntegerPtr)!
Item was changed:
----- Method: VMProfileLinuxSupportPlugin>>primitiveExecutableModules (in category 'primitives') -----
primitiveExecutableModules
"Answer an Array of pairs of strings for executable modules (the VM executable and loaded libraries).
The first element in each pair is the filename of the module. The second element is either nil or
the symlink's target, if the filename is a symlink."
<export: true>
| resultObj |
numModules := 0.
+ self dl_iterate_phdr: #countnummodules _: 0.
- self cCode: 'dl_iterate_phdr(countnummodules,0)' inSmalltalk: [0].
resultObj := interpreterProxy
instantiateClass: interpreterProxy classArray
indexableSize: numModules - 1 * 2. "skip the fake linux-gate.so.1"
resultObj = 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrNoMemory].
interpreterProxy pushRemappableOop: resultObj.
primErr := numModules := 0.
+ self dl_iterate_phdr: #reapmodulesymlinks _: 0.
- self cCode: 'dl_iterate_phdr(reapmodulesymlinks,0)' inSmalltalk: [0].
resultObj := interpreterProxy popRemappableOop.
primErr ~= 0 ifTrue:
[^interpreterProxy primitiveFailFor: primErr].
^interpreterProxy methodReturnValue: resultObj!
Item was changed:
----- Method: VMProfileLinuxSupportPlugin>>primitiveInterpretAddress (in category 'primitives') -----
primitiveInterpretAddress
"Answer the address of the interpret routine."
<export: true>
| interpret |
<var: #interpret declareC: 'extern void interpret()'>
+ ^interpreterProxy methodReturnValue: (self positiveMachineIntegerFor: interpret asUnsignedIntegerPtr)!
- ^interpreterProxy methodReturnValue: (interpreterProxy positiveMachineIntegerFor: interpret asUnsignedIntegerPtr)!
Item was changed:
----- Method: VMProfileLinuxSupportPlugin>>reap:module:names: (in category 'iteration callbacks') -----
reap: info module: size names: ignored
+ <var: 'info' type: #'struct dl_phdr_info *'>
+ <var: 'size' type: #'size_t'>
+ <var: 'ignored' type: #'void *'>
<returnTypeC: #int>
+ | elfModuleName len moduleNameObj |
- | elfModuleName len moduleNameObj GetAttributeString |
- <var: #info type: #'struct dl_phdr_info *'>
<var: 'elfModuleName' type: #'const char *'>
+ elfModuleName := numModules > 0 ifTrue: [info dlpi_name] ifFalse: [self getAttributeString: 0].
- <var: #GetAttributeString declareC: 'extern char *GetAttributeString(sqInt)'>
- <var: #size type: #'size_t'>
- <var: #ignored type: #'void *'>
- self touch: GetAttributeString.
- elfModuleName := self cCode: 'numModules ? info->dlpi_name : GetAttributeString(0)'.
(elfModuleName isNil
or: [(len := self strlen: elfModuleName) = 0]) ifTrue:
[^0]. "skip the fake linux-gate.so.1"
moduleNameObj := interpreterProxy
instantiateClass: interpreterProxy classString
indexableSize: len.
moduleNameObj = 0 ifTrue:
[primErr := PrimErrNoMemory.
^1]. "stop iteration"
self strncpy: (interpreterProxy arrayValueOf: moduleNameObj)
_: elfModuleName
_: len. "(char *)strncpy()"
interpreterProxy
storePointer: numModules
ofObject: interpreterProxy topRemappableOop
withValue: moduleNameObj.
numModules := numModules + 1.
^0!
Item was changed:
----- Method: VMProfileLinuxSupportPlugin>>reap:module:symlinks: (in category 'iteration callbacks') -----
reap: info module: size symlinks: ignored
"like reap:module:names:, but follows symlinks"
+ <var: 'info' type: #'struct dl_phdr_info *'>
+ <var: 'size' type: #'size_t'>
+ <var: 'ignored' type: #'void *'>
<returnTypeC: #int>
+ | elfModuleName len moduleNameObj symLinkBuf |
- | elfModuleName len moduleNameObj GetAttributeString symLinkBuf |
- <var: #info type: #'struct dl_phdr_info *'>
<var: 'elfModuleName' type: #'const char *'>
+ <var: 'symLinkBuf' declareC: 'char symLinkBuf[PATH_MAX]'>
+ elfModuleName := numModules > 0 ifTrue: [info dlpi_name] ifFalse: [self getAttributeString: 0].
- <var: #GetAttributeString declareC: 'extern char *GetAttributeString(sqInt)'>
- <var: #symLinkBuf declareC: 'char symLinkBuf[PATH_MAX]'>
- <var: #size type: #'size_t'>
- <var: #ignored type: #'void *'>
- self touch: GetAttributeString.
- elfModuleName := self cCode: 'numModules ? info->dlpi_name : GetAttributeString(0)'.
(elfModuleName isNil
or: [(len := self strlen: elfModuleName) = 0]) ifTrue:
[^0]. "skip the fake linux-gate.so.1"
moduleNameObj := interpreterProxy
instantiateClass: interpreterProxy classString
indexableSize: len.
moduleNameObj = 0 ifTrue:
[primErr := PrimErrNoMemory.
^1]. "stop iteration"
self strncpy: (interpreterProxy arrayValueOf: moduleNameObj)
_: elfModuleName
_: len. "(char *)strncpy()"
interpreterProxy
storePointer: numModules
ofObject: interpreterProxy topRemappableOop
withValue: moduleNameObj.
"now dereference the symlink, if it exists"
self str: symLinkBuf cpy: elfModuleName.
(len := self read: elfModuleName li: symLinkBuf nk: #'PATH_MAX') > 0
ifTrue:
[moduleNameObj := interpreterProxy
instantiateClass: interpreterProxy classString
indexableSize: len.
moduleNameObj = 0 ifTrue:
[primErr := PrimErrNoMemory.
^1]. "stop iteration"
self strncpy: (interpreterProxy arrayValueOf: moduleNameObj)
_: symLinkBuf
_: len. "(char *)strncpy()"
interpreterProxy
storePointer: numModules + 1
ofObject: interpreterProxy topRemappableOop
withValue: moduleNameObj]
ifFalse:
[interpreterProxy
storePointer: numModules + 1
ofObject: interpreterProxy topRemappableOop
withValue: interpreterProxy nilObject].
numModules := numModules + 2.
^0!
More information about the Vm-dev
mailing list