Vm-dev September 2018

vm-dev@lists.squeakfoundation.org

19 participants
41 discussions

VM Maker: VMMakerCompatibilityForPharo6-eem.9.mcz
by commits＠source.squeak.org 26 Sep '18

26 Sep '18

Eliot Miranda uploaded a new version of VMMakerCompatibilityForPharo6 to project VM Maker: http://source.squeak.org/VMMaker/VMMakerCompatibilityForPharo6-eem.9.mcz ==================== Summary ==================== Name: VMMakerCompatibilityForPharo6-eem.9 Author: eem Time: 26 September 2018, 2:34:40.566729 pm UUID: ed2013ba-2e33-0d00-8be4-25a8015cfeb3 Ancestors: VMMakerCompatibilityForPharo6-eem.8 More compatbility. InstructionPrinter et al are missing in Pharo6 and subsequent. RBProgramNode methods for Slang. GtTranscript compatibility. =============== Diff against VMMakerCompatibilityForPharo6-eem.8 =============== Item was added: + ----- Method: GtTranscript>>ensureCr (in category '*VMMakerCompatibilityForPharo6') ----- + ensureCr + "do nothing" + (self text isEmpty or: [ self text last == Character cr]) ifFalse: + [ self cr ]! Item was added: + ----- Method: GtTranscript>>flush (in category '*VMMakerCompatibilityForPharo6') ----- + flush + "do nothing"! Item was added: + ----- Method: GtTranscript>>next:put: (in category '*VMMakerCompatibilityForPharo6') ----- + next: anInteger put: aCharacter + "Make anObject be the next anInteger number of objects accessible by the + receiver. Answer anObject." + + 1 to: anInteger do: [:i| self nextPut: aCharacter ]. + ^ aCharacter! Item was added: + InstructionClient subclass: #InstructionPrinter + instanceVariableNames: 'method scanner stream oldPC innerIndents indent printPC indentSpanOfFollowingJump' + classVariableNames: '' + poolDictionaries: '' + category: 'VMMakerCompatibilityForPharo6-Kernel-Methods'! + + !InstructionPrinter commentStamp: 'md 4/8/2003 12:47' prior: 0! + My instances can print the object code of a CompiledMethod in symbolic format. They print into an instance variable, stream, and uses oldPC to determine how many bytes to print in the listing. The variable method is used to hold the method being printed.! Item was added: + ----- Method: InstructionPrinter class>>on: (in category 'printing') ----- + on: aMethod + ^self new method: aMethod. + ! Item was added: + ----- Method: InstructionPrinter class>>printClass: (in category 'printing') ----- + printClass: class + "Create a file whose name is the argument followed by '.bytes'. Store on + the file the symbolic form of the compiled methods of the class." + | file | + file := FileStream newFileNamed: class name , '.bytes'. + class selectorsAndMethodsDo: + [:sel :m | + file cr; nextPutAll: sel; cr. + (self on: m) printInstructionsOn: file]. + file close + "InstructionPrinter printClass: Parser." + ! Item was added: + ----- Method: InstructionPrinter>>blockReturnConstant: (in category 'instruction decoding') ----- + blockReturnConstant: value + "Print the Return Constant From Block bytecode." + + self print: 'blockReturn: ', value printString! Item was added: + ----- Method: InstructionPrinter>>blockReturnTop (in category 'instruction decoding') ----- + blockReturnTop + "Print the Return Top Of Stack bytecode." + + self print: 'blockReturn'! Item was added: + ----- Method: InstructionPrinter>>callPrimitive: (in category 'instruction decoding') ----- + callPrimitive: index + "Print the callPrimitive bytecode." + + self print: 'callPrimitive: ' , index printString! Item was added: + ----- Method: InstructionPrinter>>directedSuperSend:numArgs: (in category 'instruction decoding') ----- + directedSuperSend: selector "<Symbol>" numArgs: numArgs "<SmallInteger>" + self print: 'directedSuperSend: ' , (self stringForSelector: selector numArgs: numArgs)! Item was added: + ----- Method: InstructionPrinter>>doDup (in category 'instruction decoding') ----- + doDup + "Print the Duplicate Top Of Stack bytecode." + + self print: 'dup'! Item was added: + ----- Method: InstructionPrinter>>doPop (in category 'instruction decoding') ----- + doPop + "Print the Remove Top Of Stack bytecode." + + self print: 'pop'! Item was added: + ----- Method: InstructionPrinter>>indent (in category 'accessing') ----- + indent + + ^ indent ifNil: [0]! Item was added: + ----- Method: InstructionPrinter>>indent: (in category 'initialize-release') ----- + indent: numTabs + + indent := numTabs! Item was added: + ----- Method: InstructionPrinter>>jump: (in category 'instruction decoding') ----- + jump: offset + "Print the Unconditional Jump bytecode." + + self print: 'jumpTo: ' , (scanner pc + offset) printString. + indentSpanOfFollowingJump ifTrue: + [indentSpanOfFollowingJump := false. + innerIndents atAll: (scanner pc to: scanner pc + offset - 1) put: (innerIndents at: scanner pc - 1) + 1]! Item was added: + ----- Method: InstructionPrinter>>jump:if: (in category 'instruction decoding') ----- + jump: offset if: condition + "Print the Conditional Jump bytecode." + + self print: + (condition + ifTrue: ['jumpTrue: '] + ifFalse: ['jumpFalse: ']) + , (scanner pc + offset) printString! Item was added: + ----- Method: InstructionPrinter>>method (in category 'accessing') ----- + method + ^method.! Item was added: + ----- Method: InstructionPrinter>>method: (in category 'accessing') ----- + method: aMethod + method := aMethod. + printPC := true. + indentSpanOfFollowingJump := false! Item was added: + ----- Method: InstructionPrinter>>methodReturnConstant: (in category 'instruction decoding') ----- + methodReturnConstant: value + "Print the Return Constant bytecode." + + self print: 'return: ' , value printString! Item was added: + ----- Method: InstructionPrinter>>methodReturnReceiver (in category 'instruction decoding') ----- + methodReturnReceiver + "Print the Return Self bytecode." + + self print: 'returnSelf'! Item was added: + ----- Method: InstructionPrinter>>methodReturnTop (in category 'instruction decoding') ----- + methodReturnTop + "Print the Return Top Of Stack bytecode." + + self print: 'returnTop'! Item was added: + ----- Method: InstructionPrinter>>popIntoLiteralVariable: (in category 'instruction decoding') ----- + popIntoLiteralVariable: anAssociation + "Print the Remove Top Of Stack And Store Into Literal Variable bytecode." + + self print: 'popIntoLit: ' , anAssociation key! Item was added: + ----- Method: InstructionPrinter>>popIntoReceiverVariable: (in category 'instruction decoding') ----- + popIntoReceiverVariable: offset + "Print the Remove Top Of Stack And Store Into Instance Variable + bytecode." + + self print: 'popIntoRcvr: ' , offset printString! Item was added: + ----- Method: InstructionPrinter>>popIntoRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- + popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex + self print: 'popIntoTemp: ', remoteTempIndex printString, ' inVectorAt: ', tempVectorIndex printString! Item was added: + ----- Method: InstructionPrinter>>popIntoTemporaryVariable: (in category 'instruction decoding') ----- + popIntoTemporaryVariable: offset + "Print the Remove Top Of Stack And Store Into Temporary Variable + bytecode." + + self print: 'popIntoTemp: ' , offset printString! Item was added: + ----- Method: InstructionPrinter>>print: (in category 'printing') ----- + print: instruction + "Append to the receiver a description of the bytecode, instruction." + + | code | + stream tab: self indent. + printPC ifTrue: [stream print: oldPC; space]. + stream tab: (innerIndents at: oldPC). + stream nextPut: $<. + oldPC to: scanner pc - 1 do: + [:i | + code := (method at: i) radix: 16. + stream nextPut: + (code size < 2 + ifTrue: [$0] + ifFalse: [code at: 1]). + stream nextPut: code last; space]. + stream skip: -1. + stream nextPut: $>. + stream space. + stream nextPutAll: instruction. + stream cr. + oldPC := scanner pc. + "(InstructionPrinter compiledMethodAt: #print:) symbolic." + ! Item was added: + ----- Method: InstructionPrinter>>printInstructionsOn: (in category 'initialize-release') ----- + printInstructionsOn: aStream + "Append to the stream, aStream, a description of each bytecode in the + instruction stream." + + | end | + stream := aStream. + scanner := InstructionStream on: method. + end := method endPC. + oldPC := scanner pc. + innerIndents := Array new: end withAll: 0. + [scanner pc <= end] whileTrue: + [scanner interpretNextInstructionFor: self]! Item was added: + ----- Method: InstructionPrinter>>printInstructionsOn:do: (in category 'initialize-release') ----- + printInstructionsOn: aStream do: aBlock + "Append to the stream, aStream, a description of each bytecode in the + instruction stream. Evaluate aBlock with the receiver, the scanner and + the stream after each instruction." + + | end | + stream := aStream. + scanner := InstructionStream on: method. + end := method endPC. + oldPC := scanner pc. + innerIndents := Array new: end withAll: 0. + [scanner pc <= end] whileTrue: + [scanner interpretNextInstructionFor: self. + aBlock value: self value: scanner value: stream]! Item was added: + ----- Method: InstructionPrinter>>printPC (in category 'accessing') ----- + printPC + ^printPC! Item was added: + ----- Method: InstructionPrinter>>printPC: (in category 'accessing') ----- + printPC: aBoolean + printPC := aBoolean! Item was added: + ----- Method: InstructionPrinter>>pushActiveContext (in category 'instruction decoding') ----- + pushActiveContext + "Print the Push Active Context On Top Of Its Own Stack bytecode." + + self print: 'pushThisContext: '! Item was added: + ----- Method: InstructionPrinter>>pushClosureCopyNumCopiedValues:numArgs:blockSize: (in category 'instruction decoding') ----- + pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize + self print: 'closureNumCopied: ', numCopied printString + , ' numArgs: ', numArgs printString + , ' bytes ', scanner pc printString + , ' to ', (scanner pc + blockSize - 1) printString. + innerIndents + atAll: (scanner pc to: scanner pc + blockSize - 1) + put: (innerIndents at: scanner pc - 1) + 1! Item was added: + ----- Method: InstructionPrinter>>pushConsArrayWithElements: (in category 'instruction decoding') ----- + pushConsArrayWithElements: numElements + self print: 'pop ', numElements printString, ' into (Array new: ', numElements printString, ')'! Item was added: + ----- Method: InstructionPrinter>>pushConstant: (in category 'instruction decoding') ----- + pushConstant: obj + "Print the Push Constant, obj, on Top Of Stack bytecode." + + self print: (String streamContents: + [:s | + s nextPutAll: 'pushConstant: '. + obj isVariableBinding + ifTrue: + [obj key + ifNotNil: [s nextPutAll: '##'; nextPutAll: obj key] + ifNil: [s nextPutAll: '###'; nextPutAll: obj value soleInstance name]] + ifFalse: + [obj isClosure + ifTrue: [s nextPutAll: obj sourceString] + ifFalse: [obj printOn: s]]]). + + obj isCompiledMethod ifTrue: + [obj longPrintOn: stream indent: self indent + 2. + ^self]! Item was added: + ----- Method: InstructionPrinter>>pushFullClosure:numCopied: (in category 'printing') ----- + pushFullClosure: aCompiledBlock numCopied: numCopied + | literalIndex | + literalIndex := method literals identityIndexOf: aCompiledBlock. + literalIndex = 0 + ifTrue: + [self print: 'closureNumCopied: ', numCopied printString + , ' numArgs: ', aCompiledBlock numArgs printString] + ifFalse: + [self print: 'pushFullClosure: (self literalAt: ', literalIndex printString, + ') numCopied: ', numCopied printString, + ' "numArgs: ', aCompiledBlock numArgs printString, '"']! Item was added: + ----- Method: InstructionPrinter>>pushLiteralVariable: (in category 'instruction decoding') ----- + pushLiteralVariable: anAssociation + "Print the Push Value Of anAssociation On Top Of Stack bytecode." + + self print: 'pushLitVar: ' , (anAssociation printStringLimitedTo: 64)! Item was added: + ----- Method: InstructionPrinter>>pushNewArrayOfSize: (in category 'instruction decoding') ----- + pushNewArrayOfSize: numElements + self print: 'push: (Array new: ', numElements printString, ')'! Item was added: + ----- Method: InstructionPrinter>>pushReceiver (in category 'instruction decoding') ----- + pushReceiver + "Print the Push Active Context's Receiver on Top Of Stack bytecode." + + self print: 'self'! Item was added: + ----- Method: InstructionPrinter>>pushReceiverVariable: (in category 'instruction decoding') ----- + pushReceiverVariable: offset + "Print the Push Contents Of the Receiver's Instance Variable Whose Index + is the argument, offset, On Top Of Stack bytecode." + + self print: 'pushRcvr: ' , offset printString! Item was added: + ----- Method: InstructionPrinter>>pushRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- + pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex + self print: 'pushTemp: ', remoteTempIndex printString, ' inVectorAt: ', tempVectorIndex printString! Item was added: + ----- Method: InstructionPrinter>>pushTemporaryVariable: (in category 'instruction decoding') ----- + pushTemporaryVariable: offset + "Print the Push Contents Of Temporary Variable Whose Index Is the + argument, offset, On Top Of Stack bytecode." + + self print: 'pushTemp: ' , offset printString! Item was added: + ----- Method: InstructionPrinter>>send:super:numArgs: (in category 'instruction decoding') ----- + send: selector super: supered numArgs: numArgs + "Print the Send Message With Selector, selector, bytecode. The argument, + supered, indicates whether the receiver of the message is specified with + 'super' in the source method. The arguments of the message are found in + the top numArguments locations on the stack and the receiver just + below them." + + self print: (supered + ifTrue: ['superSend: '] + ifFalse: ['send: ']) + , (self stringForSelector: selector numArgs: numArgs)! Item was added: + ----- Method: InstructionPrinter>>storeIntoLiteralVariable: (in category 'instruction decoding') ----- + storeIntoLiteralVariable: anAssociation + "Print the Store Top Of Stack Into Literal Variable Of Method bytecode." + + self print: 'storeIntoLit: ' , anAssociation key! Item was added: + ----- Method: InstructionPrinter>>storeIntoReceiverVariable: (in category 'instruction decoding') ----- + storeIntoReceiverVariable: offset + "Print the Store Top Of Stack Into Instance Variable Of Method bytecode." + + self print: 'storeIntoRcvr: ' , offset printString! Item was added: + ----- Method: InstructionPrinter>>storeIntoRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- + storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex + self print: 'storeIntoTemp: ', remoteTempIndex printString, ' inVectorAt: ', tempVectorIndex printString! Item was added: + ----- Method: InstructionPrinter>>storeIntoTemporaryVariable: (in category 'instruction decoding') ----- + storeIntoTemporaryVariable: offset + "Print the Store Top Of Stack Into Temporary Variable Of Method + bytecode." + + self print: 'storeIntoTemp: ' , offset printString! Item was added: + ----- Method: InstructionPrinter>>stringForSelector:numArgs: (in category 'printing') ----- + stringForSelector: selector numArgs: numArgs + ^(selector isSymbol and: [selector numArgs = numArgs]) + ifTrue: [selector] + ifFalse: [selector printString + , (numArgs = 1 + ifTrue: [' (1 arg)'] + ifFalse: [' (', numArgs printString, ' args)'])]! Item was added: + ----- Method: InstructionPrinter>>trapIfNotInstanceOf: (in category 'instruction decoding') ----- + trapIfNotInstanceOf: behaviorOrArrayOfBehavior + "If the top of stack is not an instance of either the argument, or, if the argument is an Array, + any of the elements of the argument, send the class trap message to the current context." + self print: 'trapIfNotInstanceOf: ', behaviorOrArrayOfBehavior printString! Item was changed: ----- Method: RBAssignmentNode>>asTranslatorNodeIn: (in category '*VMMakerCompatibilityForPharo6-C translation') ----- asTranslatorNodeIn: aTMethod "Answer a TParseNode subclass equivalent of me" | varNode valueNode | varNode := variable asTranslatorNodeIn: aTMethod. valueNode := value asTranslatorNodeIn: aTMethod. valueNode isStmtList ifFalse: [^TAssignmentNode new setVariable: varNode expression: valueNode; + comment: self commentOrNil]. - comment: self missingCommentNeededForCTranslation]. "This is a super expansion. We are in trouble if any statement other than the last is a return." (self anyReturns: valueNode statements allButLast) ifTrue: [self error: 'haven''t implemented pushing down assignments into other than the last return']. "As of 6/25/2012 19:30 superExpansionNodeFor:args: elides the final return." self assert: valueNode statements last isReturn not. ^TStmtListNode new setStatements: valueNode statements allButLast, { TAssignmentNode new setVariable: varNode expression: valueNode statements last; + comment: self commentOrNil }; - comment: self missingCommentNeededForCTranslation }; yourself! Item was changed: ----- Method: RBBlockNode>>asTranslatorNodeIn: (in category '*VMMakerCompatibilityForPharo6-C translation') ----- asTranslatorNodeIn: aTMethod "Answer a TParseNode subclass equivalent of me" | statementList | statementList := OrderedCollection new. body statements do: [:s | | newS | newS := s asTranslatorNodeIn: aTMethod. "inline the statement list returned when a CascadeNode is translated and/or when ifNotNil: is transformed" newS isStmtList ifTrue: [statementList addAll: newS statements] ifFalse: [statementList add: newS]]. ^TStmtListNode new setArguments: (arguments asArray collect: [:arg | arg name]) statements: statementList; + comment: self commentOrNil! - comment: self missingCommentNeededForCTranslation! Item was changed: ----- Method: RBCascadeNode>>asTranslatorNodeIn: (in category '*VMMakerCompatibilityForPharo6-C translation') ----- asTranslatorNodeIn: aTMethod "Answer a TParseNode subclass equivalent of me." ^TStmtListNode new setArguments: #() statements: (Array streamContents: [:s| | receiverNode | receiverNode := messages first receiver asTranslatorNodeIn: aTMethod. "don't expand the receiver if it is a send to get an implicit receiver, e.g self interpreter printHex: oop => printHex(oop), /not/ printHex(cascade0,oop)." (receiverNode isSend and: [aTMethod definingClass isNonArgumentImplicitReceiverVariableName: receiverNode selector]) ifTrue: [receiverNode := TVariableNode new setName: receiverNode selector]. receiverNode isLeaf ifFalse: [| varNode | varNode := aTMethod newCascadeTempFor: receiverNode. s nextPut: (TAssignmentNode new setVariable: varNode expression: receiverNode). receiverNode := varNode]. messages do: [ :msg | s nextPut: ((msg asTranslatorNodeIn: aTMethod) receiver: receiverNode)]]); + comment: self commentOrNil! - comment: self missingCommentNeededForCTranslation! Item was changed: ----- Method: RBMessageNode>>asTranslatorNodeIn: (in category '*VMMakerCompatibilityForPharo6-C translation') ----- asTranslatorNodeIn: aTMethod "Answer a TParseNode subclass 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. Expand super nodes in place. Elide sends of halt so that halts can be sprinkled through the simulator but will be eliminated from the generated C." + | rcvrOrNil args ifNotNilBlock | - | rcvrOrNil sel args ifNotNilBlock | rcvrOrNil := receiver ifNotNil: [receiver asTranslatorNodeIn: aTMethod]. (rcvrOrNil notNil and: [rcvrOrNil isVariable and: [rcvrOrNil name = 'super']]) ifTrue: [^aTMethod superExpansionNodeFor: selector args: arguments]. + selector == #halt ifTrue: [^rcvrOrNil]. + (selector == #cCode:inSmalltalk: "extracting here rather than in translation allows inlining in the block." + or: [selector == #cCode:]) ifTrue: - sel := selector. "historical; can be simply selector" - sel == #halt ifTrue: [^rcvrOrNil]. - (sel == #cCode:inSmalltalk: "extracting here rather than in translation allows inlining in the block." - or: [sel == #cCode:]) ifTrue: [arguments first isBlockNode ifTrue: [| block | ^(block := arguments first asTranslatorNodeIn: aTMethod) statements size = 1 ifTrue: [block statements first] ifFalse: [block]]. (arguments first isLiteralNode and: [arguments first value isString and: [arguments first value isEmpty]]) ifTrue: [^arguments first asTranslatorNodeIn: aTMethod]]. args := arguments collect: [:arg| arg asTranslatorNodeIn: aTMethod]. + (selector == #ifTrue:ifFalse: and: [arguments first statements isEmpty]) ifTrue: + [selector := #ifFalse:. args := {args last}]. + (selector == #ifTrue:ifFalse: and: [arguments last statements isEmpty]) ifTrue: + [selector := #ifTrue:. args := {args first}]. + (selector == #ifFalse:ifTrue: and: [arguments first statements isEmpty]) ifTrue: + [selector := #ifTrue:. args := {args last}]. + (selector == #ifFalse:ifTrue: and: [arguments last statements isEmpty]) ifTrue: + [selector := #ifTrue:. args := {args first}]. + ((CCodeGenerator isVarargsSelector: selector) - false ifTrue: - [(sel = #to:by:do: and: [arguments size = 7 and: [(arguments at: 7) notNil]]) ifTrue: - ["Restore limit expr that got moved by transformToDo:" - args := {(arguments at: 7) value asTranslatorNodeIn: aTMethod. - args second. - args third. "add the limit var as a hidden extra argument; we may need it later" - TVariableNode new setName: arguments first key}]. - (sel == #ifTrue:ifFalse: and: [arguments first isNodeNil]) ifTrue: - [sel := #ifFalse:. args := {args last}]. - (sel == #ifTrue:ifFalse: and: [arguments last isNodeNil]) ifTrue: - [sel := #ifTrue:. args := {args first}]. - (sel == #ifFalse:ifTrue: and: [arguments first isNodeNil]) ifTrue: - [sel := #ifTrue:. args := {args last}]. - (sel == #ifFalse:ifTrue: and: [arguments last isNodeNil]) ifTrue: - [sel := #ifTrue:. args := {args first}]. - ((sel == #ifFalse: or: [sel == #or:]) - and: [arguments size = 2 and: [(arguments at: 2) notNil]]) ifTrue: - ["Restore argument block that got moved by transformOr: or transformIfFalse:" - args := {(arguments at: 2) asTranslatorNodeIn: aTMethod}]. - (args size > sel numArgs and: [sel ~~ #to:by:do:]) ifTrue: "to:by:do: has iLimiT hidden in last arg" - ["prune the extra blocks left by ifTrue:, ifFalse:, and: & or:" - self assert: args size - sel numArgs = 1. - self assert: (args last isStmtList - and: [args last statements size = 1 - and: [(args last statements first isVariable - or: [args last statements first isConstant]) - and: [#('nil' true false) includes: args last statements first nameOrValue]]]). - args := args first: sel numArgs]. - "For the benefit of later passes, e.g. value: inlining, - transform e ifNotNil: [:v| ...] into v := e. v ifNotNil: [...], - which in fact means transforming (v := e) ifTrue: [:v|...] into v := e. v ifTrue: [...]." - ((sel == #ifTrue: or: [sel == #ifFalse: or: [sel == #ifTrue:ifFalse: or: [sel == #ifFalse:ifTrue:]]]) - and: [receiver notNil - and: [receiver isAssignmentEqualsEqualsNil - and: [(ifNotNilBlock := args detect: [:arg| arg isStmtList and: [arg args size = 1]] ifNone: []) notNil]]]) ifTrue: - [ifNotNilBlock setArguments: #(). - ^TStmtListNode new - setArguments: #() - statements: - { receiver receiver asTranslatorNodeIn: aTMethod. - TSendNode new - setSelector: sel - receiver: (TSendNode new - setSelector: #== - receiver: (receiver receiver variable asTranslatorNodeIn: aTMethod) - arguments: {receiver arguments first asTranslatorNodeIn: aTMethod}) - arguments: args }]]. - ((CCodeGenerator isVarargsSelector: sel) and: [args last isCollection and: [args last isSequenceable]]) ifTrue: [args := args allButLast, args last]. ^TSendNode new + setSelector: selector - setSelector: sel receiver: rcvrOrNil arguments: args! Item was changed: ----- Method: RBMethodNode>>asTranslationMethodOfClass: (in category '*VMMakerCompatibilityForPharo6-C translation') ----- asTranslationMethodOfClass: aTMethodClass "Answer a TMethod (or subclass) derived from the receiver." + | additionalMethodState | + additionalMethodState := AdditionalMethodState forMethod: nil selector: selector. + pragmas ifNotNil: + [pragmas do: + [:pragmaNode| + additionalMethodState := additionalMethodState copyWith: pragmaNode asPragma]]. ^aTMethodClass new setSelector: selector + definingClass: compilationContext getClass - definingClass: scope instanceScope outerScope getClass args: arguments locals: ((self allDefinedVariables copyWithoutAll: arguments) collect: [:string| string -> string]) + block: (body lastIsReturn + ifTrue: [body] + ifFalse: [body shallowCopy + addSelfReturn; + yourself]) - block: body primitive: ((pragmas ifNotNil: [pragmas detect: [:pragmaNode| pragmaNode selector beginsWith: #primitve:] ifNone: []]) ifNil: [0] ifNotNil: [:pragmaNode| pragmaNode arguments first value]) + properties: additionalMethodState + comment: self commentOrNil! - properties: (properties ifNil: [AdditionalMethodState new]) - comment: self missingCommentNeededForCTranslation! Item was added: + ----- Method: RBProgramNode>>commentOrNil (in category '*VMMakerCompatibilityForPharo6-C translation') ----- + commentOrNil + ^self propertyAt: #comments ifAbsent: []! Item was added: + ----- Method: RBProgramNode>>isVariableNode (in category '*VMMakerCompatibilityForPharo6-testing') ----- + isVariableNode + ^false! Item was changed: ----- Method: RBReturnNode>>asTranslatorNodeIn: (in category '*VMMakerCompatibilityForPharo6-C translation') ----- asTranslatorNodeIn: aTMethod "Answer a TParseNode subclass equivalent of a return." | exprTranslation lastExpr | exprTranslation := value asTranslatorNodeIn: aTMethod. (value isMessage and: [value receiver isVariable and: [value receiver name = 'super' and: [exprTranslation isStmtList]]]) ifTrue: ["super expansions containing returns are fine, and (as of 6/25/2012 19:27) the last return is elided from the expansion by TMethod>>superExpansionNodeFor:args:. So we need to ensure the last expression is a return and simply reuse any other returns in the expansion." lastExpr := exprTranslation statements last. (lastExpr isReturn or: [lastExpr isReturningIf]) ifFalse: [exprTranslation statements at: exprTranslation statements size put: (TReturnNode new setExpression: lastExpr; + comment: self commentOrNil; - comment: self missingCommentNeededForCTranslation; yourself)]. ^exprTranslation]. ^TReturnNode new setExpression: exprTranslation; + comment: self commentOrNil; - comment: self missingCommentNeededForCTranslation; yourself! Item was changed: ----- Method: RBSequenceNode>>asTranslatorNodeIn: (in category '*VMMakerCompatibilityForPharo6-C translation') ----- asTranslatorNodeIn: aTMethod "Answer a TParseNode subclass equivalent of me" | statementList | statementList := OrderedCollection new. statements do: [:s | | newS | newS := s asTranslatorNodeIn: aTMethod. "inline the statement list returned when a CascadeNode is translated and/or when ifNotNil: is transformed" newS isStmtList ifTrue: [statementList addAll: newS statements] ifFalse: [statementList add: newS]]. ^TStmtListNode new + setArguments: (parent isMethod + ifTrue: [#()] + ifFalse: [parent arguments asArray collect: [:arg | arg name]]) - setArguments: (parent arguments asArray collect: [:arg | arg name]) statements: statementList; + comment: self commentOrNil! - comment: self missingCommentNeededForCTranslation! Item was added: + ----- Method: RBVariableNode>>isVariableNode (in category '*VMMakerCompatibilityForPharo6-testing') ----- + isVariableNode + ^true! Item was added: + InstructionPrinter subclass: #RelativeInstructionPrinter + instanceVariableNames: 'printCode labels labelling' + classVariableNames: '' + poolDictionaries: '' + category: 'VMMakerCompatibilityForPharo6-Kernel-Methods'! Item was added: + ----- Method: RelativeInstructionPrinter>>jump: (in category 'instruction decoding') ----- + jump: offset + "Print the Unconditional Jump bytecode." + + labelling + ifTrue: + [labels at: scanner pc + offset + 1 put: true. + self print: 'jumpBy: ', offset printString, + ' to: ', (scanner pc + offset - method initialPC) printString] + ifFalse: + [self print: 'jumpTo: ', (labels at: scanner pc + offset + 1)]! Item was added: + ----- Method: RelativeInstructionPrinter>>jump:if: (in category 'instruction decoding') ----- + jump: offset if: condition + "Print the Conditional Jump bytecode." + + labelling + ifTrue: + [labels at: scanner pc + offset + 1 put: true. + self print: + (condition ifTrue: ['jumpTrueBy: '] ifFalse: ['jumpFalseBy: ']), offset printString, + ' to: ', (labelling + ifTrue: [(scanner pc + offset - method initialPC) printString] + ifFalse: [labels at: scanner pc + offset])] + ifFalse: + [self print: + (condition ifTrue: ['jumpTrueTo: '] ifFalse: ['jumpFalseTo: ']), (labels at: scanner pc + offset + 1)]! Item was added: + ----- Method: RelativeInstructionPrinter>>print: (in category 'printing') ----- + print: instruction + "Append to the receiver a description of the bytecode, instruction." + + stream tab: self indent. + labelling + ifTrue: [stream print: oldPC - method initialPC; space] + ifFalse: [stream tab]. + stream tab: (innerIndents at: oldPC). + self printCode ifTrue: + [stream nextPut: $<. + oldPC to: scanner pc - 1 do: + [:i | | code | + code := (method at: i) radix: 16. + stream + nextPut: (code size < 2 ifTrue: [$0] ifFalse: [code at: 1]); + nextPut: code last; + space]. + stream skip: -1; nextPut: $>; space]. + stream nextPutAll: instruction. + stream cr. + labelling ifFalse: + [(labels at: scanner pc + 1) ~~ false ifTrue: + [stream nextPutAll: (labels at: scanner pc + 1); nextPut: $:; cr]]. + oldPC := scanner pc! Item was added: + ----- Method: RelativeInstructionPrinter>>printCode (in category 'printing') ----- + printCode + ^printCode ~~ false! Item was added: + ----- Method: RelativeInstructionPrinter>>printCode: (in category 'initialize-release') ----- + printCode: aBoolean + printCode := aBoolean! Item was added: + ----- Method: RelativeInstructionPrinter>>printInstructionsOn: (in category 'printing') ----- + printInstructionsOn: aStream + "Append to the stream, aStream, a description of each bytecode in the instruction stream." + + | label | + labelling := true. + labels := Array new: method size + 1 withAll: false. + super printInstructionsOn: (String new: 1024) writeStream. + label := 0. + labels withIndexDo: + [:bool :index| + bool ifTrue: [labels at: index put: 'L', (label := label + 1) printString]]. + labelling := false. + super printInstructionsOn: aStream! Item was added: + ----- Method: RelativeInstructionPrinter>>printInstructionsOn:do: (in category 'printing') ----- + printInstructionsOn: aStream do: aBlock + "Append to the stream, aStream, a description of each bytecode in the instruction stream. + Evaluate aBlock with the receiver, the scanner and the stream after each instruction." + + | label | + labelling := true. + labels := Array new: method size withAll: false. + super printInstructionsOn: (String new: 1024) writeStream do: [:ig :no :re|]. + label := 0. + labels withIndexDo: + [:bool :index| + bool ifTrue: [labels at: index put: 'L', (label := label + 1) printString]]. + labelling := false. + super printInstructionsOn: aStream do: aBlock! Item was added: + ----- Method: String>>withBlanksTrimmed (in category '*VMMakerCompatibilityForPharo6-converting') ----- + withBlanksTrimmed + "Return a copy of the receiver from which leading and trailing blanks have been trimmed." + + | first last | + first := self indexOfAnyOf: CharacterSet nonSeparators startingAt: 1. + first = 0 ifTrue: [ ^'' ]. "no non-separator character" + last := self lastIndexOfAnyOf: CharacterSet nonSeparators startingAt: self size ifAbsent: [self size]. + (first = 1 and: [ last = self size ]) ifTrue: [ ^self copy ]. + ^self + copyFrom: first + to: last + !

