"{ Package: 'stx:goodies/newcompiler' }"

Object subclass:#IRBytecodeGenerator

	instanceVariableNames:'seqOrder orderSeq jumps literals lastLiteral currentSeqId

		currentSeqNum lastSpecialReturn instrMaps instrMap maxTemp stacks

	classVariableNames:'BytecodeTable Bytecodes SpecialConstants SpecialSelectors'

	poolDictionaries:''

	category:'NewCompiler-Bytecode'

!

IRBytecodeGenerator comment:'I generate bytecodes in response to ''instructions'' messages being sent to me.  I rewrite jumps at the end so their jump offsets are correct (see #bytecodes).  For example, to create a compiled method that compares first instVar to first arg and returns ''yes'' or ''no'' (same example as in IRBuilder), do:

	BytecodeGenerator new
		numArgs: 1;
		pushInstVar: 1;
		pushTemp: 1;
		send: #>;
		if: false goto: #else;
		pushLiteral: ''yes'';
		returnTop;
		label: #else;
		pushLiteral: ''no'';
		returnTop;
		compiledMethod

You can send #ir to the compiledMethod to decompile to its IRMethod, and you can send #methodNode to either to decompile to its parse tree.
'

!

!IRBytecodeGenerator class methodsFor:'instance creation'!

new

    ^ self basicNew initialize.

    "Created: / 11-06-2008 / 13:53:20 / Jan Vrany <vranyj1@fel.cvut.cz>"

! !

!IRBytecodeGenerator methodsFor:'accessing'!

properties: aDictionary

    properties := aDictionary.

    "Created: / 17-09-2008 / 12:17:49 / Jan Vrany <vranyj1@fel.cvut.cz>"

! !

!IRBytecodeGenerator methodsFor:'accessing default'!

defaultStackCounter

        ^IRStackCount

    "Modified: / 11-06-2008 / 13:51:39 / Jan Vrany <vranyj1@fel.cvut.cz>"

! !

!IRBytecodeGenerator methodsFor:'initialize'!

initialize

        literals := OrderedCollection new.

        "The following dicts are keyed by sequence id given by client in label: (and gotos)."

        seqOrder := IdentityDictionary new.  "seqId -> seq order num"

        seqCode := IdentityDictionary new.  "seqId -> seq bytecodes"

        jumps := IdentityDictionary new.  "seqId -> last jump instr"

        instrMaps := IdentityDictionary new.  "seqId -> (clientInstr -> bytecode pos)"

        stacks := IdentityDictionary new.  "seqId -> stackCount"

        maxTemp := 0.

        primNum := 0.

        numArgs := 0.

        currentSeqNum := 0.

        orderSeq := OrderedDictionary new.  "reverse map of seqOrder"

        lastLine := 0.

        "starting label in case one is not provided by client"

        self label: self newDummySeqId.

!

numArgs: n

        numArgs := n

    "Modified: / 11-06-2008 / 14:39:46 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

primitiveNode: aPrimitiveNode

        "There are no primitives in St/X"

        "

        literals isEmpty ifFalse: [self error: 'init prim before adding instructions'].

        aPrimitiveNode spec ifNotNil: [literals add: aPrimitiveNode spec].

        primNum _ aPrimitiveNode num.

        "

    "Modified: / 17-09-2008 / 12:16:12 / Jan Vrany <vranyj1@fel.cvut.cz>"

! !

!IRBytecodeGenerator methodsFor:'instructions'!

goto: seqId

	stacks at: seqId put: (stack linkTo: (stacks at: seqId ifAbsentPut: [nil])).

	self saveLastJump: (Message

		selector: #from:goto:

		arguments: {currentSeqId. seqId}).

	self from: currentSeqId goto: seqId.

!

if: bool goto: seqId

	| otherwiseSeqId |

	otherwiseSeqId _ self newDummySeqId.

	self if: bool goto: seqId otherwise: otherwiseSeqId.

	self label: otherwiseSeqId.

!

if: bool goto: seqId1 otherwise: seqId2

	stack pop.

	stacks at: seqId1 put: (stack linkTo: (stacks at: seqId1 ifAbsentPut: [nil])).

	stacks at: seqId2 put: (stack linkTo: (stacks at: seqId2 ifAbsentPut: [nil])).

	self saveLastJump: (Message

		selector: #from:if:goto:otherwise:

		arguments: {currentSeqId. bool. seqId1. seqId2}).

	self from: currentSeqId if: bool goto: seqId1 otherwise: seqId2.

!

initializeStackCounter

	^ self defaultStackCounter new

!

