"====================================================================== | | Smalltalk in Smalltalk compiler | | $Revision: 1.7.5$ | $Date: 2000/05/28 16:56:52$ | $Author: pb$ | ======================================================================" "====================================================================== | | Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc. | Written by Paolo Bonzini. | | This file is part of GNU Smalltalk. | | GNU Smalltalk is free software; you can redistribute it and/or modify it | under the terms of the GNU General Public License as published by the Free | Software Foundation; either version 2, or (at your option) any later version. | | GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS | FOR A PARTICULAR PURPOSE. See the GNU General Public License for more | details. | | You should have received a copy of the GNU General Public License along with | GNU Smalltalk; see the file COPYING. If not, write to the Free Software | Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | ======================================================================" Object subclass: #STFakeCompiler instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'VMOtherConstants VMByteCodeNames' category: 'System-Compiler' ! STFakeCompiler comment: 'I am the Smalltalk equivalent of a wimp. I never do nothing: they tell me to compile something, and I just return nil... Actually, I am used when conditionally compiled code has to be skipped.'! !STFakeCompiler class methodsFor: 'compilation'! compile: methodDefNode for: aBehavior classified: aString parser: aParser ^nil ! ! STFakeCompiler subclass: #STCompiler instanceVariableNames: 'node symTable parser bytecodes depth maxDepth isInsideBlock' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler' ! STCompiler comment: 'Unlike my brother STFakeCompiler, I am a real worker. Give me some nodes, and I will output a full-fledged CompiledMethod!! But seriously... STCompiler''s responsibility is much limited. All its #compile method does is to tell each statement to compile itself, adding a ''pop stack top'' bytecode at the end of each statement. In addition, STCompiler mantains an interface between itself, the symbol table and the bytecodes stream. The need to mantain such an interface and pass the compiler object around on every compileFor: call is dictated by the need to make the compiler reentrant. This way, the user can nest fileIns to any level. The actual compilation policy does not reside in STCompiler, but it is spread through subclasses of STParseNode. This may look clumsy, but actually it allows to use polymorphism, which is the fastest dispatching method of all, and produces very streamlined code. Thus we have elegant and fast code... not bad! For example, when we send the ''true printOn: stdout'' message, the structure of the tree is: MessageNode, which contains: the receiver, an IdentifierNode (in this case a SpecialIdentifierNode) the message, a kind of MessageSendNode (a KeywordNode), which contains the selector the parameters, a Collection which contains a VariableNode The MessageNode checks if the receiver is super. If so, it tells the message to compile itself as a send to super. In this case however it tells both the receiver and the message to compile themselves. The SpecialIdentifierNode will output a ''push true'' bytecode. The MessageSendNode, in turn, asks the parameters to compile themselves, asks the STCompiler object to add the #printOn: literal (this request is delegated to an instance of STSymTable), then compiles a ''send message'' bytecode. The VariableNode which refers to stdout, when it is asked to compile itself, tells the STCompiler object to add a literal (since it refers to a global variable) and then compiles either a ''push global variable'' or a ''push indexed'' bytecode. The resulting stream is push true push literal corresponding to (#stdout -> stdout) send message with 0 args, selector = #printOn: This is possible by providing consistent protocols. Here they are: - ParseNodes respond to #compileFor: and #compileReturnFor:. The former is abstract, while the latter''s default implementation calls #compileFor: and appends a ''return stack top from method'' bytecode. - IdentifierNodes, which might appear on the left of an assignment, under- stand #compileAssignmentFor: too. - MessageSendNode implements the compilation of message sends, including optimizations when compiling while loops and boolean expressions. For it to work properly, its subclasses (UnaryNode, BinaryNode, KeywordNode) implement #argumentCount and #allExpressionsDo: - MessageNode implements #compileFor:dupReceiver:, which adds if necessary a ''duplicate stack top'' bytecode after having compiled the receiver, and returns whether the MessageNode identified a send to ''super''. This message is used by CascadeNodes. '! !STCompiler class methodsFor: 'compilation'! compile: methodDefNode for: aBehavior classified: aString parser: aParser | cm | cm := self new setNode: methodDefNode class: aBehavior parser: aParser; compile. cm methodCategory: aString. ^aBehavior addSelector: (methodDefNode selector) selector asSymbol withMethod: cm ! ! !STCompiler methodsFor: 'compilation'! compile | body lastIsReturn method | body := node body. node selector args do: [ :anArg | symTable declareTemporary: anArg canStore: false for: self ]. body temporaries do: [ :aTemp | symTable declareTemporary: aTemp canStore: true for: self ]. depth := maxDepth := node selector args size + body temporaries size. body statements doWithIndex: [ :each :index | index = 1 ifFalse: [ self depthDecr: 1. self nextPut: PopStackTop ]. each compileFor: self. lastIsReturn := each isReturn. ]. body statements isEmpty ifTrue: [ self nextPut: ReturnSelf ] ifFalse: [ lastIsReturn ifFalse: [ self nextPut: self finalReturn ] ]. symTable finish. method := CompiledMethod literals: symTable literals numArgs: node selector args size numTemps: symTable numTemps - node selector args size primitive: body primitive bytecodes: bytecodes contents depth: maxDepth. method getDescriptor setSourceCode: node source. ^method ! ! !STCompiler methodsFor: 'private'! finalReturn ^ReturnSelf ! setNode: methodDefNode class: aBehavior parser: aParser node := methodDefNode. symTable := STSymbolTable new. parser := aParser. bytecodes := WriteStream on: (ByteArray new: 240). isInsideBlock := 0. symTable declareEnvironment: aBehavior. ! ! !STCompiler methodsFor: 'accessing'! addLiteral: literal ^symTable addLiteral: literal ! addPool: poolDictionary symTable addPool: poolDictionary ! bytecodeSize ^bytecodes position ! bytecodesFor: aBlockNode | saveBytecodes result | saveBytecodes := bytecodes. bytecodes := WriteStream on: (ByteArray new: 240). aBlockNode compileStatementsFor: self. result := bytecodes contents. bytecodes := saveBytecodes. ^result ! bytecodesFor: aBlockNode append: aByteCode | saveBytecodes result | saveBytecodes := bytecodes. bytecodes := WriteStream on: (ByteArray new: 240). aBlockNode compileStatementsFor: self. bytecodes nextPut: aByteCode. result := bytecodes contents. bytecodes := saveBytecodes. ^result ! checkStore: aVariableName (symTable canStore: aVariableName) ifFalse: [ self compileError: 'cannot store in argument ', aVariableName ] ! compileBigLiteral: op index: index self nextPut: BigLiteral; nextPut: index // 256 + op; nextPut: (index bitAnd: 255) ! compileError: aString parser parseError: aString ! compileWarning: aString parser parseWarning: aString ! declareTemporaries: parameters numArguments: numArgs | result | parameters doWithIndex: [ :each :index | result := symTable declareTemporary: each canStore: index > numArgs for: self ]. ^result ! maxDepth ^maxDepth ! depthDecr: n depth := depth - n ! depthIncr depth = maxDepth ifTrue: [ depth := depth + 1. maxDepth := maxDepth + 1 ] ifFalse: [ depth := depth + 1 ] ! depthSet: n "n can be an integer, or a previously returned value (in which case the exact status at the moment of the previous call is remembered)" | oldDepth | oldDepth := n -> maxDepth. n isInteger ifTrue: [ depth := maxDepth := n ] ifFalse: [ depth := n key. maxDepth := n value ]. ^oldDepth ! isReceiver: variable ^symTable isReceiver: variable ! isTemporary: variable ^symTable isTemporary: variable ! literals ^symTable literals ! lookupName: variable | definition | definition := symTable lookupName: variable. definition isNil ifTrue: [ "Might want to declare this puppy as a local and go on notwithstanding the error" self compileError: 'Undefined variable ', variable printString, 'referenced.' ]. ^definition ! nextPut: aByte bytecodes nextPut: aByte. ! nextPutAll: aByteArray bytecodes nextPutAll: aByteArray. ! isInsideBlock ^isInsideBlock > 0 ! outerScopes: variable ^symTable outerScopes: variable ! pushLiteral: value | definition | definition := self addLiteral: value. definition <= 31 ifTrue: [ self nextPut: (PushLitConstant + definition). ^self ]. definition > 63 ifTrue: [ self compileBigLiteral: PushLiteral index: definition. ^self ]. self nextPut: PushIndexed; nextPut: (LiteralConstantLocation + definition) ! scopeEnter isInsideBlock := isInsideBlock + 1. symTable scopeEnter ! scopeLeave isInsideBlock := isInsideBlock - 1. symTable scopeLeave ! undeclareTemporaries: temps temps do: [ :each | symTable undeclareTemporary: each ] ! ! STCompiler subclass: #STDoitCompiler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler' ! STDoitCompiler comment: 'Like my father STCompiler, I am a real worker, not a do-nothing compiler. Unlike it, I always interpret as a return the last statement I cope with.' ! !STDoitCompiler methodsFor: 'compiling'! compile "Add the current namespace as a shared pool before compiling!" self addPool: Namespace current. ^super compile ! !STDoitCompiler methodsFor: 'private'! finalReturn ^ReturnContextStackTop ! ! "--------------------------------------------------------------------" STBlockNode comment: 'STBlockNode has a variable that contains a string for each parameter, and one that contains a list of statements. Here is how STBlockNodes are compiled: push BlockClosure literal push thisContext (or push nil) <--- optional send #blockCopy: <--- optional Statements are put in a separate CompiledBlock object that is referenced by the BlockClosure. compileStatementsFor: compiles everything after the jump and before the return. It is this method that is called by STCompiler>>bytecodesFor: and STCompiler>>bytecodesFor:append:'! !STBlockNode methodsFor: 'compiling'! compileStatementsFor: stCompiler stCompiler declareTemporaries: self parameters numArguments: self numArgs. self statements doWithIndex: [ :each :index | index = 1 ifFalse: [ stCompiler depthDecr: 1; nextPut: PopStackTop ]. each compileFor: stCompiler. ]. self statements isEmpty ifTrue: [ stCompiler depthIncr; nextPut: PushNil ]. stCompiler undeclareTemporaries: self parameters ! compileFor: stCompiler | bc depth blockClosure clean | depth := stCompiler depthSet: self numArgs + self numTemps. stCompiler scopeEnter. bc := stCompiler bytecodesFor: self append: ReturnContextStackTop. stCompiler scopeLeave. blockClosure := BlockClosure numArgs: self numArgs numTemps: self numTemps bytecodes: bc depth: stCompiler maxDepth literals: stCompiler literals. stCompiler depthSet: depth; pushLiteral: blockClosure. clean := blockClosure block flags. clean == 0 ifTrue: [ ^self ]. stCompiler nextPut: (clean == 1 ifTrue: [ PushNil ] ifFalse: [ PushActiveContext ]). stCompiler nextPut: BlockCopyColonSpecial ! ! "--------------------------------------------------------------------" STCascadeNode comment: 'STCascadeNode has two variable: the receiver of the cascaded messages and a collection with one item per message.'! !STCascadeNode methodsFor: 'compiling'! compileFor: stCompiler | toSuper | toSuper := receiver compileFor: stCompiler dupReceiver: true. toSuper ifTrue: [ messages doWithIndex: [ :each :index | stCompiler depthDecr: 1; nextPut: PopStackTop. each compileSendToSuperFor: stCompiler. ]. ^self ]. messages doWithIndex: [ :each :index | stCompiler nextPut: PopStackTop. index = messages size ifFalse: [ stCompiler nextPut: DupStackTop ] ifTrue: [ stCompiler depthDecr: 1 ]. each compileFor: stCompiler. ]. ! ! "--------------------------------------------------------------------" STConstNode comment: 'STConstNode has one instance variable, the literal it represents.'! !STConstNode methodsFor: 'compiling'! compileFor: stCompiler stCompiler depthIncr. VMSpecialIdentifiers at: self value ifPresent: [ :encodedValue | stCompiler nextPut: PushSpecial + encodedValue. ^self ]. stCompiler pushLiteral: self value. ! ! "--------------------------------------------------------------------" STExpressionNode comment: 'STExpressionNode has two instance variables: a) another STParseNode which corresponds to the value to be evaluated, and b) a list of variables which have to be set to the result of the expression.'! !STExpressionNode methodsFor: 'compiling'! compileFor: stCompiler self expression compileFor: stCompiler. self assigns isEmpty ifTrue: [ ^self ]. self assignsDo: [ :assign | "Iteration order doesn't matter here" assign compileAssignmentFor: stCompiler. ]. ! ! "--------------------------------------------------------------------" STIdentifierNode comment: 'STIdentifierNode defines a few abstract methods.'! !STIdentifierNode methodsFor: 'compiling'! compileAssignmentFor: stCompiler self subclassResponsibility ! ! "--------------------------------------------------------------------" STMessageNode comment: 'STMessageNode contains a message send. Its instance variable are a receiver, and a STMessageSendNode.'! !STMessageNode methodsFor: 'compiling'! compileFor: stCompiler self compileFor: stCompiler dupReceiver: false ! compileFor: stCompiler dupReceiver: dup | specialSelector | self receiver isSuper ifTrue: [ message compileSendToSuperFor: stCompiler. ^true ]. (VMSpecialMethods includesKey: self message selector) ifTrue: [ specialSelector := VMSpecialMethods at: self message selector. (specialSelector isNil and: [self receiver isBlock and: [ dup not ]]) ifTrue: [ (message compileFor: stCompiler whileLoop: receiver) ifTrue: [^false] ] ]. receiver compileFor: stCompiler. dup ifTrue: [ stCompiler depthIncr; nextPut: DupStackTop ]. specialSelector isNil ifFalse: [ (message perform: specialSelector with: stCompiler) ifTrue: [^false] ]. message compileFor: stCompiler. ^false ! ! "--------------------------------------------------------------------" STMessageSendNode comment: 'STMessageSendNode is at the top of a small hierarchy of STParseNodes. It contains code to compile message sends (including optimized selectors) and relies on a few abstract methods defined by STUnaryNode, STBinaryNode and STKeywordNode use these implementations.'! !STMessageSendNode methodsFor: 'compiling'! compileFor: stCompiler | args litIndex | self allExpressionsDo: [ :each | each compileFor: stCompiler ]. VMSpecialSelectors at: self selector ifPresent: [ :idx | stCompiler nextPut: SendSpecial + idx. ^self ]. args := self argumentCount. litIndex := stCompiler addLiteral: self selector. (args <= 2) & (litIndex <= 15) ifTrue: [ stCompiler nextPut: SendSelectorShort + (args * 16) + litIndex ] ifFalse: [ self emitExtendedSendBytecodesTo: stCompiler toSuperFlag: 0 literalIndex: litIndex argCount: args ]. stCompiler depthDecr: self argumentCount. ! compileFor: stCompiler whileLoop: whileBlock "Answer whether the while loop can be optimized (that is, whether the only parameter is a STBlockNode)" | whileBytecodes argBytecodes totBytecodesSize argBytecodesSize | (whileBlock isOptimizableWithArgs: 0) ifFalse: [ ^false ]. argBytecodesSize := 0. self allExpressionsDo: [ :onlyArgument | onlyArgument isBlock ifFalse: [ ^false ]. (onlyArgument isOptimizableWithArgs: 0) ifFalse: [ ^false ]. argBytecodes := stCompiler bytecodesFor: onlyArgument. argBytecodesSize := argBytecodes size. ]. whileBytecodes := stCompiler bytecodesFor: whileBlock. stCompiler nextPutAll: whileBytecodes. totBytecodesSize := whileBytecodes size + self sizeOfJump + argBytecodesSize. self selector == #repeat ifFalse: [ "The if: clause means: if selector is whileFalse:, compile a 'pop/jump if true'; else compile a 'pop/jump if false'" self compileJump: argBytecodesSize + self sizeOfJump to: stCompiler if: self isWhileFalse. argBytecodes isNil ifFalse: [ stCompiler nextPutAll: argBytecodes ]. totBytecodesSize := totBytecodesSize + self sizeOfJump. ]. self compileJump: totBytecodesSize negated to: stCompiler if: nil. "Somebody might want to use the return value of #whileTrue: and #whileFalse:" stCompiler depthIncr; nextPut: PushNil. ^true ! compileSendToSuperFor: stCompiler stCompiler depthIncr; nextPut: PushSpecial. self allExpressionsDo: [ :each | each compileFor: stCompiler ]. self emitExtendedSendBytecodesTo: stCompiler toSuperFlag: 2 literalIndex: (stCompiler addLiteral: self selector) argCount: self argumentCount. stCompiler depthDecr: self argumentCount. ! compileTimesRepeatFor: stCompiler | block | self allExpressionsDo: [ :each | block := each ]. (block isOptimizableWithArgs: 0) ifFalse: [ ^false ]. ^false ! compileLoopFor: stCompiler | stop step block | self allExpressionsDo: [ :each | stop := step. "to:" step := block. "by:" block := each. "do:" ]. (block isOptimizableWithArgs: 1) ifFalse: [ ^false ]. stop isNil ifTrue: [ stop := step. step := STConstNode one ] "#to:do:" ifFalse: [ step isOptimizableToByDoStep ifFalse: [ ^false ] ]. ^false ! compileBooleanFor: stCompiler | bc1 bc2 | self allExpressionsDo: [ :each | (each isOptimizableWithArgs: 0) ifFalse: [ ^false ]. bc1 isNil ifTrue: [ bc1 := each ] ifFalse: [ bc2 := stCompiler bytecodesFor: each ]. ]. bc1 := stCompiler bytecodesFor: bc1. self selector == #ifTrue:ifFalse: ifTrue: [ ^self compileFor: stCompiler ifTrue: bc1 ifFalse: bc2 ]. self selector == #ifFalse:ifTrue: ifTrue: [ ^self compileFor: stCompiler ifFalse: bc1 ifTrue: bc2 ]. self selector == #ifTrue: ifTrue: [ ^self compileFor: stCompiler ifTrue: bc1 ifFalse: #(115) "Push nil" ]. self selector == #ifFalse: ifTrue: [ ^self compileFor: stCompiler ifFalse: bc1 ifTrue: #(115) ]. self selector == #and: ifTrue: [ ^self compileFor: stCompiler ifTrue: bc1 ifFalse: #(114) "Push false" ]. self selector == #or: ifTrue: [ ^self compileFor: stCompiler ifFalse: bc1 ifTrue: #(113) "Push true" ]. ^false "What happened?!?" ! ! !STMessageSendNode methodsFor: 'private'! compileFor: stCompiler ifTrue: bcTrue ifFalse: bcFalse self compileJump: bcTrue size + self sizeOfJump to: stCompiler if: false. stCompiler nextPutAll: bcTrue. self compileJump: bcFalse size to: stCompiler if: nil. stCompiler nextPutAll: bcFalse. ^true ! compileFor: stCompiler ifFalse: bcFalse ifTrue: bcTrue self compileJump: bcFalse size + self sizeOfJump to: stCompiler if: true. stCompiler nextPutAll: bcFalse. self compileJump: bcTrue size to: stCompiler if: nil. stCompiler nextPutAll: bcTrue. ^true ! emitExtendedSendBytecodesTo: stCompiler toSuperFlag: toSuperFlag literalIndex: litIndex argCount: args (args <= 7) & (litIndex <= 31) ifTrue: [ stCompiler nextPut: SendSelector1ExtByte + toSuperFlag; nextPut: args * 32 + litIndex ] ifFalse: [ stCompiler nextPut: SendSelector2ExtByte + toSuperFlag; nextPut: args; nextPut: litIndex ] ! ! "--------------------------------------------------------------------" !STParseNode methodsFor: 'compiling'! compileFor: stCompiler self subclassResponsibility ! compileReturnFor: stCompiler self expression compileFor: stCompiler. stCompiler isInsideBlock ifTrue: [ stCompiler nextPut: ReturnMethodStackTop ] ifFalse: [ stCompiler nextPut: ReturnContextStackTop ] ! ! !STParseNode methodsFor: 'private'! sizeOfJump "For simplicity, I don't use short jump bytecodes." ^2 ! compileJump: displacement to: stCompiler if: jmpCondition jmpCondition isNil ifTrue: [ "Unconditional" ^stCompiler nextPut: JumpLong + (((displacement + 1024) bitShift: -8) bitAnd: 7); nextPut: (displacement bitAnd: 255). ]. displacement < 0 ifTrue: [ "Should not happen" ^self error: 'Cannot compile backwards conditional jumps'. ]. jmpCondition ifFalse: [ stCompiler depthDecr: 1; nextPut: PopJumpFalse + ((displacement bitShift: -4) bitAnd: 3) ] ifTrue: [ stCompiler depthDecr: 1; nextPut: PopJumpTrue + ((displacement bitShift: -4) bitAnd: 3) ]. stCompiler nextPut: (displacement bitAnd: 255) ! ! "--------------------------------------------------------------------" STReturnNode comment: 'STReturnNode has one instance variable, that is another STParseNode which compiles to the value to be returned.'! !STReturnNode methodsFor: 'compiling'! compileFor: stCompiler self expression compileReturnFor: stCompiler ! ! "--------------------------------------------------------------------" STSpecialIdentifierNode comment: 'STSpecialIdentifierNode has one instance variable, an id of the pseudo-variable that it represents.'! !STSpecialIdentifierNode methodsFor: 'compiling'! compileFor: stCompiler stCompiler depthIncr; nextPut: self bytecodeID + PushSpecial. ! compileReturnFor: stCompiler | bytecodeID | stCompiler isInsideBlock ifTrue: [ ^super compileReturnFor: stCompiler ]. bytecodeID := self bytecodeID. bytecodeID <= 3 ifTrue: [ stCompiler nextPut: bytecodeID + ReturnSpecial ] ifFalse: [ super compileReturnFor: stCompiler ]. ! compileAssignmentFor: stCompiler stCompiler compileError: 'cannot assign to ', (VMSpecialIdentifiers keyAtValue: id) ! ! "--------------------------------------------------------------------" STVariableNode comment: 'STVariableNode has one instance variable, the name of the variable that it represents.'! !STVariableNode methodsFor: 'compiling'! compileAssignmentFor: stCompiler | locationType definition | definition := stCompiler lookupName: self id. locationType := LiteralVariableLocation. (stCompiler isTemporary: self id) ifTrue: [ stCompiler checkStore: self id. ^self compileStoreTemporary: definition scopes: (stCompiler outerScopes: self id) for: stCompiler ]. (stCompiler isReceiver: self id) ifTrue: [ locationType := ReceiverLocation. definition <= 7 ifTrue: [ stCompiler nextPut: DupStackTop. stCompiler nextPut: (PopReceiverVariable + definition). ^self ] ]. definition > 63 ifTrue: [ stCompiler compileBigLiteral: StoreVariable index: definition. ^self ]. stCompiler nextPut: StoreIndexed; nextPut: (locationType + definition) ! compileFor: stCompiler | locationType definition | stCompiler depthIncr. definition := stCompiler lookupName: self id. locationType := LiteralVariableLocation. (stCompiler isTemporary: self id) ifTrue: [ ^self compilePushTemporary: definition scopes: (stCompiler outerScopes: self id) for: stCompiler ]. (stCompiler isReceiver: self id) ifTrue: [ locationType := ReceiverLocation. definition <= 15 ifTrue: [ stCompiler nextPut: (PushReceiverVariable + definition). ^self ] ]. definition <= 31 ifTrue: [ stCompiler nextPut: (PushLitVariable + definition). ^self ]. definition > 63 ifTrue: [ stCompiler compileBigLiteral: PushVariable index: definition. ^self ]. stCompiler nextPut: PushIndexed; nextPut: (locationType + definition) ! compilePushTemporary: number scopes: outerScopes for: stCompiler outerScopes = 0 ifFalse: [ stCompiler nextPut: OuterVar; nextPut: number + PushVariable; nextPut: outerScopes. ^self ]. number < 16 ifTrue: [ stCompiler nextPut: PushTemporaryVariable + number. ^self ]. stCompiler nextPut: PushIndexed; nextPut: (TemporaryLocation + number) ! compileStoreTemporary: number scopes: outerScopes for: stCompiler outerScopes = 0 ifFalse: [ stCompiler nextPut: OuterVar; nextPut: number + StoreVariable; nextPut: outerScopes. ]. stCompiler nextPut: StoreIndexed; nextPut: (TemporaryLocation + number) ! !