1 0

OSProcessPlugin: VMConstruction-Plugins-OSProcessPlugin.oscog-eem.58.mcz
by squeak-dev-noreply＠lists.squeakfoundation.org 21 Sep '18

21 Sep '18

Eliot Miranda uploaded a new version of VMConstruction-Plugins-OSProcessPlugin to project OSProcessPlugin: http://www.squeaksource.com/OSProcessPlugin/VMConstruction-Plugins-OSProces… ==================== Summary ==================== Name: VMConstruction-Plugins-OSProcessPlugin.oscog-eem.58 Author: eem Time: 20 September 2018, 4:45:30.928489 pm UUID: 6ddd0efa-e9d2-47db-a0b9-270bb4bc04ca Ancestors: VMConstruction-Plugins-OSProcessPlugin.oscog-eem.57 Refactor st:rn:cpy: => strncpy:_:_: et al & minor cleanups.

2 1

XDisplayControlPlugin: VMConstruction-Plugins-XDisplayControlPlugin-eem.15.mcz
by squeak-dev-noreply＠lists.squeakfoundation.org 21 Sep '18

21 Sep '18

Eliot Miranda uploaded a new version of VMConstruction-Plugins-XDisplayControlPlugin to project XDisplayControlPlugin: http://www.squeaksource.com/XDCP/VMConstruction-Plugins-XDisplayControlPlug… ==================== Summary ==================== Name: VMConstruction-Plugins-XDisplayControlPlugin-eem.15 Author: eem Time: 20 September 2018, 4:47:24.193802 pm UUID: 7274477c-7199-42c8-9948-495221a0c9fa Ancestors: VMConstruction-Plugins-XDisplayControlPlugin-dtl.14 Refactor st:rn:cpy: => strncpy:_:_:

1 0

AioPlugin: VMConstruction-Plugins-AioPlugin-eem.21.mcz
by squeak-dev-noreply＠lists.squeakfoundation.org 21 Sep '18

21 Sep '18

Eliot Miranda uploaded a new version of VMConstruction-Plugins-AioPlugin to project AioPlugin: http://www.squeaksource.com/AioPlugin/VMConstruction-Plugins-AioPlugin-eem.… ==================== Summary ==================== Name: VMConstruction-Plugins-AioPlugin-eem.21 Author: eem Time: 20 September 2018, 4:43:32.689663 pm UUID: a8437ad4-b279-498c-850a-6cc2033939dc Ancestors: VMConstruction-Plugins-AioPlugin-eem.20 Refactor st:rn:cpy: => strncpy:_:_:

1 0

VM Maker: VMMaker-eem.397.mcz
by commits＠source.squeak.org 21 Sep '18