label: seqId 

	(currentSeqId notNil and: [(jumps at: currentSeqId) isNil]) 

		ifTrue: 

			["make previous implicit goto explicit"

			self goto: seqId].

	lastSpecialReturn := nil.

	currentSeqId := seqId.

	currentSeqNum := currentSeqNum + 1.

	seqOrder at: seqId put: currentSeqNum.

	orderSeq at: currentSeqNum ifAbsentPut: [seqId].

	code := seqCode at: seqId ifAbsentPut: [OrderedCollection new].

	jumps at: seqId ifAbsentPut: [nil].

	instrMap := instrMaps at: seqId ifAbsentPut: [OrderedCollection new].

	stack := stacks at: seqId ifAbsentPut: [self initializeStackCounter]

    "Modified: / 11-06-2008 / 13:58:56 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

line: line

    lastLine = line ifTrue:[^self].

    lastLine := line.

    (line < 256) 

        ifTrue:

            [self 

                nextPut: #lineno;

                nextPut: line]

        ifFalse:

            [self 

                nextPut: #lineno16;

                nextPut: line]

    "Created: / 02-12-2008 / 09:02:30 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 02-12-2008 / 10:38:20 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

popTop

        stack pop.

        self nextPut: #drop

    "Modified: / 11-06-2008 / 14:17:22 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

pushDup

        stack push.

        self nextPut: #dup

    "Modified: / 11-06-2008 / 14:15:10 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

