"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
Parser subclass:#ByteCodeCompiler
instanceVariableNames:'codeBytes codeIndex litArray stackDelta extra lineno
maxStackDepth relocList'
classVariableNames:'JumpToAbsJump SequenceNumber STCCompilationDefines
STCCompilationIncludes STCCompilationOptions STCCompilation
KeepSource STCKeepCIntermediate'
poolDictionaries:''
category:'System-Compiler'
!
!ByteCodeCompiler class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
!
documentation
"
This class performs compilation into ByteCodes.
First, parsing is done using superclass methods,
then the parse-tree is converted into an array of symbolic codes
and a relocation table;
these two are finally combined into a byteArray of the codes.
(the intermediate step through symbolic codes is for debugging
only - it will vanish)
There are many dependencies to the run-time-system (especially the
interpreter) in here - be careful when playing around ...
Instance variables:
codeBytes <ByteArry> bytecodes
codeIndex <SmallInteger> next index to put into code array
litArray <OrderedCollection> literals
stackDelta <SmallInteger> return value of byteCodeFor:
extra <Symbol> return value of byteCodeFor:
lineno <Boolean> return value of byteCodeFor:
maxStackDepth <SmallInteger> stack need of method
relocList <Array> used temporary for relocation
Class variables:
JumpToAbsJump <Dictionary> internal table to map opcodes
"
! !
!ByteCodeCompiler class methodsFor:'compiling methods'!
compile:methodText forClass:classToCompileFor
"compile a source-string for a method in classToCompileFor"
^ self compile:methodText
forClass:classToCompileFor
inCategory:'others'
notifying:nil
install:true
skipIfSame:false
silent:false
!
compile:aString forClass:aClass inCategory:cat
"compile a source-string for a method in classToCompileFor.
The method will get cat as category"
^ self compile:aString
forClass:aClass
inCategory:cat
notifying:nil
install:true
skipIfSame:false
silent:false
!
compile:aString forClass:aClass inCategory:cat notifying:requestor
"compile a source-string for a method in classToCompileFor.
errors are forwarded to requestor.
The method will get cat as category"
^ self compile:aString
forClass:aClass
inCategory:cat
notifying:requestor
install:true
skipIfSame:false
silent:false
!
compile:aString forClass:aClass inCategory:cat notifying:requestor install:install
"compile a source-string for a method in classToCompileFor.
The install-argument controls if the method is to be installed into the
classes method-dictionary, or just to be compiled and a method object to be returned.
Errors are forwarded to requestor. The method will get cat as category"
^ self compile:aString
forClass:aClass
inCategory:cat
notifying:requestor
install:install
skipIfSame:false
silent:false
!
compile:aString forClass:aClass inCategory:cat notifying:requestor
install:install skipIfSame:skipIfSame
"compile a source-string for a method in classToCompileFor.
The install-argument controls if the method is to be installed into the
classes method-dictionary, or just to be compiled and a method object to be returned.
Errors are forwarded to requestor. The method will get cat as category.
If skipIsSame is true, and the source is the same as an existing
methods source, this is a noop (for fast fileIn)."
^ self compile:aString
forClass:aClass
inCategory:cat
notifying:requestor
install:install
skipIfSame:skipIfSame
silent:false
!
compile:aString forClass:aClass inCategory:cat notifying:requestor
install:install skipIfSame:skipIfSame silent:silent
"the basic workhorse method for compiling:
compile a source-string for a method in classToCompileFor.
errors are forwarded to requestor (report on Transcript and return
#Error, if requestor is nil).
The new method will get cat as category.
If install is true, the method will go into the classes method-table,
otherwise the method is simply returned (for anonymous methods).
If skipIsSame is true, and the source is the same as an existing
methods source, this is a noop (for fast fileIn).
The argument, silent controls if errors are to be reported."
|compiler newMethod tree lits symbolicCodeArray oldMethod lazy silencio
sourceFile sourceStream newSource primNr pos sel|
aString isNil ifTrue:[^ nil].
silencio := silent or:[Smalltalk silentLoading == true].
"lazy compilation is EXPERIMENTAL"
lazy := (LazyCompilation == true) and:[install].
"create a compiler, let it parse and create the parsetree"
compiler := self for:(ReadStream on:aString) in:aClass.
compiler parseForCode.
compiler notifying:requestor.
silent ifTrue:[
"/ compiler ignoreErrors.
compiler ignoreWarnings
].
compiler nextToken.
(compiler parseMethodSpec == #Error) ifTrue:[
tree := #Error
] ifFalse:[
"check if same source"
(skipIfSame and:[(sel := compiler selector) notNil]) ifTrue:[
oldMethod := aClass compiledMethodAt:sel.
oldMethod notNil ifTrue:[
oldMethod source = aString ifTrue:[
oldMethod isInvalid ifFalse:[
silencio ifFalse:[
Transcript showCr:(' unchanged: ',aClass name,' ',compiler selector)
].
"
same. however, category may be different
"
(cat notNil and:[cat ~~ oldMethod category]) ifTrue:[
oldMethod category:cat.
oldMethod changed:#category.
"/ aClass updateRevisionString.
aClass addChangeRecordForMethodCategory:oldMethod category:cat.
].
^ oldMethod
]
]
]
].
lazy ifFalse:[
tree := compiler parseMethodBody.
compiler tree:tree.
]
].
sel := compiler selector.
(compiler errorFlag or:[tree == #Error]) ifTrue:[
"/ compiler parseError:'syntax error'.
Transcript show:' '.
aClass notNil ifTrue:[
Transcript show:aClass name , '>>'
].
sel notNil ifTrue:[
Transcript show:(sel)
].
Transcript showCr:' -> Error'.
^ #Error
].
"if no error and also no selector ..."
sel isNil ifTrue:[
"... it was just a comment or other empty stuff"
^ nil
].
"
freak-out support ...
"
(compiler hasNonOptionalPrimitiveCode
or:[(compiler hasPrimitiveCode and:[self canCreateMachineCode])
or:[STCCompilation == #always and:[sel ~~ #doIt]]]) ifTrue:[
newMethod := compiler
compileToMachineCode:aString
forClass:aClass
inCategory:cat
notifying:requestor
install:install
skipIfSame:skipIfSame
silent:silent.
newMethod ==#Error ifTrue:[
newMethod := compiler trappingStubMethodFor:aString inCategory:cat.
install ifTrue:[
aClass addSelector:sel withMethod:newMethod
].
Transcript show:'*** '.
sel notNil ifTrue:[
Transcript show:(sel ,' ')
].
Transcript showCr:'not compiled to machine code - created a stub instead.'.
].
^ newMethod
].
"
EXPERIMENTAL: quick loading
only create a lazyMethod, which has no byteCode and will
compile itself when first called.
"
lazy ifTrue:[
newMethod := LazyMethod new.
KeepSource == false ifTrue:[
sourceFile := ObjectMemory nameForSources.
sourceStream := sourceFile asFilename appendingWriteStream.
].
sourceStream isNil ifTrue:[
newMethod source:aString.
] ifFalse:[
sourceStream setToEnd.
pos := sourceStream position.
sourceStream nextChunkPut:aString.
sourceStream close.
newMethod sourceFilename:sourceFile position:pos.
].
newMethod category:cat.
Project notNil ifTrue:[
newMethod package:(Project currentPackageName)
].
aClass addSelector:sel withLazyMethod:newMethod.
^ newMethod
].
(primNr := compiler primitiveNumber) isNil ifTrue:[
"
produce symbolic code first
"
symbolicCodeArray := compiler genSymbolicCode.
(symbolicCodeArray == #Error) ifTrue:[
Transcript show:' '.
sel notNil ifTrue:[
Transcript show:(sel ,' ')
].
Transcript showCr:'translation error'.
^ #Error
].
"
take this, producing bytecode
(someone willin' to make machine code :-)
"
((compiler genByteCodeFrom:symbolicCodeArray) == #Error) ifTrue:[
Transcript show:' '.
sel notNil ifTrue:[
Transcript show:(sel ,' ')
].
Transcript showCr:'relocation error - must be simplified'.
^ #Error
].
].
"
finally create the new method-object
"
newMethod := Method new.
lits := compiler literalArray.
lits notNil ifTrue:[
"literals MUST be an array - not just any Collection"
lits := Array withAll:lits.
newMethod literals:lits
].
primNr notNil ifTrue:[
newMethod code:(compiler checkForPrimitiveCode:primNr).
] ifFalse:[
newMethod byteCode:(compiler code).
].
newMethod numberOfMethodVars:(compiler numberOfMethodVars).
newMethod numberOfMethodArgs:(compiler numberOfMethodArgs).
newMethod stackSize:(compiler maxStackDepth).
"
if there where any corrections, install the updated source
"
(newSource := compiler correctedSource) notNil ifTrue:[
newMethod source:newSource
] ifFalse:[
newMethod source:aString.
].
newMethod category:cat.
Project notNil ifTrue:[
newMethod package:(Project currentPackageName)
].
install ifTrue:[
aClass addSelector:sel withMethod:newMethod
].
silencio ifFalse:[
Transcript showCr:(' compiled: ', aClass name,' ', sel)
].
^ newMethod
"Created: 29.10.1995 / 19:59:36 / cg"
!
compile:methodText forClass:classToCompileFor notifying:requestor
"compile a source-string for a method in classToCompileFor.
Errors are forwarded to requestor."
^ self compile:methodText
forClass:classToCompileFor
inCategory:'others'
notifying:requestor
install:true
skipIfSame:false
silent:false
!
compile:textOrStream in:aClass notifying:requestor ifFail:exceptionBlock
"name alias for ST-80 compatibility"
|m|
m := self
compile:textOrStream
forClass:aClass
inCategory:'others'
notifying:requestor
install:true
skipIfSame:false
silent:false.
m == #Error ifTrue:[
^ exceptionBlock value
].
^ m
! !
!ByteCodeCompiler class methodsFor:'constants'!
byteCodeFor:aSymbol
"only some exported codes handled here (for BlockNode)"
(aSymbol == #retNil) ifTrue:[^ 1].
(aSymbol == #retTrue) ifTrue:[^ 2].
(aSymbol == #retFalse) ifTrue:[^ 3].
(aSymbol == #ret0) ifTrue:[^ 4].
(aSymbol == #retTop) ifTrue:[^ 0].
(aSymbol == #push0) ifTrue:[^120].
(aSymbol == #push1) ifTrue:[^121].
(aSymbol == #push2) ifTrue:[^139].
(aSymbol == #pushMinus1) ifTrue:[^122].
(aSymbol == #pushNil) ifTrue:[^ 10].
(aSymbol == #pushTrue) ifTrue:[^ 11].
(aSymbol == #pushFalse) ifTrue:[^ 12].
(aSymbol == #pushSelf) ifTrue:[^ 15].
self error
! !
!ByteCodeCompiler class methodsFor:'stc compilation defaults'!
canCreateMachineCode
"return true, if compilation to machine code is supported.
Currently, all SYSV4 and Linux systems do so;
REAL/IX, AIX and HPUX do not (due to the need for dynamic loading
of object files, which is not supported by those).
MIPS ULTRIX is almost finished, but not yet released.
However, if no compiler is around (i.e. the demo distribution),
there is no chance ..."
|canDo|
ObjectFileLoader isNil ifTrue:[^ false].
ObjectFileLoader canLoadObjectFiles ifFalse:[^ false].
"/ no chance, if no stc is available
^ self incrementalStcPath notNil
"
Compiler canCreateMachineCode
"
"Modified: 13.9.1995 / 15:15:11 / claus"
!
incrementalStcPath
"return the path to the stc command for incremental method compilation,
or nil if not found."
|f|
(f := self stcPathOf:'stc') notNil ifTrue:[^ f].
^ self stcPathOf:'demostc'
"
Compiler incrementalStcPath
"
"Created: 13.9.1995 / 14:36:36 / claus"
"Modified: 13.9.1995 / 15:15:04 / claus"
!
keepSource:aBoolean
"if true, the source of a method is kept as a string in memory;
if false, the source is appended to the sources-file (st.src) and
only a reference to its fileposition is kept in memory - thus saving
space. You have to care for the source-file to not become corrupted
in this case; therefore, the default is to keep it as strings for now."
KeepSource := aBoolean
"
Compiler keepSource:true.
Compiler keepSource:false.
"
!
stcCompilation
"return the flag which controls compilation to machine code.
If #always, methods are always compiled to machine code (which takes
longer, but provides faster code). If #none, methods are never compiled
to machine code, instead for non-primitive ones, compilation is to bytecode
and for primitive ones, a trapping stub is generated.
Anything else lets the compiler compile to bytecode,
except for methods containing primitive code.
This can be set from your private.rc file or from a workspace
for selective compilation to machine code."
^ STCCompilation
"
Compiler stcCompilation
"
!
stcCompilation:how
"set the flag which controls compilation to machine code.
If #always, methods are always compiled to machine code (which takes
longer, but provides faster code). If #none, methods are never compiled
to machine code, instead for non-primitive ones, compilation is to bytecode
and for primitive ones, a trapping stub is generated.
Anything else lets the compiler compile to bytecode,
except for methods containing primitive code.
This can be set from your private.rc file or from a workspace
for selective compilation to machine code."
|ret|
ret := STCCompilation.
STCCompilation := how.
^ ret
"
Compiler stcCompilation:#always
Compiler stcCompilation:#never
Compiler stcCompilation:#default
"
!
stcCompilationDefines
"return the defines used with stc compilation"
^ STCCompilationDefines
!
stcCompilationDefines:aString
"define the flags (for example, additional -D defines)
to be used when compiling to machine code.
These are passed to stc. Can be set from your private.rc file."
STCCompilationDefines := aString
"
Compiler stcCompilationDefines:'-DVGL -DDEBUG'
"
!
stcCompilationIncludes
"return the includes used with stc compilation"
^ STCCompilationIncludes
!
stcCompilationIncludes:aString
"define the include directories via additional -I flags.
These are passed to stc. Can be set in your private.rc file"
STCCompilationIncludes := aString
"
Compiler stcCompilationIncludes:'-I/usr/local/include -I../../include'
Compiler stcCompilationIncludes:(Compiler stcCompilationIncludes , ' -I../../libxt')
"
!
stcCompilationOptions
"return the options used with stc compilation"
^ STCCompilationOptions
!
stcCompilationOptions:aString
"define the compilation options
to be used when compiling to machine code.
These are passed to stc. Can be set from your private.rc file."
STCCompilationOptions := aString
"
Compiler stcCompilationOptions:'+optinline'
"
!
stcPath
"return the path to the stc command, or nil if not found."
^ self stcPathOf:'stc'
"
Compiler stcPath
"
"Modified: 13.9.1995 / 14:37:26 / claus"
!
stcPathOf:command
"return the path to an stc command, or nil if not found."
|f|
((f := '../../stc' asFilename construct:command)) isExecutable ifTrue:[
^ f pathName
].
^ OperatingSystem pathOfCommand:command
"
Compiler stcPathOf:'stc'
"
"Created: 13.9.1995 / 14:37:16 / claus"
! !
!ByteCodeCompiler methodsFor:'ST-80 compatibility'!
compile:textOrStream in:aClass notifying:requestor ifFail:exceptionBlock
"name alias for ST-80 compatibility"
^ self class
compile:textOrStream
in:aClass
notifying:requestor
ifFail:exceptionBlock
"/ |m|
"/
"/ m := self class
"/ compile:textOrStream
"/ forClass:aClass
"/ inCategory:'no category'
"/ notifying:requestor
"/ install:true
"/ skipIfSame:false
"/ silent:false.
"/ m == #Error ifTrue:[
"/ ^ exceptionBlock value
"/ ].
"/ ^ m
! !
!ByteCodeCompiler methodsFor:'accessing'!
code
"return the bytecode array - only valid after code-generation"
^ codeBytes
!
literalArray
"return the literal array - only valid after parsing"
^ litArray
!
maxStackDepth
"return the stack-need of the method - only valid after code-generation"
^ maxStackDepth
! !
!ByteCodeCompiler methodsFor:'code generation'!
absJumpFromJump:code
"given a jump-symbolic code, return corresponding absolute jump"
JumpToAbsJump isNil ifTrue:[
JumpToAbsJump := IdentityDictionary new.
JumpToAbsJump at:#jump put:#jumpabs.
JumpToAbsJump at:#trueJump put:#trueJumpabs.
JumpToAbsJump at:#falseJump put:#falseJumpabs.
JumpToAbsJump at:#nilJump put:#nilJumpabs.
JumpToAbsJump at:#notNilJump put:#notNilJumpabs.
JumpToAbsJump at:#eqJump put:#eqJumpabs.
JumpToAbsJump at:#notEqJump put:#notEqJumpabs.
JumpToAbsJump at:#zeroJump put:#zeroJumpabs.
JumpToAbsJump at:#notZeroJump put:#notZeroJumpabs.
JumpToAbsJump at:#makeBlock put:#makeBlockabs.
].
^ JumpToAbsJump at:code
!
addLiteral:anObject
"add a literal to the literalArray - watch for and eliminate
duplicates. return the index of the literal in the Array"
|index class|
litArray isNil ifTrue:[
litArray := Array with:anObject.
^ 1
].
index := litArray identityIndexOf:anObject.
(index == 0) ifTrue:[
"
reuse constants if same value and same class
"
class := anObject class.
((class == Float)
or:[class == Fraction]) ifTrue:[
index := litArray indexOf:anObject.
].
((index == 0) or:[(litArray at:index) class ~~ class]) ifTrue:[
litArray := litArray copyWith:anObject.
^ litArray size
].
].
^ index
!
addReloc:symIndex
"remember to relocate offset at symIndex later ..."
relocList isNil ifTrue:[
relocList := OrderedCollection new.
].
relocList add:symIndex
!
appendByte:aByte
"append a byte to the code-Array, checking for byte-range (debug-only)"
|idx "{Class: SmallInteger }"|
idx := codeIndex.
(aByte between:0 and:255) ifTrue:[
codeBytes at:idx put:aByte.
codeIndex := idx + 1
] ifFalse:[
self error:'byte range error'.
errorFlag := #Error
]
!
appendByteCodeFor:codeSymbol
"append the byteCode for an instructionSymbol to the code-Array"
|idx "{Class: SmallInteger }"|
idx := codeIndex.
codeBytes at:idx put:(self byteCodeFor:codeSymbol).
codeIndex := idx + 1
!
appendEmptyByte
"append an empty byte to the code-Array"
|idx "{Class: SmallInteger }"|
idx := codeIndex.
codeBytes at:idx put:0.
codeIndex := idx + 1
!
appendSignedByte:aByte
"append a signedbyte (as in jump-offsets) to the code-Array,
check range and report an error if invalid"
|b "{Class: SmallInteger }"
idx "{Class: SmallInteger }"|
idx := codeIndex.
b := aByte.
(b >= 0) ifTrue:[
(b > 127) ifTrue:[
self error:'jump-range error'.
errorFlag := #Error
].
codeBytes at:idx put:b
] ifFalse:[
(b < -128) ifTrue:[
self error:'jump-range error'.
errorFlag := #Error
].
b := 256 + b
].
codeBytes at:idx put:b.
codeIndex := idx + 1
!
appendSignedWord:aWord
"append a signed word to the code-Array,
check range and report an error if invalid"
|w "{Class: SmallInteger }"|
w := aWord.
(w >= 0) ifTrue:[
(w > 16r7FFFF) ifTrue:[
self error:'word-range error'.
errorFlag := #Error
].
] ifFalse:[
(w < 16r-8000) ifTrue:[
self error:'word-range error'.
errorFlag := #Error
].
w := (16r10000 + w).
].
self appendWord:w
!
appendWord:aWord
"append an unsigned word (low-high) to the code-Array,
checking for word-range (debug-only)"
|idx "{Class: SmallInteger }"|
idx := codeIndex.
(aWord between:0 and:16rFFFF) ifTrue:[
codeBytes at:idx put:(aWord bitAnd:16rFF).
idx := idx + 1.
codeBytes at:idx put:(aWord bitShift:-8).
codeIndex := idx + 1
] ifFalse:[
self error:'word range error'.
errorFlag := #Error
]
!
byteCodeFor:aSymbol
"given a symbolic instruction, return the corresponding bytecode.
as a side-effect, leave number of bytes pushed/popped by this instr.
in stackDelta, and, if the instruction needs extra arguments, leave
this info in extra"
"standard bytecodes"
(aSymbol == #pushNil) ifTrue:[stackDelta := 1. ^ 10].
(aSymbol == #pushTrue) ifTrue:[stackDelta := 1. ^ 11].
(aSymbol == #pushFalse) ifTrue:[stackDelta := 1. ^ 12].
(aSymbol == #pushLit) ifTrue:[stackDelta := 1. extra := #lit. ^ 14].
(aSymbol == #pushLitS) ifTrue:[stackDelta := 1. extra := #index. ^ 14].
(aSymbol == #pushSelf) ifTrue:[stackDelta := 1. ^ 15].
(aSymbol == #pushNum) ifTrue:[stackDelta := 1. extra := #number. ^ 16].
(aSymbol == #pushMethodArg) ifTrue:[stackDelta := 1. extra := #index. ^ 30].
(aSymbol == #pushMethodVar) ifTrue:[stackDelta := 1. extra := #index. ^ 31].
(aSymbol == #pushBlockArg) ifTrue:[stackDelta := 1. extra := #index. ^ 32].
(aSymbol == #pushBlockVar) ifTrue:[stackDelta := 1. extra := #index. ^ 33].
(aSymbol == #pushInstVar) ifTrue:[stackDelta := 1. extra := #index. ^ 34].
(aSymbol == #pushOuterBlockArg) ifTrue:[stackDelta := 1. extra := #indexLevel. ^ 42].
(aSymbol == #pushOuterBlockVar) ifTrue:[stackDelta := 1. extra := #indexLevel. ^ 128].
(aSymbol == #retTop) ifTrue:[stackDelta := -1. ^ 0].
(aSymbol == #retSelf) ifTrue:[^5].
(aSymbol == #==) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^ 45].
(aSymbol == #~~) ifTrue:[stackDelta := -1. self addLiteral:aSymbol. ^ 46].
(aSymbol == #falseJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 50].
(aSymbol == #trueJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 51].
(aSymbol == #nilJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 52].
(aSymbol == #notNilJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 53].
(aSymbol == #jump) ifTrue:[extra := #offset. ^ 54].
(aSymbol == #makeBlock) ifTrue:[stackDelta := 1. extra := #offsetNvarNarg. ^ 55].
(aSymbol == #zeroJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 56].
(aSymbol == #notZeroJump) ifTrue:[stackDelta := -1. extra := #offset. ^ 57].
(aSymbol == #eqJump) ifTrue:[stackDelta := -2. extra := #offset. ^ 58].
(aSymbol == #notEqJump) ifTrue:[stackDelta := -2. extra := #offset. ^ 59].
(aSymbol == #lineno) ifTrue:[lineno := true. ^ 8].
(aSymbol == #send) ifTrue:[lineno := true. extra := #special. ^ 19].
(aSymbol == #superSend) ifTrue:[lineno := true. extra := #special. ^ 20].
(aSymbol == #hereSend) ifTrue:[lineno := true. extra := #special. ^ 20].
(aSymbol == #sendSelf) ifTrue:[lineno := true. extra := #special. ^ 13].
(aSymbol == #drop) ifTrue:[stackDelta := -1. ^ 18].
(aSymbol == #dup) ifTrue:[stackDelta := 1. ^ 47].
(aSymbol == #storeMethodVar) ifTrue:[extra := #index. stackDelta := -1. ^ 37].
(aSymbol == #storeBlockVar) ifTrue:[extra := #index. stackDelta := -1. ^ 38].
(aSymbol == #storeInstVar) ifTrue:[extra := #index. stackDelta := -1. ^ 39].
(aSymbol == #pushClassVarS) ifTrue:[stackDelta := 1. extra := #speciallitS. ^ 35].
(aSymbol == #pushGlobalS) ifTrue:[stackDelta := 1. extra := #speciallitS. ^ 35].
(aSymbol == #storeClassVarS) ifTrue:[extra := #speciallitS.stackDelta := -1. ^ 40].
(aSymbol == #storeGlobalS) ifTrue:[extra := #speciallitS. stackDelta := -1. ^ 40].
(aSymbol == #storeOuterBlockVar) ifTrue:[stackDelta := -1. extra := #indexLevel. ^ 129].
(aSymbol == #pushClassInstVar) ifTrue:[stackDelta := 1. extra := #index. ^ 176].
(aSymbol == #storeClassInstVar) ifTrue:[extra := #index.stackDelta := -1. ^ 177].
"optimized bytecodes"
(aSymbol == #retNil) ifTrue:[^ 1].
(aSymbol == #retTrue) ifTrue:[^ 2].
(aSymbol == #retFalse) ifTrue:[^ 3].
(aSymbol == #ret0) ifTrue:[^ 4].
(aSymbol == #retNum) ifTrue:[extra := #number. ^ 127].
(aSymbol == #homeRetTop) ifTrue:[^ 7].
(aSymbol == #pushNum16) ifTrue:[stackDelta := 1. extra := #number16. ^ 17].
(aSymbol == #push0) ifTrue:[stackDelta := 1. ^120].
(aSymbol == #push1) ifTrue:[stackDelta := 1. ^121].
(aSymbol == #push2) ifTrue:[stackDelta := 1. ^139].
(aSymbol == #pushMinus1) ifTrue:[stackDelta := 1. ^122].
(aSymbol == #send0) ifTrue:[lineno := true. extra := #index. ^21].
(aSymbol == #send1) ifTrue:[lineno := true. extra := #index. stackDelta := -1. ^22].
(aSymbol == #send2) ifTrue:[lineno := true. extra := #index. stackDelta := -2. ^23].
(aSymbol == #send3) ifTrue:[lineno := true. extra := #index. stackDelta := -3. ^24].
(aSymbol == #sendSelf0) ifTrue:[lineno := true. extra := #index. stackDelta := 1. ^180].
(aSymbol == #sendSelf1) ifTrue:[lineno := true. extra := #index. ^181].
(aSymbol == #sendSelf2) ifTrue:[lineno := true. extra := #index. stackDelta := -1. ^182].
(aSymbol == #sendSelf3) ifTrue:[lineno := true. extra := #index. stackDelta := -2. ^183].
(aSymbol == #sendSelfDrop0) ifTrue:[lineno := true. extra := #index. ^184].
(aSymbol == #sendSelfDrop1) ifTrue:[lineno := true. extra := #index. stackDelta := -1. ^185].
(aSymbol == #sendSelfDrop2) ifTrue:[lineno := true. extra := #index. stackDelta := -2. ^186].
(aSymbol == #sendSelfDrop3) ifTrue:[lineno := true. extra := #index. stackDelta := -3. ^187].
(aSymbol == #sendDrop) ifTrue:[lineno := true. extra := #special. ^25].
(aSymbol == #sendDrop0) ifTrue:[lineno := true. extra := #index. stackDelta := -1. ^26].
(aSymbol == #sendDrop1) ifTrue:[lineno := true. extra := #index. stackDelta := -2. ^27].
(aSymbol == #sendDrop2) ifTrue:[lineno := true. extra := #index. stackDelta := -3. ^28].
(aSymbol == #sendDrop3) ifTrue:[lineno := true. extra := #index. stackDelta := -4. ^29].
(aSymbol == #pushMethodVar1) ifTrue:[stackDelta := 1. ^80].
(aSymbol == #pushMethodVar2) ifTrue:[stackDelta := 1. ^81].
(aSymbol == #pushMethodVar3) ifTrue:[stackDelta := 1. ^82].
(aSymbol == #pushMethodVar4) ifTrue:[stackDelta := 1. ^83].
(aSymbol == #pushMethodVar5) ifTrue:[stackDelta := 1. ^84].
(aSymbol == #pushMethodVar6) ifTrue:[stackDelta := 1. ^85].
(aSymbol == #pushMethodArg1) ifTrue:[stackDelta := 1. ^86].
(aSymbol == #pushMethodArg2) ifTrue:[stackDelta := 1. ^87].
(aSymbol == #pushMethodArg3) ifTrue:[stackDelta := 1. ^88].
(aSymbol == #pushMethodArg4) ifTrue:[stackDelta := 1. ^89].
(aSymbol == #pushInstVar1) ifTrue:[stackDelta := 1. ^90].
(aSymbol == #pushInstVar2) ifTrue:[stackDelta := 1. ^91].
(aSymbol == #pushInstVar3) ifTrue:[stackDelta := 1. ^92].
(aSymbol == #pushInstVar4) ifTrue:[stackDelta := 1. ^93].
(aSymbol == #pushInstVar5) ifTrue:[stackDelta := 1. ^94].
(aSymbol == #pushInstVar6) ifTrue:[stackDelta := 1. ^95].
(aSymbol == #pushInstVar7) ifTrue:[stackDelta := 1. ^96].
(aSymbol == #pushInstVar8) ifTrue:[stackDelta := 1. ^97].
(aSymbol == #pushInstVar9) ifTrue:[stackDelta := 1. ^98].
(aSymbol == #pushInstVar10) ifTrue:[stackDelta := 1. ^99].
(aSymbol == #storeMethodVar1) ifTrue:[stackDelta := -1. ^100].
(aSymbol == #storeMethodVar2) ifTrue:[stackDelta := -1. ^101].
(aSymbol == #storeMethodVar3) ifTrue:[stackDelta := -1. ^102].
(aSymbol == #storeMethodVar4) ifTrue:[stackDelta := -1. ^103].
(aSymbol == #storeMethodVar5) ifTrue:[stackDelta := -1. ^104].
(aSymbol == #storeMethodVar6) ifTrue:[stackDelta := -1. ^105].
(aSymbol == #storeInstVar1) ifTrue:[stackDelta := -1. ^110].
(aSymbol == #storeInstVar2) ifTrue:[stackDelta := -1. ^111].
(aSymbol == #storeInstVar3) ifTrue:[stackDelta := -1. ^112].
(aSymbol == #storeInstVar4) ifTrue:[stackDelta := -1. ^113].
(aSymbol == #storeInstVar5) ifTrue:[stackDelta := -1. ^114].
(aSymbol == #storeInstVar6) ifTrue:[stackDelta := -1. ^115].
(aSymbol == #storeInstVar7) ifTrue:[stackDelta := -1. ^116].
(aSymbol == #storeInstVar8) ifTrue:[stackDelta := -1. ^117].
(aSymbol == #storeInstVar9) ifTrue:[stackDelta := -1. ^118].
(aSymbol == #storeInstVar10) ifTrue:[stackDelta := -1. ^119].
(aSymbol == #pushLit1) ifTrue:[stackDelta := 1. ^ 222].
(aSymbol == #pushLit2) ifTrue:[stackDelta := 1. ^ 223].
(aSymbol == #pushLit3) ifTrue:[stackDelta := 1. ^ 224].
(aSymbol == #pushLit4) ifTrue:[stackDelta := 1. ^ 225].
(aSymbol == #pushLit5) ifTrue:[stackDelta := 1. ^ 226].
(aSymbol == #pushLit6) ifTrue:[stackDelta := 1. ^ 227].
(aSymbol == #pushLit7) ifTrue:[stackDelta := 1. ^ 228].
(aSymbol == #pushLit8) ifTrue:[stackDelta := 1. ^ 229].
(aSymbol == #retMethodVar1) ifTrue:[^160].
(aSymbol == #retMethodVar2) ifTrue:[^161].
(aSymbol == #retMethodVar3) ifTrue:[^162].
(aSymbol == #retMethodVar4) ifTrue:[^163].
(aSymbol == #retMethodVar5) ifTrue:[^164].
(aSymbol == #retMethodVar6) ifTrue:[^165].
(aSymbol == #retInstVar1) ifTrue:[^166].
(aSymbol == #retInstVar2) ifTrue:[^167].
(aSymbol == #retInstVar3) ifTrue:[^168].
(aSymbol == #retInstVar4) ifTrue:[^169].
(aSymbol == #retInstVar5) ifTrue:[^170].
(aSymbol == #retInstVar6) ifTrue:[^171].
(aSymbol == #retInstVar7) ifTrue:[^172].
(aSymbol == #retInstVar8) ifTrue:[^173].
(aSymbol == #retMethodArg1) ifTrue:[^174].
(aSymbol == #retMethodArg2) ifTrue:[^175].
(aSymbol == #pushBlockArg1) ifTrue:[stackDelta := 1. ^140].
(aSymbol == #pushBlockArg2) ifTrue:[stackDelta := 1. ^141].
(aSymbol == #pushBlockArg3) ifTrue:[stackDelta := 1. ^142].
(aSymbol == #pushBlockArg4) ifTrue:[stackDelta := 1. ^143].
(aSymbol == #pushOuter1BlockArg) ifTrue:[stackDelta := 1. extra := #index. ^ 43].
(aSymbol == #pushOuter2BlockArg) ifTrue:[stackDelta := 1. extra := #index. ^ 44].
(aSymbol == #=) ifTrue:[lineno := true. stackDelta := -1. self addLiteral:aSymbol. ^130].
(aSymbol == #+) ifTrue:[lineno := true. stackDelta := -1. self addLiteral:aSymbol. ^131].
(aSymbol == #~=) ifTrue:[lineno := true. stackDelta := -1. self addLiteral:aSymbol. ^132].
(aSymbol == #-) ifTrue:[lineno := true. stackDelta := -1. self addLiteral:aSymbol. ^133].
(aSymbol == #*) ifTrue:[lineno := true. stackDelta := -1. self addLiteral:aSymbol. ^230].
(aSymbol == #class) ifTrue:[self addLiteral:aSymbol. ^134].
(aSymbol == #x) ifTrue:[lineno := true. self addLiteral:aSymbol. ^106].
(aSymbol == #y) ifTrue:[lineno := true. self addLiteral:aSymbol. ^107].
(aSymbol == #width) ifTrue:[lineno := true. self addLiteral:aSymbol. ^108].
(aSymbol == #height) ifTrue:[lineno := true. self addLiteral:aSymbol. ^109].
(aSymbol == #origin) ifTrue:[lineno := true. self addLiteral:aSymbol. ^154].
(aSymbol == #extent) ifTrue:[lineno := true. self addLiteral:aSymbol. ^155].
(aSymbol == #at:) ifTrue:[lineno := true. stackDelta := -1. self addLiteral:aSymbol. ^135].
(aSymbol == #at:put:)ifTrue:[lineno := true. stackDelta := -2. self addLiteral:aSymbol. ^136].
(aSymbol == #bitAnd:) ifTrue:[lineno := true. stackDelta := -1. self addLiteral:aSymbol. ^137].
(aSymbol == #bitOr:) ifTrue:[lineno := true. stackDelta := -1. self addLiteral:aSymbol. ^138].
(aSymbol == #plus1) ifTrue:[lineno := true. self addLiteral:#+. ^123].
(aSymbol == #minus1) ifTrue:[lineno := true. self addLiteral:#-. ^124].
(aSymbol == #incMethodVar) ifTrue:[lineno := true. self addLiteral:#+. extra := #index. ^125].
(aSymbol == #decMethodVar) ifTrue:[lineno := true. self addLiteral:#-. extra := #index. ^126].
(aSymbol == #eq0) ifTrue:[self addLiteral:#==. ^48].
(aSymbol == #ne0) ifTrue:[self addLiteral:#~~. ^49].
(aSymbol == #>) ifTrue:[lineno := true. self addLiteral:aSymbol. stackDelta := -1. ^ 145].
(aSymbol == #>=) ifTrue:[lineno := true. self addLiteral:aSymbol. stackDelta := -1. ^ 146].
(aSymbol == #<) ifTrue:[lineno := true. self addLiteral:aSymbol. stackDelta := -1. ^ 147].
(aSymbol == #<=) ifTrue:[lineno := true. self addLiteral:aSymbol. stackDelta := -1. ^ 148].
(aSymbol == #next) ifTrue:[lineno := true. self addLiteral:aSymbol. ^ 149].
(aSymbol == #peek) ifTrue:[lineno := true. self addLiteral:aSymbol. ^ 150].
(aSymbol == #value) ifTrue:[lineno := true. self addLiteral:aSymbol. ^ 151].
(aSymbol == #value:) ifTrue:[lineno := true. self addLiteral:aSymbol. stackDelta := -1. ^ 152].
(aSymbol == #value:value:) ifTrue:[lineno := true. self addLiteral:aSymbol. stackDelta := -2. ^ 178].
(aSymbol == #size) ifTrue:[lineno := true. self addLiteral:aSymbol. ^ 153].
(aSymbol == #asInteger) ifTrue:[lineno := true. self addLiteral:aSymbol. ^ 158].
(aSymbol == #rounded) ifTrue:[lineno := true. self addLiteral:aSymbol. ^ 159].
(aSymbol == #mk0Block) ifTrue:[^ 156].
(aSymbol == #mkNilBlock) ifTrue:[^ 157].
(aSymbol == #gt0) ifTrue:[lineno := true. self addLiteral:#>. ^ 212].
(aSymbol == #pushgt0) ifTrue:[lineno := true. stackDelta := 1. self addLiteral:#>. ^ 208].
(aSymbol == #basicNew) ifTrue:[lineno := true. self addLiteral:aSymbol. ^ 211].
(aSymbol == #new) ifTrue:[lineno := true. self addLiteral:aSymbol. ^ 213].
(aSymbol == #basicNew:) ifTrue:[lineno := true. self addLiteral:aSymbol. ^ 214].
(aSymbol == #new:) ifTrue:[lineno := true. self addLiteral:aSymbol. ^ 215].
(aSymbol == #falseJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 190].
(aSymbol == #trueJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 191].
(aSymbol == #nilJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 192].
(aSymbol == #notNilJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 193].
(aSymbol == #jumpabs) ifTrue:[extra := #absoffset. ^ 194].
(aSymbol == #makeBlockabs) ifTrue:[stackDelta := 1. extra := #absoffsetNvarNarg. ^ 195].
(aSymbol == #zeroJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 196].
(aSymbol == #notZeroJumpabs) ifTrue:[stackDelta := -1. extra := #absoffset. ^ 197].
(aSymbol == #eqJumpabs) ifTrue:[stackDelta := -2. extra := #absoffset. ^ 198].
(aSymbol == #notEqJumpabs) ifTrue:[stackDelta := -2. extra := #absoffset. ^ 199].
(aSymbol == #pushThisContext) ifTrue:[stackDelta := 1. ^ 144].
(aSymbol == #isNil) ifTrue:[^ 188].
(aSymbol == #notNil) ifTrue:[^ 189].
(aSymbol == #not) ifTrue:[lineno := true. ^ 179].
(aSymbol == #&) ifTrue:[lineno := true. ^ 216].
(aSymbol == #|) ifTrue:[lineno := true. ^ 217].
(aSymbol == #pushClassVarL) ifTrue:[stackDelta := 1. extra := #speciallitL. ^ 218].
(aSymbol == #pushGlobalL) ifTrue:[stackDelta := 1. extra := #speciallitL. ^ 218].
(aSymbol == #storeClassVarL) ifTrue:[extra := #speciallitL.stackDelta := -1. ^ 219].
(aSymbol == #storeGlobalL) ifTrue:[extra := #speciallitL. stackDelta := -1. ^ 219].
(aSymbol == #pushLitL) ifTrue:[stackDelta := 1. extra := #unsigned16. ^ 201].
(aSymbol == #sendL) ifTrue:[lineno := true. extra := #specialL. ^ 205].
(aSymbol == #sendSelfL) ifTrue:[lineno := true. extra := #specialL. ^ 207].
(aSymbol == #sendDropL) ifTrue:[lineno := true. extra := #specialL. ^ 204].
(aSymbol == #superSendL) ifTrue:[lineno := true. extra := #specialL. ^ 206].
(aSymbol == #hereSendL) ifTrue:[lineno := true. extra := #specialL. ^ 206].
self error:'invalid code symbol'.
errorFlag := #Error
"Modified: 3.9.1995 / 12:58:47 / claus"
!
checkForPrimitiveCode:nr
"return the code for an ST-80 primitive method.
Since many primitives available on ST-80 should also be available
somewhere in ST/X, this may work for many primitive numbers.
However, more information is needed and more things to be added below.
This was added to allow emulation of (some) ST-80
primitives (to fileIn RemoteInvocation & Monitor41 packages)"
|cls sel|
(nr == 75) ifTrue:[ cls := Object. sel := #identityHash ].
(nr == 110) ifTrue:[ cls := Object. sel := #== ].
(nr == 111) ifTrue:[ cls := Object. sel := #class ].
"
should add more here, to be able to fileIn ST-80 methods
containing primitive calls (who gives me the numbers ... ?)
"
cls notNil ifTrue:[
^ (cls compiledMethodAt:sel) code
].
^ nil
!
genByteCodeFrom:symbolicCodeArray
"convert symbolicCode into bytecodes"
|symIndex "{Class: SmallInteger }"
codeSize "{Class: SmallInteger }"
symCodeSize "{Class: SmallInteger }"
index addr
codeSymbol nargs needRetry
stackDepth relocInfo level nvars round t|
symbolicCodeArray isNil ifTrue:[^ self].
round := 0.
needRetry := true.
symCodeSize := symbolicCodeArray size.
codeSize := symCodeSize.
[needRetry] whileTrue:[
stackDepth := 0.
maxStackDepth := 0.
codeBytes := ByteArray uninitializedNew:codeSize.
relocInfo := Array basicNew:(codeSize + 1).
symIndex := 1.
codeIndex := 1.
needRetry := false.
round := round + 1.
[symIndex <= symCodeSize] whileTrue:[
relocInfo at:symIndex put:codeIndex.
codeSymbol := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
stackDelta := 0.
extra := nil.
lineno := false.
self appendByteCodeFor:codeSymbol.
lineno ifTrue:[
self appendByte:((symbolicCodeArray at:symIndex) min:255).
symIndex := symIndex + 1
].
extra notNil ifTrue:[
(extra == #number) ifTrue:[
index := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendSignedByte:index
].
(extra == #number16) ifTrue:[
index := symbolicCodeArray at:symIndex.
symIndex := symIndex + 2.
self appendSignedWord:index
].
(extra == #unsigned16) ifTrue:[
index := symbolicCodeArray at:symIndex.
symIndex := symIndex + 2.
self appendWord:index
].
(extra == #index) ifTrue:[
index := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:index
].
(extra == #lit) ifTrue:[
index := self addLiteral:(symbolicCodeArray at:symIndex).
symIndex := symIndex + 1.
self appendByte:index
].
(extra == #speciallit) ifTrue:[
index := self addLiteral:(symbolicCodeArray at:symIndex).
index > 255 ifTrue:[
self parseError:'too many globals (' ,
(symbolicCodeArray at:symIndex) ,
' index=' , index printString ,
') in method - please simplify'.
^ #Error
].
symIndex := symIndex + 1.
self appendByte:index.
self appendByte:0. "space for inline-generation"
self appendByte:0. "space for inline-address"
self appendByte:0.
self appendByte:0.
self appendByte:0.
symIndex := symIndex + 5
].
(extra == #speciallitS) ifTrue:[
index := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:index.
self appendByte:0. "space for inline-generation"
self appendByte:0. "space for inline-address"
self appendByte:0.
self appendByte:0.
self appendByte:0.
symIndex := symIndex + 5
].
(extra == #speciallitL) ifTrue:[
index := symbolicCodeArray at:symIndex.
symIndex := symIndex + 2.
self appendWord:index.
self appendByte:0. "space for inline-generation"
self appendByte:0. "space for inline-address"
self appendByte:0.
self appendByte:0.
self appendByte:0.
symIndex := symIndex + 5
].
(extra == #offset) ifTrue:[
relocInfo at:symIndex put:codeIndex.
self addReloc:symIndex.
symIndex := symIndex + 1.
self appendByte:0
].
(extra == #indexLevel) ifTrue:[
index := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:index.
level := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:level
].
(extra == #offsetNvarNarg) ifTrue:[
relocInfo at:symIndex put:codeIndex.
self addReloc:symIndex.
symIndex := symIndex + 1.
self appendByte:0.
nvars := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:nvars.
level := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:level
].
(extra == #absoffset) ifTrue:[
relocInfo at:symIndex put:codeIndex.
self addReloc:symIndex.
addr := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:(addr bitAnd:16rFF).
self appendByte:((addr bitShift:-8) bitAnd:16rFF).
].
(extra == #absoffsetNvarNarg) ifTrue:[
relocInfo at:symIndex put:codeIndex.
self addReloc:symIndex.
addr := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:(addr bitAnd:16rFF).
self appendByte:((addr bitShift:-8) bitAnd:16rFF).
nvars := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:nvars.
level := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:level
].
extra == #special ifTrue:[
((codeSymbol == #send)
or:[codeSymbol == #sendSelf
or:[codeSymbol == #superSend
or:[codeSymbol == #hereSend]]]) ifTrue:[
index := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
nargs := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:nargs.
self appendByte:index.
(codeSymbol == #superSend
or:[codeSymbol == #hereSend]) ifTrue:[
index := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:index
].
stackDelta := nargs negated.
codeSymbol == #sendSelf ifTrue:[
stackDelta := stackDelta + 1
]
] ifFalse:[
(codeSymbol == #sendDrop) ifTrue:[
index := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
nargs := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:nargs.
self appendByte:index.
stackDelta := (nargs + 1) negated
]
]
].
extra == #specialL ifTrue:[
((codeSymbol == #sendL)
or:[codeSymbol == #sendSelfL
or:[codeSymbol == #superSendL
or:[codeSymbol == #hereSendL]]]) ifTrue:[
index := symbolicCodeArray at:symIndex.
symIndex := symIndex + 2.
nargs := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:nargs.
self appendWord:index.
(codeSymbol == #superSendL
or:[codeSymbol == #hereSendL]) ifTrue:[
index := symbolicCodeArray at:symIndex.
symIndex := symIndex + 2.
self appendWord:index.
].
stackDelta := nargs negated.
codeSymbol == #sendSelfL ifTrue:[
stackDelta := stackDelta + 1
]
]
].
].
stackDepth := stackDepth + stackDelta.
(stackDepth > maxStackDepth) ifTrue:[
maxStackDepth := stackDepth
]
].
relocInfo at:symIndex put:codeIndex.
needRetry ifFalse:[
"
now relocate - returns true if ok, false if we have to do it again
(when short jumps have been changed to long jumps)
"
relocList notNil ifTrue:[
needRetry := (self relocateWith:symbolicCodeArray relocInfo:relocInfo) not.
"
if returned with false, a relative jump was made into
an absolute jump - need to start over with one more byte space
"
needRetry ifTrue:[
relocList := nil.
codeSize := codeSize + 1.
]
]
] ifTrue:[
'compiling again ...' infoPrintNL.
]
].
"code printNL."
^ errorFlag
"Modified: 3.9.1995 / 12:59:43 / claus"
!
genSymbolicCode
"traverse the parse-tree producing symbolicCode - return the codeArray"
|codeStream code thisStatement lastStatement|
litArray := nil.
codeStream := WriteStream on:(OrderedCollection new:100).
thisStatement := tree.
[thisStatement notNil] whileTrue:[
lastStatement := thisStatement.
thisStatement codeForSideEffectOn:codeStream inBlock:nil for:self.
thisStatement := thisStatement nextStatement
].
(lastStatement isNil or:[lastStatement isReturnNode not])
ifTrue:[
"not a return - add retSelf"
"
if the last statement was a send for side-effect,
replace the previous drop by a retSelf
"
lastStatement notNil ifTrue:[
((code := codeStream contents) notNil
and:[code size > 0
and:[code last == #drop]]) ifTrue:[
codeStream position:(codeStream position - 1).
codeStream nextPut:#retSelf
]
].
codeStream nextPut:#retSelf
].
^ codeStream contents
!
moveGlobalsToFront
"move all global-literals to the front of the literal array.
This may be the last chance to compile the method, since
for globals, the maximum literal index is 255 - while for normal
literals its a stress-less 65535"
litArray isNil ifTrue:[
^ self error:'oops compiler botch'.
].
litArray sort:[:a :b | "a < b -> #(a b)"
(a isMemberOf:Symbol) ifFalse:[false]
ifTrue:[
(b isMemberOf:Symbol) ifFalse:[true]
ifTrue:[
(a at:1) isUppercase ifFalse:[false]
ifTrue:[
(b at:1) isUppercase ifFalse:[true]
ifTrue:[a < b].
]
]
]
].
"
#(#A #c #B #D #E #a #b #F)
sort:[:a :b |
(a isMemberOf:Symbol) ifFalse:[false]
ifTrue:[
(b isMemberOf:Symbol) ifFalse:[true]
ifTrue:[
(a at:1) isUppercase ifFalse:[false]
ifTrue:[
(b at:1) isUppercase ifFalse:[true]
ifTrue:[(a < b)].
]
]
]
].
"
!
relocateWith:symbolicCodeArray relocInfo:relocInfo
"helper for genByteCodeFrom - relocate code using relocInfo.
if relocation fails badly (due to long relative jumps) patch
symbolicCode to use absolute jumps instead and return false
(genByteCodeFrom will then try again). Otherwise return true.
Also, on the fly, jumps to jumps and jumps to return are handled."
|delta "{Class: SmallInteger }"
codePos "{Class: SmallInteger }"
opCodePos "{Class: SmallInteger }"
codeOffset "{Class: SmallInteger }"
symOffset
opcode "{Class: SmallInteger }"
dstOpcode jumpTarget
jumpCode deleteSet|
deleteSet := OrderedCollection new.
relocList do:[:sIndex |
"have to relocate symCode at sIndex ..."
symOffset := symbolicCodeArray at:sIndex. "the target in the symbolic code"
codePos := relocInfo at:sIndex. "position of the offet in byte code"
codeOffset := relocInfo at:symOffset. "position of the target in byte code"
delta := codeOffset - codePos - 1.
opCodePos := codePos - 1.
opcode := codeBytes at:opCodePos.
(opcode between:190 and:199) ifTrue:[
"an absolute jump/makeBlock"
codeBytes at:codePos put:(codeOffset bitAnd:16rFF).
codeBytes at:(codePos + 1) put:(codeOffset bitShift:-8)
] ifFalse:[
"get jump-code from long and vlong codes"
(opcode between:50 and:59) ifFalse:[
(opcode between:60 and:69) ifTrue:[
opcode := opcode - 10
] ifFalse:[
(opcode between:70 and:79) ifTrue:[
opcode := opcode - 20
] ifFalse:[
self error:'invalid code to relocate'
]
].
].
"optimize jump to return and jump to jump"
(opcode == 54) ifTrue:[
"a jump"
dstOpcode := symbolicCodeArray at:symOffset.
(#(retSelf retTop retNil retTrue retFalse ret0 "blockRetTop") includes:dstOpcode) ifTrue:[
"a jump to a return - put in the return instead jump"
symbolicCodeArray at:(sIndex - 1) put:dstOpcode.
symbolicCodeArray at:sIndex put:dstOpcode.
codeBytes at:opCodePos put:(self byteCodeFor:dstOpcode).
delta := 0.
deleteSet add:sIndex.
"
'jump to return at: ' print. (sIndex - 1) printNL.
"
] ifFalse:[
(dstOpcode == #jump) ifTrue:[
"jump to jump to be done soon"
jumpTarget := symbolicCodeArray at:(symOffset + 1).
"
'jump to jump at: ' print. (sIndex - 1) print.
' newTarget:' print. jumpTarget printNL.
"
symbolicCodeArray at:sIndex put:jumpTarget.
symOffset := jumpTarget.
codeOffset := relocInfo at:symOffset.
delta := codeOffset - codePos - 1.
"continue with new delta"
]
]
].
(#(50 51 52 53 56 57 58 59) includes:opcode) ifTrue:[
"a conditional jump"
dstOpcode := symbolicCodeArray at:symOffset.
(dstOpcode == #jump) ifTrue:[
"conditional jump to unconditional jump"
jumpTarget := symbolicCodeArray at:(symOffset + 1).
"
'cond jump to jump at: ' print. (sIndex - 1) print.
' newTarget:' print. jumpTarget printNL.
"
symbolicCodeArray at:sIndex put:jumpTarget.
symOffset := jumpTarget.
codeOffset := relocInfo at:symOffset.
delta := codeOffset - codePos - 1.
"continue with new delta"
].
].
(delta >= 0) ifTrue:[
(delta > 127) ifTrue:[
(opcode between:50 and:59) ifFalse:[
self error:'invalid code to relocate'
] ifTrue:[
(delta > 255) ifTrue:[
"change jmp into vljmp ..."
codeBytes at:opCodePos put:(opcode + 20).
delta := delta - 256
] ifFalse:[
"change jmp into ljmp ..."
codeBytes at:opCodePos put:(opcode + 10).
delta := delta - 128
].
(delta > 127) ifTrue:[
"change symbolic into a jump absolute and fail"
jumpCode := symbolicCodeArray at:(sIndex - 1).
symbolicCodeArray at:(sIndex - 1) put:(self absJumpFromJump:jumpCode).
symbolicCodeArray at:sIndex put:symOffset.
"
'change short into abs jump' printNL.
"
deleteSet do:[:d | relocList remove:d].
^ false
]
].
].
codeBytes at:codePos put:delta
] ifFalse:[
(delta < -128) ifTrue:[
(opcode between:50 and:59) ifFalse:[
self error:'invalid code to relocate'
] ifTrue:[
(delta < -256) ifTrue:[
"change jmp into vljmp ..."
codeBytes at:opCodePos put:(opcode + 20).
delta := delta + 256
] ifFalse:[
"change jmp into ljmp ..."
codeBytes at:opCodePos put:(opcode + 10).
delta := delta + 128
].
(delta < -128) ifTrue:[
"change symbolic into a jump absolute and fail"
jumpCode := symbolicCodeArray at:(sIndex - 1).
symbolicCodeArray at:(sIndex - 1) put:(self absJumpFromJump:jumpCode).
symbolicCodeArray at:sIndex put:symOffset.
"
'change short into abs jump' printNL.
"
deleteSet do:[:d | relocList remove:d].
^ false
]
]
].
codeBytes at:codePos put:(256 + delta)
]
]
].
(errorFlag == #Error) ifTrue:[
self error:'relocation range error'
].
^ true
! !
!ByteCodeCompiler methodsFor:'machine code generation'!
compileToMachineCode:aString forClass:aClass inCategory:cat
notifying:requestor install:install skipIfSame:skipIfSame silent:silent
"this is called to compile primitive code.
This is EXPERIMENTAL and going to be changed to raise an error,
an redefined in subclasses which can do it (either by direct compilation, or by calling
the external stc do do it.
For a description of the arguments, see compile:forClass....."
|stFileName stream handle address flags command oFileName soFileName
initName newMethod ok status className sep class stcPath
errorStream errorMessages eMsg m|
ObjectFileLoader isNil ifTrue:[^ #Error].
STCCompilation == #never ifTrue:[^ #Error].
(stcPath := self class incrementalStcPath) isNil ifTrue:[
self parseError:'no stc compiler available - cannot create machine code' position:1.
^ #Error
].
SequenceNumber isNil ifTrue:[
SequenceNumber := 0.
].
SequenceNumber := SequenceNumber + 1.
initName := 'ttt' , SequenceNumber printString.
stFileName := initName , '.st'.
stream := stFileName asFilename writeStream.
sep := stream class chunkSeparator.
class := aClass.
class isMeta ifTrue:[
class := aClass soleInstance
].
class allSuperclasses reverseDo:[:cls|
cls ~~ Object ifTrue:[
cls isLoaded ifFalse:[
^ #Error
].
cls fileOutDefinitionOn:stream.
stream nextPut:sep; cr.
]
].
class fileOutDefinitionOn:stream.
stream nextPut:sep; cr.
class fileOutPrimitiveDefinitionsOn:stream.
stream nextPut:sep.
className := aClass name.
aClass isMeta ifTrue:[
stream nextPutAll:(className copyTo:(className size - 5)); nextPutAll:' class'.
] ifFalse:[
stream nextPutAll:className.
].
stream nextPutAll:' methodsFor:'''; nextPutAll:cat; nextPutAll:''''.
stream nextPut:sep.
stream cr.
stream nextPutAll:'"{ Line: 0 }"'; cr; nextPutAll:aString.
stream nextPut:sep; space; nextPut:sep.
stream close.
"
call stc to compile it
"
oFileName := './' , initName , '.o'.
oFileName asFilename delete.
flags := '-commonSymbols +sharedLibCode +newIncremental -E:errorOutput -N' , initName .
STCCompilationDefines notNil ifTrue:[
flags := STCCompilationDefines , ' ' , flags
].
STCCompilationIncludes notNil ifTrue:[
flags := STCCompilationIncludes , ' ' , flags
].
STCCompilationOptions notNil ifTrue:[
flags := STCCompilationOptions , ' ' , flags
].
command := stcPath , ' ' , flags , ' -c ' , stFileName.
"/ command printNL.
ok := OperatingSystem executeCommand:command.
status := OperatingSystem lastExecStatus.
"for debugging - leave c intermediate"
STCKeepCIntermediate == true ifTrue:[
command := stcPath , ' ' , flags , ' -C ' , stFileName.
command printNL.
OperatingSystem executeCommand:command
].
oFileName asFilename exists ifTrue:[
ok ifFalse:[
'oops - system says it failed - but o-file is there ...' printNL.
ok := true
]
] ifFalse:[
ok := false
].
ok ifFalse:[
status >= 16r200 ifTrue:[
errorStream := 'errorOutput' asFilename readStream.
errorStream notNil ifTrue:[
errorMessages := errorStream contents.
errorMessages notNil ifTrue:[
errorMessages := errorMessages asStringCollection.
errorMessages size > 20 ifTrue:[
errorMessages := (errorMessages copyTo:20) copyWith:'... more messages skipped'
].
errorMessages := errorMessages asString
].
].
errorMessages isNil ifTrue:[
errorMessages := ''
].
eMsg := ('STC error during compilation:\',errorMessages) withCRs.
] ifFalse:[
eMsg := 'oops, no STC - cannot create machine code'
].
self parseError:eMsg position:1.
OperatingSystem removeFile:stFileName.
^ #Error
].
(ObjectFileLoader notNil
and:[ObjectFileLoader canLoadObjectFiles]) ifFalse:[
self parseError:'no dynamic load configured - cannot load machine code' position:1.
OperatingSystem removeFile:stFileName.
^ #Error
].
OperatingSystem getOSType = 'irix' ifTrue:[
"
link it to a shared object
"
soFileName := './' , initName , '.so'.
OperatingSystem executeCommand:'rm -f ' , soFileName.
OperatingSystem executeCommand:'ld -shared -all -o ' , soFileName , ' ' , oFileName.
OperatingSystem removeFile:oFileName.
oFileName := soFileName.
] ifFalse:[
OperatingSystem getOSType = 'sys5_4' ifTrue:[
"
link it to a shared object
"
soFileName := './' , initName , '.so'.
OperatingSystem executeCommand:'rm -f ' , soFileName.
OperatingSystem executeCommand:'ld -G -o ' , soFileName , ' ' , oFileName.
OperatingSystem removeFile:oFileName.
oFileName := soFileName.
].
].
"
load the objectfile
"
handle := ObjectFileLoader loadDynamicObject:oFileName.
handle isNil ifTrue:[
OperatingSystem removeFile:stFileName.
OperatingSystem removeFile:oFileName.
self parseError:'dynamic load failed - cannot create machine code' position:1.
^ #Error
].
"/ ('handle is ' , handle printString) printNL.
address := ObjectFileLoader getFunction:'__' , initName , '_Init' from:handle.
address isNil ifTrue:[
address := ObjectFileLoader getFunction:'_' , initName , '_Init' from:handle.
address isNil ifTrue:[
(ObjectFileLoader getListOfUndefinedSymbolsFrom:handle) size > 0 ifTrue:[
ObjectFileLoader listUndefinedSymbolsIn:handle.
eMsg := 'undefined symbols in primitive code'.
] ifFalse:[
eMsg := initName , '_Init() lookup failed'
].
ObjectFileLoader unloadDynamicObject:handle.
OperatingSystem removeFile:stFileName.
OperatingSystem removeFile:oFileName.
self parseError:(eMsg , ' - cannot create machine code') position:1.
^ #Error
]
].
"/ ('init at ' , address printString) printNL.
m := ObjectFileLoader
callInitFunctionAt:address
specialInit:true
forceOld:true
interruptable:false
argument:2
identifyAs:handle
returnsObject:true.
"
did it work ?
"
newMethod := aClass compiledMethodAt:selector.
newMethod notNil ifTrue:[
m ~~ newMethod ifTrue:[
'BCOMPILER: oops - loaded method installed itself elsewhere' errorPrintNL.
].
newMethod source:aString.
Project notNil ifTrue:[
newMethod package:(Project currentPackageName)
].
"/ aClass updateRevisionString.
aClass addChangeRecordForMethod:newMethod.
(silent or:[Smalltalk silentLoading == true]) ifFalse:[
Transcript showCr:(' compiled: ', className,' ',selector,' - machine code')
].
ObjectMemory flushCaches.
OperatingSystem removeFile:stFileName.
handle method:newMethod.
"/ check for obsolete loaded objects and unload them
ObjectFileLoader loadedObjectHandlesDo:[:anotherHandle |
anotherHandle isMethodHandle ifTrue:[
anotherHandle method isNil ifTrue:[
ObjectFileLoader unloadObjectFile:anotherHandle pathName.
OperatingSystem removeFile:anotherHandle pathName.
]
]
].
^ newMethod.
].
OperatingSystem removeFile:stFileName.
OperatingSystem removeFile:oFileName.
self parseError:'dynamic load failed' position:1.
^ #Error
"
|m|
Object subclass:#Test
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
category:'tests'.
m := ByteCodeCompiler
compile:'foo ^ ''hello'''
forClass:Test
inCategory:'tests'
notifying:nil
install:false
skipIfSame:false.
m inspect
"
"
|m|
Object subclass:#Test
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
category:'tests'.
m := ByteCodeCompiler
compileToMachineCode:'foo %{ RETURN (_MKSMALLINT(1)); %}'
forClass:Test
inCategory:'tests'
notifying:nil
install:false
skipIfSame:false
silent:false.
m inspect
"
"Modified: 14.9.1995 / 22:33:04 / claus"
"Modified: 6.12.1995 / 13:16:17 / cg"
!
trappingStubMethodFor:aString inCategory:cat
"return a stub method which traps and reports an error whenever
called."
|newMethod lits|
newMethod := Method new.
lits := self literalArray.
lits notNil ifTrue:[
"literals MUST be an array - not just any Collection"
lits := Array withAll:lits.
newMethod literals:lits
].
newMethod makeUncompiled.
newMethod numberOfMethodVars:(self numberOfMethodVars).
newMethod numberOfMethodArgs:(self numberOfMethodArgs).
newMethod source:aString.
newMethod category:cat.
Project notNil ifTrue:[
newMethod package:(Project currentPackageName)
].
^ newMethod
! !
!ByteCodeCompiler class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libcomp/Attic/BCompiler.st,v 1.55 1995-12-07 23:41:38 cg Exp $'
! !