21 Sep '18

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker-eem.397.mcz ==================== Summary ==================== Name: VMMaker-eem.397 Author: eem Time: 20 September 2018, 4:40:17.831313 pm UUID: db24f1da-c1aa-416d-8f29-d5df182e43de Ancestors: VMMaker-dtl.396 Add support for the varargs convention (good for eliminating cCode:). Port the much simplified FilePlugin/FilePluginSimulator directory primitive support from VMMaker.oscog. =============== Diff against VMMaker-dtl.396 =============== Item was changed: ----- Method: CCodeGenerator>>cFunctionNameFor: (in category 'C code generator') ----- cFunctionNameFor: aSelector "Create a C function name from the given selector by finding + a specific translation, or if none, simply omitting colons, and + any trailing underscores (this supports a varargs convention)." + ^selectorTranslations + at: aSelector + ifAbsent: + [| cSelector | + cSelector := aSelector copyWithout: $:. + [cSelector last = $_] whileTrue: + [cSelector := cSelector allButLast]. + cSelector]! - a specific translation, or if none, simply omitting colons." - ^selectorTranslations at: aSelector ifAbsent: [aSelector copyWithout: $:]! Item was changed: ----- Method: CCodeGenerator>>initializeCTranslationDictionary (in category 'C translation') ----- initializeCTranslationDictionary "Initialize the dictionary mapping message names to actions for C code generation." | pairs | translationDict := Dictionary new: 200. pairs := #( #& #generateAnd:on:indent: #| #generateOr:on:indent: #and: #generateSequentialAnd:on:indent: #or: #generateSequentialOr:on:indent: #not #generateNot:on:indent: #+ #generatePlus:on:indent: #- #generateMinus:on:indent: #negated #generateNegated:on:indent: #* #generateTimes:on:indent: #/ #generateDivide:on:indent: #// #generateDivide:on:indent: #\\ #generateModulo:on:indent: #<< #generateShiftLeft:on:indent: #>> #generateShiftRight:on:indent: #min: #generateMin:on:indent: #max: #generateMax:on:indent: #between:and: #generateBetweenAnd:on:indent: #bitAnd: #generateBitAnd:on:indent: #bitOr: #generateBitOr:on:indent: #bitXor: #generateBitXor:on:indent: #bitShift: #generateBitShift:on:indent: #signedBitShift: #generateSignedBitShift:on:indent: #bitInvert32 #generateBitInvert32:on:indent: #bitClear: #generateBitClear:on:indent: #< #generateLessThan:on:indent: #<= #generateLessThanOrEqual:on:indent: #= #generateEqual:on:indent: #> #generateGreaterThan:on:indent: #>= #generateGreaterThanOrEqual:on:indent: #~= #generateNotEqual:on:indent: #== #generateEqual:on:indent: #~~ #generateNotEqual:on:indent: #isNil #generateIsNil:on:indent: #notNil #generateNotNil:on:indent: #whileTrue: #generateWhileTrue:on:indent: #whileFalse: #generateWhileFalse:on:indent: #whileTrue #generateDoWhileTrue:on:indent: #whileFalse #generateDoWhileFalse:on:indent: #to:do: #generateToDo:on:indent: #to:by:do: #generateToByDo:on:indent: #repeat #generateRepeat:on:indent: #ifTrue: #generateIfTrue:on:indent: #ifFalse: #generateIfFalse:on:indent: #ifTrue:ifFalse: #generateIfTrueIfFalse:on:indent: #ifFalse:ifTrue: #generateIfFalseIfTrue:on:indent: #at: #generateAt:on:indent: #at:put: #generateAtPut:on:indent: #basicAt: #generateAt:on:indent: #basicAt:put: #generateAtPut:on:indent: #integerValueOf: #generateIntegerValueOf:on:indent: #integerObjectOf: #generateIntegerObjectOf:on:indent: #isIntegerObject: #generateIsIntegerObject:on:indent: #cCode: #generateInlineCCode:on:indent: #cCode:inSmalltalk: #generateInlineCCode:on:indent: #cPreprocessorDirective: #generateInlineCPreprocessorDirective:on:indent: #preprocessorExpression: #generateInlineCppDirective:on:indent: #isDefined:inSmalltalk:comment:ifTrue: #generateInlineCppIfDef:on:indent: #isDefined:inSmalltalk:comment:ifTrue:ifFalse: #generateInlineCppIfDefElse:on:indent: #isDefinedTrueExpression:inSmalltalk:comment:ifTrue:ifFalse: #generateInlineCppIfElse:on:indent: #cCoerce:to: #generateCCoercion:on:indent: #cCoerceSimple:to: #generateCCoercion:on:indent: #addressOf: #generateAddressOf:on:indent: + #addressOf:put: #generateAddressOf:on:indent: + #addressOf: #generateAddressOf:on:indent: #signedIntFromLong #generateSignedIntFromLong:on:indent: #signedIntToLong #generateSignedIntToLong:on:indent: #signedIntFromShort #generateSignedIntFromShort:on:indent: #signedIntToShort #generateSignedIntToShort:on:indent: #preIncrement #generatePreIncrement:on:indent: #preDecrement #generatePreDecrement:on:indent: #inline: #generateInlineDirective:on:indent: #asFloat #generateAsFloat:on:indent: #asInteger #generateAsInteger:on:indent: #asIntegerPtr #generateAsIntegerPtr:on:indent: #asUnsignedInteger #generateAsUnsignedInteger:on:indent: #asUnsignedIntegerPtr #generateAsUnsignedIntegerPtr:on:indent: #asLong #generateAsLong:on:indent: #asUnsignedLong #generateAsUnsignedLong:on:indent: #asUnsignedLongLong #generateAsUnsignedLongLong:on:indent: #asVoidPointer #generateAsVoidPointer:on:indent: #asSymbol #generateAsSymbol:on:indent: #flag: #generateFlag:on:indent: #anyMask: #generateBitAnd:on:indent: #raisedTo: #generateRaisedTo:on:indent: #touch: #generateTouch:on:indent: #bytesPerWord #generateBytesPerWord:on:indent: #baseHeaderSize #generateBaseHeaderSize:on:indent: #sharedCodeNamed:inCase: #generateSharedCodeDirective:on:indent: #perform: #generatePerform:on:indent: #perform:with: #generatePerform:on:indent: #perform:with:with: #generatePerform:on:indent: #perform:with:with:with: #generatePerform:on:indent: #perform:with:with:with:with: #generatePerform:on:indent: #perform:with:with:with:with:with: #generatePerform:on:indent: #value #generateValue:on:indent: #value: #generateValue:on:indent: #value:value: #generateValue:on:indent: #shouldNotImplement #generateSmalltalkMetaError:on:indent: #shouldBeImplemented #generateSmalltalkMetaError:on:indent: ). 1 to: pairs size by: 2 do: [:i | translationDict at: (pairs at: i) put: (pairs at: i + 1)]. pairs := #( #ifTrue: #generateIfTrueAsArgument:on:indent: #ifFalse: #generateIfFalseAsArgument:on:indent: #ifTrue:ifFalse: #generateIfTrueIfFalseAsArgument:on:indent: #ifFalse:ifTrue: #generateIfFalseIfTrueAsArgument:on:indent: #cCode: #generateInlineCCodeAsArgument:on:indent: #cCode:inSmalltalk: #generateInlineCCodeAsArgument:on:indent: #value #generateValueAsArgument:on:indent: #value: #generateValueAsArgument:on:indent: #value:value: #generateValueAsArgument:on:indent: ). asArgumentTranslationDict := Dictionary new: 8. 1 to: pairs size by: 2 do: [:i | asArgumentTranslationDict at: (pairs at: i) put: (pairs at: i + 1)]. ! Item was changed: ----- Method: FilePlugin>>makeDirEntryName:size:createDate:modDate:isDir:fileSize: (in category 'directory primitives') ----- makeDirEntryName: entryName size: entryNameSize createDate: createDate modDate: modifiedDate + isDir: dirFlag fileSize: fileSize + <var: 'entryName' type: #'char *'> + <var: 'fileSize' type: #squeakFileOffsetType> - isDir: dirFlag fileSize: fileSize - | modDateOop createDateOop nameString results stringPtr fileSizeOop | + <var: 'stringPtr' type: #'char *'> - <var: 'entryName' type: 'char *'> - <var: 'stringPtr' type:'char *'> - <var: 'fileSize' type:'squeakFileOffsetType '> "allocate storage for results, remapping newly allocated + oops if required in case GC happens during allocation" + results := interpreterProxy instantiateClass: interpreterProxy classArray indexableSize: 5. + self remapOop: results in: + [nameString := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: entryNameSize. + self remapOop: nameString in: + [createDateOop := interpreterProxy positive32BitIntegerFor: createDate. + self remapOop: createDateOop in: + [modDateOop := interpreterProxy positive32BitIntegerFor: modifiedDate. + self remapOop: modDateOop in: + [fileSizeOop := interpreterProxy positive64BitIntegerFor: fileSize]]]]. - oops in case GC happens during allocation" - interpreterProxy pushRemappableOop: - (interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 5). - interpreterProxy pushRemappableOop: - (interpreterProxy instantiateClass: (interpreterProxy classString) indexableSize: entryNameSize). - interpreterProxy pushRemappableOop: - (interpreterProxy positive32BitIntegerFor: createDate). - interpreterProxy pushRemappableOop: - (interpreterProxy positive32BitIntegerFor: modifiedDate). - interpreterProxy pushRemappableOop: - (interpreterProxy positive64BitIntegerFor: fileSize). - fileSizeOop := interpreterProxy popRemappableOop. - modDateOop := interpreterProxy popRemappableOop. - createDateOop := interpreterProxy popRemappableOop. - nameString := interpreterProxy popRemappableOop. - results := interpreterProxy popRemappableOop. - "copy name into Smalltalk string" stringPtr := interpreterProxy firstIndexableField: nameString. + 0 to: entryNameSize - 1 do: + [ :i | + self cCode: [stringPtr at: i put: (entryName at: i)] + inSmalltalk: [interpreterProxy storeByte: i ofObject: nameString withValue: (entryName at: i+1) asciiValue]]. - 0 to: entryNameSize - 1 do: [ :i | - stringPtr at: i put: (entryName at: i). - ]. + interpreterProxy + storePointer: 0 ofObject: results withValue: nameString; + storePointer: 1 ofObject: results withValue: createDateOop; + storePointer: 2 ofObject: results withValue: modDateOop; + storePointer: 3 ofObject: results withValue: (dirFlag + ifTrue: [interpreterProxy trueObject] + ifFalse: [interpreterProxy falseObject]); + storePointer: 4 ofObject: results withValue: fileSizeOop. + ^results! - interpreterProxy storePointer: 0 ofObject: results withValue: nameString. - interpreterProxy storePointer: 1 ofObject: results withValue: createDateOop. - interpreterProxy storePointer: 2 ofObject: results withValue: modDateOop. - dirFlag - ifTrue: [ interpreterProxy storePointer: 3 ofObject: results withValue: interpreterProxy trueObject ] - ifFalse: [ interpreterProxy storePointer: 3 ofObject: results withValue: interpreterProxy falseObject ]. - interpreterProxy storePointer: 4 ofObject: results withValue: fileSizeOop. - ^ results! Item was added: + ----- Method: FilePlugin>>primitiveDirectoryEntry (in category 'directory primitives') ----- + primitiveDirectoryEntry + + "Two arguments - directory path, and simple file name; + returns an array (see primitiveDirectoryLookup) describing the file or directory, + or nil if it does not exist. + Primitive fails if the outer path does not identify a readable directory. + (This is a lookup-by-name variant of primitiveDirectoryLookup.)" + + | requestedName pathName pathNameIndex pathNameSize status entryName entryNameSize createDate modifiedDate dirFlag posixPermissions symlinkFlag fileSize okToList reqNameIndex reqNameSize | + + <var: 'entryName' declareC: 'char entryName[256]'> + <var: 'pathNameIndex' type: 'char *'> + <var: 'reqNameIndex' type: 'char *'> + <var: 'fileSize' type: 'squeakFileOffsetType'> + <export: true> + + requestedName := interpreterProxy stackValue: 0. + pathName := interpreterProxy stackValue: 1. + (interpreterProxy isBytes: pathName) ifFalse: + [^interpreterProxy primitiveFail]. + + "Outbound string parameters" + pathNameIndex := interpreterProxy firstIndexableField: pathName. + pathNameSize := interpreterProxy byteSizeOf: pathName. + + reqNameIndex := interpreterProxy firstIndexableField: requestedName. + reqNameSize := interpreterProxy byteSizeOf: requestedName. + self cCode: '' inSmalltalk: + [entryName := ByteString new: 256. + entryNameSize := createDate := modifiedDate := dirFlag := fileSize := posixPermissions := symlinkFlag := nil]. + "If the security plugin can be loaded, use it to check for permission. + If not, assume it's ok" + okToList := sCLPfn ~= 0 + ifTrue: [self cCode: '((sqInt (*)(char *, sqInt))sCLPfn)(pathNameIndex, pathNameSize)' inSmalltalk: [true]] + ifFalse: [true]. + status := okToList + ifTrue: + [self dir_EntryLookup: pathNameIndex _: pathNameSize + _: reqNameIndex _: reqNameSize + _: entryName _: (self addressOf: entryNameSize put: [:v| entryNameSize := v]) + _: (self addressOf: createDate put: [:v| createDate := v]) + _: (self addressOf: modifiedDate put: [:v| modifiedDate := v]) + _: (self addressOf: dirFlag put: [:v| dirFlag := v]) + _: (self addressOf: fileSize put: [:v| fileSize := v]) + _: (self addressOf: posixPermissions put: [:v| posixPermissions := v]) + _: (self addressOf: symlinkFlag put: [:v| symlinkFlag := v])] + ifFalse: + [DirNoMoreEntries]. + + interpreterProxy failed ifTrue: + [^nil]. + status = DirNoMoreEntries ifTrue: "no entry; return nil" + [interpreterProxy "pop pathName, index, rcvr" + pop: 3 thenPush: interpreterProxy nilObject. + ^nil]. + status = DirBadPath ifTrue: + [^interpreterProxy primitiveFail]."bad path" + + interpreterProxy + pop: 3 "pop pathName, index, rcvr" + thenPush: (self + makeDirEntryName: entryName + size: entryNameSize + createDate: createDate + modDate: modifiedDate + isDir: dirFlag + fileSize: fileSize)! Item was changed: ----- Method: FilePlugin>>primitiveDirectoryLookup (in category 'directory primitives') ----- primitiveDirectoryLookup | index pathName pathNameIndex pathNameSize status entryName entryNameSize createDate modifiedDate dirFlag symlinkFlag posixPermissions fileSize okToList | <var: 'entryName' declareC: 'char entryName[256]'> <var: 'pathNameIndex' type: 'char *'> <var: 'fileSize' type: 'squeakFileOffsetType'> <export: true> index := interpreterProxy stackIntegerValue: 0. pathName := interpreterProxy stackValue: 1. (interpreterProxy isBytes: pathName) ifFalse: [^interpreterProxy primitiveFail]. pathNameIndex := interpreterProxy firstIndexableField: pathName. pathNameSize := interpreterProxy byteSizeOf: pathName. + self cCode: '' inSmalltalk: + [entryName := ByteString new: 256. + entryNameSize := createDate := modifiedDate := dirFlag := fileSize := posixPermissions := symlinkFlag := nil]. "If the security plugin can be loaded, use it to check for permission. If not, assume it's ok" + okToList := sCLPfn ~= 0 + ifTrue: [self cCode: '((sqInt (*)(char *, sqInt))sCLPfn)(pathNameIndex, pathNameSize)' inSmalltalk: [true]] + ifFalse: [true]. + status := okToList + ifTrue: + [self dir_Lookup: pathNameIndex _: pathNameSize + _: index + _: entryName _: (self addressOf: entryNameSize put: [:v| entryNameSize := v]) + _: (self addressOf: createDate put: [:v| createDate := v]) + _: (self addressOf: modifiedDate put: [:v| modifiedDate := v]) + _: (self addressOf: dirFlag put: [:v| dirFlag := v]) + _: (self addressOf: fileSize put: [:v| fileSize := v]) + _: (self addressOf: posixPermissions put: [:v| posixPermissions := v]) + _: (self addressOf: symlinkFlag put: [:v| symlinkFlag := v])] + ifFalse: [DirNoMoreEntries]. + interpreterProxy failed ifTrue: + [^nil]. + status = DirNoMoreEntries ifTrue: "no more entries; return nil" + [interpreterProxy "pop pathName, index, rcvr" + pop: 3 thenPush: interpreterProxy nilObject. + ^nil]. + status = DirBadPath ifTrue: + [^interpreterProxy primitiveFail]."bad path" - sCLPfn ~= 0 - ifTrue: [okToList := self cCode: '((sqInt (*)(char *, sqInt))sCLPfn)(pathNameIndex, pathNameSize)'] - ifFalse: [okToList := true]. - okToList - ifTrue: [ - self isDefined: 'PharoVM' - inSmalltalk: [ status := -1 ] - comment: 'platform support code diverged for pharo' - ifTrue: [ - status := self cCode: 'dir_Lookup(pathNameIndex, pathNameSize, index, - entryName, &entryNameSize, &createDate, - &modifiedDate, &dirFlag, &fileSize, - &posixPermissions, &symlinkFlag)' ] - ifFalse: [ - status := self cCode: 'dir_Lookup(pathNameIndex, pathNameSize, index, - entryName, &entryNameSize, &createDate, - &modifiedDate, &dirFlag, &fileSize)' ] ] - ifFalse: [status := DirNoMoreEntries]. - interpreterProxy failed - ifTrue: [^nil]. - status = DirNoMoreEntries - ifTrue: ["no more entries; return nil" - interpreterProxy pop: 3 "pop pathName, index, rcvr" - thenPush: interpreterProxy nilObject. - ^nil]. - status = DirBadPath - ifTrue: [^interpreterProxy primitiveFail]."bad path" + interpreterProxy + pop: 3 "pop pathName, index, rcvr" + thenPush:(self - self isDefined: 'PharoVM' - inSmalltalk: [ status := -1 ] - comment: 'platform support code diverged for pharo' - ifTrue: [ - interpreterProxy - pop: 3 "pop pathName, index, rcvr" - thenPush: (self - makeDirEntryName: entryName - size: entryNameSize - createDate: createDate - modDate: modifiedDate - isDir: dirFlag - fileSize: fileSize - posixPermissions: posixPermissions - isSymlink: symlinkFlag) ] - ifFalse: [ - interpreterProxy - pop: 3 "pop pathName, index, rcvr" - thenPush: (self makeDirEntryName: entryName size: entryNameSize createDate: createDate modDate: modifiedDate isDir: dirFlag + fileSize: fileSize)! - fileSize: fileSize) ]! Item was added: + ----- Method: FilePluginSimulator>>dir_EntryLookup:_:_:_:_:_:_:_:_:_:_:_: (in category 'simulation') ----- + dir_EntryLookup: pathString _: pathStringLength _: entryNameString _: entryNameStringLength _: name _: nameLength _: creationDate _: modificationDate _: isDirectory _: sizeIfFile _: posixPermissions _: isSymlink + "sqInt dir_EntryLookup(char *pathString, sqInt pathStringLength, char *nameString, sqInt nameStringLength, + /* outputs: */ char *name, sqInt *nameLength, sqInt *creationDate, sqInt *modificationDate, + sqInt *isDirectory, squeakFileOffsetType *sizeIfFile, sqInt *posixPermissions, sqInt *isSymlink)" + | result pathName entryName | + pathName := ((0 to: pathStringLength - 1) collect: [:i| (pathString at: i) asCharacter]) as: ByteString. + entryName := ((0 to: entryNameStringLength - 1) collect: [:i| (entryNameString at: i) asCharacter]) as: ByteString. + result := self primLookupEntryIn: pathName name: entryName. + result ifNil: [^DirNoMoreEntries]. + result isInteger ifTrue: + [result > 1 ifTrue: + [interpreterProxy primitiveFailFor: result]. + ^DirBadPath]. + name replaceFrom: 1 to: result first size with: result first startingAt: 1. + nameLength at: 0 put: result first size. + creationDate at: 0 put: (result at: 2). + modificationDate at: 0 put: (result at: 3). + isDirectory at: 0 put: (result at: 4). + sizeIfFile at: 0 put: (result at: 5). + posixPermissions at: 0 put: (result at: 6 ifAbsent: [(result at: 4) ifTrue: [8r755] ifFalse: [8r644]]). + isSymlink at: 0 put: (result at: 7 ifAbsent: [false]). + ^DirEntryFound! Item was added: + ----- Method: FilePluginSimulator>>dir_Lookup:_:_:_:_:_:_:_:_:_:_: (in category 'simulation') ----- + dir_Lookup: pathString _: pathStringLength _: index _: name _: nameLength _: creationDate _: modificationDate _: isDirectory _: sizeIfFile _: posixPermissions _: isSymlink + "sqInt dir_Lookup( char *pathString, sqInt pathStringLength, sqInt index, + /* outputs: */ char *name, sqInt *nameLength, sqInt *creationDate, sqInt *modificationDate, + sqInt *isDirectory, squeakFileOffsetType *sizeIfFile, sqInt * posixPermissions, sqInt *isSymlink)" + | result pathName | + pathName := ((0 to: pathStringLength - 1) collect: [:i| (pathString at: i) asCharacter]) as: ByteString. + result := self primLookupEntryIn: pathName index: index. + result ifNil: [^DirNoMoreEntries]. + result isInteger ifTrue: + [result > 1 ifTrue: + [interpreterProxy primitiveFailFor: result]. + ^DirBadPath]. + name replaceFrom: 1 to: result first size with: result first startingAt: 1. + nameLength at: 0 put: result first size. + creationDate at: 0 put: (result at: 2). + modificationDate at: 0 put: (result at: 3). + isDirectory at: 0 put: (result at: 4). + sizeIfFile at: 0 put: (result at: 5). + posixPermissions at: 0 put: (result at: 6 ifAbsent: [(result at: 4) ifTrue: [8r755] ifFalse: [8r644]]). + isSymlink at: 0 put: (result at: 7 ifAbsent: [false]). + ^DirEntryFound! Item was changed: ----- Method: FilePluginSimulator>>fileOpenName:size:write:secure: (in category 'file primitives') ----- fileOpenName: nameIndex size: nameSize write: writeFlag secure: secureFlag "Open the named file, possibly checking security. Answer the file oop." | path f index | + path := interpreterProxy asString: nameIndex size: nameSize. - path := interpreterProxy interpreter asString: nameIndex size: nameSize. f := writeFlag ifTrue: [FileStream fileNamed: path] ifFalse: [(StandardFileStream isAFileNamed: path) ifTrue: [FileStream readOnlyFileNamed: path]]. f ifNil: [^interpreterProxy primitiveFail]. f binary. index := openFiles size + 1. openFiles at: index put: f. ^interpreterProxy integerObjectOf: index! Item was changed: ----- Method: FilePluginSimulator>>fileValueOf: (in category 'simulation') ----- fileValueOf: objectPointer | index file | index := (interpreterProxy isIntegerObject: objectPointer) ifTrue: [interpreterProxy integerValueOf: objectPointer] ifFalse: [((interpreterProxy isBytes: objectPointer) and: [(interpreterProxy byteSizeOf: objectPointer) = (self sizeof: #SQFile)]) ifFalse: [interpreterProxy primitiveFail. ^nil]. interpreterProxy longAt: objectPointer + interpreterProxy baseHeaderSize]. + file := openFiles at: index ifAbsent: [ interpreterProxy primitiveFail. ^ nil ]. - file := openFiles at: index. "this attempts to preserve file positions across snapshots when debugging the VM requires saving an image in full flight and pushing it over the cliff time after time..." (file closed and: [states includesKey: file]) ifTrue: [[:pos :isBinary| file reopen; position: pos. isBinary ifTrue: [file binary]] valueWithArguments: (states at: file)]. ^file! Item was removed: - ----- Method: FilePluginSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize: (in category 'simulation') ----- - makeDirEntryName: entryName size: entryNameSize - createDate: createDate modDate: modifiedDate - isDir: dirFlag fileSize: fileSize - - ^interpreterProxy - makeDirEntryName: entryName size: entryNameSize - createDate: createDate modDate: modifiedDate - isDir: dirFlag fileSize: fileSize - ! Item was added: + ----- Method: FilePluginSimulator>>primLookupEntryIn:index: (in category 'simulation') ----- + primLookupEntryIn: fullPath index: index + "Look up the index-th entry of the directory with the given fully-qualified path (i.e., starting from the root of the file hierarchy) and return an array containing: + + <name> <creationTime> <modificationTime> <dirFlag> <fileSize> + + The empty string enumerates the top-level files or drives. (For example, on Unix, the empty path enumerates the contents of '/'. On Macs and PCs, it enumerates the mounted volumes/drives.) + + The creation and modification times are in seconds since the start of the Smalltalk time epoch. DirFlag is true if the entry is a directory. FileSize the file size in bytes or zero for directories. The primitive returns nil when index is past the end of the directory. It fails if the given path is bad." + + <primitive: 'primitiveDirectoryLookup' module: 'FilePlugin' error: ec> + ^ec isInteger + ifTrue: [ec] + ifFalse: + [Smalltalk primitiveErrorTable + indexOf: ec + ifAbsent: [Smalltalk primitiveErrorTable size + 1]]! Item was added: + ----- Method: FilePluginSimulator>>primLookupEntryIn:name: (in category 'simulation') ----- + primLookupEntryIn: fullPath name: fName + "Look up <fName> (a simple file name) in the directory identified by <fullPath> + and return an array containing: + + <fName> <creationTime> <modificationTime> <dirFlag> <fileSize> + + On Unix, the empty path denotes '/'. + On Macs and PCs, it is the container of the system volumes.) + + The creation and modification times are in seconds since the start of the Smalltalk time epoch. DirFlag is true if the entry is a directory. FileSize the file size in bytes or zero for directories. The primitive returns nil when index is past the end of the directory. It fails if the given path is bad." + + <primitive: 'primitiveDirectoryEntry' module: 'FilePlugin' error: ec> + ^ec isInteger + ifTrue: [ec] + ifFalse: + [Smalltalk primitiveErrorTable + indexOf: ec + ifAbsent: [Smalltalk primitiveErrorTable size + 1]]! Item was removed: - ----- Method: FilePluginSimulator>>primitiveDirectoryEntry (in category 'simulation') ----- - primitiveDirectoryEntry - ^interpreterProxy interpreter primitiveDirectoryEntry! Item was removed: - ----- Method: FilePluginSimulator>>primitiveDirectoryLookup (in category 'simulation') ----- - primitiveDirectoryLookup - ^interpreterProxy interpreter primitiveDirectoryLookup! Item was changed: ----- Method: FilePluginSimulator>>sqFile:Read:Into:At: (in category 'simulation') ----- + sqFile: file Read: count Into: byteArrayIndexArg At: startIndex + | byteArrayIndex | + byteArrayIndex := byteArrayIndexArg asInteger. "Coerces CArray et al correctly" - sqFile: file Read: count Into: byteArrayIndex At: startIndex - | interpreter | - interpreter := interpreterProxy interpreter. [[startIndex to: startIndex + count - 1 do: [ :i | file atEnd ifTrue: [(file isKindOf: FakeStdinStream) ifTrue: [file atEnd: false]. ^i - startIndex]. + interpreterProxy - interpreter byteAt: byteArrayIndex + i put: file next asInteger]] on: Error do: [:ex| (file isKindOf: TranscriptStream) ifFalse: [ex pass]. ^0]] ensure: [self recordStateOf: file]. ^count! Item was changed: ----- Method: FilePluginSimulator>>sqFile:Write:From:At: (in category 'simulation') ----- + sqFile: file Write: count From: byteArrayIndexArg At: startIndex + | byteArrayIndex | + byteArrayIndex := byteArrayIndexArg asInteger. "Coerces CArray et al correctly" - sqFile: file Write: count From: byteArrayIndex At: startIndex - | interpreter | - interpreter := interpreterProxy interpreter. file isBinary ifTrue: [startIndex to: startIndex + count - 1 do: + [ :i | file nextPut: (interpreterProxy byteAt: byteArrayIndex + i)]] - [ :i | file nextPut: (interpreter byteAt: byteArrayIndex + i)]] ifFalse: [startIndex to: startIndex + count - 1 do: [ :i | | byte | + byte := interpreterProxy byteAt: byteArrayIndex + i. - byte := interpreter byteAt: byteArrayIndex + i. file nextPut: (Character value: (byte == 12 "lf" ifTrue: [15"cr"] ifFalse: [byte]))]]. self recordStateOf: file. ^count! Item was changed: ----- Method: FilePluginSimulator>>sqFileDeleteName:Size: (in category 'simulation') ----- sqFileDeleteName: nameIndex Size: nameSize | path | + path := interpreterProxy asString: nameIndex size: nameSize. - path := interpreterProxy interpreter asString: nameIndex size: nameSize. (StandardFileStream isAFileNamed: path) ifFalse: [^interpreterProxy primitiveFail]. [FileDirectory deleteFilePath: path] on: Error do: [:ex| interpreterProxy primitiveFail]! Item was added: + ----- Method: Interpreter>>stackIntegerValue: (in category 'internal interpreter access') ----- + stackIntegerValue: offset + "In the StackInterpreter stacks grow down." + | integerPointer | + integerPointer := stackPages longAt: stackPointer + (offset * self bytesPerWord). + ^self checkedIntegerValueOf: integerPointer! Item was changed: ----- Method: InterpreterSimulator>>loadNewPlugin: (in category 'plugin support') ----- loadNewPlugin: pluginString | plugin plugins simulatorClasses | transcript cr; show: 'Looking for module ', pluginString. "but *why*??" (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: pluginString) ifTrue: [transcript show: ' ... defeated'. ^nil]. plugins := InterpreterPlugin allSubclasses select: [:psc| psc moduleName asString = pluginString asString]. simulatorClasses := (plugins select: [:psc| psc simulatorClass notNil] thenCollect: [:psc| psc simulatorClass]) asSet. simulatorClasses isEmpty ifTrue: [transcript show: ' ... not found'. ^nil]. simulatorClasses size > 1 ifTrue: [^self error: 'This won''t work...']. plugins size > 1 ifTrue: [transcript show: '...multiple plugin classes; choosing ', plugins last name]. plugin := simulatorClasses anyOne newFor: plugins last. "hopefully lowest in the hierarchy..." + plugin setInterpreter: objectMemory. "Ignore return value from setInterpreter" - plugin setInterpreter: self. "Ignore return value from setInterpreter" (plugin respondsTo: #initialiseModule) ifTrue: [plugin initialiseModule ifFalse: [transcript show: ' ... initialiser failed'. ^nil]]. "module initialiser failed" pluginList := pluginList copyWith: (pluginString asString -> plugin). transcript show: ' ... loaded'. ^pluginList last! Item was changed: ----- Method: InterpreterSimulator>>openAsMorph (in category 'UI') ----- openAsMorph "Open a morphic view on this simulation." | window localImageName | localImageName := FileDirectory default localNameFor: imageName. window := (SystemWindow labelled: 'Simulation of ' , localImageName) model: self. window addMorph: (displayView := ImageMorph new image: displayForm) frame: (0@0 corner: 1(a)0.8). transcript := TranscriptStream on: (String new: 10000). window addMorph: (PluggableTextMorph on: transcript text: nil accept: nil readSelection: nil menu: #codePaneMenu:shifted:) frame: (0(a)0.8 corner: 0.7@1). window addMorph: (PluggableTextMorph on: self + text: #byteCountText accept: nil) hideScrollBarsIndefinitely - text: #byteCountText accept: nil) hideScrollBarIndefinitely frame: (0.7(a)0.8 corner: 1@1). window openInWorld! Item was removed: - ----- Method: InterpreterSimulator>>primitiveDirectoryEntry (in category 'file primitives') ----- - primitiveDirectoryEntry - | name pathName array result | - name := self stringOf: self stackTop. - pathName := self stringOf: (self stackValue: 1). - - self successful ifFalse: - [^self primitiveFail]. - - array := FileDirectory default primLookupEntryIn: pathName name: name. - array == nil ifTrue: - [self pop: 3 thenPush: objectMemory nilObj. - ^array]. - array == #badDirectoryPath ifTrue: - [self halt. - ^self primitiveFail]. - array == #primFailed ifTrue: - [self halt. - ^self primitiveFail]. - - result := self makeDirEntryName: (array at: 1) size: (array at: 1) size - createDate: (array at: 2) modDate: (array at: 3) - isDir: (array at: 4) fileSize: (array at: 5). - self pop: 3. - self push: result! Item was removed: - ----- Method: InterpreterSimulator>>primitiveDirectoryLookup (in category 'file primitives') ----- - primitiveDirectoryLookup - | index pathName array result | - index := self stackIntegerValue: 0. - pathName := (self stringOf: (self stackValue: 1)). - - self successful ifFalse: [ - ^self primitiveFail. - ]. - - array := FileDirectory default primLookupEntryIn: pathName index: index. - - array == nil ifTrue: [ - self pop: 3. - self push: objectMemory nilObj. - ^array. - ]. - array == #badDirectoryPath ifTrue: [self halt. - ^self primitiveFail. - ]. - - result := self makeDirEntryName: (array at: 1) size: (array at: 1) size - createDate: (array at: 2) modDate: (array at: 3) - isDir: (array at: 4) fileSize: (array at: 5). - self pop: 3. - self push: result. - ! Item was changed: ----- Method: InterpreterSimulator>>primitiveMouseButtons (in category 'I/O primitives') ----- primitiveMouseButtons | buttons | self pop: 1. + buttons := Sensor oldPrimMouseButtons. - buttons := Sensor primMouseButtons. self pushInteger: buttons! Item was added: + ----- Method: ObjectMemory>>interpreter (in category 'accessing') ----- + interpreter + <doNotGenerate> + ^interpreter! Item was added: + ----- Method: ObjectMemorySimulator>>booleanValueOf: (in category 'simulation only') ----- + booleanValueOf: obj + "hack around the Interpreter/ObjectMemory split refactoring" + ^interpreter booleanValueOf: obj! Item was added: + ----- Method: ObjectMemorySimulator>>failed (in category 'simulation only') ----- + failed + "hack around the Interpreter/ObjectMemory split refactoring" + ^interpreter failed! Item was added: + ----- Method: ObjectMemorySimulator>>ioLoadFunction:From: (in category 'simulation only') ----- + ioLoadFunction: functionName From: moduleName + "hack around the Interpreter/ObjectMemory split refactoring. + provide accurate types for the VMPluginCodeGenerator." + <returnTypeC: #'void *'> + <var: #functionName type: #'char *'> + <var: #moduleName type: #'char *'> + ^interpreter ioLoadFunction: functionName From: moduleName! Item was added: + ----- Method: ObjectMemorySimulator>>pop: (in category 'simulation only') ----- + pop: nItems + "hack around the Interpreter/ObjectMemory split refactoring" + ^interpreter pop: nItems! Item was added: + ----- Method: ObjectMemorySimulator>>pop:thenPush: (in category 'simulation only') ----- + pop: nItems thenPush: oop + "hack around the Interpreter/ObjectMemory split refactoring" + ^interpreter pop: nItems thenPush: oop! Item was added: + ----- Method: ObjectMemorySimulator>>positive32BitIntegerFor: (in category 'simulation only') ----- + positive32BitIntegerFor: integerValue + "hack around the Interpreter/ObjectMemory split refactoring" + ^interpreter positive32BitIntegerFor: integerValue! Item was added: + ----- Method: ObjectMemorySimulator>>positive32BitValueOf: (in category 'simulation only') ----- + positive32BitValueOf: oop + "hack around the Interpreter/ObjectMemory split refactoring" + ^interpreter positive32BitValueOf: oop! Item was added: + ----- Method: ObjectMemorySimulator>>positive64BitIntegerFor: (in category 'simulation only') ----- + positive64BitIntegerFor: integerValue + "hack around the Interpreter/ObjectMemory split refactoring" + ^interpreter positive64BitIntegerFor: integerValue! Item was added: + ----- Method: ObjectMemorySimulator>>positive64BitValueOf: (in category 'simulation only') ----- + positive64BitValueOf: oop + "hack around the Interpreter/ObjectMemory split refactoring" + ^interpreter positive64BitValueOf: oop! Item was added: + ----- Method: ObjectMemorySimulator>>primitiveFail (in category 'simulation only') ----- + primitiveFail + "hack around the Interpreter/ObjectMemory split refactoring" + ^interpreter primitiveFail! Item was added: + ----- Method: ObjectMemorySimulator>>stackFloatValue: (in category 'simulation only') ----- + stackFloatValue: offset + "hack around the Interpreter/ObjectMemory split refactoring" + ^Interpreter stackFloatValue: offset! Item was added: + ----- Method: ObjectMemorySimulator>>stackIntegerValue: (in category 'simulation only') ----- + stackIntegerValue: offset + "hack around the Interpreter/ObjectMemory split refactoring" + ^interpreter stackIntegerValue: offset! Item was added: + ----- Method: ObjectMemorySimulator>>stackObjectValue: (in category 'simulation only') ----- + stackObjectValue: offset + "hack around the Interpreter/ObjectMemory split refactoring" + ^Interpreter stackObjectValue: offset! Item was added: + ----- Method: ObjectMemorySimulator>>stackValue: (in category 'simulation only') ----- + stackValue: offset + "hack around the Interpreter/ObjectMemory split refactoring" + ^interpreter stackValue: offset! Item was removed: - ----- Method: StackInterpreterSimulator>>primitiveDirectoryEntry (in category 'file primitives') ----- - primitiveDirectoryEntry - | name pathName array result | - name := self stringOf: self stackTop. - pathName := self stringOf: (self stackValue: 1). - - self successful ifFalse: - [^self primitiveFail]. - - array := FileDirectory default primLookupEntryIn: pathName name: name. - array == nil ifTrue: - [self pop: 3 thenPush: objectMemory nilObject. - ^array]. - array == #badDirectoryPath ifTrue: - [self halt. - ^self primitiveFail]. - - result := self makeDirEntryName: (array at: 1) size: (array at: 1) size - createDate: (array at: 2) modDate: (array at: 3) - isDir: (array at: 4) fileSize: (array at: 5). - self pop: 3. - self push: result! Item was removed: - ----- Method: StackInterpreterSimulator>>primitiveDirectoryLookup (in category 'file primitives') ----- - primitiveDirectoryLookup - | index pathName array result | - index := self stackIntegerValue: 0. - pathName := (self stringOf: (self stackValue: 1)). - - self successful ifFalse: - [^self primitiveFail]. - - array := FileDirectory default primLookupEntryIn: pathName index: index. - - array == nil ifTrue: - [self pop: 3 thenPush: objectMemory nilObject. - ^array]. - array == #badDirectoryPath ifTrue: - ["self halt." - ^self primitiveFail]. - - result := self makeDirEntryName: (array at: 1) size: (array at: 1) size - createDate: (array at: 2) modDate: (array at: 3) - isDir: (array at: 4) fileSize: (array at: 5). - self pop: 3 thenPush: result! Item was added: + ----- Method: VMClass>>addressOf: (in category 'translation support') ----- + addressOf: anObject + <doNotGenerate> + "Translates into &anObject in C." + ^anObject! Item was added: + ----- Method: VMClass>>addressOf:put: (in category 'translation support') ----- + addressOf: anObject put: aBlock + <doNotGenerate> + "Simulate a C pointer. Translates into &anObject in C. Provides something + that evaluates aBlock with the new value in response to at:put:" + | thing | + thing := anObject. + ^CPluggableAccessor new + setObject: nil; + atBlock: [:obj :idx| thing] + atPutBlock: [:obj :idx :val| aBlock value: (thing := val)]! Item was added: + ----- Method: VMClass>>asString:size: (in category 'C library extensions') ----- + asString: stringIndex size: stringSize + "stringIndex is an address in the heap. Create a String of the requested length + form the bytes in the heap starting at stringIndex." + <doNotGenerate> + ^self strncpy: (ByteString new: stringSize) _: stringIndex _: stringSize! Item was added: + ----- Method: VMClass>>strncpy:_:_: (in category 'C library simulation') ----- + strncpy: aString _: bString _: n + <doNotGenerate> + "implementation of strncpy(3)" + aString isString + ifTrue: + [1 to: n do: + [:i| | v | + v := bString isString + ifTrue: [bString at: i] + ifFalse: [Character value: (self byteAt: bString + i - 1)]. + aString at: i put: v. + v asInteger = 0 ifTrue: [^aString]]] + ifFalse: + [1 to: n do: + [:i| | v | + v := bString isString + ifTrue: [(bString at: i) asInteger] + ifFalse: [self byteAt: bString + i - 1]. + self byteAt: aString + i - 1 put: v. + v = 0 ifTrue: [^aString]]]. + ^aString!

1 0

slides with a bit about the OpenSmalltalk VM
by Jecel Assumpcao Jr. 20 Sep '18

20 Sep '18

Today I talked about this history of Smalltalk and Smalltalk hardware. the Self VM and the OpenSmalltalk VM at the meeting about the J Extension (dynamic languages) for the RISC-V standard. Since the last part is about OpenSmalltalk I thought some people here might be interested. The slides are in OpenOffice (6.5MB) and PDF (2.3MB) formats, but two of the slides are a bit messed up in PDF due to the lack of animation. http://www.merlintec.com/download/self_opensmalltalk_vm.odp http://www.merlintec.com/download/self_opensmalltalk_vm.pdf A good starting point for information about RISC-V is https://riscv.org/ -- Jecel

2 1

VM Maker: VMMaker.oscog-eem.2444.mcz
by commits＠source.squeak.org 20 Sep '18

20 Sep '18

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2444.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.2444 Author: eem Time: 20 September 2018, 12:08:29.869065 pm UUID: 426a03e8-1520-44fa-864a-99bc5302d545 Ancestors: VMMaker.oscog-eem.2443 Eliminate cCode: usage in the B3DAcceleratorPlugin and HostWindowPlugin usign the new "var args" style. Rewrite mem:mo:ve: et al in the new style. Fix TMethod>>statementsFor:varName: for Pharo. =============== Diff against VMMaker.oscog-eem.2443 =============== Item was changed: ----- Method: B3DAcceleratorPlugin>>primitiveClearDepthBuffer (in category 'primitives-renderer') ----- primitiveClearDepthBuffer + | handle | - | result handle | <export: true> + interpreterProxy methodArgumentCount = 1 ifFalse: + [^interpreterProxy primitiveFail]. - interpreterProxy methodArgumentCount = 1 - ifFalse:[^interpreterProxy primitiveFail]. handle := interpreterProxy stackIntegerValue: 0. + interpreterProxy failed ifFalse: + [(self b3dxClearDepthBuffer: handle) + ifTrue: [interpreterProxy pop: 1] "pop args; return rcvr" + ifFalse:[interpreterProxy primitiveFail]]! - interpreterProxy failed ifTrue:[^nil]. - result := self cCode:'b3dxClearDepthBuffer(handle)'. - result ifFalse:[^interpreterProxy primitiveFail]. - ^interpreterProxy pop: 1. "pop args; return rcvr"! Item was changed: ----- Method: B3DAcceleratorPlugin>>primitiveClearViewport (in category 'primitives-renderer') ----- primitiveClearViewport + | handle pv rgba | - | result handle pv rgba | <export: true> + interpreterProxy methodArgumentCount = 3 ifFalse: + [^interpreterProxy primitiveFail]. - interpreterProxy methodArgumentCount = 3 - ifFalse:[^interpreterProxy primitiveFail]. pv := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0). rgba := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1). handle := interpreterProxy stackIntegerValue: 2. interpreterProxy failed ifTrue:[^nil]. + (self b3dxClearViewport: handle _: rgba _: pv) + ifTrue: [interpreterProxy pop: 3] "pop args; return rcvr" + ifFalse:[interpreterProxy primitiveFail]! - result := self cCode:'b3dxClearViewport(handle, rgba, pv)'. - result ifFalse:[^interpreterProxy primitiveFail]. - ^interpreterProxy pop: 3. "pop args; return rcvr"! Item was changed: ----- Method: B3DAcceleratorPlugin>>primitiveCreateRenderer (in category 'primitives-renderer') ----- primitiveCreateRenderer "NOTE: This primitive is obsolete but should be supported for older images" | h w y x result allowHardware allowSoftware | <export: true> + interpreterProxy methodArgumentCount = 6 ifFalse: + [^interpreterProxy primitiveFail]. - interpreterProxy methodArgumentCount = 6 - ifFalse:[^interpreterProxy primitiveFail]. h := interpreterProxy stackIntegerValue: 0. w := interpreterProxy stackIntegerValue: 1. y := interpreterProxy stackIntegerValue: 2. x := interpreterProxy stackIntegerValue: 3. allowHardware := interpreterProxy booleanValueOf: (interpreterProxy stackValue: 4). allowSoftware := interpreterProxy booleanValueOf: (interpreterProxy stackValue: 5). + interpreterProxy failed ifFalse: + [(self b3dxCreateRenderer: allowSoftware _: allowHardware _: x _: y _: w _: h) >= 0 + ifTrue: [interpreterProxy methodReturnInteger: result] + ifFalse: [interpreterProxy primitiveFail]]! - interpreterProxy failed ifTrue:[^nil]. - result := self cCode:'b3dxCreateRenderer(allowSoftware, allowHardware, x, y, w, h)'. - result < 0 ifTrue:[^interpreterProxy primitiveFail]. - interpreterProxy pop: 7. - ^interpreterProxy pushInteger: result.! Item was changed: ----- Method: B3DAcceleratorPlugin>>primitiveCreateRendererFlags (in category 'primitives-renderer') ----- primitiveCreateRendererFlags | flags h w y x result | <export: true> + interpreterProxy methodArgumentCount = 5 ifFalse: + [^interpreterProxy primitiveFail]. - interpreterProxy methodArgumentCount = 5 - ifFalse:[^interpreterProxy primitiveFail]. h := interpreterProxy stackIntegerValue: 0. w := interpreterProxy stackIntegerValue: 1. y := interpreterProxy stackIntegerValue: 2. x := interpreterProxy stackIntegerValue: 3. flags := interpreterProxy stackIntegerValue: 4. + interpreterProxy failed ifFalse: + [(self b3dxCreateRendererFlags: x _: y _: w _: h _: flags) >= 0 + ifTrue: [interpreterProxy methodReturnInteger: result] + ifFalse: [interpreterProxy primitiveFail]]! - interpreterProxy failed ifTrue:[^nil]. - result := self cCode:'b3dxCreateRendererFlags(x, y, w, h, flags)'. - result < 0 ifTrue:[^interpreterProxy primitiveFail]. - interpreterProxy pop: 6. - ^interpreterProxy pushInteger: result.! Item was changed: ----- Method: B3DAcceleratorPlugin>>primitiveGetIntProperty (in category 'primitives-renderer') ----- primitiveGetIntProperty | handle prop result | <export: true> + interpreterProxy methodArgumentCount = 2 ifFalse: + [^interpreterProxy primitiveFail]. - <inline: false> - interpreterProxy methodArgumentCount = 2 - ifFalse:[^interpreterProxy primitiveFail]. prop := interpreterProxy stackIntegerValue: 0. handle := interpreterProxy stackIntegerValue: 1. + result := self b3dxGetIntProperty: handle _: prop. + interpreterProxy methodReturnInteger: result! - result := self cCode:'b3dxGetIntProperty(handle, prop)'. - interpreterProxy pop: 3. "args+rcvr" - ^interpreterProxy pushInteger: result! Item was changed: ----- Method: B3DAcceleratorPlugin>>primitiveSetBufferRect (in category 'primitives-renderer') ----- primitiveSetBufferRect "Primitive. Set the buffer rectangle (e.g., the pixel area on screen) to use for this renderer. The viewport is positioned within the buffer rectangle." + | h w y x handle | - | h w y x result handle | <export: true> + interpreterProxy methodArgumentCount = 5 ifFalse: + [^interpreterProxy primitiveFail]. - interpreterProxy methodArgumentCount = 5 - ifFalse:[^interpreterProxy primitiveFail]. h := interpreterProxy stackIntegerValue: 0. w := interpreterProxy stackIntegerValue: 1. y := interpreterProxy stackIntegerValue: 2. x := interpreterProxy stackIntegerValue: 3. handle := interpreterProxy stackIntegerValue: 4. + interpreterProxy failed ifFalse: + [(self b3dxSetBufferRect: handle _: x _: y _: w _: h) + ifTrue: [interpreterProxy pop: 5] "pop args; return rcvr" + ifFalse:[interpreterProxy primitiveFail]]! - interpreterProxy failed ifTrue:[^nil]. - result := self cCode:'b3dxSetBufferRect(handle, x, y, w, h)'. - result ifFalse:[^interpreterProxy primitiveFail]. - ^interpreterProxy pop: 5. "pop args; return rcvr"! Item was changed: ----- Method: B3DAcceleratorPlugin>>primitiveSetFog (in category 'primitives-renderer') ----- primitiveSetFog + | handle rgba density fogType stop start | - | result handle rgba density fogType stop start | <export: true> + <var: #density type: #double> + <var: #start type: #double> + <var: #stop type: #double> + interpreterProxy methodArgumentCount = 6 ifFalse: + [^interpreterProxy primitiveFail]. - <var: #density type:'double'> - <var: #start type: 'double'> - <var: #stop type: 'double'> - interpreterProxy methodArgumentCount = 6 - ifFalse:[^interpreterProxy primitiveFail]. rgba := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0). stop := interpreterProxy floatValueOf: (interpreterProxy stackValue: 1). start := interpreterProxy floatValueOf: (interpreterProxy stackValue: 2). density := interpreterProxy floatValueOf: (interpreterProxy stackValue: 3). fogType := interpreterProxy stackIntegerValue: 4. handle := interpreterProxy stackIntegerValue: 5. + interpreterProxy failed ifFalse: + [(self b3dxSetFog: handle _: fogType _: density _: start _: stop _: rgba) + ifTrue: [interpreterProxy pop: 6] "pop args; return rcvr" + ifFalse:[interpreterProxy primitiveFail]]! - interpreterProxy failed ifTrue:[^nil]. - result := self cCode:'b3dxSetFog(handle, fogType, density, start, stop, rgba)'. - result ifFalse:[^interpreterProxy primitiveFail]. - ^interpreterProxy pop: 6. "pop args; return rcvr"! Item was changed: ----- Method: B3DAcceleratorPlugin>>primitiveSetIntProperty (in category 'primitives-renderer') ----- primitiveSetIntProperty + | handle prop value | - | handle prop result value | <export: true> + interpreterProxy methodArgumentCount = 3 ifFalse: + [^interpreterProxy primitiveFail]. - <inline: false> - interpreterProxy methodArgumentCount = 3 - ifFalse:[^interpreterProxy primitiveFail]. value := interpreterProxy stackIntegerValue: 0. prop := interpreterProxy stackIntegerValue: 1. handle := interpreterProxy stackIntegerValue: 2. + (self b3dxSetIntProperty: handle _: prop _: value) + ifTrue: [interpreterProxy pop: 3] "args; return rcvr" + ifFalse: [interpreterProxy primitiveFail] - result := self cCode:'b3dxSetIntProperty(handle, prop, value)'. - result ifFalse:[^interpreterProxy primitiveFail]. - ^interpreterProxy pop: 3. "args; return rcvr" ! Item was changed: ----- Method: B3DAcceleratorPlugin>>primitiveSetTransform (in category 'primitives-renderer') ----- primitiveSetTransform "Transform an entire vertex buffer using the supplied modelview and projection matrix." | projectionMatrix modelViewMatrix handle | <export: true> + <var: #projectionMatrix type: #'float *'> + <var: #modelViewMatrix type: #'float *'> - <inline: false> - <var: #projectionMatrix declareC:'float *projectionMatrix'> - <var: #modelViewMatrix declareC:'float *modelViewMatrix'> + interpreterProxy methodArgumentCount = 3 ifFalse: + [^interpreterProxy primitiveFail]. - interpreterProxy methodArgumentCount = 3 - ifFalse:[^interpreterProxy primitiveFail]. - projectionMatrix := self stackMatrix: 0. modelViewMatrix := self stackMatrix: 1. handle := interpreterProxy stackIntegerValue: 2. + interpreterProxy failed ifFalse: + [self b3dxSetTransform: handle _: modelViewMatrix _: projectionMatrix. + interpreterProxy pop: 3] "Leave rcvr on stack"! - interpreterProxy failed ifTrue:[^nil]. - self cCode: 'b3dxSetTransform(handle, modelViewMatrix, projectionMatrix)'. - ^interpreterProxy pop: 3. "Leave rcvr on stack"! Item was changed: ----- Method: B3DAcceleratorPlugin>>primitiveSetVerboseLevel (in category 'primitives-renderer') ----- primitiveSetVerboseLevel | result level | <export: true> + interpreterProxy methodArgumentCount = 1 ifFalse: + [^interpreterProxy primitiveFail]. - <inline: false> - interpreterProxy methodArgumentCount = 1 - ifFalse:[^interpreterProxy primitiveFail]. level := interpreterProxy stackIntegerValue: 0. + result := self b3dxSetVerboseLevel: level. + interpreterProxy methodReturnInteger: result! - result := self cCode:'b3dxSetVerboseLevel(level)'. - interpreterProxy pop: 2. "args+rcvr" - ^interpreterProxy pushInteger: result! Item was changed: ----- Method: B3DAcceleratorPlugin>>primitiveSetViewport (in category 'primitives-renderer') ----- primitiveSetViewport + | h w y x handle | - | h w y x result handle | <export: true> + interpreterProxy methodArgumentCount = 5 ifFalse: + [^interpreterProxy primitiveFail]. - interpreterProxy methodArgumentCount = 5 - ifFalse:[^interpreterProxy primitiveFail]. h := interpreterProxy stackIntegerValue: 0. w := interpreterProxy stackIntegerValue: 1. y := interpreterProxy stackIntegerValue: 2. x := interpreterProxy stackIntegerValue: 3. handle := interpreterProxy stackIntegerValue: 4. + interpreterProxy failed ifFalse: + [(self b3dxSetViewport: handle _: x _: y _: w _: h) + ifTrue: [interpreterProxy pop: 5] "pop args; return rcvr" + ifFalse:[interpreterProxy primitiveFail]]! - interpreterProxy failed ifTrue:[^nil]. - result := self cCode:'b3dxSetViewport(handle, x, y, w, h)'. - result ifFalse:[^interpreterProxy primitiveFail]. - ^interpreterProxy pop: 5. "pop args; return rcvr"! Item was changed: ----- Method: CoInterpreter>>callbackEnter: (in category 'callback support') ----- callbackEnter: callbackID "Re-enter the interpreter for executing a callback" | currentCStackPointer currentCFramePointer savedReenterInterpreter wasInMachineCode calledFromMachineCode | <volatile> <export: true> <var: #currentCStackPointer type: #'void *'> <var: #currentCFramePointer type: #'void *'> <var: #callbackID type: #'sqInt *'> <var: #savedReenterInterpreter type: #'jmp_buf'> "For now, do not allow a callback unless we're in a primitiveResponse" (self asserta: primitiveFunctionPointer ~= 0) ifFalse: [^false]. self assert: primFailCode = 0. "Check if we've exceeded the callback depth" (self asserta: jmpDepth < MaxJumpBuf) ifFalse: [^false]. jmpDepth := jmpDepth + 1. wasInMachineCode := self isMachineCodeFrame: framePointer. calledFromMachineCode := instructionPointer <= objectMemory startOfMemory. "Suspend the currently active process" suspendedCallbacks at: jmpDepth put: self activeProcess. "We need to preserve newMethod explicitly since it is not activated yet and therefore no context has been created for it. If the caller primitive for any reason decides to fail we need to make sure we execute the correct method and not the one 'last used' in the call back" suspendedMethods at: jmpDepth put: newMethod. self flag: 'need to debug this properly. Conceptually it is the right thing to do but it crashes in practice'. false ifTrue: ["Signal external semaphores since a signalSemaphoreWithIndex: request may have been issued immediately prior to this callback before the VM has any chance to do a signalExternalSemaphores in checkForEventsMayContextSwitch:" self signalExternalSemaphores. "If no process is awakened by signalExternalSemaphores then transfer to the highest priority runnable one." (suspendedCallbacks at: jmpDepth) = self activeProcess ifTrue: [self transferTo: self wakeHighestPriority from: CSCallbackLeave]] ifFalse: [self transferTo: self wakeHighestPriority from: CSCallbackLeave]. "Typically, invoking the callback means that some semaphore has been signaled to indicate the callback. Force an interrupt check as soon as possible." self forceInterruptCheck. "Save the previous CStackPointers and interpreter entry jmp_buf." currentCStackPointer := cogit getCStackPointer. currentCFramePointer := cogit getCFramePointer. + self memcpy: savedReenterInterpreter asVoidPointer + _: reenterInterpreter + _: (self sizeof: #'jmp_buf'). - self mem: savedReenterInterpreter asVoidPointer - cp: reenterInterpreter - y: (self sizeof: #'jmp_buf'). cogit assertCStackWellAligned. (self setjmp: (jmpBuf at: jmpDepth)) = 0 ifTrue: "Fill in callbackID" [callbackID at: 0 put: jmpDepth. self enterSmalltalkExecutive. self assert: false "NOTREACHED"]. "Restore the previous CStackPointers and interpreter entry jmp_buf." cogit setCStackPointer: currentCStackPointer. cogit setCFramePointer: currentCFramePointer. + self memcpy: reenterInterpreter + _: (self cCoerceSimple: savedReenterInterpreter to: #'void *') + _: (self sizeof: #'jmp_buf'). - self mem: reenterInterpreter - cp: (self cCoerceSimple: savedReenterInterpreter to: #'void *') - y: (self sizeof: #'jmp_buf'). "Transfer back to the previous process so that caller can push result" self putToSleep: self activeProcess yieldingIf: preemptionYields. self transferTo: (suspendedCallbacks at: jmpDepth) from: CSCallbackLeave. newMethod := suspendedMethods at: jmpDepth. "see comment above" argumentCount := self argumentCountOf: newMethod. self assert: wasInMachineCode = (self isMachineCodeFrame: framePointer). calledFromMachineCode ifTrue: [instructionPointer asUnsignedInteger >= objectMemory startOfMemory ifTrue: [self iframeSavedIP: framePointer put: instructionPointer. instructionPointer := cogit ceReturnToInterpreterPC]] ifFalse: ["Even if the context was flushed to the heap and rebuilt in transferTo:from: above it will remain an interpreted frame because the context's pc would remain a bytecode pc. So the instructionPointer must also be a bytecode pc." self assert: (self isMachineCodeFrame: framePointer) not. self assert: instructionPointer > objectMemory startOfMemory]. self assert: primFailCode = 0. jmpDepth := jmpDepth-1. ^true! Item was changed: ----- Method: CoInterpreter>>restoreCStackStateForCallbackContext: (in category 'callback support') ----- restoreCStackStateForCallbackContext: vmCallbackContext <var: #vmCallbackContext type: #'VMCallbackContext *'> cogit setCStackPointer: vmCallbackContext savedCStackPointer; setCFramePointer: vmCallbackContext savedCFramePointer. + self memcpy: reenterInterpreter + _: vmCallbackContext savedReenterInterpreter asVoidPointer + _: (self sizeof: #'jmp_buf')! - self mem: reenterInterpreter - cp: vmCallbackContext savedReenterInterpreter asVoidPointer - y: (self sizeof: #'jmp_buf')! Item was changed: ----- Method: CoInterpreterMT>>ownVM: (in category 'vm scheduling') ----- ownVM: threadIndexAndFlags <api> <inline: false> "This is the entry-point for plugins and primitives that wish to reacquire the VM after having released it via disownVM or callbacks that want to acquire it without knowing their ownership status. This call will block until the VM is owned by the current thread or an error occurs. The argument should be the value answered by disownVM, or 0 for callbacks that don't know if they have disowned or not. This is both an optimization to avoid having to query thread- local storage for the current thread's index (since it can easily keep it in some local variable), and a record of when an unbound process becomes affined to a thread for the dynamic extent of some operation. Answer 0 if the current thread is known to the VM. Answer 1 if the current thread is unknown to the VM and takes ownership. Answer -1 if the current thread is unknown to the VM and fails to take ownership." | threadIndex flags vmThread myProc activeProc sched | <var: #vmThread type: #'CogVMThread *'> threadIndexAndFlags = 0 ifTrue: [^self ownVMFromUnidentifiedThread]. threadIndex := threadIndexAndFlags bitAnd: ThreadIdMask. flags := threadIndexAndFlags >> DisownFlagsShift. (flags anyMask: DisownVMForProcessorRelinquish) ifTrue: [relinquishing := false. self sqLowLevelMFence]. (threadIndexAndFlags anyMask: LockGUIThreadFlag) ifTrue: [self assert: (noThreadingOfGUIThread and: [self inGUIThread]). self assert: disowningVMThread = nil. (flags anyMask: DisownVMLockOutFullGC) ifTrue: [objectMemory decrementFullGCLock]. cogit recordEventTrace ifTrue: [self recordTrace: TraceOwnVM thing: ConstZero source: 0]. ^0]. vmThread := cogThreadManager acquireVMFor: threadIndex. disownCount := disownCount - 1. (flags anyMask: DisownVMLockOutFullGC) ifTrue: [objectMemory decrementFullGCLock]. disowningVMThread notNil ifTrue: [vmThread = disowningVMThread ifTrue: [self cCode: '' inSmalltalk: [| range | range := self cStackRangeForThreadIndex: threadIndex. self assert: (range includes: cogit getCStackPointer). self assert: (range includes: cogit getCFramePointer)]. self assert: self successful. self assert: (objectMemory fetchPointer: MyListIndex ofObject: self activeProcess) = objectMemory nilObject. disowningVMThread := nil. cogit recordEventTrace ifTrue: [self recordTrace: TraceOwnVM thing: ConstOne source: 0]. ^0]. "if not preempted we're done." self preemptDisowningThread]. "We've been preempted; we must restore state and update the threadId in our process, and may have to put the active process to sleep." sched := self schedulerPointer. activeProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched. (threadIndexAndFlags anyMask: OwnVMForeignThreadFlag) ifTrue: [self assert: foreignCallbackProcessSlot == ForeignCallbackProcess. myProc := objectMemory splObj: foreignCallbackProcessSlot. self assert: myProc ~= objectMemory nilObject. objectMemory splObj: foreignCallbackProcessSlot put: objectMemory nilObject] ifFalse: [myProc := cogThreadManager popAWOLProcess: vmThread]. self assert: activeProc ~= myProc. (activeProc ~= objectMemory nilObject and: [(objectMemory fetchPointer: MyListIndex ofObject: activeProc) = objectMemory nilObject]) ifTrue: [self putToSleep: activeProc yieldingIf: preemptionYields]. self assert: (objectMemory fetchPointer: MyListIndex ofObject: myProc) = (objectMemory splObj: ProcessInExternalCodeTag). objectMemory storePointer: ActiveProcessIndex ofObject: sched withValue: myProc; storePointerUnchecked: MyListIndex ofObject: myProc withValue: objectMemory nilObject. "Only unaffine if the process was affined at this level and did not become bound in the interim." ((threadIndexAndFlags anyMask: ProcessUnaffinedOnDisown) and: [(self isBoundProcess: myProc) not]) ifTrue: [self setOwnerIndexOfProcess: myProc to: 0 bind: false]. self initPrimCall. self externalSetStackPageAndPointersForSuspendedContextOfProcess: myProc. "If this primitive is called from machine code maintain the invariant that the return pc of an interpreter callee calling a machine code caller is ceReturnToInterpreterPC." (vmThread inMachineCode and: [instructionPointer >= objectMemory startOfMemory]) ifTrue: [self iframeSavedIP: framePointer put: instructionPointer. instructionPointer := cogit ceReturnToInterpreterPC]. newMethod := vmThread newMethodOrNull. argumentCount := vmThread argumentCount. self cCode: + [self memcpy: reenterInterpreter + _: vmThread reenterInterpreter + _: (self sizeof: #'jmp_buf')] - [self mem: reenterInterpreter - cp: vmThread reenterInterpreter - y: (self sizeof: #'jmp_buf')] inSmalltalk: [reenterInterpreter := vmThread reenterInterpreter]. vmThread newMethodOrNull: nil. self cCode: '' inSmalltalk: [| range | range := self cStackRangeForThreadIndex: threadIndex. self assert: (range includes: vmThread cStackPointer). self assert: (range includes: vmThread cFramePointer)]. cogit setCStackPointer: vmThread cStackPointer. cogit setCFramePointer: vmThread cFramePointer. self assert: newMethod ~~ nil. cogit recordEventTrace ifTrue: [self recordTrace: TraceOwnVM thing: ConstTwo source: 0]. ^threadIndexAndFlags bitAnd: OwnVMForeignThreadFlag! Item was changed: ----- Method: CoInterpreterMT>>preemptDisowningThread (in category 'vm scheduling') ----- preemptDisowningThread "Set the relevant state for disowningVMThread so that it can resume after being preempted and set disowningVMThread to nil to indicate preemption. N.B. This should only be sent from checkPreemptionOfDisowningThread. There are essentially four things to do. a) save the VM's notion of the current C stack pointers; these are pointers into a thread's stack and must be saved and restored in thread switch. b) save the VM's notion of the current Smalltalk execution point. This is simply the suspend half of a process switch that saves the current context in the current process. c) add the process to the thread's set of AWOL processes so that the scheduler won't try to run the process while the thread has disowned the VM. d) save the in-primitive VM state, newMethod and argumentCount ownVM: will restore the VM context as of disownVM: from the above when it finds it has been preempted." | activeProc activeContext preemptedThread | <var: #preemptedThread type: #'CogVMThread *'> <inline: false> self assert: disowningVMThread notNil. self assert: (disowningVMThread state = CTMUnavailable or: [disowningVMThread state = CTMWantingOwnership]). self cCode: '' inSmalltalk: [| range | range := self cStackRangeForThreadIndex: disowningVMThread index. self assert: (range includes: cogit getCStackPointer). self assert: (range includes: cogit getCFramePointer)]. cogit recordEventTrace ifTrue: [self recordTrace: TracePreemptDisowningThread thing: (objectMemory integerObjectOf: disowningVMThread index) source: 0]. disowningVMThread cStackPointer: cogit getCStackPointer. disowningVMThread cFramePointer: cogit getCFramePointer. activeProc := self activeProcess. self assert: (objectMemory fetchPointer: MyListIndex ofObject: activeProc) = objectMemory nilObject. objectMemory storePointer: MyListIndex ofObject: activeProc withValue: (objectMemory splObj: ProcessInExternalCodeTag). "The instructionPointer must be pushed because the convention for inactive stack pages is that the instructionPointer is top of stack. We need to know if this primitive is called from machine code because the invariant that the return pc of an interpreter callee calling a machine code caller is ceReturnToInterpreterPC must be maintained." self push: instructionPointer. self externalWriteBackHeadFramePointers. activeContext := self ensureFrameIsMarried: framePointer SP: stackPointer. objectMemory storePointer: SuspendedContextIndex ofObject: activeProc withValue: activeContext. "Since pushing the awol process may realloc disowningVMThread we need to reassign. But since we're going to nil disowningVMThread anyway we can assign to a local." preemptedThread := cogThreadManager pushAWOLProcess: activeProc on: disowningVMThread. disowningVMThread := nil. preemptedThread priority: (self quickFetchInteger: PriorityIndex ofObject: activeProc). (self ownerIndexOfProcess: activeProc) = 0 ifTrue: [self setOwnerIndexOfProcess: activeProc to: preemptedThread index bind: false] ifFalse: [self assert: (self ownerIndexOfProcess: activeProc) = preemptedThread index]. preemptedThread newMethodOrNull: newMethod; argumentCount: argumentCount; inMachineCode: instructionPointer asUnsignedInteger <= objectMemory startOfMemory. self cCode: + [self memcpy: preemptedThread reenterInterpreter + _: reenterInterpreter + _: (self sizeof: #'jmp_buf')] - [self mem: preemptedThread reenterInterpreter - cp: reenterInterpreter - y: (self sizeof: #'jmp_buf')] inSmalltalk: [preemptedThread reenterInterpreter: reenterInterpreter]! Item was changed: ----- Method: CoInterpreterMT>>primitiveRelinquishProcessor (in category 'I/O primitives') ----- primitiveRelinquishProcessor "Relinquish the processor for up to the given number of microseconds. The exact behavior of this primitive is platform dependent. Override to check for waiting threads." | microSecs threadIndexAndFlags currentCStackPointer currentCFramePointer savedReenterInterpreter | <var: #currentCStackPointer type: #'void *'> <var: #currentCFramePointer type: #'void *'> <var: #savedReenterInterpreter type: #'jmp_buf'> microSecs := self stackTop. (objectMemory isIntegerObject: microSecs) ifFalse: [^self primitiveFail]. self assert: (objectMemory fetchPointer: MyListIndex ofObject: self activeProcess) = objectMemory nilObject. self assert: relinquishing not. "DO NOT allow relinquishing the processor while we are profiling since this may skew the time base for our measures (it may reduce processor speed etc). Instead we go full speed, therefore measuring the precise time we spend in the inner idle loop as a busy loop." nextProfileTick = 0 ifTrue: "Presumably we have nothing to do; this primitive is typically called from the background process. So we should /not/ try and activate any threads in the pool; they will waste cycles finding there is no runnable process, and will cause a VM abort if no runnable process is found. But we /do/ want to allow FFI calls that have completed, or callbacks a chance to get into the VM; they do have something to do. DisownVMForProcessorRelinquish indicates this." [currentCStackPointer := cogit getCStackPointer. currentCFramePointer := cogit getCFramePointer. self cCode: + [self memcpy: savedReenterInterpreter asVoidPointer + _: reenterInterpreter + _: (self sizeof: #'jmp_buf')]. - [self mem: savedReenterInterpreter asVoidPointer - cp: reenterInterpreter - y: (self sizeof: #'jmp_buf')]. threadIndexAndFlags := self disownVM: DisownVMForProcessorRelinquish. self assert: relinquishing. self ioRelinquishProcessorForMicroseconds: (objectMemory integerValueOf: microSecs). self assert: relinquishing. self ownVM: threadIndexAndFlags. self assert: relinquishing not. self assert: cogThreadManager currentVMThread state = CTMAssignableOrInVM. self assert: currentCStackPointer = cogit getCStackPointer. self assert: currentCFramePointer = cogit getCFramePointer. self cCode: [self assert: (self mem: (self cCoerceSimple: savedReenterInterpreter to: #'void *') cm: reenterInterpreter p: (self sizeof: #'jmp_buf')) = 0]]. self assert: (objectMemory fetchPointer: MyListIndex ofObject: self activeProcess) = objectMemory nilObject. self pop: 1 "microSecs; leave rcvr on stack"! Item was changed: ----- Method: CoInterpreterMT>>returnToSchedulingLoopAndReleaseVMOrWakeThread:source: (in category 'process primitive support') ----- returnToSchedulingLoopAndReleaseVMOrWakeThread: vmThread source: source | savedReenterInterpreter | <var: #savedReenterInterpreter type: #'jmp_buf'> <var: #vmThread type: #'CogVMThread *'> <inline: false> self cCode: [self flag: 'this is just for debugging. Note the current C stack pointers'. cogThreadManager currentVMThread cStackPointer: cogit getCStackPointer; cFramePointer: cogit getCFramePointer] inSmalltalk: [| range | range := self cStackRangeForThreadIndex: cogThreadManager getVMOwner. self assert: (range includes: cogit getCStackPointer). self assert: (range includes: cogit getCFramePointer)]. "We must use a copy of reenterInterpreter since we're giving up the VM to another vmThread." self cCode: + [self memcpy: savedReenterInterpreter asVoidPointer + _: reenterInterpreter + _: (self sizeof: #'jmp_buf')] - [self mem: savedReenterInterpreter asVoidPointer - cp: reenterInterpreter - y: (self sizeof: #'jmp_buf')] inSmalltalk: [savedReenterInterpreter := reenterInterpreter]. self recordThreadSwitchTo: (vmThread ifNotNil: [vmThread index] ifNil: [0]) source: source. vmThread ifNotNil: [cogThreadManager wakeVMThreadFor: vmThread index] ifNil: [cogThreadManager releaseVM]. "2 implies returning to the threadSchedulingLoop." self siglong: savedReenterInterpreter jmp: ReturnToThreadSchedulingLoop! Item was changed: ----- Method: CogMethodZone>>compactCompiledCode (in category 'compaction') ----- compactCompiledCode | objectHeaderValue source dest bytes | <var: #source type: #'CogMethod *'> <var: #dest type: #'CogMethod *'> compactionInProgress := true. objectHeaderValue := objectMemory nullHeaderForMachineCodeMethod. source := coInterpreter cCoerceSimple: baseAddress to: #'CogMethod *'. self voidOpenPICList. "The list will be rebuilt with the current live set" methodCount := 0. NewspeakVM ifTrue: [unpairedMethodList := nil]. [source < self limitZony and: [source cmType ~= CMFree]] whileTrue: [self assert: (cogit cogMethodDoesntLookKosher: source) = 0. source objectHeader: objectHeaderValue. source cmUsageCount > 0 ifTrue: [source cmUsageCount: source cmUsageCount // 2]. NewspeakVM ifTrue: [(source cmType = CMMethod and: [(coInterpreter rawHeaderOf: source methodObject) asInteger ~= source asInteger]) ifTrue: [source nextMethodOrIRCs: unpairedMethodList. unpairedMethodList := source asUnsignedInteger]]. SistaVM ifTrue: [self clearSavedPICUsageCount: source]. source cmType = CMOpenPIC ifTrue: [self addToOpenPICList: source]. methodCount := methodCount + 1. source := self methodAfter: source]. source >= self limitZony ifTrue: [^self halt: 'no free methods; cannot compact.']. dest := source. [source < self limitZony] whileTrue: [self assert: (cogit maybeFreeCogMethodDoesntLookKosher: source) = 0. bytes := source blockSize. source cmType ~= CMFree ifTrue: [methodCount := methodCount + 1. + objectMemory memmove: dest _: source _: bytes. - objectMemory mem: dest mo: source ve: bytes. dest objectHeader: objectHeaderValue. dest cmType = CMMethod ifTrue: ["For non-Newspeak there should be a one-to-one mapping between bytecoded and cog methods. For Newspeak not necessarily, but only for anonymous accessors." "Only update the original method's header if it is referring to this CogMethod." (coInterpreter rawHeaderOf: dest methodObject) asInteger = source asInteger ifTrue: [coInterpreter rawHeaderOf: dest methodObject put: dest asInteger] ifFalse: [self assert: (cogit noAssertMethodClassAssociationOf: dest methodObject) = objectMemory nilObject. NewspeakVM ifTrue: [dest nextMethodOrIRCs: unpairedMethodList. unpairedMethodList := dest asUnsignedInteger]]] ifFalse: [SistaVM ifTrue: [self clearSavedPICUsageCount: dest]. dest cmType = CMOpenPIC ifTrue: [self addToOpenPICList: dest]]. dest cmUsageCount > 0 ifTrue: [dest cmUsageCount: dest cmUsageCount // 2]. dest := coInterpreter cCoerceSimple: dest asUnsignedInteger + bytes to: #'CogMethod *']. source := coInterpreter cCoerceSimple: source asUnsignedInteger + bytes to: #'CogMethod *']. mzFreeStart := dest asUnsignedInteger. methodBytesFreedSinceLastCompaction := 0. compactionInProgress := false! Item was changed: ----- Method: CogVMSimulator>>ioLoadFunction:From: (in category 'plugin support') ----- ioLoadFunction: functionString From: pluginString "Load and return the requested function from a module" | firstTime plugin fnSymbol | firstTime := false. fnSymbol := functionString asSymbol. transcript cr; show: '(', byteCount printString, ') Looking for ', functionString, ' in ', (pluginString isEmpty ifTrue:['vm'] ifFalse:[pluginString]). (breakSelector notNil and: [pluginString size = breakSelector size + and: [(self strncmp: pluginString _: breakSelector _: pluginString size) = 0 + or: [(self strncmp: functionString _: breakSelector _: functionString size) = 0]]]) ifTrue: - and: [(self str: pluginString n: breakSelector cmp: pluginString size) = 0 - or: [(self str: functionString n: breakSelector cmp: functionString size) = 0]]]) ifTrue: [self halt: functionString]. plugin := pluginList detect:[:any| any key = pluginString asString] ifNone: [firstTime := true. self loadNewPlugin: pluginString]. plugin ifNil: [firstTime ifTrue: [transcript cr; show: 'Failed ... primitive not in plugin']. ^0]. plugin := plugin value. mappedPluginEntries doWithIndex: [:pluginAndName :index| ((pluginAndName at: 1) == plugin and:[(pluginAndName at: 2) == fnSymbol]) ifTrue: [^index]]. (plugin respondsTo: fnSymbol) ifFalse: [firstTime ifTrue: [transcript cr; show: 'Failed ... primitive not in plugin']. ^0]. mappedPluginEntries addLast: (Array with: plugin with: fnSymbol with: [plugin perform: fnSymbol. self]). "Transcript show: ' ... okay'." transcript cr. ^ mappedPluginEntries size! Item was changed: ----- Method: CogVMSimulator>>ioLoadFunction:From:AccessorDepthInto: (in category 'plugin support') ----- ioLoadFunction: functionString From: pluginString AccessorDepthInto: accessorDepthPtr "Load and return the requested function from a module. Assign the accessor depth through accessorDepthPtr. N.B. The actual code lives in platforms/Cross/vm/sqNamedPrims.h" | firstTime plugin fnSymbol | firstTime := false. fnSymbol := functionString asSymbol. transcript cr; show: '(', byteCount printString, ') Looking for ', functionString, ' in ', (pluginString isEmpty ifTrue:['vm'] ifFalse:[pluginString]). (breakSelector notNil and: [pluginString size = breakSelector size + and: [(self strncmp: pluginString _: breakSelector _: pluginString size) = 0 + or: [(self strncmp: functionString _: breakSelector _: functionString size) = 0]]]) ifTrue: - and: [(self str: pluginString n: breakSelector cmp: pluginString size) = 0 - or: [(self str: functionString n: breakSelector cmp: functionString size) = 0]]]) ifTrue: [self halt: functionString]. plugin := pluginList detect: [:any| any key = pluginString asString] ifNone: [firstTime := true. self loadNewPlugin: pluginString]. plugin ifNil: [firstTime ifTrue: [transcript cr; show: 'Failed ... primitive not in plugin']. ^0]. plugin := plugin value. mappedPluginEntries doWithIndex: [:pluginAndName :index| ((pluginAndName at: 1) == plugin and:[(pluginAndName at: 2) == fnSymbol]) ifTrue: [firstTime ifTrue: [transcript show: ' ... okay'; cr]. accessorDepthPtr at: 0 put: (pluginAndName at: 4). ^index]]. firstTime ifTrue: [transcript cr; show: 'Failed ... primitive not in plugin']. transcript cr. ^0! Item was changed: ----- Method: CogVMSimulator>>loadNewPlugin: (in category 'plugin support') ----- loadNewPlugin: pluginString (breakSelector notNil + and: [(self strncmp: pluginString _: breakSelector _: pluginString size) = 0]) ifTrue: - and: [(self str: pluginString n: breakSelector cmp: pluginString size) = 0]) ifTrue: [self halt: pluginString]. ^(self tryLoadNewPlugin: pluginString pluginEntries: mappedPluginEntries) ifNotNil: [:entry| pluginList := pluginList copyWith: entry. entry]! Item was changed: ----- Method: CogVMSimulator>>utilitiesMenu: (in category 'UI') ----- utilitiesMenu: aMenuMorph aMenuMorph add: 'toggle transcript' action: #toggleTranscript; add: 'clone VM' action: #cloneSimulationWindow; addLine; add: 'print ext head frame' action: #printExternalHeadFrame; add: 'print int head frame' action: #printHeadFrame; add: 'print mc/cog head frame' action: [self printFrame: cogit processor fp WithSP: cogit processor sp]; add: 'short print ext head frame & callers' action: [self shortPrintFrameAndCallers: framePointer]; add: 'short print int head frame & callers' action: [self shortPrintFrameAndCallers: localFP]; add: 'short print mc/cog head frame & callers' action: [self shortPrintFrameAndCallers: cogit processor fp]; add: 'long print ext head frame & callers' action: [self printFrameAndCallers: framePointer SP: stackPointer]; add: 'long print int head frame & callers' action: [self printFrameAndCallers: localFP SP: localSP]; add: 'long print mc/cog head frame & callers' action: [self printFrameAndCallers: cogit processor fp SP: cogit processor sp]; add: 'print frame...' action: [(self promptHex: 'print frame') ifNotNil: [:fp| self printFrame: fp]]; add: 'print call stack' action: #printCallStack; add: 'print stack call stack' action: #printStackCallStack; add: 'print stack call stack of...' action: [(self promptHex: 'frame') ifNotNil: [:fp| self printStackCallStackOf: fp]]; add: 'print call stack of...' action: [(self promptHex: 'context or process oop') ifNotNil: [:obj| self printCallStackOf: obj]]; add: 'print call stack of frame...' action: [(self promptHex: 'frame') ifNotNil: [:fp| self printCallStackFP: fp]]; add: 'print all stacks' action: #printAllStacks; add: 'write back local ptrs' action: [stackPointer := localSP. framePointer := localFP. instructionPointer := localIP. self writeBackHeadFramePointers]; add: 'write back mc ptrs' action: [stackPointer := cogit processor sp. framePointer := cogit processor fp. instructionPointer := cogit processor pc. self externalWriteBackHeadFramePointers]; addLine; add: 'print rump C stack' action: [objectMemory printMemoryFrom: cogit processor sp to: cogit getCStackPointer]; add: 'print registers' action: [cogit processor printRegistersOn: transcript]; add: 'print register map' action: [cogit printRegisterMapOn: transcript]; add: 'disassemble method/trampoline...' action: [(self promptHex: 'pc') ifNotNil: [:pc| cogit disassembleCodeAt: pc]]; add: 'disassemble method/trampoline at pc' action: [cogit disassembleCodeAt: (((cogit codeEntryFor: cogit processor pc) isNil and: [(cogit methodZone methodFor: cogit processor pc) = 0]) ifTrue: [instructionPointer] ifFalse: [cogit processor pc])]; add: 'disassemble ext head frame method' action: [cogit disassembleMethod: (self frameMethod: framePointer)]; 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]]; add: 'print context...' action: [(self promptHex: 'print context') ifNotNil: [:oop| self printContext: oop]]; add: 'symbolic method...' action: [(self promptHex: 'method bytecodes') ifNotNil: [:oop| self symbolicMethod: oop]]; addLine; add: 'inspect object memory' target: objectMemory action: #inspect; add: 'run leak checker' action: [Cursor execute showWhile: [self runLeakChecker]]; add: 'inspect cointerpreter' action: #inspect; add: 'inspect cogit' target: cogit action: #inspect; add: 'inspect method zone' target: cogit methodZone action: #inspect. self isThreadedVM ifTrue: [aMenuMorph add: 'inspect thread manager' target: self threadManager action: #inspect]. aMenuMorph addLine; add: 'print cog methods' target: cogMethodZone action: #printCogMethods; add: 'print cog methods with prim...' action: [(self promptNum: 'prim index') ifNotNil: [:pix| cogMethodZone printCogMethodsWithPrimitive: pix]]; add: 'print cog methods with selector...' action: [|s| s := UIManager default request: 'selector'. s notEmpty ifTrue: [s = 'nil' ifTrue: [s := nil]. cogMethodZone methodsDo: [:m| (s ifNil: [m selector = objectMemory nilObject] ifNotNil: [(objectMemory numBytesOf: m selector) = s size + and: [(self strncmp: s + _: (m selector + objectMemory baseHeaderSize) + _: (objectMemory numBytesOf: m selector)) = 0]]) ifTrue: - and: [(self str: s - n: (m selector + objectMemory baseHeaderSize) - cmp: (objectMemory numBytesOf: m selector)) = 0]]) ifTrue: [cogit printCogMethod: m]]]]; add: 'print cog methods with method...' action: [(self promptHex: 'method') ifNotNil: [:methodOop| cogMethodZone printCogMethodsWithMethod: methodOop]]; add: 'print cog method for...' action: [(self promptHex: 'pc') ifNotNil: [:pc| cogit printCogMethodFor: pc]]; add: 'print cog method header for...' action: [(self promptHex: 'pc') ifNotNil: [:pc| cogit printCogMethodHeaderFor: pc]]; add: 'print trampoline table' target: cogit action: #printTrampolineTable; add: 'print prim trace log' action: #dumpPrimTraceLog; add: 'report recent instructions' target: cogit action: #reportLastNInstructions; add: (cogit printRegisters ifTrue: ['no print registers each instruction'] ifFalse: ['print registers each instruction']) action: [cogit printRegisters: cogit printRegisters not]; add: (cogit printInstructions ifTrue: ['no print instructions each instruction'] ifFalse: ['print instructions each instruction']) action: [cogit printInstructions: cogit printInstructions not]; addLine; add: (cogit singleStep ifTrue: ['no single step'] ifFalse: ['single step']) action: [cogit singleStep: cogit singleStep not]; add: 'click step' action: [cogit setClickStepBreakBlock]; add: 'set break pc', cogit breakPC menuPrompt, '...-ve to disable or remove' action: [cogit promptForBreakPC]; add: 'set break count...' action: [|s| s := UIManager default request: 'break count (dec)'. s notEmpty ifTrue: [breakCount := Integer readFrom: s readStream]]; add: 'set break selector...' action: [|s| s := UIManager default request: 'break selector (MNU:foo for MNU)'. s notEmpty ifTrue: [(s size > 4 and: [s beginsWith: 'MNU:']) ifTrue: [self setBreakMNUSelector: (s allButFirst: 4)] ifFalse: [self setBreakSelector: s]]]; add: 'set break block...' action: [|s| s := UIManager default request: 'break block' initialAnswer: '[:theCogit| false]'. s notEmpty ifTrue: [self setBreakBlockFromString: s]]; add: 'set cogit break method...' action: [(self promptHex: 'cogit breakMethod') ifNotNil: [:bm| cogit setBreakMethod: bm]]; 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: Cogit>>cogMNUPICSelector:receiver:methodOperand:numArgs: (in category 'in-line cacheing') ----- cogMNUPICSelector: selector receiver: rcvr methodOperand: methodOperand numArgs: numArgs <api> "Attempt to create a one-case PIC for an MNU. The tag for the case is at the send site and so doesn't need to be generated." <returnTypeC: #'CogMethod *'> | startAddress | ((objectMemory isYoung: selector) or: [(objectRepresentation inlineCacheTagForInstance: rcvr) = self picAbortDiscriminatorValue]) ifTrue: [^0]. coInterpreter compilationBreak: selector point: (objectMemory numBytesOf: selector) isMNUCase: true. self assert: endCPICCase0 notNil. "get memory in the code zone for the CPIC; if that fails we return an error code for the sender to use to work out how to blow up" startAddress := methodZone allocate: closedPICSize. startAddress = 0 ifTrue: [coInterpreter callForCogCompiledCodeCompaction. ^0]. "memcpy the prototype across to our allocated space; because anything else would be silly" objectMemory + memcpy: (self cCoerceSimple: startAddress to: #'CogMethod *') + _: (self cCoerceSimple: cPICPrototype to: #'CogMethod *') + _: closedPICSize. - mem: (self cCoerceSimple: startAddress to: #'CogMethod *') - cp: (self cCoerceSimple: cPICPrototype to: #'CogMethod *') - y: closedPICSize. self configureMNUCPIC: (self cCoerceSimple: startAddress to: #'CogMethod *') methodOperand: methodOperand numArgs: numArgs delta: startAddress - cPICPrototype. ^self fillInCPICHeader: (self cCoerceSimple: startAddress to: #'CogMethod *') numArgs: numArgs numCases: 1 hasMNUCase: true selector: selector ! Item was changed: ----- Method: Cogit>>cogPICSelector:numArgs:Case0Method:Case1Method:tag:isMNUCase: (in category 'in-line cacheing') ----- cogPICSelector: selector numArgs: numArgs Case0Method: case0CogMethod Case1Method: case1MethodOrNil tag: case1Tag isMNUCase: isMNUCase "Attempt to create a two-case PIC for case0CogMethod and case1Method,case1Tag. The tag for case0CogMethod is at the send site and so doesn't need to be generated. case1Method may be any of - a Cog method; link to its unchecked entry-point - a CompiledMethod; link to ceInterpretMethodFromPIC: - a CompiledMethod; link to ceMNUFromPICMNUMethod:receiver:" <var: #case0CogMethod type: #'CogMethod *'> <returnTypeC: #'CogMethod *'> | startAddress | (objectMemory isYoung: selector) ifTrue: [^self cCoerceSimple: YoungSelectorInPIC to: #'CogMethod *']. coInterpreter compilationBreak: selector point: (objectMemory numBytesOf: selector) isMNUCase: isMNUCase. "get memory in the code zone for the CPIC; if that fails we return an error code for the sender to use to work out how to blow up" startAddress := methodZone allocate: closedPICSize. startAddress = 0 ifTrue: [^self cCoerceSimple: InsufficientCodeSpace to: #'CogMethod *']. "memcpy the prototype across to our allocated space; because anything else would be silly" objectMemory + memcpy: (self cCoerceSimple: startAddress to: #'CogMethod *') + _: (self cCoerceSimple: cPICPrototype to: #'CogMethod *') + _: closedPICSize. - mem: (self cCoerceSimple: startAddress to: #'CogMethod *') - cp: (self cCoerceSimple: cPICPrototype to: #'CogMethod *') - y: closedPICSize. self configureCPIC: (self cCoerceSimple: startAddress to: #'CogMethod *') Case0: case0CogMethod Case1Method: case1MethodOrNil tag: case1Tag isMNUCase: isMNUCase numArgs: numArgs delta: startAddress - cPICPrototype . ^self fillInCPICHeader: (self cCoerceSimple: startAddress to: #'CogMethod *') numArgs: numArgs numCases: 2 hasMNUCase: isMNUCase selector: selector ! Item was changed: ----- Method: FFIPlugin>>primitiveFFIDoubleAt (in category 'primitives') ----- primitiveFFIDoubleAt "Return a (signed or unsigned) n byte integer from the given byte offset." | byteOffset rcvr addr floatValue | <export: true> <inline: false> <var: #floatValue type: #double> byteOffset := interpreterProxy stackIntegerValue: 0. rcvr := interpreterProxy stackObjectValue: 1. interpreterProxy failed ifTrue:[^0]. addr := self ffiAddressOf: rcvr startingAt: byteOffset size: 8. interpreterProxy failed ifTrue:[^0]. + self memcpy: (self addressOf: floatValue) _: addr _: (self sizeof: floatValue). - self mem: (self addressOf: floatValue) cp: addr y: (self sizeof: floatValue). interpreterProxy pop: 2. ^interpreterProxy pushFloat: floatValue ! Item was changed: ----- Method: FFIPlugin>>primitiveFFIDoubleAtPut (in category 'primitives') ----- primitiveFFIDoubleAtPut "Return a (signed or unsigned) n byte integer from the given byte offset." | byteOffset rcvr addr floatValue floatOop | <export: true> <inline: false> <var: #floatValue type: #double> floatOop := interpreterProxy stackValue: 0. (interpreterProxy isIntegerObject: floatOop) ifTrue:[floatValue := self cCoerce: (interpreterProxy integerValueOf: floatOop) to:'double'] ifFalse:[floatValue := self cCoerce: (interpreterProxy floatValueOf: floatOop) to:'double']. byteOffset := interpreterProxy stackIntegerValue: 1. rcvr := interpreterProxy stackObjectValue: 2. interpreterProxy failed ifTrue:[^0]. addr := self ffiAddressOf: rcvr startingAt: byteOffset size: 8. interpreterProxy failed ifTrue:[^0]. + self memcpy: addr _: (self addressOf: floatValue) _: (self sizeof: floatValue). - self mem: addr cp: (self addressOf: floatValue) y: (self sizeof: floatValue). interpreterProxy pop: 3. ^interpreterProxy push: floatOop! Item was changed: ----- Method: FFIPlugin>>primitiveFFIFloatAt (in category 'primitives') ----- primitiveFFIFloatAt "Return a (signed or unsigned) n byte integer from the given byte offset." | byteOffset rcvr addr floatValue | <export: true> <inline: false> <var: #floatValue type: #float> byteOffset := interpreterProxy stackIntegerValue: 0. rcvr := interpreterProxy stackObjectValue: 1. interpreterProxy failed ifTrue:[^0]. addr := self ffiAddressOf: rcvr startingAt: byteOffset size: 4. interpreterProxy failed ifTrue:[^0]. + self memcpy: (self addressOf: floatValue) _: addr _: (self sizeof: floatValue). - self mem: (self addressOf: floatValue) cp: addr y: (self sizeof: floatValue). interpreterProxy pop: 2. ^interpreterProxy pushFloat: floatValue! Item was changed: ----- Method: FFIPlugin>>primitiveFFIFloatAtPut (in category 'primitives') ----- primitiveFFIFloatAtPut "Return a (signed or unsigned) n byte integer from the given byte offset." | byteOffset rcvr addr floatValue floatOop | <export: true> <inline: false> <var: #floatValue type: #float> floatOop := interpreterProxy stackValue: 0. (interpreterProxy isIntegerObject: floatOop) ifTrue:[floatValue := self cCoerce: (interpreterProxy integerValueOf: floatOop) to:'float'] ifFalse:[floatValue := self cCoerce: (interpreterProxy floatValueOf: floatOop) to:'float']. byteOffset := interpreterProxy stackIntegerValue: 1. rcvr := interpreterProxy stackObjectValue: 2. interpreterProxy failed ifTrue:[^0]. addr := self ffiAddressOf: rcvr startingAt: byteOffset size: 4. interpreterProxy failed ifTrue:[^0]. + self memcpy: addr _: (self addressOf: floatValue) _: (self sizeof: floatValue). - self mem: addr cp: (self addressOf: floatValue) y: (self sizeof: floatValue). interpreterProxy pop: 3. ^interpreterProxy push: floatOop! Item was changed: ----- Method: FilePlugin>>primitiveFileStdioHandles (in category 'file primitives') ----- primitiveFileStdioHandles "Answer an Array of file handles for standard in, standard out and standard error, with nil in entries that are unvailable, e.g. because the platform does not provide standard error, etc. Fail if an error occurs determining the stdio handles, if the security plugin denies access or if memory runs out." | fileRecords result validMask | <export: true> <var: 'fileRecords' declareC: 'SQFile fileRecords[3]'> sHFAfn ~= 0 ifTrue: [(self cCode: ' ((sqInt (*)(void))sHFAfn)()' inSmalltalk: [true]) ifFalse: [^interpreterProxy primitiveFailFor: PrimErrUnsupported]]. self cCode: '' inSmalltalk: [fileRecords := Array new: 3]. validMask := self sqFileStdioHandlesInto: fileRecords. validMask < 0 ifTrue: [^interpreterProxy primitiveFailForOSError: validMask]. result := interpreterProxy instantiateClass: interpreterProxy classArray indexableSize: 3. result = nil ifTrue: [^interpreterProxy primitiveFailFor: PrimErrNoMemory]. interpreterProxy pushRemappableOop: result. 0 to: 2 do: [:index| (validMask bitAnd: (1 << index)) ~= 0 ifTrue: [result := interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: self fileRecordSize. result = nil ifTrue: [interpreterProxy popRemappableOop. ^interpreterProxy primitiveFailFor: PrimErrNoMemory]. interpreterProxy storePointer: index ofObject: interpreterProxy topRemappableOop withValue: result. self cCode: + [self memcpy: (interpreterProxy firstIndexableField: result) + _: (self addressOf: (fileRecords at: index)) + _: self fileRecordSize] - [self mem: (interpreterProxy firstIndexableField: result) - cp: (self addressOf: (fileRecords at: index)) - y: self fileRecordSize] inSmalltalk: [(interpreterProxy firstIndexableField: result) unitSize: interpreterProxy wordSize; at: 0 put: (fileRecords at: index + 1)]]]. "In the non-Spur threaded VM ensure the handles are old, so that sqFileReadIntoAt is unaffected by incremental GCs. See platforms/Cross/plugins/FilePlugin/sqFilePluginBasicPrims.c. The Spur VM uses pinning, so it doesn't need the GC." self cppIf: COGMTVM ifTrue: [self cppIf: SPURVM ifTrue: [] ifFalse: [interpreterProxy fullGC]]. result := interpreterProxy popRemappableOop. interpreterProxy methodReturnValue: result! Item was changed: ----- Method: HostWindowPlugin>>primitiveHostWindowIcon:path: (in category 'system primitives') ----- primitiveHostWindowIcon: id path: pathString "Set the icon of the window by fetching the logo in given path. Fail if the windowIndex is invalid or the platform routine returns -1 to indicate failure" | res pathLength | self primitive: 'primitiveHostWindowIcon' parameters: #(SmallInteger ByteArray). pathLength := interpreterProxy slotSizeOf: pathString cPtrAsOop. + res := self ioSetIconOfWindow: id _: pathString _: pathLength. - res := self cCode: 'ioSetIconOfWindow(id, pathString, pathLength)'. res = 0 ifTrue: [^ self ]. res = -1 ifTrue: [^ interpreterProxy primitiveFailFor: PrimErrBadArgument ]. "As the GetLastError function can return 0, but it is still an error, 1 is added to all the GetLastError error codes." ^ interpreterProxy primitiveFail! Item was changed: ----- Method: HostWindowPlugin>>primitiveHostWindowTitle:string: (in category 'system primitives') ----- primitiveHostWindowTitle: id string: titleString "Set the title bar label of the window. Fail if the windowIndex is invalid or the platform routine returns -1 to indicate failure" + | titleLength | - | res titleLength | self primitive: 'primitiveHostWindowTitle' parameters: #(SmallInteger String). titleLength := interpreterProxy slotSizeOf: titleString cPtrAsOop. + (self ioSetTitleOfWindow: id _: titleString _: titleLength) = -1 ifTrue: + [interpreterProxy primitiveFail]! - res := self cCode: 'ioSetTitleOfWindow(id, titleString, titleLength)'. - res = -1 - ifTrue: [interpreterProxy primitiveFail]! Item was changed: ----- Method: HostWindowPlugin>>primitiveShowHostWindow:bits:width:height:depth:left:right:top:bottom: (in category 'system primitives') ----- primitiveShowHostWindow: windowIndex bits: dispBits width: w height: h depth: d left: left right: right top: top bottom: bottom "Host window analogue of DisplayScreen> primShowRectLeft:right:top:bottom: (Interpreter>primitiveShowDisplayRect) which takes the window index, bitmap details and the rectangle bounds. Fail if the windowIndex is invalid or the platform routine returns false to indicate failure" - |ok| self primitive: 'primitiveShowHostWindowRect' parameters: #(SmallInteger WordArray SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger). "Tell the vm to copy pixel's from dispBits to the screen - this is just ioShowDisplay with the extra parameter of the windowIndex integer" + (self ioShowDisplayOnWindow: dispBits _: w _: h _: d _: left _: right _: top _: bottom _: windowIndex) ifFalse: + [interpreterProxy primitiveFail]! - ok := self cCode: 'ioShowDisplayOnWindow(dispBits, w, h, d, left, right, top, - bottom, windowIndex)'. - ok ifFalse:[interpreterProxy primitiveFail]! Item was changed: ----- Method: IA32ABIPlugin>>primAlienReplace (in category 'primitives-accessing') ----- primAlienReplace "Copy some number of bytes from some source object starting at the index into the receiver destination object from startIndex to stopIndex. The source and destination may be Aliens or byte-indexable objects. The primitive wll have either of the following signatures: <Alien | indexableByteSubclass | indexableWordSubclass> primReplaceFrom: start <Integer> to: stop <Integer> with: replacement <Alien | indexableByteSubclass | indexableWordSubclass | Integer> startingAt: repStart <Integer> ^<self> <primitive: 'primitiveAlienReplace' error: errorCode module: 'IA32ABI'> <Anywhere> primReplaceIn: dest <Alien | indexableByteSubclass | indexableWordSubclass> from: start <Integer> to: stop <Integer> with: replacement <Alien | indexableByteSubclass | indexableWordSubclass | Integer> startingAt: repStart <Integer> ^<self> <primitive: 'primitiveAlienReplace' error: errorCode module: 'IA32ABI'> " | array start stop repl replStart dest src totalLength count | <export: true> array := interpreterProxy stackValue: 4. start := interpreterProxy stackIntegerValue: 3. stop := interpreterProxy stackIntegerValue: 2. repl := interpreterProxy stackValue: 1. replStart := interpreterProxy stackIntegerValue: 0. (interpreterProxy failed or: [(interpreterProxy isWordsOrBytes: array) not]) ifTrue: [^interpreterProxy primitiveFailFor: PrimErrBadArgument]. (self isAlien: array) ifTrue: [totalLength := self sizeField: array. dest := (self startOfData: array withSize: totalLength) + start - 1. totalLength = 0 "no bounds checks for zero-sized (pointer) Aliens" ifTrue: [totalLength := stop] ifFalse: [totalLength := totalLength abs]] ifFalse: [totalLength := interpreterProxy byteSizeOf: array. dest := (self startOfByteData: array) + start - 1]. (start >= 1 and: [start - 1 <= stop and: [stop <= totalLength]]) ifFalse: [^interpreterProxy primitiveFailFor: PrimErrBadIndex]. (interpreterProxy isKindOfInteger: repl) ifTrue: [src := (interpreterProxy positiveMachineIntegerValueOf: repl) + replStart - 1. interpreterProxy failed ifTrue: [^interpreterProxy primitiveFailFor: PrimErrBadArgument]] ifFalse: [(self isAlien: repl) ifTrue: [totalLength := self sizeField: repl. src := (self startOfData: repl withSize: totalLength) + replStart - 1. totalLength = 0 "no bounds checks for zero-sized (pointer) Aliens" ifTrue: [totalLength := stop - start + replStart] ifFalse: [totalLength := totalLength abs]] ifFalse: [(interpreterProxy isWordsOrBytes: repl) ifFalse: [^interpreterProxy primitiveFailFor: PrimErrBadArgument]. totalLength := interpreterProxy byteSizeOf: repl. src := (self startOfByteData: repl) + replStart - 1]. (replStart >= 1 and: [stop - start + replStart <= totalLength]) ifFalse: [^interpreterProxy primitiveFailFor: PrimErrBadIndex]]. (interpreterProxy isOopImmutable: array) ifTrue: [^interpreterProxy primitiveFailFor: PrimErrNoModification]. count := stop - start + 1. + self memmove: dest asVoidPointer _: src asVoidPointer _: count. - self mem: dest asVoidPointer mo: src asVoidPointer ve: count. interpreterProxy pop: interpreterProxy methodArgumentCount! Item was changed: ----- Method: IA32ABIPlugin>>primDoubleAt (in category 'primitives-accessing') ----- primDoubleAt "Answer the 64-bit double starting at the given byte offset (little endian)." "<Alien> doubleAt: index <Integer> ^<Float> <primitive: 'primDoubleAt' error: errorCode module: 'IA32ABI'>" | byteOffset rcvr startAddr addr floatValue | <export: true> <var: #floatValue type: #double> byteOffset := (interpreterProxy stackPositiveMachineIntegerValue: 0) - 1. rcvr := interpreterProxy stackObjectValue: 1. interpreterProxy failed ifTrue: [^interpreterProxy primitiveFailFor: PrimErrBadArgument]. (self index: byteOffset length: 8 inRange: rcvr) ifFalse: [^interpreterProxy primitiveFailFor: PrimErrBadIndex]. (startAddr := self startOfData: rcvr) = 0 ifTrue: [^interpreterProxy primitiveFailFor: PrimErrBadReceiver]. addr := startAddr + byteOffset. + self memcpy: (self addressOf: floatValue) _: addr _: (self sizeof: floatValue). - self mem: (self addressOf: floatValue) cp: addr y: (self sizeof: floatValue). interpreterProxy pop: 2. ^interpreterProxy pushFloat: floatValue! Item was changed: ----- Method: IA32ABIPlugin>>primDoubleAtPut (in category 'primitives-accessing') ----- primDoubleAtPut "Store a double into 64 bits starting at the given byte offset (little endian)." "<Alien> doubleAt: index <Integer> put: value <Float | Integer> ^<Float | Integer> <primitive: 'primDoubleAtPut' error: errorCode module: 'IA32ABI'>" | byteOffset rcvr startAddr addr valueOop floatValue | <export: true> <var: #floatValue type: #double> valueOop := interpreterProxy stackValue: 0. (interpreterProxy isIntegerObject: valueOop) ifTrue:[floatValue := self cCoerce: (interpreterProxy integerValueOf: valueOop) to: #double] ifFalse:[floatValue := self cCoerce: (interpreterProxy floatValueOf: valueOop) to: #double]. byteOffset := (interpreterProxy stackPositiveMachineIntegerValue: 1) - 1. rcvr := interpreterProxy stackObjectValue: 2. interpreterProxy failed ifTrue: [^interpreterProxy primitiveFailFor: PrimErrBadArgument]. (self index: byteOffset length: 8 inRange: rcvr) ifFalse: [^interpreterProxy primitiveFailFor: PrimErrBadIndex]. (interpreterProxy isOopImmutable: rcvr) ifTrue: [^interpreterProxy primitiveFailFor: PrimErrNoModification]. (startAddr := self startOfData: rcvr) = 0 ifTrue: [^interpreterProxy primitiveFailFor: PrimErrBadReceiver]. addr := startAddr + byteOffset. + self memcpy: addr _: (self addressOf: floatValue) _: (self sizeof: floatValue). - self mem: addr cp: (self addressOf: floatValue) y: (self sizeof: floatValue). interpreterProxy methodReturnValue: valueOop! Item was changed: ----- Method: IA32ABIPlugin>>primFloatAt (in category 'primitives-accessing') ----- primFloatAt "Answer the 32-bit float starting at the given byte offset (little endian)." "<Alien> floatAt: index <Integer> ^<Float> <primitive: 'primFloatAt' error: errorCode module: 'IA32ABI'>" | byteOffset rcvr startAddr addr floatValue | <export: true> <var: #floatValue type: #float> byteOffset := (interpreterProxy stackPositiveMachineIntegerValue: 0) - 1. rcvr := interpreterProxy stackObjectValue: 1. interpreterProxy failed ifTrue: [^interpreterProxy primitiveFailFor: PrimErrBadArgument]. (self index: byteOffset length: 4 inRange: rcvr) ifFalse: [^interpreterProxy primitiveFailFor: PrimErrBadIndex]. (startAddr := self startOfData: rcvr) = 0 ifTrue: [^interpreterProxy primitiveFailFor: PrimErrBadReceiver]. addr := startAddr + byteOffset. + self memcpy: (self addressOf: floatValue) _: addr _: (self sizeof: floatValue). - self mem: (self addressOf: floatValue) cp: addr y: (self sizeof: floatValue). interpreterProxy pop: 2. ^interpreterProxy pushFloat: floatValue! Item was changed: ----- Method: IA32ABIPlugin>>primFloatAtPut (in category 'primitives-accessing') ----- primFloatAtPut "Store a float into 32 bits starting at the given byte offset (little endian)." "<Alien> floatAt: index <Integer> put: value <Float | Integer> ^<Float | Integer> <primitive: 'primFloatAtPut' error: errorCode module: 'IA32ABI'>" | byteOffset rcvr startAddr addr valueOop floatValue | <export: true> <var: #floatValue type: #float> valueOop := interpreterProxy stackValue: 0. (interpreterProxy isIntegerObject: valueOop) ifTrue:[floatValue := self cCoerce: (interpreterProxy integerValueOf: valueOop) to: #double] ifFalse:[floatValue := self cCoerce: (interpreterProxy floatValueOf: valueOop) to: #double]. byteOffset := (interpreterProxy stackPositiveMachineIntegerValue: 1) - 1. rcvr := interpreterProxy stackObjectValue: 2. interpreterProxy failed ifTrue: [^interpreterProxy primitiveFailFor: PrimErrBadArgument]. (self index: byteOffset length: 4 inRange: rcvr) ifFalse: [^interpreterProxy primitiveFailFor: PrimErrBadIndex]. (interpreterProxy isOopImmutable: rcvr) ifTrue: [^interpreterProxy primitiveFailFor: PrimErrNoModification]. (startAddr := self startOfData: rcvr) = 0 ifTrue: [^interpreterProxy primitiveFailFor: PrimErrBadReceiver]. addr := startAddr + byteOffset. + self memcpy: addr _: (self addressOf: floatValue) _: (self sizeof: floatValue). - self mem: addr cp: (self addressOf: floatValue) y: (self sizeof: floatValue). interpreterProxy methodReturnValue: valueOop! Item was changed: ----- Method: IA32ABIPlugin>>primReturnFromContextThrough (in category 'primitives-callbacks') ----- primReturnFromContextThrough "Return a result from a callback to the callback's callee. The primitive has a signature of either of the forms: result <FFICallbackResult> primReturnFromContext: callbackContext <MethodContext> through: jmpBuf <Integer> result <FFICallbackResult> primSignal: aSemaphore <Semaphore> andReturnFromContext: callbackContext <MethodContext> through: jmpBuf <Integer> <primitive: 'primReturnFromContextThrough' error: errorCode module: 'IA32ABI'>. If of the second form answer true if this is not the most recent callback, and signal aSemaphore if it is, so as to implement LIFO ordering of callbacks." <export: true> <legacy> | mac vmCallbackContext vmCallbackReturnValue isMostRecent | <var: #vmCallbackContext type: #'VMCallbackContext *'> <var: #vmCallbackReturnValue type: #'VMCallbackReturnValue *'> vmCallbackContext := self cCoerceSimple: (interpreterProxy positiveMachineIntegerValueOf: (interpreterProxy stackValue: 0)) to: #'VMCallbackContext *'. (interpreterProxy failed or: [vmCallbackContext = 0]) ifTrue: [^interpreterProxy primitiveFailFor: PrimErrBadArgument]. (mac := interpreterProxy methodArgumentCount) = 3 ifTrue: [isMostRecent := vmCallbackContext = self getMostRecentCallbackContext. isMostRecent ifFalse: [interpreterProxy methodReturnValue: interpreterProxy trueObject. ^nil]. (interpreterProxy fetchClassOf: (interpreterProxy stackValue: 2)) = interpreterProxy classSemaphore ifFalse: [^interpreterProxy primitiveFailFor: PrimErrBadArgument]. [interpreterProxy signalNoResume: (interpreterProxy stackValue: 2)] whileFalse]. vmCallbackReturnValue := self cCoerceSimple: (self startOfData: (interpreterProxy stackValue: mac)) to: #'VMCallbackReturnValue *'. self cCode: "C needs a typedef for structs to be assigned, but that implies a struct class for just one assignment." + [self memcpy: (self addressOf: vmCallbackContext rvs) + _: (self addressOf: vmCallbackReturnValue crvrvs) + _: (self sizeof: vmCallbackContext rvs)] - [self mem: (self addressOf: vmCallbackContext rvs) - cp: (self addressOf: vmCallbackReturnValue crvrvs) - y: (self sizeof: vmCallbackContext rvs)] inSmalltalk: [vmCallbackContext rvs: vmCallbackReturnValue crvrvs]. (interpreterProxy returnAs: (interpreterProxy integerObjectOf: vmCallbackReturnValue type + 1) ThroughCallback: vmCallbackContext Context: (interpreterProxy stackValue: 1)) ifFalse: [^interpreterProxy primitiveFailFor: PrimErrBadArgument]. "NOTREACHED"! Item was removed: - ----- Method: InterpreterPlugin>>st:rn:cpy: (in category 'simulation support') ----- - st: aString rn: bString cpy: n - <doNotGenerate> - ^interpreterProxy st: aString rn: bString cpy: n! Item was added: + ----- Method: InterpreterPlugin>>strncpy:_:_: (in category 'simulation support') ----- + strncpy: aString _: bString _: n + <doNotGenerate> + ^interpreterProxy strncpy: aString _: bString _: n! Item was changed: ----- Method: InterpreterPrimitives>>cStringOrNullFor: (in category 'primitive support') ----- cStringOrNullFor: oop "Answer either a malloced string with the null-terminated contents of oop if oop is a string, or the null pointer if oop is nil, or fail. It is the client's responsibility to free the string later." <api> <returnTypeC: #'char *'> <inline: false> | isString len cString | <var: 'cString' type: #'char *'> isString := self isInstanceOfClassByteString: oop. isString ifFalse: [oop ~= objectMemory nilObject ifTrue: [self primitiveFailFor: PrimErrBadArgument]. ^0]. len := objectMemory lengthOf: oop. len = 0 ifTrue: [^0]. cString := self malloc: len + 1. cString ifNil: [self primitiveFailFor: PrimErrNoCMemory. ^0]. + self memcpy: cString _: (objectMemory firstIndexableField: oop) _: len. - self mem: cString cp: (objectMemory firstIndexableField: oop) y: len. cString at: (self cCode: [len] inSmalltalk: [len + 1]) put: 0. ^cString! Item was changed: ----- Method: InterpreterPrimitives>>primitiveCopyObject (in category 'object access primitives') ----- primitiveCopyObject "Primitive. Copy the state of the receiver from the argument. Fail if receiver and argument are of a different class. Fail if the receiver or argument are contexts (because of context-to-stack mapping). Fail if receiver and argument have different lengths (for indexable objects). Fail if the objects are not in a fit state to be copied (e.g. married contexts and Cogged methods)" | rcvr arg length | self methodArgumentCount >= 1 ifFalse: [^self primitiveFailFor: PrimErrBadNumArgs]. arg := self stackTop. rcvr := self stackValue: 1. (objectMemory isImmediate: rcvr) ifTrue: [^self primitiveFailFor: PrimErrBadReceiver]. (objectMemory isImmediate: arg) ifTrue: [^self primitiveFailFor: PrimErrBadArgument]. (objectMemory fetchClassTagOfNonImm: rcvr) ~= (objectMemory fetchClassTagOfNonImm: arg) ifTrue: [^self primitiveFailFor: PrimErrBadArgument]. (objectMemory isWordsOrBytesNonImm: rcvr) ifTrue: [length := objectMemory numBytesOf: rcvr. ((objectMemory formatOf: rcvr) = (objectMemory formatOf: arg) and: [length = (objectMemory numBytesOf: arg)]) ifFalse: [^self primitiveFailFor: PrimErrBadArgument]. + self memcpy: (rcvr + objectMemory baseHeaderSize) asVoidPointer + _: (arg + objectMemory baseHeaderSize) asVoidPointer + _: length] - self mem: (rcvr + objectMemory baseHeaderSize) asVoidPointer - cp: (arg + objectMemory baseHeaderSize) asVoidPointer - y: length] ifFalse: [(self isAppropriateForCopyObject: rcvr) ifFalse: [^self primitiveFailFor: PrimErrBadReceiver]. length := objectMemory numSlotsOf: rcvr. ((self isAppropriateForCopyObject: arg) and: [length = (objectMemory lengthOf: arg)]) ifFalse: [^self primitiveFailFor: PrimErrBadArgument]. 0 to: length - 1 do: [:i| objectMemory storePointer: i ofObject: rcvr withValue: (objectMemory fetchPointer: i ofObject: arg)]]. "Note: The above could be faster for young receivers but I don't think it'll matter" self pop: self methodArgumentCount "pop arg; answer receiver"! Item was changed: ----- Method: LargeIntegersPlugin>>primGetModuleName (in category 'control & support primitives') ----- primGetModuleName "If calling this primitive fails, then C module does not exist." | strLen strOop | self debugCode: [self msg: 'primGetModuleName']. self primitive: 'primGetModuleName' parameters: #() receiver: #Oop. strLen := self strlen: self getModuleName. strOop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: strLen. + self strncpy: (interpreterProxy firstIndexableField: strOop) + _: self getModuleName + _: strLen. - self st: (interpreterProxy firstIndexableField: strOop) - rn: self getModuleName - cpy: strLen. ^strOop! Item was changed: ----- Method: MIDIPlugin>>primitiveMIDIGetPortName: (in category 'primitives') ----- primitiveMIDIGetPortName: portNum | portName sz nameObj | <var: #portName declareC: 'char portName[256]'> self primitive: 'primitiveMIDIGetPortName' parameters: #(SmallInteger). sz := self sqMIDIGet: portNum Port: portName Name: 255. nameObj := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: sz. interpreterProxy failed ifTrue: [^nil]. + self memcpy: (nameObj asValue: String) _: portName _: sz. - self mem: (nameObj asValue: String) cp: portName y: sz. ^nameObj! Item was changed: ----- Method: NewObjectMemory>>findString: (in category 'debug support') ----- findString: aCString "Print the oops of all string-like things that have the same characters as aCString" <api> <var: #aCString type: #'char *'> | cssz obj sz | cssz := self strlen: aCString. obj := self firstObject. [self oop: obj isLessThan: freeStart] whileTrue: [(self isFreeObject: obj) ifTrue: [sz := self sizeOfFree: obj] ifFalse: [((self isBytesNonImm: obj) and: [(self lengthOf: obj) = cssz + and: [(self strncmp: aCString _: (self pointerForOop: obj + self baseHeaderSize) _: cssz) = 0]]) ifTrue: - and: [(self str: aCString n: (self pointerForOop: obj + self baseHeaderSize) cmp: cssz) = 0]]) ifTrue: [coInterpreter printHex: obj; space; printOopShort: obj; cr]. sz := self sizeBitsOf: obj]. obj := self oopFromChunk: obj + sz]! Item was changed: ----- Method: NewObjectMemory>>findStringBeginningWith: (in category 'debug support') ----- findStringBeginningWith: aCString "Print the oops of all string-like things that start with the same characters as aCString" <api> <var: #aCString type: #'char *'> | cssz obj sz | cssz := self strlen: aCString. obj := self firstObject. [self oop: obj isLessThan: freeStart] whileTrue: [(self isFreeObject: obj) ifTrue: [sz := self sizeOfFree: obj] ifFalse: [((self isBytesNonImm: obj) and: [(self lengthOf: obj) >= cssz + and: [(self strncmp: aCString _: (self pointerForOop: obj + self baseHeaderSize) _: cssz) = 0]]) ifTrue: - and: [(self str: aCString n: (self pointerForOop: obj + self baseHeaderSize) cmp: cssz) = 0]]) ifTrue: [coInterpreter printHex: obj; space; printNum: (self lengthOf: obj); space; printOopShort: obj; cr]. sz := self sizeBitsOf: obj]. obj := self oopFromChunk: obj + sz]! Item was changed: ----- Method: ObjectMemory>>stringForCString: (in category 'primitive support') ----- stringForCString: aCString "Answer a new String copied from a null-terminated C string, or nil if out of memory. Caution: This may invoke the garbage collector." <api> <var: 'aCString' type: 'const char *'> <inline: false> | len newString | len := self strlen: aCString. newString := self instantiateClass: (self splObj: ClassByteString) indexableSize: len. newString ifNotNil: + [self strncpy: (self cCoerceSimple: newString + self baseHeaderSize to: #'char *') + _: aCString + _: len]. "(char *)strncpy()" - [self st: (self cCoerceSimple: newString + self baseHeaderSize to: #'char *') - rn: aCString - cpy: len]. "(char *)strncpy()" ^newString! Item was changed: ----- Method: RegisterAllocatingCogit>>copySimStackToFixup: (in category 'bytecode generator support') ----- copySimStackToFixup: fixup <var: #fixup type: #'BytecodeFixup *'> <inline: true> + self cCode: [self memcpy: fixup mergeSimStack _: simStack _: simStackPtr + 1 * (self sizeof: CogSimStackEntry)] - self cCode: [self mem: fixup mergeSimStack cp: simStack y: simStackPtr + 1 * (self sizeof: CogSimStackEntry)] inSmalltalk: [0 to: simStackPtr do: [:i| fixup mergeSimStack at: i put: (simStack at: i) copy]]! Item was changed: ----- Method: RegisterAllocatingCogit>>copySimStackToScratch: (in category 'bytecode generator support') ----- copySimStackToScratch: spillBase <inline: true> self assert: (spillBase > methodOrBlockNumTemps or: [self maybeCompilingFirstPassOfBlockWithInitialPushNil and: [spillBase > methodOrBlockNumArgs]]). scratchBytecodePC = bytecodePC ifTrue: [^self]. scratchBytecodePC := bytecodePC. + self cCode: [self memcpy: scratchSimStack _: simStack _: self simStackSlots * (self sizeof: CogSimStackEntry)] - self cCode: [self mem: scratchSimStack cp: simStack y: self simStackSlots * (self sizeof: CogSimStackEntry)] inSmalltalk: [0 to: simStackPtr do: [:i| scratchSimStack at: i put: (simStack at: i) copy]]. scratchSpillBase := spillBase! Item was changed: ----- Method: RegisterAllocatingCogit>>restoreSimStackFromScratch (in category 'bytecode generator support') ----- restoreSimStackFromScratch <inline: true> + self cCode: [self memcpy: simStack _: scratchSimStack _: self simStackSlots * (self sizeof: CogSimStackEntry)] - self cCode: [self mem: simStack cp: scratchSimStack y: self simStackSlots * (self sizeof: CogSimStackEntry)] inSmalltalk: [0 to: simStackPtr do: [:i| simStack at: i put: (scratchSimStack at: i) copy]]. simSpillBase := scratchSpillBase! Item was changed: ----- Method: RegisterAllocatingCogit>>setMergeSimStackOf: (in category 'bytecode generator support') ----- setMergeSimStackOf: fixup <var: #fixup type: #'BytecodeFixup *'> fixup mergeSimStack ifNil: [self assert: nextFixup <= numFixups. self cCode: [fixup mergeSimStack: mergeSimStacksBase + (nextFixup * self simStackSlots * (self sizeof: CogSimStackEntry))]. nextFixup := nextFixup + 1] ifNotNil: [self assert: fixup simStackPtr = simStackPtr. 0 to: simStackPtr do: [:i| self assert: ((self simStackAt: i) isSameEntryAs: (self addressOf: (fixup mergeSimStack at: i))). (self simStackAt: i) liveRegister ~= (self addressOf: (fixup mergeSimStack at: i)) liveRegister ifTrue: [(self simStackAt: i) liveRegister: NoReg]]]. fixup simStackPtr: simStackPtr. + self cCode: [self memcpy: fixup mergeSimStack _: simStack _: self simStackSlots * (self sizeof: CogSimStackEntry)] - self cCode: [self mem: fixup mergeSimStack cp: simStack y: self simStackSlots * (self sizeof: CogSimStackEntry)] inSmalltalk: [fixup mergeSimStack: self copySimStack]! Item was changed: ----- Method: SimulatorHarnessForTests>>findSymbol: (in category 'utilities') ----- findSymbol: aString "Find the Symbol equal to aString in oldHeap." | om size symbolClassTag | symbolClassTag := (om := simulator objectMemory) rawClassTagForClass: self symbolClass. size := aString size. om allObjectsDo: [:obj| (symbolClassTag = (om fetchClassTagOfNonImm: obj) and: [(om numBytesOf: obj) = size and: ["(om fetchByte: 0 ofObject: obj) asCharacter == $C ifTrue: [simulator printOopShort: obj; halt]." + (om strncmp: aString _: obj + om baseHeaderSize _: size) = 0]]) ifTrue: - (om str: aString n: obj + om baseHeaderSize cmp: size) = 0]]) ifTrue: [^obj]]. ^nil! Item was changed: ----- Method: SocketPluginSimulator>>sqResolverStartName:Lookup: (in category 'simulation') ----- sqResolverStartName: aCArray Lookup: size "For now don't simulate the implicit semaphore." | hostName | + hostName := self strncpy: (String new: size) _: aCArray _: size. - hostName := self st: (String new: size) rn: aCArray cpy: size. addressForName := NetNameResolver addressForName: hostName timeout: 30. resolverSemaphoreIndex ifNotNil: [resolverStatus := ResolverReady. interpreterProxy signalSemaphoreWithIndex: resolverSemaphoreIndex]! Item was changed: ----- Method: Spur64BitMemoryManager>>isSmallFloatValue: (in category 'interpreter access') ----- isSmallFloatValue: aFloat <inline: true> <var: #rawFloat type: #usqLong> <var: #aFloat type: #double> | exponent rawFloat | self + cCode: [self memcpy: (self addressOf: rawFloat) _: (self addressOf: aFloat) _: (self sizeof: rawFloat)] - cCode: [self mem: (self addressOf: rawFloat) cp: (self addressOf: aFloat) y: (self sizeof: rawFloat)] inSmalltalk: [rawFloat := (aFloat at: 1) << 32 + (aFloat at: 2)]. exponent := rawFloat >> self smallFloatMantissaBits bitAnd: 16r7FF. ^exponent > self smallFloatExponentOffset ifTrue: [exponent <= (255 + self smallFloatExponentOffset)] ifFalse: [(rawFloat bitAnd: (1 << self smallFloatMantissaBits - 1)) = 0 ifTrue: [exponent = 0] ifFalse: [exponent = self smallFloatExponentOffset]]! Item was removed: - ----- Method: Spur64BitMemoryManager>>mem:mo:ve: (in category 'simulation only') ----- - mem: destAddress mo: sourceAddress ve: bytes - <doNotGenerate> - | dst src | - dst := destAddress asInteger. - src := sourceAddress asInteger. - "Emulate the c library memmove function" - self assert: bytes \\ 4 = 0. - destAddress > sourceAddress - ifTrue: - [bytes - 4 to: 0 by: -4 do: - [:i| self long32At: dst + i put: (self long32At: src + i)]] - ifFalse: - [0 to: bytes - 4 by: 4 do: - [:i| self long32At: dst + i put: (self long32At: src + i)]]! Item was added: + ----- Method: Spur64BitMemoryManager>>memmove:_:_: (in category 'simulation only') ----- + memmove: destAddress _: sourceAddress _: bytes + <doNotGenerate> + | dst src | + dst := destAddress asInteger. + src := sourceAddress asInteger. + "Emulate the c library memmove function" + self assert: bytes \\ 4 = 0. + destAddress > sourceAddress + ifTrue: + [bytes - 4 to: 0 by: -4 do: + [:i| self long32At: dst + i put: (self long32At: src + i)]] + ifFalse: + [0 to: bytes - 4 by: 4 do: + [:i| self long32At: dst + i put: (self long32At: src + i)]]! Item was changed: ----- Method: Spur64BitMemoryManager>>smallFloatObjectOf: (in category 'interpreter access') ----- smallFloatObjectOf: aFloat "Encode the argument, aFloat in the SmallFloat range, as a tagged small float. See section 61-bit Immediate Floats in the SpurMemoryManager class comment. Encode: [1s][ 11 exponent ][52mantissa] rot sign: [ 11 exponent ][52mantissa][1s] sub exponent offset: [ 000 ][8expsubset][52 mantissa][1s] shift: [8expsubset][52 mantissa][1s][ 000 ] or/add tags: [8expsubset][52mantissa][1s][3tags]" <inline: true> <returnTypeC: #sqInt> <var: #aFloat type: #double> | rawFloat rot | <var: #rawFloat type: #usqLong> <var: #rot type: #usqLong> self assert: (self isSmallFloatValue: aFloat). self + cCode: [self memcpy: (self addressOf: rawFloat) _: (self addressOf: aFloat) _: (self sizeof: rawFloat)] - cCode: [self mem: (self addressOf: rawFloat) cp: (self addressOf: aFloat) y: (self sizeof: rawFloat)] inSmalltalk: [rawFloat := (aFloat at: 1) << 32 + (aFloat at: 2)]. rot := self rotateLeft: rawFloat. rot > 1 ifTrue: "a.k.a. ~= +/-0.0" [rot := rot - (self smallFloatExponentOffset << (self smallFloatMantissaBits + 1)). self assert: rot > 0]. ^self cCode: [rot << self numTagBits + self smallFloatTag] inSmalltalk: [((rot << self numTagBits) bitAnd: 16rFFFFFFFFFFFFFFFF) + self smallFloatTag]! Item was changed: ----- Method: Spur64BitMemoryManager>>smallFloatValueOf: (in category 'interpreter access') ----- smallFloatValueOf: oop "Answer the C double precision floating point value of the argument, a SmallFloat. See section 61-bit Immediate Floats in the SpurMemoryManager class comment. msb lsb Decode: [8expsubset][52mantissa][1s][3tags] shift away tags: [ 000 ][8expsubset][52mantissa][1s] add exponent offset: [ 11 exponent ][52mantissa][1s] rot sign: [1s][ 11 exponent ][52mantissa]" | bits value | <returnTypeC: #double> <var: #value type: #double> <var: #bits type: #usqLong> bits := self smallFloatBitsOf: oop. self cCode: + [self memcpy: (self addressOf: value) _: (self addressOf: bits) _: (self sizeof: value). - [self mem: (self addressOf: value) cp: (self addressOf: bits) y: (self sizeof: value). ^value] inSmalltalk: [^(Float new: 2) at: 1 put: bits >> 32; at: 2 put: (bits bitAnd: 16rFFFFFFFF); * 1.0 "reduce to SmallFloat64 if possible"]! Item was changed: ----- Method: SpurGenerationScavenger>>copyToFutureSpace:bytes: (in category 'scavenger') ----- copyToFutureSpace: survivor bytes: bytesInObject "Copy survivor to futureSpace. Assume it will fit (checked by sender). Answer the new oop of the object (it may have an overflow size field)." <inline: true> | startOfSurvivor newStart | statSurvivorCount := statSurvivorCount + 1. "we hope writes are cheap..." self assert: futureSurvivorStart + bytesInObject <= futureSpace limit. startOfSurvivor := manager startOfObject: survivor. newStart := futureSurvivorStart. futureSurvivorStart := futureSurvivorStart + bytesInObject. + manager memcpy: newStart asVoidPointer _: startOfSurvivor asVoidPointer _: bytesInObject. - manager mem: newStart asVoidPointer cp: startOfSurvivor asVoidPointer y: bytesInObject. tenureCriterion = TenureToShrinkRT ifTrue: [manager rtRefCountOf: newStart + (survivor - startOfSurvivor) put: 0]. ^newStart + (survivor - startOfSurvivor)! Item was changed: ----- Method: SpurGenerationScavenger>>copyToOldSpace:bytes:format: (in category 'scavenger') ----- copyToOldSpace: survivor bytes: bytesInObject format: formatOfSurvivor "Copy survivor to oldSpace. Answer the new oop of the object." <inline: #never> "Should be too infrequent to lower icache density of copyAndForward:" | nTenures startOfSurvivor newStart newOop | self assert: (formatOfSurvivor = (manager formatOf: survivor) and: [((manager isMarked: survivor) not or: [tenureCriterion = MarkOnTenure]) and: [tenureCriterion = TenureToShrinkRT or: [(manager isPinned: survivor) not and: [(manager isRemembered: survivor) not]]]]). nTenures := statTenures. startOfSurvivor := manager startOfObject: survivor. newStart := manager allocateOldSpaceChunkOfBytes: bytesInObject. newStart ifNil: [manager growOldSpaceByAtLeast: 0. "grow by growHeadroom" newStart := manager allocateOldSpaceChunkOfBytes: bytesInObject. newStart ifNil: [self error: 'out of memory']]. "manager checkFreeSpace." + manager memcpy: newStart asVoidPointer _: startOfSurvivor asVoidPointer _: bytesInObject. - manager mem: newStart asVoidPointer cp: startOfSurvivor asVoidPointer y: bytesInObject. newOop := newStart + (survivor - startOfSurvivor). tenureCriterion >= (TenureToShrinkRT min: MarkOnTenure) ifTrue: [tenureCriterion = TenureToShrinkRT ifTrue: [manager rtRefCountOf: newOop put: 0]. tenureCriterion = MarkOnTenure ifTrue: [manager setIsMarkedOf: newOop to: true]]. statTenures := nTenures + 1. (manager isAnyPointerFormat: formatOfSurvivor) ifTrue: ["A very quick and dirty scan to find young referents. If we misidentify bytes in a CompiledMethod as young we don't care; it's unlikely, and a subsequent scan of the rt will filter the object out. But it's good to filter here because otherwise an attempt to shrink the RT may simply fill it up with new objects, and here the data is likely in the cache." manager baseHeaderSize to: bytesInObject - (survivor - startOfSurvivor) - manager wordSize by: manager wordSize do: [:p| | field | field := manager longAt: survivor + p. (manager isReallyYoung: field) ifTrue: [self remember: newOop. ^newOop]]]. ^newOop! Item was changed: ----- Method: SpurMemoryManager>>copyObj:toAddr:stopAt:savedFirstFields:index: (in category 'image segment in/out') ----- copyObj: objOop toAddr: segAddr stopAt: endSeg savedFirstFields: savedFirstFields index: i "This is part of storeImageSegmentInto:outPointers:roots:. Copy objOop into the segment beginning at segAddr, and forward it to the copy, saving its first field in savedFirstField, and setting its marked bit to indicate it has been copied. If it is a class in the class table, set the copy's hash to 0 for reassignment on load, and mark it as a class by setting its isRemembered bit. Answer the next segmentAddr if successful. Answer an appropriate error code if not" "Copy the object..." | bodySize copy hash | <inline: false> self deny: (self isCopiedIntoSegment: objOop). bodySize := self bytesInObject: objOop. (self oop: segAddr + bodySize isGreaterThanOrEqualTo: endSeg) ifTrue: [^PrimErrWritePastObject halt]. + self memcpy: segAddr asVoidPointer _: (self startOfObject: objOop) asVoidPointer _: bodySize. - self mem: segAddr asVoidPointer cp: (self startOfObject: objOop) asVoidPointer y: bodySize. copy := self objectStartingAt: segAddr. "Clear remembered, mark bits of all headers copied into the segment (except classes)" self setIsRememberedOf: copy to: false; setIsMarkedOf: copy to: false. "Make any objects with hidden dynamic state (contexts, methods) look like normal objects." self ifAProxy: objOop updateCopy: copy. "If the object is a class, zero its identityHash (which is its classIndex) and set its isRemembered bit. It will be assigned a new hash and entered into the table on load." hash := self rawHashBitsOf: objOop. (hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = objOop]) ifTrue: [self setHashBitsOf: copy to: 0. self setIsRememberedOf: copy to: true]. "Now forward the object to its copy in the segment." self storePointerUnchecked: i ofObject: savedFirstFields withValue: (self fetchPointer: 0 ofObject: objOop); storePointerUnchecked: 0 ofObject: objOop withValue: copy; markAsCopiedIntoSegment: objOop. "Answer the new end of segment" ^segAddr + bodySize! Item was changed: ----- Method: SpurMemoryManager>>ensureHasOverflowHeader:forwardIfCloned: (in category 'image segment in/out') ----- ensureHasOverflowHeader: arrayArg forwardIfCloned: forwardIfCloned "If arrayArg is too short to be truncated, clone it so that the clone is long enough. Answer nil if it can't be cloned." <inline: false> (self hasOverflowHeader: arrayArg) ifTrue: [^arrayArg]. ^(self allocateSlots: self numSlotsMask + 1 format: (self formatOf: arrayArg) classIndex: (self classIndexOf: arrayArg)) ifNotNil: [:clonedArray| + self memcpy: clonedArray + self baseHeaderSize + _: arrayArg + self baseHeaderSize + _: (self numSlotsOf: arrayArg) * self bytesPerOop. - self mem: clonedArray + self baseHeaderSize - cp: arrayArg + self baseHeaderSize - y: (self numSlotsOf: arrayArg) * self bytesPerOop. (self isRemembered: arrayArg) ifTrue: [scavenger remember: clonedArray]. forwardIfCloned ifTrue: [self forward: arrayArg to: clonedArray]. clonedArray]! Item was changed: ----- Method: SpurMemoryManager>>findString: (in category 'debug support') ----- findString: aCString "Print the oops of all string-like things that have the same characters as aCString" <api> <var: #aCString type: #'char *'> | cssz | cssz := self strlen: aCString. self allObjectsDo: [:obj| ((self isBytesNonImm: obj) and: [(self lengthOf: obj) = cssz + and: [(self strncmp: aCString _: (self pointerForOop: obj + self baseHeaderSize) _: cssz) = 0]]) ifTrue: - and: [(self str: aCString n: (self pointerForOop: obj + self baseHeaderSize) cmp: cssz) = 0]]) ifTrue: [coInterpreter printHex: obj; space; printOopShort: obj; cr]]! Item was changed: ----- Method: SpurMemoryManager>>findStringBeginningWith: (in category 'debug support') ----- findStringBeginningWith: aCString "Print the oops of all string-like things that start with the same characters as aCString" <api> <var: #aCString type: #'char *'> | cssz | cssz := self strlen: aCString. self allObjectsDo: [:obj| ((self isBytesNonImm: obj) and: [(self lengthOf: obj) >= cssz + and: [(self strncmp: aCString _: (self pointerForOop: obj + self baseHeaderSize) _: cssz) = 0]]) ifTrue: - and: [(self str: aCString n: (self pointerForOop: obj + self baseHeaderSize) cmp: cssz) = 0]]) ifTrue: [coInterpreter printHex: obj; space; printNum: (self lengthOf: obj); space; printOopShort: obj; cr]]! Item was removed: - ----- Method: SpurMemoryManager>>mem:cp:y: (in category 'simulation') ----- - mem: destAddress cp: sourceAddress y: bytes - "For SpurGenerationScavenger>>copyToFutureSpace:bytes:. N.B. If ranges overlap, must use memmove." - <doNotGenerate> - self deny: ((destAddress <= sourceAddress and: [destAddress asInteger + bytes > sourceAddress]) - or: [sourceAddress <= destAddress and: [sourceAddress asInteger + bytes > destAddress]]). - ^self mem: destAddress mo: sourceAddress ve: bytes! Item was added: + ----- Method: SpurMemoryManager>>memcpy:_:_: (in category 'simulation') ----- + memcpy: destAddress _: sourceAddress _: bytes + "For SpurGenerationScavenger>>copyToFutureSpace:bytes:. N.B. If ranges overlap, must use memmove." + <doNotGenerate> + self deny: ((destAddress <= sourceAddress and: [destAddress asInteger + bytes > sourceAddress]) + or: [sourceAddress <= destAddress and: [sourceAddress asInteger + bytes > destAddress]]). + ^self memmove: destAddress _: sourceAddress _: bytes! Item was changed: ----- Method: SpurMemoryManager>>stringForCString: (in category 'primitive support') ----- stringForCString: aCString "Answer a new String copied from a null-terminated C string, or nil if out of memory." <api> <var: 'aCString' type: 'const char *'> <inline: false> | len newString | len := self strlen: aCString. newString := self allocateSlots: (self numSlotsForBytes: len) format: (self byteFormatForNumBytes: len) classIndex: ClassByteStringCompactIndex. newString ifNotNil: + [self strncpy: (self cCoerceSimple: newString + self baseHeaderSize to: #'char *') + _: aCString + _: len]. "(char *)strncpy()" - [self st: (self cCoerceSimple: newString + self baseHeaderSize to: #'char *') - rn: aCString - cpy: len]. "(char *)strncpy()" ^newString! Item was changed: ----- Method: SpurPlanningCompactor>>copyAndUnmarkObject:to:bytes:firstField: (in category 'compaction') ----- copyAndUnmarkObject: o to: toFinger bytes: bytes firstField: firstField "Copy the object to toFinger, clearing its mark bit both in the target and the corpse, and restoring its firstField, which was overwritten with a forwarding pointer." <inline: true> | numSlots destObj start | manager setIsMarkedOf: o to: false. numSlots := manager rawNumSlotsOf: o. destObj := (manager objectWithRawSlotsHasOverflowHeader: numSlots) ifTrue: [toFinger + manager baseHeaderSize] ifFalse: [toFinger]. start := manager startOfObject: o given: numSlots. "memmove must be used since the ranges may overlap." manager + memmove: toFinger asVoidPointer _: start asVoidPointer _: bytes; - mem: toFinger asVoidPointer mo: start asVoidPointer ve: bytes; storePointerUnchecked: 0 ofObject: destObj withValue: firstField! Item was changed: ----- Method: SpurSelectiveCompactor>>compactSegment:freeStart: (in category 'compaction') ----- compactSegment: segInfo freeStart: initialFreeStart <var: 'segInfo' type: #'SpurSegmentInfo *'> | currentEntity fillStart bytesToCopy bridge copy | fillStart := initialFreeStart. bridge := manager segmentManager bridgeFor: segInfo. currentEntity := manager objectStartingAt: segInfo segStart. [self oop: currentEntity isLessThan: bridge] whileTrue: [(manager isFreeObject: currentEntity) ifTrue: ["To avoid confusing too much Spur (especially the leak/free checks), we mark the free chunk as a word object." manager detachFreeObject: currentEntity. manager set: currentEntity classIndexTo: manager wordSizeClassIndexPun formatTo: manager wordIndexableFormat] ifFalse: ["Copy the object in segmentToFill and replace it by a forwarder." self assert: (manager isPinned: currentEntity) not. bytesToCopy := manager bytesInObject: currentEntity. + manager memcpy: fillStart asVoidPointer _: (manager startOfObject: currentEntity) asVoidPointer _: bytesToCopy. - manager mem: fillStart asVoidPointer cp: (manager startOfObject: currentEntity) asVoidPointer y: bytesToCopy. copy := manager objectStartingAt: fillStart. (manager isRemembered: copy) ifTrue: ["copy has the remembered bit set, but is not in the remembered table." manager setIsRememberedOf: copy to: false. scavenger remember: copy]. manager forward: currentEntity to: (manager objectStartingAt: fillStart). fillStart := fillStart + bytesToCopy. self assert: (self oop: fillStart isLessThan: (segmentToFill segLimit - manager bridgeSize))]. currentEntity := manager objectAfter: currentEntity limit: manager endOfMemory]. self assert: currentEntity = bridge. ^ fillStart! Item was changed: ----- Method: StackInterpreter>>callbackEnter: (in category 'callback support') ----- callbackEnter: callbackID "Re-enter the interpreter to execute a (non-ALien,non-FFI) callback (as used by the Python bridge)." <volatile> <export: true> <var: #callbackID type: #'sqInt *'> | savedReenterInterpreter | <var: #savedReenterInterpreter type: #'jmp_buf'> "For now, do not allow a callback unless we're in a primitiveResponse" (self asserta: primitiveFunctionPointer ~= 0) ifFalse: [^false]. self assert: primFailCode = 0. "Check if we've exceeded the callback depth" (self asserta: jmpDepth < MaxJumpBuf) ifFalse: [^false]. jmpDepth := jmpDepth + 1. "Suspend the currently active process" suspendedCallbacks at: jmpDepth put: self activeProcess. "We need to preserve newMethod explicitly since it is not activated yet and therefore no context has been created for it. If the caller primitive for any reason decides to fail we need to make sure we execute the correct method and not the one 'last used' in the call back" suspendedMethods at: jmpDepth put: newMethod. "Signal external semaphores since a signalSemaphoreWithIndex: request may have been issued immediately prior to this callback before the VM has any chance to do a signalExternalSemaphores in checkForEventsMayContextSwitch:" self signalExternalSemaphores. "If no process is awakened by signalExternalSemaphores then transfer to the highest priority runnable one." (suspendedCallbacks at: jmpDepth) = self activeProcess ifTrue: [self transferTo: self wakeHighestPriority]. "Typically, invoking the callback means that some semaphore has been signaled to indicate the callback. Force an interrupt check as soon as possible." self forceInterruptCheck. "Save the previous interpreter entry jmp_buf." + self memcpy: savedReenterInterpreter asVoidPointer + _: reenterInterpreter + _: (self sizeof: #'jmp_buf'). - self mem: savedReenterInterpreter asVoidPointer - cp: reenterInterpreter - y: (self sizeof: #'jmp_buf'). (self setjmp: (jmpBuf at: jmpDepth)) = 0 ifTrue: "Fill in callbackID" [callbackID at: 0 put: jmpDepth. self enterSmalltalkExecutive. self assert: false "NOTREACHED"]. "Restore the previous interpreter entry jmp_buf." + self memcpy: reenterInterpreter + _: (self cCoerceSimple: savedReenterInterpreter to: #'void *') + _: (self sizeof: #'jmp_buf'). - self mem: reenterInterpreter - cp: (self cCoerceSimple: savedReenterInterpreter to: #'void *') - y: (self sizeof: #'jmp_buf'). "Transfer back to the previous process so that caller can push result" self putToSleep: self activeProcess yieldingIf: preemptionYields. self transferTo: (suspendedCallbacks at: jmpDepth). newMethod := suspendedMethods at: jmpDepth. "see comment above" argumentCount := self argumentCountOf: newMethod. self assert: primFailCode = 0. jmpDepth := jmpDepth - 1. ^true! Item was changed: ----- Method: StackInterpreter>>initializeExtraClassInstVarIndices (in category 'initialization') ----- initializeExtraClassInstVarIndices "Initialize metaclassNumSlots and thisClassIndex which are used in debug printing, and classNameIndex which is used not only for debug printing but for is:KindOf: & is:MemberOf: via classNameOf:is: (evil but a reality we have to accept)." | classArrayObj classArrayClass | classArrayObj := objectMemory splObj: ClassArray. classArrayClass := objectMemory fetchClassOfNonImm: classArrayObj. metaclassNumSlots := objectMemory numSlotsOf: classArrayClass. "determine actual Metaclass instSize" thisClassIndex := 5. "default" InstanceSpecificationIndex + 1 to: (objectMemory lengthOf: classArrayClass) do: [:i| (objectMemory fetchPointer: i - 1 ofObject: classArrayClass) = classArrayObj ifTrue: [thisClassIndex := i - 1]]. classNameIndex := 6. "default" InstanceSpecificationIndex + 1 to: (objectMemory lengthOf: classArrayObj) do: [:i| | oop | oop := objectMemory fetchPointer: i - 1 ofObject: classArrayObj. ((objectMemory isBytes: oop) and: [(objectMemory lengthOf: oop) = 5 + and: [(objectMemory strncmp: 'Array' _: (objectMemory firstFixedField: oop) _: 5) = 0]]) ifTrue: - and: [(objectMemory str: 'Array' n: (objectMemory firstFixedField: oop) cmp: 5) = 0]]) ifTrue: [classNameIndex := i - 1]]! Item was changed: ----- Method: StackInterpreter>>lowcode_mem:cp:y: (in category 'inline primitive support') ----- lowcode_mem: destAddress cp: sourceAddress y: bytes "This method is a workaround a GCC bug. In Windows memcpy is putting too much register pressure on GCC when used by Lowcode instructions" <inline: #never> <option: #LowcodeVM> <var: #destAddress type: #'void*'> <var: #sourceAddress type: #'void*'> <var: #bytes type: #'sqInt'> "Using memmove instead of memcpy to avoid crashing GCC in Windows." + self memmove: destAddress _: sourceAddress _: bytes! - self mem: destAddress mo: sourceAddress ve: bytes! Item was changed: ----- Method: StackInterpreter>>printOopShortInner: (in category 'debug printing') ----- printOopShortInner: oop | classOop name nameLen | <var: #name type: #'char *'> <inline: true> (objectMemory isImmediate: oop) ifTrue: [(objectMemory isImmediateCharacter: oop) ifTrue: [^self printChar: $$; printChar: (objectMemory characterValueOf: oop); printChar: $(; printHexnp: (objectMemory characterValueOf: oop); printChar: $)]. (objectMemory isIntegerObject: oop) ifTrue: [^self printNum: (objectMemory integerValueOf: oop); printChar: $(; printHexnp: (objectMemory integerValueOf: oop); printChar: $)]. (objectMemory isImmediateFloat: oop) ifTrue: [^self printFloat: (objectMemory dbgFloatValueOf: oop); printChar: $(; printHexnp: oop; printChar: $)]. ^self print: 'unknown immediate '; printHexnp: oop]. (objectMemory addressCouldBeObj: oop) ifFalse: [^self print: ((oop bitAnd: objectMemory allocationUnit - 1) ~= 0 ifTrue: [' is misaligned'] ifFalse: [self whereIs: oop])]. (objectMemory isFreeObject: oop) ifTrue: [^self print: ' is a free chunk']. (objectMemory isForwarded: oop) ifTrue: [^self print: ' is a forwarder to '; printHexnp: (objectMemory followForwarded: oop)]. (self isFloatObject: oop) ifTrue: [^self printFloat: (objectMemory dbgFloatValueOf: oop)]. classOop := objectMemory fetchClassOfNonImm: oop. (objectMemory addressCouldBeObj: classOop) ifFalse: [^self print: 'a ??']. (objectMemory numSlotsOf: classOop) = metaclassNumSlots ifTrue: [^self printNameOfClass: oop count: 5]. oop = objectMemory nilObject ifTrue: [^self print: 'nil']. oop = objectMemory trueObject ifTrue: [^self print: 'true']. oop = objectMemory falseObject ifTrue: [^self print: 'false']. nameLen := self lengthOfNameOfClass: classOop. nameLen = 0 ifTrue: [^self print: 'a ??']. name := self nameOfClass: classOop. nameLen = 10 ifTrue: + [(self strncmp: name _: 'ByteString' _: 10) = 0 "strncmp is weird" ifTrue: - [(self str: name n: 'ByteString' cmp: 10) = 0 "strncmp is weird" ifTrue: [^self printChar: $'; printStringOf: oop; printChar: $']. + (self strncmp: name _: 'ByteSymbol' _: 10) = 0 "strncmp is weird" ifTrue: - (self str: name n: 'ByteSymbol' cmp: 10) = 0 "strncmp is weird" ifTrue: [self printChar: $#; printStringOf: oop. ^self]]. + (nameLen = 9 and: [(self strncmp: name _: 'Character' _: 9) = 0]) ifTrue: - (nameLen = 9 and: [(self str: name n: 'Character' cmp: 9) = 0]) ifTrue: [^self printChar: $$; printChar: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop))]. self print: 'a(n) '. self cCode: [0 to: nameLen - 1 do: [:i| self printChar: (name at: i)]] inSmalltalk: [name isString ifTrue: [self print: name] ifFalse: [0 to: nameLen - 1 do: [:i| self printChar: (name at: i)]]]. "Try to spot association-like things; they're all subclasses of LookupKey" ((objectMemory isPointersNonImm: oop) and: [(objectMemory instanceSizeOf: classOop) = (ValueIndex + 1) and: [(objectMemory isBytes: (objectMemory fetchPointer: KeyIndex ofObject: oop))]]) ifTrue: [| classLookupKey | classLookupKey := objectMemory fetchClassOfNonImm: (objectMemory splObj: SchedulerAssociation). [classLookupKey = objectMemory nilObject ifTrue: [^self]. (objectMemory instanceSizeOf: classLookupKey) = (KeyIndex + 1)] whileFalse: [classLookupKey := self superclassOf: classLookupKey]. (self includesBehavior: classOop ThatOf: classLookupKey) ifTrue: [self space; printOopShort: (objectMemory fetchPointer: KeyIndex ofObject: oop); print: ' -> '; printHexnp: (objectMemory fetchPointer: ValueIndex ofObject: oop)]]! Item was changed: ----- Method: StackInterpreter>>restoreCStackStateForCallbackContext: (in category 'callback support') ----- restoreCStackStateForCallbackContext: vmCallbackContext <var: #vmCallbackContext type: #'VMCallbackContext *'> + self memcpy: reenterInterpreter + _: vmCallbackContext savedReenterInterpreter asVoidPointer + _: (self sizeof: #'jmp_buf')! - self mem: reenterInterpreter - cp: vmCallbackContext savedReenterInterpreter asVoidPointer - y: (self sizeof: #'jmp_buf')! Item was changed: ----- Method: StackInterpreter>>saveCStackStateForCallbackContext: (in category 'callback support') ----- saveCStackStateForCallbackContext: vmCallbackContext <var: #vmCallbackContext type: #'VMCallbackContext *'> + self memcpy: vmCallbackContext savedReenterInterpreter asVoidPointer + _: reenterInterpreter + _: (self sizeof: #'jmp_buf')! - self mem: vmCallbackContext savedReenterInterpreter asVoidPointer - cp: reenterInterpreter - y: (self sizeof: #'jmp_buf')! Item was changed: ----- Method: StackInterpreterSimulator>>ioLoadFunction:From: (in category 'plugin support') ----- ioLoadFunction: functionString From: pluginString "Load and return the requested function from a module" | plugin fnSymbol | fnSymbol := functionString asSymbol. transcript cr; show: '(', byteCount printString, ') Looking for ', functionString, ' in ', (pluginString isEmpty ifTrue:['vm'] ifFalse:[pluginString]). (breakSelector notNil and: [pluginString size = breakSelector size + and: [(self strncmp: pluginString _: breakSelector _: pluginString size) = 0 + or: [(self strncmp: functionString _: breakSelector _: functionString size) = 0]]]) ifTrue: - and: [(self str: pluginString n: breakSelector cmp: pluginString size) = 0 - or: [(self str: functionString n: breakSelector cmp: functionString size) = 0]]]) ifTrue: [self halt: functionString]. plugin := pluginList detect:[:any| any key = pluginString asString] ifNone:[self loadNewPlugin: pluginString]. plugin ifNil:[ "Transcript cr; show:'Failed ... no plugin found'." ^ 0]. plugin := plugin value. mappedPluginEntries doWithIndex:[:pluginAndName :index| ((pluginAndName at: 1) == plugin and:[(pluginAndName at: 2) == fnSymbol]) ifTrue:[ "Transcript show:' ... okay'." ^ index]]. (plugin respondsTo: fnSymbol) ifFalse:[ "Transcript cr; show:'Failed ... primitive not in plugin'." ^ 0]. mappedPluginEntries := mappedPluginEntries copyWith: (Array with: plugin with: fnSymbol). "Transcript show:' ... okay'." ^ mappedPluginEntries size! Item was changed: ----- Method: StackInterpreterSimulator>>ioLoadFunction:From:AccessorDepthInto: (in category 'plugin support') ----- ioLoadFunction: functionString From: pluginString AccessorDepthInto: accessorDepthPtr "Load and return the requested function from a module. Assign the accessor depth through accessorDepthPtr. N.B. The actual code lives in platforms/Cross/vm/sqNamedPrims.h" | firstTime plugin fnSymbol | firstTime := false. fnSymbol := functionString asSymbol. transcript cr; show: '(', byteCount printString, ') Looking for ', functionString, ' in ', (pluginString isEmpty ifTrue:['vm'] ifFalse:[pluginString]). (breakSelector notNil and: [pluginString size = breakSelector size + and: [(self strncmp: pluginString _: breakSelector _: pluginString size) = 0 + or: [(self strncmp: functionString _: breakSelector _: functionString size) = 0]]]) ifTrue: - and: [(self str: pluginString n: breakSelector cmp: pluginString size) = 0 - or: [(self str: functionString n: breakSelector cmp: functionString size) = 0]]]) ifTrue: [self halt: functionString]. plugin := pluginList detect: [:any| any key = pluginString asString] ifNone: [firstTime := true. self loadNewPlugin: pluginString]. plugin ifNil: [firstTime ifTrue: [transcript cr; show: 'Failed ... primitive not in plugin']. ^0]. plugin := plugin value. mappedPluginEntries doWithIndex: [:pluginAndName :index| ((pluginAndName at: 1) == plugin and:[(pluginAndName at: 2) == fnSymbol]) ifTrue: [firstTime ifTrue: [transcript show: ' ... okay'; cr]. accessorDepthPtr at: 0 put: (pluginAndName at: 4). ^index]]. firstTime ifTrue: [transcript cr; show: 'Failed ... primitive not in plugin']. transcript cr. ^0! Item was changed: ----- Method: StackInterpreterSimulator>>loadNewPlugin: (in category 'plugin support') ----- loadNewPlugin: pluginString breakSelector ifNotNil: + [(self strncmp: pluginString _: breakSelector _: pluginString size) = 0 ifTrue: - [(self str: pluginString n: breakSelector cmp: pluginString size) = 0 ifTrue: [self halt: pluginString]]. ^(self tryLoadNewPlugin: pluginString pluginEntries: mappedPluginEntries) ifNotNil: [:entry| pluginList := pluginList copyWith: entry. entry]! Item was changed: ----- Method: TMethod>>statementsFor:varName: (in category 'primitive compilation') ----- statementsFor: sourceText varName: varName "Return the parse tree for the given expression. The result is the statements list of the method parsed from the given source text." "Details: Various variables are declared as locals to avoid Undeclared warnings from the parser." | s | s := WriteStream on: String new. s nextPutAll: 'temp'; cr; crtab. self printTempsAndVar: varName on: s. s nextPutAll: sourceText. + ^ (([ | compiler | + compiler := Smalltalk compiler class: Object. + (compiler parse: s contents) + compilationContext: compiler compilationContext; + yourself] "Pharo" - ^ (([Smalltalk compiler parse: s contents] "Pharo" on: MessageNotUnderstood do: [:ex| ex message selector == #compiler ifFalse: [ex pass]. Compiler new parse: s contents in: Object notifying: nil]) "Squeak" asTranslationMethodOfClass: self class) removeFinalSelfReturnIn: nil; + statements! - statements - ! Item was changed: ----- Method: TStmtListNode>>addReadBeforeAssignedIn:to:assignments:in: (in category 'utilities') ----- addReadBeforeAssignedIn: variables to: readBeforeAssigned assignments: assigned in: aCodeGen "Add any variables in variables that are read before written to readBeforeAssigned. Add unconditional assignments to assigned. For convenience answer assigned." self nodesWithParentsDo: [:node :parent| (node isAssignment and: [variables includes: node variable name]) ifTrue: [assigned add: node variable name]. (node isVariable and: [(variables includes: node name) and: [(assigned includes: node name) not and: [(#(nil pointer) includes: (node structTargetKindIn: aCodeGen)) and: [(parent notNil and: [parent isAssignment and: [parent variable == node]]) not]]]]) ifTrue: [node name = 'theCalloutState' ifTrue: [self halt]. readBeforeAssigned add: node name]] unless: [:node :parent| | conditionalAssignments mayHaveSideEffects | node isSend ifTrue: ["First deal with implicit assignments..." node isValueExpansion ifTrue: [assigned addAll: node receiver args]. + (#(#'memcpy:_:_:' #'memmove:_:_:') includes: node selector) ifTrue: - (#(mem:cp:y: mem:mo:ve:) includes: node selector) ifTrue: [assigned add: (node args first detect: [:subnode| subnode isVariable]) name]. (#(to:do: to:by:do:) includes: node selector) ifTrue: [assigned addAll: (node args at: node selector numArgs) args. mayHaveSideEffects := node args size = 4. "See TMethod>>prepareMethodIn:" mayHaveSideEffects ifTrue: [assigned add: node args last name]]. "Then deal with read-before-written in the arms of conditionals..." (#(ifTrue: ifFalse: ifNil: ifNotNil:) intersection: node selector keywords) notEmpty ifTrue: ["First find assignments in the expression..." (TStmtListNode new setStatements: {node receiver}; yourself) addReadBeforeAssignedIn: variables to: readBeforeAssigned assignments: assigned in: aCodeGen. "Now find read-before-written in each arm, and collect the assignments to spot those assigned in both arms" conditionalAssignments := node args collect: [:block| block isStmtList ifTrue: [block addReadBeforeAssignedIn: variables to: readBeforeAssigned assignments: assigned copy in: aCodeGen]] thenSelect: [:each| each notNil]. "add to assigned those variables written to in both arms" conditionalAssignments size = 2 ifTrue: [conditionalAssignments := conditionalAssignments collect: [:set| set difference: assigned]. assigned addAll: (conditionalAssignments first intersection: conditionalAssignments last)]. true] ifFalse: [false]] ifFalse: [false]]. ^assigned! Item was changed: ----- Method: ThreadedARMFFIPlugin>>ffiPushStructure:ofSize:typeSpec:ofLength:in: (in category 'marshalling') ----- ffiPushStructure: pointer ofSize: structSize typeSpec: argSpec ofLength: argSpecSize in: calloutState <var: #pointer type: #'void *'> <var: #argSpec type: #'sqInt *'> <var: #calloutState type: #'CalloutState *'> <inline: true> | availableRegisterSpace stackPartSize roundedSize | availableRegisterSpace := (NumIntRegArgs - calloutState integerRegisterIndex) * 4. stackPartSize := structSize. availableRegisterSpace > 0 ifTrue: [structSize <= availableRegisterSpace ifTrue: ["all in registers" stackPartSize := 0. self + memcpy: (self cCoerceSimple: (self addressOf: (calloutState integerRegisters at: calloutState integerRegisterIndex)) to: 'void *') + _: pointer + _: structSize. - mem: (self cCoerceSimple: (self addressOf: (calloutState integerRegisters at: calloutState integerRegisterIndex)) to: 'void *') - cp: pointer - y: structSize. calloutState integerRegisterIndex: calloutState integerRegisterIndex + (structSize + 3 bitShift: -2) ] ifFalse: ["If no previous co-processor candidate arg has already been pushed on the stack, then split the struct between registers and stack. Otherwise push entire struct on stack." calloutState currentArg = calloutState argVector ifTrue: [stackPartSize := structSize - availableRegisterSpace. self + memcpy: (self cCoerceSimple: (self addressOf: (calloutState integerRegisters at: calloutState integerRegisterIndex)) to: 'void *') + _: pointer + _: availableRegisterSpace] - mem: (self cCoerceSimple: (self addressOf: (calloutState integerRegisters at: calloutState integerRegisterIndex)) to: 'void *') - cp: pointer - y: availableRegisterSpace] ifFalse: [availableRegisterSpace := 0]. calloutState integerRegisterIndex: NumIntRegArgs]]. stackPartSize > 0 ifTrue: [roundedSize := stackPartSize + 3 bitClear: 3. calloutState currentArg + roundedSize > calloutState limit ifTrue: [^FFIErrorCallFrameTooBig]. + self memcpy: calloutState currentArg _: (self addressOf: ((self cCoerceSimple: pointer to: 'char *') at: availableRegisterSpace)) _: stackPartSize. - self mem: calloutState currentArg cp: (self addressOf: ((self cCoerceSimple: pointer to: 'char *') at: availableRegisterSpace)) y: stackPartSize. calloutState currentArg: calloutState currentArg + roundedSize]. ^0! Item was changed: ----- Method: ThreadedARMFFIPlugin>>ffiReturnStruct:ofType:in: (in category 'callout support') ----- ffiReturnStruct: longLongRet ofType: ffiRetType in: calloutState <var: #longLongRet type: #usqLong> <var: #calloutState type: #'CalloutState *'> "Create a structure return value from an external function call. The value has been stored in alloca'ed space pointed to by the calloutState or in the return value." | retOop retClass oop | <inline: true> retClass := interpreterProxy fetchPointer: 1 ofObject: ffiRetType. retOop := interpreterProxy instantiateClass: retClass indexableSize: 0. self remapOop: retOop in: [oop := interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: calloutState structReturnSize]. + self memcpy: (interpreterProxy firstIndexableField: oop) + _: ((self returnStructInRegisters: calloutState structReturnSize) - self mem: (interpreterProxy firstIndexableField: oop) - cp: ((self returnStructInRegisters: calloutState structReturnSize) ifTrue: [self addressOf: longLongRet] ifFalse: [calloutState limit]) + _: calloutState structReturnSize. - y: calloutState structReturnSize. interpreterProxy storePointer: 0 ofObject: retOop withValue: oop. ^retOop! Item was changed: ----- Method: ThreadedFFIPlugin>>ffiPushString:OfLength:in: (in category 'marshalling') ----- ffiPushString: pointer OfLength: length in: calloutState <var: #pointer type: #'char *'> <var: #calloutState type: #'CalloutState *'> | copy | <var: #copy type: #'char *'> <inline: true> calloutState stringArgIndex >= MaxNumArgs ifTrue: [^PrimErrBadNumArgs negated]. copy := self malloc: length + 1. copy isNil ifTrue: [^PrimErrNoCMemory negated]. + self memcpy: copy _: pointer _: length. - self mem: copy cp: pointer y: length. copy at: length put: 0. calloutState stringArgs at: calloutState stringArgIndex put: copy. calloutState stringArgIndex: calloutState stringArgIndex + 1. ^self ffiPushPointer: copy in: calloutState! Item was changed: ----- Method: ThreadedFFIPlugin>>primitiveFFIDoubleAt (in category 'primitives') ----- primitiveFFIDoubleAt "Return a (signed or unsigned) n byte integer from the given byte offset." | byteOffset rcvr addr floatValue | <export: true> <inline: false> <var: #floatValue type: #double> byteOffset := interpreterProxy stackIntegerValue: 0. rcvr := interpreterProxy stackObjectValue: 1. interpreterProxy failed ifTrue:[^0]. addr := self ffiAddressOf: rcvr startingAt: byteOffset size: 8. addr = 0 ifTrue: [^interpreterProxy primitiveFail]. + self memcpy: (self addressOf: floatValue) _: addr _: (self sizeof: floatValue). - self mem: (self addressOf: floatValue) cp: addr y: (self sizeof: floatValue). interpreterProxy pop: 2. ^interpreterProxy pushFloat: floatValue ! Item was changed: ----- Method: ThreadedFFIPlugin>>primitiveFFIDoubleAtPut (in category 'primitives') ----- primitiveFFIDoubleAtPut "Return a (signed or unsigned) n byte integer from the given byte offset." | byteOffset rcvr addr floatValue floatOop | <export: true> <inline: false> <var: #floatValue type: #double> floatOop := interpreterProxy stackValue: 0. (interpreterProxy isIntegerObject: floatOop) ifTrue:[floatValue := self cCoerce: (interpreterProxy integerValueOf: floatOop) to:'double'] ifFalse:[floatValue := self cCoerce: (interpreterProxy floatValueOf: floatOop) to:'double']. byteOffset := interpreterProxy stackIntegerValue: 1. rcvr := interpreterProxy stackObjectValue: 2. interpreterProxy failed ifTrue:[^0]. addr := self ffiAddressOf: rcvr startingAt: byteOffset size: 8. addr = 0 ifTrue: [^interpreterProxy primitiveFail]. + self memcpy: addr _: (self addressOf: floatValue) _: (self sizeof: floatValue). - self mem: addr cp: (self addressOf: floatValue) y: (self sizeof: floatValue). ^interpreterProxy pop: 3 thenPush: floatOop! Item was changed: ----- Method: ThreadedFFIPlugin>>primitiveFFIFloatAt (in category 'primitives') ----- primitiveFFIFloatAt "Return a (signed or unsigned) n byte integer from the given byte offset." | byteOffset rcvr addr floatValue | <export: true> <inline: false> <var: #floatValue type: #float> byteOffset := interpreterProxy stackIntegerValue: 0. rcvr := interpreterProxy stackObjectValue: 1. interpreterProxy failed ifTrue:[^0]. addr := self ffiAddressOf: rcvr startingAt: byteOffset size: 4. addr = 0 ifTrue: [^interpreterProxy primitiveFail]. + self memcpy: (self addressOf: floatValue) _: addr _: (self sizeof: floatValue). - self mem: (self addressOf: floatValue) cp: addr y: (self sizeof: floatValue). interpreterProxy pop: 2. ^interpreterProxy pushFloat: floatValue! Item was changed: ----- Method: ThreadedFFIPlugin>>primitiveFFIFloatAtPut (in category 'primitives') ----- primitiveFFIFloatAtPut "Return a (signed or unsigned) n byte integer from the given byte offset." | byteOffset rcvr addr floatValue floatOop | <export: true> <inline: false> <var: #floatValue type: #float> floatOop := interpreterProxy stackValue: 0. (interpreterProxy isIntegerObject: floatOop) ifTrue:[floatValue := self cCoerce: (interpreterProxy integerValueOf: floatOop) to:'float'] ifFalse:[floatValue := self cCoerce: (interpreterProxy floatValueOf: floatOop) to:'float']. byteOffset := interpreterProxy stackIntegerValue: 1. rcvr := interpreterProxy stackObjectValue: 2. interpreterProxy failed ifTrue:[^0]. addr := self ffiAddressOf: rcvr startingAt: byteOffset size: 4. addr = 0 ifTrue: [^interpreterProxy primitiveFail]. + self memcpy: addr _: (self addressOf: floatValue) _: (self sizeof: floatValue). - self mem: addr cp: (self addressOf: floatValue) y: (self sizeof: floatValue). ^interpreterProxy pop: 3 thenPush: floatOop! Item was changed: ----- Method: ThreadedIA32FFIPlugin>>ffiPushStructure:ofSize:typeSpec:ofLength:in: (in category 'marshalling') ----- ffiPushStructure: pointer ofSize: structSize typeSpec: argSpec ofLength: argSpecSize in: calloutState <var: #pointer type: #'void *'> <var: #argSpec type: #'sqInt *'> <var: #calloutState type: #'CalloutState *'> <inline: true> | roundedSize | roundedSize := structSize + 3 bitClear: 3. calloutState currentArg + roundedSize > calloutState limit ifTrue: [^FFIErrorCallFrameTooBig]. + self memcpy: calloutState currentArg _: pointer _: structSize. - self mem: calloutState currentArg cp: pointer y: structSize. calloutState currentArg: calloutState currentArg + roundedSize. ^0! Item was changed: ----- Method: ThreadedIA32FFIPlugin>>ffiReturnStruct:ofType:in: (in category 'callout support') ----- ffiReturnStruct: longLongRet ofType: ffiRetType in: calloutState <var: #longLongRet type: #usqLong> <var: #calloutState type: #'CalloutState *'> "Create a structure return value from an external function call. The value as been stored in alloca'ed space pointed to by the calloutState." | retOop retClass oop | <inline: true> retClass := interpreterProxy fetchPointer: 1 ofObject: ffiRetType. retOop := interpreterProxy instantiateClass: retClass indexableSize: 0. self remapOop: retOop in: [oop := interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: calloutState structReturnSize]. + self memcpy: (interpreterProxy firstIndexableField: oop) + _: ((self returnStructInRegisters: calloutState structReturnSize) - self mem: (interpreterProxy firstIndexableField: oop) - cp: ((self returnStructInRegisters: calloutState structReturnSize) ifTrue: [(self addressOf: longLongRet) asVoidPointer] ifFalse: [calloutState limit]) + _: calloutState structReturnSize. - y: calloutState structReturnSize. interpreterProxy storePointer: 0 ofObject: retOop withValue: oop. ^retOop! Item was changed: ----- Method: ThreadedX64SysVFFIPlugin>>ffiPushStructure:ofSize:typeSpec:ofLength:in: (in category 'marshalling') ----- ffiPushStructure: pointer ofSize: structSize typeSpec: argSpec ofLength: argSpecSize in: calloutState <var: #pointer type: #'void *'> <var: #argSpec type: #'sqInt *'> <var: #calloutState type: #'CalloutState *'> <inline: true> | roundedSize doubleType floatType numDoubleRegisters numIntegerRegisters passField0InXmmReg passField1InXmmReg | structSize <= 16 ifTrue: ["See sec 3.2.3 of http://people.freebsd.org/~obrien/amd64-elf-abi.pdf. (dravft version 0.90). All of the folowing are passed in registers: typedef struct { long a; } s0; typedef struct { double a; } s1; typedef struct { long a; double b; } s2; typedef struct { int a; int b; double c; } s2a; typedef struct { short a; short b; short c; short d; double e; } s2b; typedef struct { long a; float b; } s2f; typedef struct { long a; float b; float c; } s2g; but not ones like this: typedef struct { int a; float b; int c; float d; } s2h;" doubleType := FFITypeDoubleFloat << FFIAtomicTypeShift + FFITypeDoubleFloat. floatType := FFITypeDoubleFloat << FFIAtomicTypeShift + FFITypeSingleFloat. passField0InXmmReg := doubleType = ((self cCoerce: argSpec to: #'int *') at: 1) "0th field is struct type and size" or: [floatType = ((self cCoerce: argSpec to: #'int *') at: 1) and: [floatType = ((self cCoerce: argSpec to: #'int *') at: 2)]]. structSize <= 8 ifTrue: [numDoubleRegisters := passField0InXmmReg ifTrue: [1] ifFalse: [0]. numIntegerRegisters := 1 - numDoubleRegisters] ifFalse: [passField1InXmmReg := doubleType = ((self cCoerce: argSpec to: #'int *') at: argSpecSize - 1) "Nth field is last field of struct" or: [floatType = ((self cCoerce: argSpec to: #'int *') at: argSpecSize - 2) and: [floatType = ((self cCoerce: argSpec to: #'int *') at: argSpecSize - 1)]]. numDoubleRegisters := (passField0InXmmReg ifTrue: [1] ifFalse: [0]) + (passField1InXmmReg ifTrue: [1] ifFalse: [0]). numIntegerRegisters := 2 - numDoubleRegisters]. (calloutState floatRegisterIndex + numDoubleRegisters <= NumFloatRegArgs and: [calloutState integerRegisterIndex + numIntegerRegisters <= NumIntRegArgs]) ifTrue: [passField0InXmmReg ifTrue: [self ffiPushDoubleFloat: ((self cCoerceSimple: pointer to: #'double *') at: 0) in: calloutState] ifFalse: [self ffiPushSignedLongLong: ((self cCoerceSimple: pointer to: #'long long *') at: 0) in: calloutState]. structSize > 8 ifTrue: [passField1InXmmReg ifTrue: [self ffiPushDoubleFloat: ((self cCoerceSimple: pointer to: #'double *') at: 1) in: calloutState] ifFalse: [self ffiPushSignedLongLong: ((self cCoerceSimple: pointer to: #'long long *') at: 1) in: calloutState]]. ^0]]. roundedSize := structSize + 7 bitClear: 7. calloutState currentArg + roundedSize > calloutState limit ifTrue: [^FFIErrorCallFrameTooBig]. + self memcpy: calloutState currentArg _: (self cCoerceSimple: pointer to: 'char *') _: structSize. - self mem: calloutState currentArg cp: (self cCoerceSimple: pointer to: 'char *') y: structSize. calloutState currentArg: calloutState currentArg + roundedSize. ^0! Item was changed: ----- Method: ThreadedX64SysVFFIPlugin>>ffiReturnStruct:ofType:in: (in category 'callout support') ----- ffiReturnStruct: sixteenByteRet ofType: ffiRetType in: calloutState <var: #sixteenByteRet type: #SixteenByteReturn> <var: #calloutState type: #'CalloutState *'> "Create a structure return value from an external function call. The value has been stored in alloca'ed space pointed to by the calloutState or in the return value." | retOop retClass oop | <inline: true> retClass := interpreterProxy fetchPointer: 1 ofObject: ffiRetType. retOop := interpreterProxy instantiateClass: retClass indexableSize: 0. self remapOop: retOop in: [oop := interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: calloutState structReturnSize]. + self memcpy: (interpreterProxy firstIndexableField: oop) + _: ((self returnStructInRegisters: calloutState structReturnSize) - self mem: (interpreterProxy firstIndexableField: oop) - cp: ((self returnStructInRegisters: calloutState structReturnSize) ifTrue: [(self addressOf: sixteenByteRet) asVoidPointer] ifFalse: [calloutState limit]) + _: calloutState structReturnSize. - y: calloutState structReturnSize. interpreterProxy storePointer: 0 ofObject: retOop withValue: oop. ^retOop! Item was changed: ----- Method: ThreadedX64Win64FFIPlugin>>ffiPushStructure:ofSize:typeSpec:ofLength:in: (in category 'marshalling') ----- ffiPushStructure: pointer ofSize: structSize typeSpec: argSpec ofLength: argSpecSize in: calloutState <var: #pointer type: #'void *'> <var: #argSpec type: #'sqInt *'> <var: #calloutState type: #'CalloutState *'> <var: #arg type: #usqLong> <inline: true> structSize <= 0 ifTrue: [^FFIErrorStructSize]. (structSize <= WordSize and: [(structSize bitAnd: structSize - 1) = 0 "a.k.a. structSize isPowerOfTwo"]) ifTrue: [| arg | + self memcpy: (self addressOf: arg) _: pointer _: structSize. - self mem: (self addressOf: arg) cp: pointer y: structSize. ^self ffiPushUnsignedLongLong: arg in: calloutState]. "For now just push the pointer; we should copy the struct to the outgoing stack frame!!!!" self flag: 'quick hack'. ^self ffiPushPointer: pointer in: calloutState! Item was changed: ----- Method: ThreadedX64Win64FFIPlugin>>ffiReturnStruct:ofType:in: (in category 'callout support') ----- ffiReturnStruct: intRet ofType: ffiRetType in: calloutState <var: #intRet type: #usqLong> <var: #calloutState type: #'CalloutState *'> "Create a structure return value from an external function call. The value has been stored in alloca'ed space pointed to by the calloutState or in the return value." | retOop retClass oop | <inline: true> retClass := interpreterProxy fetchPointer: 1 ofObject: ffiRetType. retOop := interpreterProxy instantiateClass: retClass indexableSize: 0. self remapOop: retOop in: [oop := interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: calloutState structReturnSize]. + self memcpy: (interpreterProxy firstIndexableField: oop) + _: ((self returnStructInRegisters: calloutState structReturnSize) - self mem: (interpreterProxy firstIndexableField: oop) - cp: ((self returnStructInRegisters: calloutState structReturnSize) ifTrue: [self addressOf: intRet] ifFalse: [calloutState limit]) + _: calloutState structReturnSize. - y: calloutState structReturnSize. interpreterProxy storePointer: 0 ofObject: retOop withValue: oop. ^retOop! Item was changed: ----- Method: VMClass>>asString: (in category 'C library simulation') ----- asString: aStringOrStringIndex "aStringOrStringIndex is either a string or an address in the heap. Create a String of the requested length form the bytes in the heap starting at stringIndex." <doNotGenerate> | sz | aStringOrStringIndex isString ifTrue: [^aStringOrStringIndex]. sz := self strlen: aStringOrStringIndex. + ^self strncpy: (ByteString new: sz) _: aStringOrStringIndex _: sz! - ^self st: (ByteString new: sz) rn: aStringOrStringIndex cpy: sz! Item was changed: ----- Method: VMClass>>asString:size: (in category 'C library simulation') ----- asString: stringIndex size: stringSize "stringIndex is an address in the heap. Create a String of the requested length form the bytes in the heap starting at stringIndex." <doNotGenerate> + ^self strncpy: (ByteString new: stringSize) _: stringIndex _: stringSize! - ^self st: (ByteString new: stringSize) rn: stringIndex cpy: stringSize! Item was removed: - ----- Method: VMClass>>mem:cp:y: (in category 'C library simulation') ----- - mem: dString cp: sString y: bytes - <doNotGenerate> - "implementation of memcpy(3). N.B. If ranges overlap, must use memmove." - (dString isString or: [sString isString]) ifFalse: - [| destAddress sourceAddress | - dString class == ByteArray ifTrue: - [ByteString adoptInstance: dString. - ^[self mem: dString cp: sString y: bytes] ensure: - [ByteArray adoptInstance: dString]]. - destAddress := dString asInteger. - sourceAddress := sString asInteger. - self deny: ((destAddress <= sourceAddress and: [destAddress + bytes > sourceAddress]) - or: [sourceAddress <= destAddress and: [sourceAddress + bytes > destAddress]])]. - dString isString - ifTrue: - [1 to: bytes do: - [:i| | v | - v := sString isString - ifTrue: [sString at: i] - ifFalse: [Character value: (self byteAt: sString + i - 1)]. - dString at: i put: v]] - ifFalse: - [1 to: bytes do: - [:i| | v | - v := sString isString - ifTrue: [(sString at: i) asInteger] - ifFalse: [self byteAt: sString + i - 1]. - self byteAt: dString + i - 1 put: v]]. - ^dString! Item was removed: - ----- Method: VMClass>>mem:mo:ve: (in category 'C library simulation') ----- - mem: destAddress mo: sourceAddress ve: bytes - <doNotGenerate> - | dst src | - dst := destAddress asInteger. - src := sourceAddress asInteger. - "Emulate the c library memmove function" - self assert: bytes \\ 4 = 0. - destAddress > sourceAddress - ifTrue: - [bytes - 4 to: 0 by: -4 do: - [:i| self longAt: dst + i put: (self longAt: src + i)]] - ifFalse: - [0 to: bytes - 4 by: 4 do: - [:i| self longAt: dst + i put: (self longAt: src + i)]]! Item was added: + ----- Method: VMClass>>memcpy:_:_: (in category 'C library simulation') ----- + memcpy: dString _: sString _: bytes + <doNotGenerate> + "implementation of memcpy(3). N.B. If ranges overlap, must use memmove." + (dString isString or: [sString isString]) ifFalse: + [| destAddress sourceAddress | + dString class == ByteArray ifTrue: + [ByteString adoptInstance: dString. + ^[self memcpy: dString _: sString _: bytes] ensure: + [ByteArray adoptInstance: dString]]. + destAddress := dString asInteger. + sourceAddress := sString asInteger. + self deny: ((destAddress <= sourceAddress and: [destAddress + bytes > sourceAddress]) + or: [sourceAddress <= destAddress and: [sourceAddress + bytes > destAddress]])]. + dString isString + ifTrue: + [1 to: bytes do: + [:i| | v | + v := sString isString + ifTrue: [sString at: i] + ifFalse: [Character value: (self byteAt: sString + i - 1)]. + dString at: i put: v]] + ifFalse: + [1 to: bytes do: + [:i| | v | + v := sString isString + ifTrue: [(sString at: i) asInteger] + ifFalse: [self byteAt: sString + i - 1]. + self byteAt: dString + i - 1 put: v]]. + ^dString! Item was added: + ----- Method: VMClass>>memmove:_:_: (in category 'C library simulation') ----- + memmove: destAddress _: sourceAddress _: bytes + <doNotGenerate> + | dst src | + dst := destAddress asInteger. + src := sourceAddress asInteger. + "Emulate the c library memmove function" + self assert: bytes \\ 4 = 0. + destAddress > sourceAddress + ifTrue: + [bytes - 4 to: 0 by: -4 do: + [:i| self longAt: dst + i put: (self longAt: src + i)]] + ifFalse: + [0 to: bytes - 4 by: 4 do: + [:i| self longAt: dst + i put: (self longAt: src + i)]]! Item was removed: - ----- Method: VMClass>>st:rn:cpy: (in category 'C library simulation') ----- - st: aString rn: bString cpy: n - <doNotGenerate> - "implementation of strncpy(3)" - aString isString - ifTrue: - [1 to: n do: - [:i| | v | - v := bString isString - ifTrue: [bString at: i] - ifFalse: [Character value: (self byteAt: bString + i - 1)]. - aString at: i put: v. - v asInteger = 0 ifTrue: [^aString]]] - ifFalse: - [1 to: n do: - [:i| | v | - v := bString isString - ifTrue: [(bString at: i) asInteger] - ifFalse: [self byteAt: bString + i - 1]. - self byteAt: aString + i - 1 put: v. - v = 0 ifTrue: [^aString]]]. - ^aString! Item was removed: - ----- Method: VMClass>>str:cat: (in category 'C library simulation') ----- - str: aString cat: bString - <doNotGenerate> - "implementation of strcat(3)" - ^(self asString: aString), (self asString: bString)! Item was removed: - ----- Method: VMClass>>str:n:cmp: (in category 'C library simulation') ----- - str: aString n: bString cmp: n - <doNotGenerate> - "implementation of strncmp(3)" - bString isString ifTrue: - [1 to: n do: - [:i| - (aString at: i) asCharacter ~= (bString at: i) ifTrue: - [^i]]. - ^0]. - 1 to: n do: - [:i| | v | - v := (aString at: i) asInteger - (self byteAt: bString + i - 1). - v ~= 0 ifTrue: [^v]]. - ^0! Item was added: + ----- Method: VMClass>>strcat:_: (in category 'C library simulation') ----- + strcat: aString _: bString + <doNotGenerate> + "implementation of strcat(3)" + ^(self asString: aString), (self asString: bString)! Item was changed: ----- Method: VMClass>>stretch:cat: (in category 'C library extensions') ----- stretch: s1 cat: s2 <var: 's1' type: #'char *'> <var: 's2' type: #'char *'> | ns | <var: 'ns' type: #'char *'> ^self cCode: [ns := self malloc: (self strlen: s1) + (self strlen: s2) + 2. + self strcpy: ns _: s1. + self strcat: ns _: s2] + inSmalltalk: [self strcat: s1 _: s2]! - self str: ns cpy: s1. - self str: ns cat: s2] - inSmalltalk: [self str: s1 cat: s2]! Item was added: + ----- Method: VMClass>>strncmp:_:_: (in category 'C library simulation') ----- + strncmp: aString _: bString _: n + <doNotGenerate> + "implementation of strncmp(3)" + bString isString ifTrue: + [1 to: n do: + [:i| + (aString at: i) asCharacter ~= (bString at: i) ifTrue: + [^i]]. + ^0]. + 1 to: n do: + [:i| | v | + v := (aString at: i) asInteger - (self byteAt: bString + i - 1). + v ~= 0 ifTrue: [^v]]. + ^0! Item was added: + ----- Method: VMClass>>strncpy:_:_: (in category 'C library simulation') ----- + strncpy: aString _: bString _: n + <doNotGenerate> + "implementation of strncpy(3)" + aString isString + ifTrue: + [1 to: n do: + [:i| | v | + v := bString isString + ifTrue: [bString at: i] + ifFalse: [Character value: (self byteAt: bString + i - 1)]. + aString at: i put: v. + v asInteger = 0 ifTrue: [^aString]]] + ifFalse: + [1 to: n do: + [:i| | v | + v := bString isString + ifTrue: [(bString at: i) asInteger] + ifFalse: [self byteAt: bString + i - 1]. + self byteAt: aString + i - 1 put: v. + v = 0 ifTrue: [^aString]]]. + ^aString! 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. - self st: libName rn: (interpreterProxy firstIndexableField: nameObj) cpy: 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. - self st: symName rn: (interpreterProxy firstIndexableField: nameObj) cpy: 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: (interpreterProxy positiveMachineIntegerFor: addr asUnsignedIntegerPtr)! Item was changed: ----- Method: VMProfileLinuxSupportPlugin>>reap:module:names: (in category 'iteration callbacks') ----- reap: info module: size names: ignored <returnTypeC: #int> | elfModuleName len moduleNameObj GetAttributeString | <var: #info type: #'struct dl_phdr_info *'> <var: 'elfModuleName' type: #'const char *'> <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()" - self st: (interpreterProxy arrayValueOf: moduleNameObj) - rn: elfModuleName - cpy: 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" <returnTypeC: #int> | elfModuleName len moduleNameObj GetAttributeString symLinkBuf | <var: #info type: #'struct dl_phdr_info *'> <var: 'elfModuleName' type: #'const char *'> <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()" - self st: (interpreterProxy arrayValueOf: moduleNameObj) - rn: elfModuleName - cpy: 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()" - self st: (interpreterProxy arrayValueOf: moduleNameObj) - rn: symLinkBuf - cpy: 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! Item was changed: ----- Method: VMProfileMacSupportPlugin>>primitiveExecutableModulesAndOffsets (in category 'primitives') ----- primitiveExecutableModulesAndOffsets "Answer an Array of quads for executable modules (the VM executable and loaded libraries). Each quad is the module's name, its vm address relocation in memory, the (unrelocated) start address, and the size." | nimages resultObj name valueObj nameObjData slide start size | <export: true> <var: #name type: 'const char *'> <var: #nameObjData type: #'char *'> <var: #h type: 'const struct mach_header *'> <var: #h64 type: 'const struct mach_header_64 *'> <var: #s64 type: 'const struct section_64 *'> <var: #s type: 'const struct section *'> <var: #start type: 'usqIntptr_t'> <var: #slide type: 'usqIntptr_t'> <var: #size type: 'usqIntptr_t'> self cppIf: #'MAC_OS_X_VERSION_MIN_REQUIRED' <= #'MAC_OS_X_VERSION_10_4' ifTrue: "_dyld_present was deprecated in 10.5" [(self cCode: '_dyld_present()' inSmalltalk: false) ifFalse: [^interpreterProxy primitiveFail]]. nimages := self cCode: '_dyld_image_count()' inSmalltalk: 0. resultObj := interpreterProxy instantiateClass: interpreterProxy classArray indexableSize: nimages * 4. resultObj = 0 ifTrue: [^interpreterProxy primitiveFail]. interpreterProxy pushRemappableOop: resultObj. 0 to: nimages - 1 do: [:i| start := size := -1. "impossible start & size" name := self cCode: '_dyld_get_image_name(i)' inSmalltalk: 0. slide := self cCode: '_dyld_get_image_vmaddr_slide(i)' inSmalltalk: 0. self cppIf: #'__x86_64__' ifTrue: [(self cCode: '(const struct mach_header_64 *)_dyld_get_image_header(i)' inSmalltalk: nil) ifNotNil: [:h64| (self cCode: 'getsectbynamefromheader_64(h64,SEG_TEXT,SECT_TEXT)' inSmalltalk: nil) ifNotNil: [:s64| start := self cCode: 's64->addr' inSmalltalk: 0. size := self cCode: 's64->size' inSmalltalk: 0]]] ifFalse: [(self cCode: '_dyld_get_image_header(i)' inSmalltalk: nil) ifNotNil: [:h| (self cCode: 'getsectbynamefromheader(h,SEG_TEXT,SECT_TEXT)' inSmalltalk: nil) ifNotNil: [:s| start := self cCode: 's->addr' inSmalltalk: 0. size := self cCode: 's->size' inSmalltalk: 0]]]. valueObj := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: (self strlen: name). interpreterProxy failed ifTrue: [interpreterProxy popRemappableOop. ^interpreterProxy primitiveFail]. interpreterProxy storePointer: i * 4 ofObject: interpreterProxy topRemappableOop withValue: valueObj. nameObjData := interpreterProxy arrayValueOf: valueObj. + self memcpy: nameObjData _: name _: (self strlen: name). - self mem: nameObjData cp: name y: (self strlen: name). valueObj := interpreterProxy signedMachineIntegerFor: slide. interpreterProxy failed ifTrue: [interpreterProxy popRemappableOop. ^interpreterProxy primitiveFail]. interpreterProxy storePointer: i * 4 + 1 ofObject: interpreterProxy topRemappableOop withValue: valueObj. valueObj := interpreterProxy positiveMachineIntegerFor: start. interpreterProxy failed ifTrue: [interpreterProxy popRemappableOop. ^interpreterProxy primitiveFail]. interpreterProxy storePointer: i * 4 + 2 ofObject: interpreterProxy topRemappableOop withValue: valueObj. valueObj := interpreterProxy positiveMachineIntegerFor: size. interpreterProxy failed ifTrue: [interpreterProxy popRemappableOop. ^interpreterProxy primitiveFail]. interpreterProxy storePointer: i * 4 + 3 ofObject: interpreterProxy topRemappableOop withValue: valueObj]. resultObj := interpreterProxy popRemappableOop. ^interpreterProxy pop: 1 thenPush: resultObj!

1 0

Squeak.rc FILEVERSIONVALUES
by Ben Coman 20 Sep '18

20 Sep '18

I tried to build via "build.win32x86/squeak.cog.spur/mvm" but got an error with the resource file... ``` i686-w64-mingw32-windres \ --include-dir ../../platforms/win32/misc \ -D_WIN32 \ -DFILEVERSIONVALUES=,,, '-DFILEVERSIONSTRING=\"...\\0\"' \ -i Squeak.rc \ -o builddbg/vm/Squeak.res ==> i686-w64-mingw32-windres: Squeak.rc:7: syntax error make[1]: *** [../common/Makefile:296: Squeak.res] Error 1 ``` I see a reference at the top of [1] to this for Pharo but no direct resolution is mentioned. [1] http://forum.world.st/Compiling-the-windows-32-bits-vm-td5072691.html [Squeak.rc:7]( https://github.com/OpenSmalltalk/opensmalltalk-vm/blob/Cog/build.win32x86/s…) is... ``` FILEVERSION FILEVERSIONVALUES ``` and the value ",,," supplied for FILEVERSIONVALUES on the command line seems invalid. I see Pharo has hardcoded the value... https://www.diffchecker.com/O36vXV5b https://github.com/OpenSmalltalk/opensmalltalk-vm/blob/Cog/build.win32x86/p… ``` FILEVERSION 5,0,0,0 ``` and if I do the same in Squeak.rc the build completes. So should I submit a PR for that, or does anyone know how the command line "FILEVERSIONVALUES" is supposed to be supplied a proper value? Searching the repo doesn't give any hints... https://github.com/OpenSmalltalk/opensmalltalk-vm/search?q=FILEVERSIONVALUES cheers -ben

7 8

VM Maker: VMMaker.oscog-eem.2443.mcz
by commits＠source.squeak.org 19 Sep '18

19 Sep '18

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2443.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.2443 Author: eem Time: 19 September 2018, 10:30:59.900508 am UUID: fe048b98-1f17-4bc2-99ca-13809f5d7c25 Ancestors: VMMaker.oscog-eem.2442 Oops; remember to use isFakeStdinStream, and avoid isKindOf: in a couple of other places. =============== Diff against VMMaker.oscog-eem.2442 =============== Item was changed: ----- Method: FilePluginSimulator>>sqFile:Read:Into:At: (in category 'simulation') ----- sqFile: file Read: count Into: byteArrayIndexArg At: startIndex | byteArrayIndex | byteArrayIndex := byteArrayIndexArg asInteger. "Coerces CArray et al correctly" [[startIndex to: startIndex + count - 1 do: [ :i | file atEnd ifTrue: + [file isFakeStdinStream ifTrue: [file atEnd: false]. - [(file isKindOf: FakeStdinStream) ifTrue: [file atEnd: false]. ^i - startIndex]. interpreterProxy byteAt: byteArrayIndex + i + put: (file next ifNil: [file isFakeStdinStream ifTrue: [^0]] ifNotNil: [:c| c asInteger])]] - put: (file next ifNil: [(file isKindOf: FakeStdinStream) ifTrue: [^0]] ifNotNil: [:c| c asInteger])]] on: Error do: [:ex| + (file isStream and: [file isTranscriptStream]) ifFalse: + [ex pass]. - (file isKindOf: TranscriptStream) ifFalse: [ex pass]. ^0]] ensure: [self recordStateOf: file]. ^count! Item was changed: ----- Method: SmartSyntaxPluginTMethod>>recordDeclarationsIn: (in category 'transforming') ----- recordDeclarationsIn: aCCodeGen "Record C type declarations of the forms <returnTypeC: 'float'> <var: #foo declareC: 'float foo'> <var: #foo type:'float'> <var: #foo as: Class> or the older, obsolete self returnTypeC: 'float'. self var: #foo declareC: 'float foo' self var: #foo type:'float'. self var: #foo as: Class and remove the declarations from the method body." | newStatements | properties pragmas notEmpty ifTrue: [properties pragmas do: [:pragma| pragma keyword = #var:declareC: ifTrue: [self checkedDeclarationAt: pragma arguments first asString put: pragma arguments last in: aCCodeGen]. pragma keyword = #var:type: ifTrue: [| varName varType | varName := pragma arguments first asString. varType := pragma arguments last. varType last = $* ifFalse: [varType := varType, ' ']. self checkedDeclarationAt: varName put: varType, varName in: aCCodeGen]. pragma keyword = #var:as: ifTrue: [| theClass | theClass := Smalltalk at: pragma arguments last name asSymbol ifAbsent: [nil]. + theClass isBehavior ifFalse: - (theClass isKindOf: Behavior) ifFalse: [^self error: 'declarator must be a Behavior']. self checkedDeclarationAt: pragma arguments first value asString put: (theClass ccgDeclareCForVar: pragma arguments first asString) in: aCCodeGen]. pragma keyword = #returnTypeC: ifTrue: [self returnType: pragma arguments last]. pragma keyword = #doNotGenerate: ifTrue: [locals removeKey: pragma arguments last]]. ^self]. newStatements := OrderedCollection new: parseTree statements size. parseTree statements do: [:stmt | | isDeclaration | isDeclaration := false. stmt isSend ifTrue: [stmt selector = #var:declareC: ifTrue: [isDeclaration := true. self declarationAt: stmt args first value asString put: stmt args last value]. stmt selector = #var:type: ifTrue: [ | varName varType | isDeclaration := true. varName := stmt args first value asString. varType := stmt args last value. varType last = $* ifFalse: [varType := varType, ' ']. self declarationAt: varName put: varType, varName. ]. stmt selector = #var:as: ifTrue: [| theClass | isDeclaration := true. theClass := Smalltalk at: stmt args last name asSymbol ifAbsent: [nil]. + theClass isBehavior ifFalse: - (theClass isKindOf: Behavior) ifFalse: [^self error: 'declarator must be a Behavior']. self declarationAt: stmt args first value asString put: (theClass ccgDeclareCForVar: stmt args first value asString)]. stmt selector = #returnTypeC: ifTrue: [isDeclaration := true. returnType := stmt args last value]]. isDeclaration ifFalse: [newStatements add: stmt]]. parseTree setStatements: newStatements asArray! Item was added: + ----- Method: Stream>>isTranscriptStream (in category '*VMMaker-JITSimulation-testing') ----- + isTranscriptStream + ^false! Item was added: + ----- Method: TranscriptStream>>isTranscriptStream (in category '*VMMaker-JITSimulation-testing') ----- + isTranscriptStream + ^true!

1 0

VM Maker: VMMaker.oscog-eem.2442.mcz
by commits＠source.squeak.org 19 Sep '18

19 Sep '18

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2442.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.2442 Author: eem Time: 19 September 2018, 9:22:37.266528 am UUID: f7e49724-6cf7-484b-a024-25d028888354 Ancestors: VMMaker.oscog-eem.2441 Final piece of Pharo compatibility to allow e.g. the REPL startreader images to run in Pharo 6.1. Split the input dialog for FakeStdinStream so it works both on Pharo and Squeak. =============== Diff against VMMaker.oscog-eem.2441 =============== Item was added: + ----- Method: FakeStdinStream>>isFakeStdinStream (in category 'testing') ----- + isFakeStdinStream + ^true! Item was changed: ----- Method: FakeStdinStream>>next (in category 'accessing') ----- next "Answer the next object in the Stream represented by the receiver. If there are no more elements in the stream fill up the buffer by prompting for input" | sem threadIndex inputLine next | position >= readLimit ifTrue: [simulator isThreadedVM ifTrue: ["(simulator cogit singleStep not and: [UIManager confirm: 'Single step?']) ifTrue: [simulator cogit singleStep: true]." threadIndex := simulator disownVM: DisownVMLockOutFullGC. simulator forceInterruptCheckFromHeartbeat. sem := Semaphore new. WorldState addDeferredUIMessage: [inputLine := UIManager default request: 'Input please!!'. sem signal]. sem wait] ifFalse: "simulate line-oriented input" + [inputLine := ((Smalltalk classNamed: #FillInTheBlankMorph) + ifNotNil: "Squeak" + [:fITBM| + fITBM + request: 'Input please!!' + initialAnswer: '' + centerAt: ActiveHand cursorPoint + inWorld: ActiveWorld + onCancelReturn: nil + acceptOnCR: true] + ifNil: "Pharo; onCancelReturn: nil is the default here" + [UIManager default + request: 'Input please!!' + initialAnswer: '']). - [inputLine := FillInTheBlankMorph - request: 'Input please!!' - initialAnswer: '' - centerAt: ActiveHand cursorPoint - inWorld: ActiveWorld - onCancelReturn: nil - acceptOnCR: true. inputLine ifNil: [self atEnd: true. ^nil]]. collection size <= inputLine size ifTrue: [collection := collection species new: inputLine size + 1]. collection replaceFrom: 1 to: inputLine size with: inputLine startingAt: 1; at: (readLimit := inputLine size + 1) put: Character lf. position := 0. simulator isThreadedVM ifTrue: [simulator ownVM: threadIndex]]. next := collection at: (position := position + 1). "This is set temporarily to allow (FilePluginSimulator>>#sqFile:Read:Into:At: to brwak out of its loop. sqFile:Read:Into:At: resets it on the way out." atEnd := position >= readLimit. ^next " This does it with workspaces: | ws r s | s := Semaphore new. ws := Workspace new contents: ''. ws acceptAction: [:t| r := t asString. s signal]. [ws openLabel: 'Yo!!'; shouldStyle: false. (ws dependents detect: [:dep | dep isKindOf: PluggableTextMorph] ifNone: [nil]) ifNotNil: [:textMorph| textMorph acceptOnCR: true; hasUnacceptedEdits: true]] fork. Processor activeProcess == Project uiProcess ifTrue: [[r isNil] whileTrue: [World doOneCycle]] ifFalse: [s wait]. ws topView delete. s wait. s signal. r"! Item was added: + ----- Method: Stream>>isFakeStdinStream (in category '*VMMaker-JITSimulation-testing') ----- + isFakeStdinStream + ^false!

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Vm-dev September 2018