[Vm-dev] VM Maker: VMMaker.oscog-eem.214.mcz
commits at source.squeak.org
commits at source.squeak.org
Tue Nov 20 01:56:56 UTC 2012
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.214.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.214
Author: eem
Time: 19 November 2012, 5:54:17.791 pm
UUID: 4bf85ad2-0e8f-4dc1-8fa1-7d6369f5fb10
Ancestors: VMMaker.oscog-lw.213
ThreadedFFIPlugin:
Fix bug with not attempting to run GC enough times for COGMTVM to
freeze arguments.
Fix bug in ffiCall:ArgArrayOrNil:NumArgs: not checking for an error case.
Simulators:
Add setBreakCount to other simulators also.
Slang:
Track variables in nested cppIf:ifTrue:[ifFalse:]'s so that both arms of
nested occurrences aren't duplicated (code is less confusing).
Simplify TMethod>>exitVar:label:.
Neaten up spotting duplicated code in cases by avoiding generating
asm labels when printing cases for duplication tests. Also avoids
incrementing the asm label counters unnecessarily.
Comment nodesDo: implementations to be bottom-up.
=============== Diff against VMMaker.oscog-lw.213 ===============
Item was changed:
Object subclass: #CCodeGenerator
+ instanceVariableNames: 'vmClass translationDict asArgumentTranslationDict inlineList constants variables variableDeclarations scopeStack methods macros apiMethods currentMethod headerFiles globalVariableUsage useSymbolicConstants generateDeadCode requiredSelectors logger suppressAsmLabels asmLabelCounts pools selectorTranslations optionsDictionary breakSrcInlineSelector breakDestInlineSelector'
- instanceVariableNames: 'vmClass translationDict asArgumentTranslationDict inlineList constants variables variableDeclarations scopeStack methods macros apiMethods currentMethod headerFiles globalVariableUsage useSymbolicConstants generateDeadCode requiredSelectors logger asmLabelCounts pools selectorTranslations optionsDictionary breakSrcInlineSelector breakDestInlineSelector'
classVariableNames: 'UseRightShiftForDivide'
poolDictionaries: 'VMBasicConstants'
category: 'VMMaker-Translation to C'!
!CCodeGenerator commentStamp: 'tpr 5/2/2003 14:30' prior: 0!
This class oversees the translation of a subset of Smalltalk to C, allowing the comforts of Smalltalk during development and the efficiency and portability of C for the resulting interpreter.
See VMMaker for more useful info!
Item was changed:
----- Method: CCodeGenerator>>generateInlineCppIfElse:asArgument:on:indent: (in category 'C translation') -----
generateInlineCppIfElse: msgNode asArgument: asArgument on: aStream indent: level
"Generate the C code for this message onto the given stream."
| expr putStatement |
"Compile-time expansion for constants set in the options dictionary,
e.g. to cut down on noise for MULTIPLEBYTECODESETS."
putStatement := asArgument
ifTrue: "emitCCodeAsArgumentOn: doesn't indent, the code needs indenting if it takes multiple lines, so post-process."
[[:node| | expansion |
expansion := String streamContents: [:s| node emitCCodeAsArgumentOn: s level: level generator: self].
aStream nextPutAll:
((expansion includes: Character cr)
ifTrue:
[(String streamContents:
[:s|
s next: level + 1 put: Character tab.
node emitCCodeAsArgumentOn: s level: level generator: self])
copyReplaceAll: (String with: Character cr)
with: (String with: Character cr), (String new: level + 1 withAll: Character tab)]
ifFalse: [expansion])]]
ifFalse:
[[:node| | expansion |
expansion := String streamContents: [:s| node emitCCodeOn: s level: level generator: self].
"Remove tabs from first line to avoid indenting a second time"
(aStream position > 0 and: [aStream last ~= Character tab]) ifTrue:
[expansion := expansion allButFirst: (expansion findFirst: [:c| c ~~ Character tab]) - 1].
aStream nextPutAll: expansion]].
(optionsDictionary notNil
and: [msgNode args first isConstant
and: [#(true false) includes: (optionsDictionary at: msgNode args first name ifAbsent: [nil])]]) ifTrue:
[(optionsDictionary at: msgNode args first name)
ifTrue:
[putStatement value: msgNode args second]
ifFalse:
[msgNode args size >= 3 ifTrue:
[putStatement value: msgNode args third]].
^self].
"Full #if ... #else..."
putStatement := asArgument
ifTrue: "emitCCodeAsArgumentOn: doesn't indent, the code needs indenting in this case, so post-process."
[[:node|
aStream nextPutAll:
((String streamContents:
[:s|
s next: level + 1 put: Character tab.
node emitCCodeAsArgumentOn: s level: level generator: self])
copyReplaceAll: (String with: Character cr)
with: (String with: Character cr), (String new: level + 1 withAll: Character tab))]]
ifFalse:
[[:node| node emitCCodeOn: aStream level: level generator: self]].
expr := String streamContents:
[:es|
msgNode args first
emitCCodeAsArgumentOn: es
level: 0
generator: self].
[expr last isSeparator] whileTrue:
[expr := expr allButLast].
aStream
ensureCr;
nextPut: $#; next: level * 2 put: Character space; nextPutAll: 'if '; nextPutAll: expr; cr.
+ self with: msgNode args first
+ ifAppropriateSetTo: true
+ do: [putStatement value: msgNode args second].
- putStatement value: msgNode args second.
expr := ' /* ', expr, ' */'.
msgNode args size >= 3 ifTrue:
[aStream
ensureCr;
nextPut: $#; next: level * 2 put: Character space; nextPutAll: 'else'; nextPutAll: expr;
cr.
+ self with: msgNode args first
+ ifAppropriateSetTo: false
+ do: [putStatement value: msgNode args third]].
- putStatement value: msgNode args third].
aStream
ensureCr;
nextPut: $#; next: level * 2 put: Character space; nextPutAll: 'endif'; nextPutAll: expr;
cr.
asArgument ifTrue:
[aStream next: level + 1 put: Character tab]!
Item was changed:
----- Method: CCodeGenerator>>initialize (in category 'public') -----
initialize
translationDict := Dictionary new.
inlineList := Array new.
constants := Dictionary new: 100.
variables := Set new: 100.
variableDeclarations := Dictionary new: 100.
methods := Dictionary new: 500.
macros := Dictionary new.
self initializeCTranslationDictionary.
headerFiles := OrderedCollection new.
globalVariableUsage := Dictionary new.
useSymbolicConstants := true.
generateDeadCode := true.
scopeStack := OrderedCollection new.
logger := (ProvideAnswerNotification new tag: #logger; signal) ifNil: [Transcript].
pools := IdentitySet new.
+ selectorTranslations := IdentityDictionary new.
+ suppressAsmLabels := false!
- selectorTranslations := IdentityDictionary new!
Item was changed:
----- Method: CCodeGenerator>>options: (in category 'accessing') -----
options: aDictionary
+ "Set optionsDictionary to the argument and scan it for accessors on the receiver,
+ performing the accessor with the value, allowing one to specify things like
+ generateDeadCode: false in the options."
+ optionsDictionary := aDictionary.
+ optionsDictionary keysAndValuesDo:
+ [:k :v| | accessor |
+ ((self class instVarNames includes: k)
+ and: [(Symbol hasInterned: k, ':' ifTrue: [:s| accessor := s])
+ and: [self class canUnderstand: accessor]]) ifTrue:
+ [self perform: accessor with: v]]!
- optionsDictionary := aDictionary!
Item was changed:
----- Method: CCodeGenerator>>outputAsmLabel:on: (in category 'utilities') -----
outputAsmLabel: selector on: aStream
| count |
+ suppressAsmLabels ifTrue: [^self].
asmLabelCounts isNil ifTrue:
[asmLabelCounts := Dictionary new].
count := asmLabelCounts
at: selector
put: 1 + (asmLabelCounts at: selector ifAbsent: [-1]).
aStream
nextPutAll: 'VM_LABEL(';
print: count;
nextPutAll: (self cFunctionNameFor: selector);
nextPut: $);
nextPut: $;!
Item was added:
+ ----- Method: CCodeGenerator>>suppressAsmLabels (in category 'accessing') -----
+ suppressAsmLabels
+ ^suppressAsmLabels!
Item was added:
+ ----- Method: CCodeGenerator>>suppressAsmLabels: (in category 'accessing') -----
+ suppressAsmLabels: aBoolean
+ suppressAsmLabels := aBoolean!
Item was added:
+ ----- Method: CCodeGenerator>>suppressAsmLabelsWhile: (in category 'utilities') -----
+ suppressAsmLabelsWhile: aBlock
+ | oldSuppressAsmLabels |
+ oldSuppressAsmLabels := suppressAsmLabels.
+ suppressAsmLabels := true.
+ ^aBlock ensure: [suppressAsmLabels := oldSuppressAsmLabels]!
Item was added:
+ ----- Method: CCodeGenerator>>with:ifAppropriateSetTo:do: (in category 'utilities') -----
+ with: aNode ifAppropriateSetTo: aBoolean do: aBlock
+ "If aNode is a TDefineNode for a variable, set it to the supplied boolean for the duration
+ of aBlock. This avoids duplicating both arms of nested cppIf:ifTrue:[ifFalse:]'s."
+ | savedOptions |
+ (aNode isConstant and: [aNode name notEmpty and: [aNode name first isLetter]]) ifFalse:
+ [^aBlock value].
+ savedOptions := optionsDictionary.
+ optionsDictionary := savedOptions
+ ifNil: [Dictionary new]
+ ifNotNil: [savedOptions copy].
+ optionsDictionary at: aNode name put: aBoolean.
+ ^aBlock ensure: [optionsDictionary := savedOptions]!
Item was changed:
----- Method: MessageNode>>asTranslatorNodeIn: (in category '*VMMaker-C translation') -----
asTranslatorNodeIn: aTMethod
"make a CCodeGenerator equivalent of me"
"selector is sometimes a Symbol, sometimes a SelectorNode!!
On top of this, numArgs is needed due to the (truly grody) use of
arguments as a place to store the extra expressions needed to generate
code for in-line to:by:do:, etc. see below, where it is used."
| rcvrOrNil sel args |
rcvrOrNil := receiver ifNotNil: [receiver asTranslatorNodeIn: aTMethod].
(rcvrOrNil notNil
and: [rcvrOrNil isVariable
and: [rcvrOrNil name = 'super']]) ifTrue:
[^aTMethod superExpansionNodeFor: selector key args: arguments].
sel := selector isSymbol ifTrue: [selector] ifFalse: [selector key].
+ ((sel = #cCode:inSmalltalk: "extracting here rather than in translation allows inlining in the block."
+ or: [sel = #cCode:])
- (sel = #cCode:inSmalltalk: "extracting here rather than in translation allows inlining in the block."
and: [arguments first isBlockNode]) ifTrue:
[| block |
^(block := arguments first asTranslatorNodeIn: aTMethod) statements size = 1
ifTrue: [block statements first]
ifFalse: [block]].
args := (1 to: sel numArgs) collect:
[:i | (arguments at: i) asTranslatorNodeIn: aTMethod].
(sel = #to:by:do: and: [arguments size = 7 and: [(arguments at: 7) notNil]])
ifTrue: ["Restore limit expr that got moved by transformToDo:"
args at: 1 put: ((arguments at: 7) value asTranslatorNodeIn: aTMethod)].
(sel = #or: and: [arguments size = 2 and: [(arguments at: 2) notNil]])
ifTrue: ["Restore argument block that got moved by transformOr:"
args at: 1 put: ((arguments at: 2) asTranslatorNodeIn: aTMethod)].
(sel = #ifFalse: and: [arguments size = 2 and: [(arguments at: 2) notNil]])
ifTrue: ["Restore argument block that got moved by transformIfFalse:"
args at: 1 put: ((arguments at: 2) asTranslatorNodeIn: aTMethod)].
^TSendNode new
setSelector: sel
receiver: rcvrOrNil
arguments: args!
Item was changed:
----- Method: NewspeakInterpreterSimulator>>utilitiesMenu: (in category 'UI') -----
utilitiesMenu: aMenuMorph
aMenuMorph
add: 'toggle transcript' action: #toggleTranscript;
addLine;
add: 'print active context' action: [self printContext: activeContext WithSP: localSP];
add: 'print int head frame' action: #printHeadFrame;
add: 'print call stack' action: #printCallStack;
add: 'print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self printOop: oop]];
addLine;
add: 'inspect interpreter' action: #inspect;
addLine;
+ add: 'set break count...' action: [|s| s := UIManager default request: 'break count (dec)'.
+ s notEmpty ifTrue: [breakCount := Integer readFrom: s readStream]];
- add: 'set break count...' action: #setBreakCount;
add: (printSends
ifTrue: ['no print sends']
ifFalse: ['print sends'])
action: [self ensureDebugAtEachStepBlock.
printSends := printSends not];
"currently printReturns does nothing"
"add: (printReturns
ifTrue: ['no print returns']
ifFalse: ['print returns'])
action: [self ensureDebugAtEachStepBlock.
printReturns := printReturns not];"
add: (printBytecodeAtEachStep
ifTrue: ['no print bytecode each bytecode']
ifFalse: ['print bytecode each bytecode'])
action: [self ensureDebugAtEachStepBlock.
printBytecodeAtEachStep := printBytecodeAtEachStep not];
add: (printContextAtEachStep
ifTrue: ['no print context each bytecode']
ifFalse: ['print context each bytecode'])
action: [self ensureDebugAtEachStepBlock.
printContextAtEachStep := printBytecodeAtEachStep not].
^aMenuMorph!
Item was changed:
----- Method: StackInterpreterSimulator>>utilitiesMenu: (in category 'UI') -----
utilitiesMenu: aMenuMorph
aMenuMorph
add: 'toggle transcript' action: #toggleTranscript;
addLine;
add: 'print ext head frame' action: #printExternalHeadFrame;
add: 'print int head frame' action: #printHeadFrame;
add: 'short print ext frame & callers' action: [self shortPrintFrameAndCallers: framePointer];
add: 'short print int frame & callers' action: [self shortPrintFrameAndCallers: localFP];
add: 'long print ext frame & callers' action: [self printFrameAndCallers: framePointer SP: stackPointer];
add: 'long print int frame & callers' action: [self printFrameAndCallers: localFP SP: localSP];
add: 'print frame...' action: [(self promptHex: 'print frame') ifNotNil: [:fp| self printFrame: fp]];
add: 'print call stack' action: #printCallStack;
add: 'print all stacks' action: #printAllStacks;
addLine;
add: 'print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self printOop: oop]];
add: 'long print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self longPrintOop: oop]];
addLine;
add: 'inspect object memory' target: objectMemory action: #inspect;
add: 'inspect cointerpreter' action: #inspect;
addLine;
+ add: 'set break count...' action: [|s| s := UIManager default request: 'break count (dec)'.
+ s notEmpty ifTrue: [breakCount := Integer readFrom: s readStream]];
- add: 'set break count...' action: #setBreakCount;
add: 'set break selector...' action: [|s| s := UIManager default request: 'break selector'.
s notEmpty ifTrue: [self setBreakSelector: s]];
add: (printSends
ifTrue: ['no print sends']
ifFalse: ['print sends'])
action: [self ensureDebugAtEachStepBlock.
printSends := printSends not];
"currently printReturns does nothing"
"add: (printReturns
ifTrue: ['no print returns']
ifFalse: ['print returns'])
action: [self ensureDebugAtEachStepBlock.
printReturns := printReturns not];"
add: (printBytecodeAtEachStep
ifTrue: ['no print bytecode each bytecode']
ifFalse: ['print bytecode each bytecode'])
action: [self ensureDebugAtEachStepBlock.
printBytecodeAtEachStep := printBytecodeAtEachStep not];
add: (printFrameAtEachStep
ifTrue: ['no print frame each bytecode']
ifFalse: ['print frame each bytecode'])
action: [self ensureDebugAtEachStepBlock.
printFrameAtEachStep := printFrameAtEachStep not].
^aMenuMorph!
Item was changed:
----- Method: TAssignmentNode>>nodesDo: (in category 'enumerating') -----
nodesDo: aBlock
+ "Apply aBlock to all nodes in the receiver.
+ N.B. This is assumed to be bottom-up, leaves first."
-
variable nodesDo: aBlock.
expression nodesDo: aBlock.
+ aBlock value: self!
- aBlock value: self.!
Item was changed:
----- Method: TBraceCaseNode>>nodesDo: (in category 'enumerating') -----
nodesDo: aBlock
+ "Apply aBlock to all nodes in the receiver.
+ N.B. This is assumed to be bottom-up, leaves first."
caseLabels do:
[:node| node nodesDo: aBlock].
cases do:
[:node| node nodesDo: aBlock].
aBlock value: self!
Item was changed:
----- Method: TCaseStmtNode>>emitCCodeOn:level:generator: (in category 'C code generation') -----
emitCCodeOn: aStream level: level generator: aCodeGen
| printMod expansions duplicates |
printMod := false.
(expression isVariable
and: [expression name = 'currentBytecode']) ifTrue:
[printMod := true.
aStream nextPutAll: 'bytecodeDispatchDebugHook();'; cr; crtab: level.
aCodeGen outputAsmLabel: 'bytecodeDispatch' on: aStream.
aStream crtab: level].
aStream nextPutAll: 'switch ('.
expression emitCCodeOn: aStream level: level generator: aCodeGen.
aStream nextPutAll: ') {'; cr.
+ expansions := aCodeGen suppressAsmLabelsWhile:
+ [cases collect:
+ [:case|
+ self filterCommentsFrom:
+ (String streamContents:
+ [:s|
+ case emitCCodeOn: s level: 0 generator: aCodeGen])]].
- expansions := cases collect:
- [:case|
- self filterCodeFrom:
- (String streamContents:
- [:s|
- case emitCCodeOn: s level: 0 generator: aCodeGen])].
duplicates := Set new.
1 to: cases size do:
[:i|
(duplicates includes: i) ifFalse:
[(duplicates addAll: ((i to: cases size) select: [:j| (expansions at: i) = (expansions at: j)])) do:
[:k|
(firsts at: k) to: (lasts at: k) do:
[:caseIndex|
aStream tab: level; nextPutAll: 'case '; print: caseIndex; nextPut: $:.
(caseIndex > 255 and: [printMod]) ifTrue:
[aStream nextPutAll: ' /*'; print: (caseIndex bitAnd: 255); nextPutAll: '*/'].
aStream cr]].
(cases at: i) emitCCodeOn: aStream level: level + 1 generator: aCodeGen.
aStream tab: level + 1; nextPutAll: 'break;'; cr]].
aStream tab: level; nextPut: $}!
Item was removed:
- ----- Method: TCaseStmtNode>>filterCodeFrom: (in category 'private') -----
- filterCodeFrom: aString
- "elide any /* comment */ and VM_LABEL(...) occurrences from aString."
- | m n i closer |
- m := aString indexOfSubCollection: '/*'.
- n := aString indexOfSubCollection: 'VM_LABEL('.
- m + n = 0 ifTrue:
- [^aString].
- (m ~= 0 and: [n = 0 or: [m < n]])
- ifTrue: [closer := '*/'. i := m]
- ifFalse: [closer := ');'. i := n].
- ^(aString copyFrom: 1 to: i - 1),
- (self filterCodeFrom:
- (aString
- copyFrom: (aString indexOfSubCollection: closer startingAt: i + 2) + closer size
- to: aString size))!
Item was added:
+ ----- Method: TCaseStmtNode>>filterCommentsFrom: (in category 'private') -----
+ filterCommentsFrom: aString
+ "elide any /* comment */ occurrences from aString."
+ | i |
+ i := aString indexOfSubCollection: '/*'startingAt: 1 ifAbsent: [^aString].
+ ^(aString copyFrom: 1 to: i - 1),
+ (self filterCommentsFrom:
+ (aString
+ copyFrom: (aString indexOfSubCollection: '*/' startingAt: i + 2) + 2
+ to: aString size))!
Item was changed:
----- Method: TCaseStmtNode>>nodesDo: (in category 'enumerating') -----
nodesDo: aBlock
+ "Apply aBlock to all nodes in the receiver.
+ N.B. This is assumed to be bottom-up, leaves first."
-
expression nodesDo: aBlock.
cases do: [ :c | c nodesDo: aBlock ].
+ aBlock value: self!
- aBlock value: self.!
Item was changed:
----- Method: TInlineNode>>nodesDo: (in category 'enumerating') -----
nodesDo: aBlock
+ "Apply aBlock to all nodes in the receiver.
+ N.B. This is assumed to be bottom-up, leaves first."
method parseTree nodesDo: aBlock.
+ aBlock value: self!
- aBlock value: self.!
Item was changed:
----- Method: TMethod>>exitVar:label: (in category 'inlining') -----
exitVar: exitVar label: exitLabel
+ "Replace each return statement in this method with an assignment to the
+ exit variable followed by either a return or a goto to the given label.
+ Answer if a goto was generated."
- "Replace each return statement in this method with an assignment to the exit variable followed by a goto to the given label. Return true if a goto was generated."
"Optimization: If exitVar is nil, the return value of the inlined method is not being used, so don't add the assignment statement."
+ | labelUsed map |
- | labelUsed |
labelUsed := false.
+ map := Dictionary new.
parseTree nodesDo:
+ [:node | | replacement |
+ node isReturn ifTrue:
+ [replacement := exitVar
+ ifNil: [node expression]
+ ifNotNil: [TAssignmentNode new
+ setVariable: (TVariableNode new setName: exitVar)
+ expression: node expression].
+ node ~~ parseTree statements last ifTrue:
+ [replacement := TStmtListNode new
+ setArguments: #()
+ statements: {replacement.
+ TGoToNode new setLabel: exitLabel; yourself};
+ yourself.
+ labelUsed := true].
+ map at: node put: replacement]].
+ parseTree replaceNodesIn: map.
+ "Now flatten any new statement lists..."
+ parseTree nodesDo:
+ [:node| | list |
+ (node isStmtList and: [node statements last isStmtList]) ifTrue:
+ [list := node statements last statements.
+ node statements removeLast; addAllLast: list]].
- [:node | | newStmts |
- node isStmtList ifTrue:
- [newStmts := OrderedCollection new: 100.
- node statements do:
- [:stmt |
- stmt isReturn
- ifTrue:
- [exitVar
- ifNil:
- [false "eem 8/8/2012 14:18 why exclude leaves explicity? Makes no sense to me and breaks inlining of asimple accessors"
- ifTrue:
- [stmt expression isLeaf ifFalse: "evaluate return expression even though value isn't used"
- [newStmts add: stmt expression]]
- ifFalse: [newStmts add: stmt expression]]
- ifNotNil: "assign return expression to exit variable"
- [newStmts add:
- (TAssignmentNode new
- setVariable: (TVariableNode new setName: exitVar)
- expression: stmt expression)].
- stmt ~~ parseTree statements last ifTrue: "generate a goto (this return is NOT the last statement in the method)"
- [newStmts add: (TGoToNode new setLabel: exitLabel).
- labelUsed := true]]
- ifFalse: [newStmts addLast: stmt]].
- node setStatements: newStmts asArray]].
^labelUsed!
Item was changed:
----- Method: TParseNode>>nodesDo: (in category 'enumerating') -----
nodesDo: aBlock
+ "Apply aBlock to all nodes in the receiver.
+ N.B. This is assumed to be bottom-up, leaves first."
+ aBlock value: self!
-
- aBlock value: self.!
Item was changed:
----- Method: TReturnNode>>nodesDo: (in category 'enumerating') -----
nodesDo: aBlock
+ "Apply aBlock to all nodes in the receiver.
+ N.B. This is assumed to be bottom-up, leaves first."
-
expression nodesDo: aBlock.
+ aBlock value: self!
- aBlock value: self.!
Item was changed:
----- Method: TSendNode>>nodesDo: (in category 'enumerating') -----
nodesDo: aBlock
+ "Apply aBlock to all nodes in the receiver.
+ N.B. This is assumed to be bottom-up, leaves first."
-
receiver nodesDo: aBlock.
arguments do: [ :arg | arg nodesDo: aBlock ].
+ aBlock value: self!
- aBlock value: self.!
Item was changed:
----- Method: TStmtListNode>>nodesDo: (in category 'enumerating') -----
nodesDo: aBlock
+ "Apply aBlock to all nodes in the receiver.
+ N.B. This is assumed to be bottom-up, leaves first."
-
statements do: [ :s | s nodesDo: aBlock ].
+ aBlock value: self!
- aBlock value: self.!
Item was changed:
----- Method: TSwitchStmtNode>>nodesDo: (in category 'enumerating') -----
nodesDo: aBlock
+ "Apply aBlock to all nodes in the receiver.
+ N.B. This is assumed to be bottom-up, leaves first."
expression nodesDo: aBlock.
cases do:
[:pair|
pair first do: [:node| node nodesDo: aBlock].
pair last nodesDo: aBlock].
otherwiseOrNil ifNotNil:
+ [otherwiseOrNil nodesDo: aBlock].
+ aBlock value: self!
- [otherwiseOrNil nodesDo: aBlock]!
Item was changed:
----- Method: ThreadedFFIPlugin>>ffiCall:ArgArrayOrNil:NumArgs: (in category 'callout support') -----
ffiCall: externalFunction ArgArrayOrNil: argArrayOrNil NumArgs: nArgs
"Generic callout. Does the actual work. If argArrayOrNil is nil it takes args from the stack
and the spec from the method. If argArrayOrNil is not nil takes args from argArrayOrNil
and the spec from the receiver."
| flags argTypeArray address argType oop argSpec argClass err theCalloutState calloutState requiredStackSize stackSize allocation result |
<inline: true>
<var: #theCalloutState type: #'CalloutState'>
<var: #calloutState type: #'CalloutState *'>
<var: #allocation type: #'char *'>
(interpreterProxy is: externalFunction KindOfClass: interpreterProxy classExternalFunction) ifFalse:
[^self ffiFail: FFIErrorNotFunction].
"Load and check the values in the externalFunction before we call out"
flags := interpreterProxy fetchInteger: ExternalFunctionFlagsIndex ofObject: externalFunction.
interpreterProxy failed ifTrue:
[^self ffiFail: FFIErrorBadArgs].
"This must come early for compatibility with the old FFIPlugin. Image-level code
may assume the function pointer is loaded eagerly. Thanks to Nicolas Cellier."
address := self ffiLoadCalloutAddress: externalFunction.
interpreterProxy failed ifTrue:
[^0 "error code already set by ffiLoadCalloutAddress:"].
argTypeArray := interpreterProxy fetchPointer: ExternalFunctionArgTypesIndex ofObject: externalFunction.
"must be array of arg types"
((interpreterProxy isArray: argTypeArray)
and: [(interpreterProxy slotSizeOf: argTypeArray) = (nArgs + 1)]) ifFalse:
[^self ffiFail: FFIErrorBadArgs].
"check if the calling convention is supported"
self cppIf: COGMTVM
ifTrue:
[(self ffiSupportsCallingConvention: (flags bitAnd: FFICallTypesMask)) ifFalse:
[^self ffiFail: FFIErrorCallType]]
ifFalse: "not masking causes threaded calls to fail, which is as they should if the plugin is not threaded."
[(self ffiSupportsCallingConvention: flags) ifFalse:
[^self ffiFail: FFIErrorCallType]].
requiredStackSize := self externalFunctionHasStackSizeSlot
ifTrue: [interpreterProxy
fetchInteger: ExternalFunctionStackSizeIndex
ofObject: externalFunction]
ifFalse: [-1].
interpreterProxy failed ifTrue:
[^interpreterProxy primitiveFailFor: (argArrayOrNil isNil
ifTrue: [PrimErrBadMethod]
ifFalse: [PrimErrBadReceiver])].
stackSize := requiredStackSize < 0 ifTrue: [DefaultMaxStackSize] ifFalse: [requiredStackSize].
self cCode: [] inSmalltalk: [theCalloutState := self class calloutStateClass new].
calloutState := self addressOf: theCalloutState.
self cCode: [self me: calloutState ms: 0 et: (self sizeof: #CalloutState asSymbol)].
calloutState callFlags: flags.
"Fetch return type and args"
argType := interpreterProxy fetchPointer: 0 ofObject: argTypeArray.
argSpec := interpreterProxy fetchPointer: 0 ofObject: argType.
argClass := interpreterProxy fetchPointer: 1 ofObject: argType.
(err := self ffiCheckReturn: argSpec With: argClass in: calloutState) ~= 0 ifTrue:
[^self ffiFail: err]. "cannot return"
"alloca the outgoing stack frame, leaving room for register args while marshalling, and including space for the return struct, if any."
allocation := self alloca: stackSize + calloutState structReturnSize + self registerArgsSlop + self cStackAlignment.
self allocaLiesSoUseGetsp ifTrue:
[allocation := self getsp].
self cStackAlignment ~= 0 ifTrue:
[allocation := self cCoerce: (allocation asUnsignedInteger bitClear: self cStackAlignment - 1)
to: #'char *'].
calloutState
argVector: allocation;
currentArg: allocation + self registerArgsSlop;
limit: allocation + stackSize + self registerArgsSlop.
(calloutState structReturnSize > 0
and: [self nonRegisterStructReturnIsViaImplicitFirstArgument
and: [(self returnStructInRegisters: calloutState structReturnSize) not]]) ifTrue:
+ [err := self ffiPushPointer: calloutState limit in: calloutState.
+ err ~= 0 ifTrue:
+ [self cleanupCalloutState: calloutState.
+ self cppIf: COGMTVM ifTrue:
+ [err = PrimErrObjectMayMove negated ifTrue:
+ [^PrimErrObjectMayMove]]. "N.B. Do not fail if object may move because caller will GC and retry."
+ ^self ffiFail: err]].
- [self ffiPushPointer: calloutState limit in: calloutState].
1 to: nArgs do:
[:i|
argType := interpreterProxy fetchPointer: i ofObject: argTypeArray.
argSpec := interpreterProxy fetchPointer: 0 ofObject: argType.
argClass := interpreterProxy fetchPointer: 1 ofObject: argType.
oop := argArrayOrNil isNil
ifTrue: [interpreterProxy stackValue: nArgs - i]
ifFalse: [interpreterProxy fetchPointer: i - 1 ofObject: argArrayOrNil].
err := self ffiArgument: oop Spec: argSpec Class: argClass in: calloutState.
err ~= 0 ifTrue:
[self cleanupCalloutState: calloutState.
self cppIf: COGMTVM ifTrue:
[err = PrimErrObjectMayMove negated ifTrue:
[^PrimErrObjectMayMove]]. "N.B. Do not fail if object may move because caller will GC and retry."
^self ffiFail: err]]. "coercion failed or out of stack space"
"Failures must be reported back from ffiArgument:Spec:Class:in:.
Should not fail from here on in."
self assert: interpreterProxy failed not.
self ffiLogCallout: externalFunction.
(requiredStackSize < 0
and: [self externalFunctionHasStackSizeSlot]) ifTrue:
[stackSize := calloutState currentArg - calloutState argVector.
interpreterProxy storeInteger: ExternalFunctionStackSizeIndex ofObject: externalFunction withValue: stackSize].
"Go out and call this guy"
result := self ffiCalloutTo: address SpecOnStack: argArrayOrNil notNil in: calloutState.
self cleanupCalloutState: calloutState.
^result!
Item was changed:
----- Method: ThreadedFFIPlugin>>primitiveCallout (in category 'primitives') -----
primitiveCallout
"IMPORTANT: IF YOU CHANGE THE NAME OF THIS METHOD YOU MUST CHANGE
Interpreter>>primitiveCalloutToFFI
TO REFLECT THE CHANGE."
"Perform a function call to a foreign function.
Only invoked from method containing explicit external call spec."
<returnTypeC: #void>
<export: true>
| meth externalFunction |
meth := interpreterProxy primitiveMethod.
(interpreterProxy literalCountOf: meth) > 0 ifFalse:
[^interpreterProxy primitiveFailFor: PrimErrBadMethod].
externalFunction := interpreterProxy literal: 0 ofMethod: meth.
self cppIf: COGMTVM
ifTrue:
+ [ | nArgs retryCount result |
- [ | nArgs retryCount |
nArgs := interpreterProxy methodArgumentCount.
retryCount := 0.
+ [result := self ffiCall: externalFunction ArgArrayOrNil: nil NumArgs: nArgs.
+ result = PrimErrObjectMayMove
+ and: [(retryCount := retryCount + 1) <= (nArgs + 1)]] whileTrue:
- [(self ffiCall: externalFunction ArgArrayOrNil: nil NumArgs: nArgs) = PrimErrObjectMayMove
- and: [(retryCount := retryCount + 1) <= nArgs]] whileTrue:
[interpreterProxy tenuringIncrementalGC]]
ifFalse:
[self ffiCall: externalFunction ArgArrayOrNil: nil NumArgs: interpreterProxy methodArgumentCount].
^0!
Item was changed:
----- Method: ThreadedFFIPlugin>>primitiveCalloutWithArgs (in category 'primitives') -----
primitiveCalloutWithArgs
"Perform a function call to a foreign function.
Only invoked from ExternalFunction>>invokeWithArguments:"
<returnTypeC: #void>
<export: true>
| externalFunction argArray nArgs |
interpreterProxy methodArgumentCount = 1 ifFalse:
[^interpreterProxy primitiveFailFor: PrimErrBadNumArgs].
self cppIf: COGMTVM
ifTrue:
+ [| retryCount result |
- [| retryCount |
retryCount := 0.
[externalFunction := interpreterProxy stackValue: 1.
argArray := interpreterProxy stackValue: 0.
(interpreterProxy isArray: argArray) ifFalse:
[^interpreterProxy primitiveFailFor: PrimErrBadArgument].
nArgs := interpreterProxy slotSizeOf: argArray.
+ result := self ffiCall: externalFunction ArgArrayOrNil: argArray NumArgs: nArgs.
+ result = PrimErrObjectMayMove
+ and: [(retryCount := retryCount + 1) <= (nArgs + 1)]] whileTrue:
- (self ffiCall: externalFunction ArgArrayOrNil: argArray NumArgs: nArgs) = PrimErrObjectMayMove
- and: [(retryCount := retryCount + 1) <= nArgs]] whileTrue:
[interpreterProxy tenuringIncrementalGC]]
ifFalse:
[externalFunction := interpreterProxy stackValue: 1.
argArray := interpreterProxy stackValue: 0.
(interpreterProxy isArray: argArray) ifFalse:
[^interpreterProxy primitiveFailFor: PrimErrBadArgument].
nArgs := interpreterProxy slotSizeOf: argArray.
self ffiCall: externalFunction ArgArrayOrNil: argArray NumArgs: nArgs].
^0!
More information about the Vm-dev
mailing list