pushInstVar: index

        stack push.

        (index between: 1 and: 10)

            ifTrue:[self nextPut:('pushInstVar',index printString) asSymbol]

            ifFalse:[self nextPut:#pushInstVar; nextPut: index].

    "Modified: / 11-06-2008 / 14:19:57 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

pushLiteral: object

        stack push.

        self 

            nextPut: #pushLitS;

            nextPut: (self addLiteral: object).

    "Modified: / 03-11-2008 / 14:32:04 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

pushLiteralVariable: object

        stack push.

        self 

            nextPut: #pushGlobalS;

            nextPut: (self addLiteral: object)

    "Modified: / 11-06-2008 / 14:13:42 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

pushReceiver

        stack push.

        self nextPut: #pushSelf

    "Modified: / 11-06-2008 / 14:14:25 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

pushThisContext

        stack push.

        self nextPut: #pushThisContext

    "Modified: / 11-06-2008 / 14:31:32 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

remoteReturn

	self saveLastJump: #return.

	self send: #privRemoteReturnTo:.

!

returnConstant: obj

        self saveLastJump: #return.

        code size = 0 ifTrue: [

                lastSpecialReturn := Message selector: #returnConstant: argument: obj].

        obj = true ifTrue:[^self nextPut: #retTrue].

        obj = false ifTrue:[^self nextPut: #retFalse].

        obj = nil ifTrue:[^self nextPut: #retNil].

        obj = 0 ifTrue:[^self nextPut: #ret0].

        self pushLiteral: obj.

        self returnTop.

    "Modified: / 11-06-2008 / 14:07:40 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

returnInstVar: index

	self saveLastJump: #return.

	code size = 0 ifTrue: [

		lastSpecialReturn := Message selector: #returnInstVar: argument: index].

	self pushInstVar: index.

	self returnTop.

    "Modified: / 11-06-2008 / 13:56:42 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

returnReceiver

        self saveLastJump: #return.

        code size = 0 ifTrue: [

                lastSpecialReturn := Message selector: #returnReceiver].

        self nextPut: #retSelf

    "Modified: / 11-06-2008 / 14:29:31 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

returnTop

        self saveLastJump: #return.

        self nextPut: #retTop

    "Modified: / 11-06-2008 / 14:04:55 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

send: selector numArgs: sendNumArgs

        stack pop: sendNumArgs.

        self 

            nextPut: #send;

            nextPut: lastLine;

            nextPut: (self addLiteral: selector);

            nextPut: sendNumArgs.

    "Created: / 01-12-2008 / 19:47:43 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 02-12-2008 / 09:10:31 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

send: selector numArgs: sendNumArgs toSuperOf: behavior

        stack pop: sendNumArgs.

        self 

            nextPut: #superSend;

            nextPut: lastLine;

            nextPut: (self addLiteral: selector);

            nextPut: sendNumArgs;

            nextPut: (self addLiteral: behavior superclass)

    "Created: / 01-12-2008 / 19:48:14 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 02-12-2008 / 09:10:37 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

storeInstVar: index

    self

        nextPut: #storeInstVar;

        nextPut: index.

    "Modified: / 11-06-2008 / 14:49:52 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

storeIntoLiteralVariable: object

        stack pop.

        self 

            nextPut: #storeGlobalS;

            nextPut: (self addLiteral: object)

    "Modified: / 11-06-2008 / 16:23:06 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

! !

!IRBytecodeGenerator methodsFor:'mapping'!

mapBytesTo: instr

	"Associate next byte with instr"

	instrMap add: instr -> (code size + 1)

    "Modified: / 11-06-2008 / 13:56:42 / Jan Vrany <vranyj1@fel.cvut.cz>"

! !

!IRBytecodeGenerator methodsFor:'old style blocks'!

blockReturnTop

	self saveLastJump: #return.

	self nextPut: (Bytecodes at: #returnTopFromBlock).

!

fromBlock: curId goto: seqId

	| distance from to |

	from _ seqOrder at: curId.

	to _ seqOrder at: seqId ifAbsent: [^ self].

	distance _ (from + 1 to: to - 1) inject: 0 into: [:size :i | 

				size + (seqCode at: (orderSeq at: i)) size].

	distance > 1023 ifTrue: [self error: 'forward jump too big'].

	self nextPut: (Bytecodes at: #longUnconditionalJump) first + (distance // 256) + 4.

	self nextPut: distance \\ 256.

    "Modified: / 11-06-2008 / 13:58:56 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

jumpOverBlock: seqId

	stacks at: seqId put: (stack linkTo: (stacks at: seqId ifAbsentPut: [nil])).

	self saveLastJump: (Message

		selector: #fromBlock:goto:

		arguments: {currentSeqId. seqId}).

	self fromBlock: currentSeqId goto: seqId.

! !

!IRBytecodeGenerator methodsFor:'private'!

addLastLiteral: object

        lastLiteral ifNil: [^ lastLiteral := object].

        (lastLiteral = object)

                ifFalse: [self error: 'there can only be one last literal'].

    "Modified: / 11-06-2008 / 13:49:30 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

addLiteral: object

    (literals includesIdentical: object)

        ifFalse:[literals add: object].

    ^ literals identityIndexOf: object

    "Modified: / 03-11-2008 / 13:49:25 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

from: fromSeqId goto: toSeqId

	| distance from to |

	from _ seqOrder at: fromSeqId.

	to _ seqOrder at: toSeqId ifAbsent: [^ self].

	from + 1 = to ifTrue: [^ self].  "fall through, no jump needed"

	from < to ifTrue: [ "jump forward"

		distance _ (from + 1 to: to - 1) inject: 0 into: [:size :i | 

				size + (seqCode at: (orderSeq at: i)) size].

		self jumpForward: distance.

	] ifFalse: [ "jump backward"

		distance _ ((to to: from - 1) inject: 0 into: [:size :i |

				size + (seqCode at: (orderSeq at: i)) size])

			+ code size.

		self jumpBackward: distance.

	].

    "Modified: / 11-06-2008 / 13:58:56 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

from: fromSeqId if: bool goto: toSeqId otherwise: otherwiseSeqId

	| distance from to otherwise |

	from _ seqOrder at: fromSeqId.

	to _ seqOrder at: toSeqId ifAbsent: [^ self jump: 0 if: bool].  "not done yet"

	otherwise _ seqOrder at: otherwiseSeqId ifAbsent: [^ self jump: 0 if: bool].  "not done yet"

	from < to ifFalse: [self errorConditionalJumpBackwards].

	from + 1 = otherwise ifFalse: [self errorFallThroughSequenceNotNext].

	distance _ (from + 1 to: to - 1)

		inject: 0

		into: [:size :i | size + (seqCode at: (orderSeq at: i)) size].

	self jump: distance if: bool.

    "Modified: / 11-06-2008 / 13:58:56 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

jump: distance if: condition

        |  |

        distance = 0 ifTrue: [

                "jumps to fall through, no-op"

                ^ self popTop].

        self

            nextPut:(condition ifTrue:[#trueJump] ifFalse:[#falseJump]);

            nextPut: distance

    "Modified: / 11-06-2008 / 15:49:07 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

jumpBackward: distance

        |  |

        distance = 0 ifTrue: [^ self].  "no-op"

        self

            nextPut:#jump;

            nextPut: distance negated

        "

        dist _ 1024 - distance - 2.

        dist < 0 ifTrue: [self error: 'back jump too big'].

        self nextPut: (Bytecodes at: #longUnconditionalJump) first + (dist // 256).

        self nextPut: dist \\ 256.

        "

    "Modified: / 11-06-2008 / 15:48:56 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

jumpForward: distance

        distance = 0 ifTrue: [^ self].  "no-op"