--- a/BCompiler.st Sun Oct 29 18:50:14 1995 +0100
+++ b/BCompiler.st Sun Oct 29 20:27:36 1995 +0100
@@ -10,47 +10,24 @@
hereby transferred.
"
+'From Smalltalk/X, Version:2.10.8 on 29-oct-1995 at 20:01:16' !
+
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'
+ instanceVariableNames:'codeBytes codeIndex litArray stackDelta extra lineno
+ maxStackDepth relocList'
+ classVariableNames:'JumpToAbsJump SequenceNumber STCCompilationDefines
+ STCCompilationIncludes STCCompilationOptions STCCompilation
+ KeepSource STCKeepCIntermediate'
+ poolDictionaries:''
+ category:'System-Compiler'
!
-ByteCodeCompiler comment:'
-COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
-
-$Header: /cvs/stx/stx/libcomp/Attic/BCompiler.st,v 1.43 1995-10-24 15:54:48 cg Exp $
-'!
-
!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.
-"
-!
-
version
"
-$Header: /cvs/stx/stx/libcomp/Attic/BCompiler.st,v 1.43 1995-10-24 15:54:48 cg Exp $
-"
-!
+$Header: /cvs/stx/stx/libcomp/Attic/BCompiler.st,v 1.44 1995-10-29 19:27:36 cg Exp $
+"!
documentation
"
@@ -81,36 +58,42 @@
JumpToAbsJump <Dictionary> internal table to map opcodes
"
-! !
+!
-!ByteCodeCompiler methodsFor:'ST-80 compatibility'!
-
-compile:textOrStream in:aClass notifying:requestor ifFail:exceptionBlock
- "name alias for ST-80 compatibility"
+copyright
+"
+ COPYRIGHT (c) 1989 by Claus Gittinger
+ All Rights Reserved
- ^ 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
+ 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.
+"
! !
!ByteCodeCompiler class methodsFor:'compiling methods'!
+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:textOrStream in:aClass notifying:requestor ifFail:exceptionBlock
"name alias for ST-80 compatibility"
@@ -156,19 +139,6 @@
silent:false
!
-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:aString forClass:aClass inCategory:cat notifying:requestor
"compile a source-string for a method in classToCompileFor.
errors are forwarded to requestor.
@@ -183,39 +153,6 @@
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
@@ -268,6 +205,7 @@
(cat notNil and:[cat ~~ oldMethod category]) ifTrue:[
oldMethod category:cat.
oldMethod changed:#category.
+ aClass updateVersionString.
aClass addChangeRecordForMethodCategory:oldMethod category:cat.
].
^ oldMethod
@@ -429,6 +367,36 @@
].
^ 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: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
! !
!ByteCodeCompiler class methodsFor:'constants'!
@@ -467,12 +435,6 @@
"
!
-stcCompilationIncludes
- "return the includes used with stc compilation"
-
- ^ STCCompilationIncludes
-!
-
stcCompilationDefines:aString
"define the flags (for example, additional -D defines)
to be used when compiling to machine code.
@@ -485,12 +447,6 @@
"
!
-stcCompilationDefines
- "return the defines used with stc compilation"
-
- ^ STCCompilationDefines
-!
-
stcCompilationOptions:aString
"define the compilation options
to be used when compiling to machine code.
@@ -503,6 +459,42 @@
"
!
+stcCompilationIncludes
+ "return the includes used with stc compilation"
+
+ ^ STCCompilationIncludes
+!
+
+stcCompilationDefines
+ "return the defines used with stc compilation"
+
+ ^ STCCompilationDefines
+!
+
+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
+ "
+!
+
stcCompilationOptions
"return the options used with stc compilation"
@@ -527,30 +519,6 @@
"
!
-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
- "
-!
-
stcPathOf:command
"return the path to an stc command, or nil if not found."
@@ -637,13 +605,33 @@
"
! !
-!ByteCodeCompiler methodsFor:'accessing'!
+!ByteCodeCompiler methodsFor:'ST-80 compatibility'!
+
+compile:textOrStream in:aClass notifying:requestor ifFail:exceptionBlock
+ "name alias for ST-80 compatibility"
-literalArray
- "return the literal array - only valid after parsing"
+ ^ 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
+! !
- ^ litArray
-!
+!ByteCodeCompiler methodsFor:'accessing'!
code
"return the bytecode array - only valid after code-generation"
@@ -655,6 +643,12 @@
"return the stack-need of the method - only valid after code-generation"
^ maxStackDepth
+!
+
+literalArray
+ "return the literal array - only valid after parsing"
+
+ ^ litArray
! !
!ByteCodeCompiler methodsFor:'code generation'!
@@ -693,30 +687,6 @@
^ codeStream contents
!
-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"
@@ -967,6 +937,34 @@
"Modified: 3.9.1995 / 12:59:43 / claus"
!
+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
+!
+
absJumpFromJump:code
"given a jump-symbolic code, return corresponding absolute jump"
@@ -986,6 +984,31 @@
^ JumpToAbsJump at:code
!
+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
+!
+
relocateWith:symbolicCodeArray relocInfo:relocInfo
"helper for genByteCodeFrom - relocate code using relocInfo.
if relocation fails badly (due to long relative jumps) patch
@@ -1153,67 +1176,28 @@
^ true
!
-addLiteral:anObject
- "add a literal to the literalArray - watch for and eliminate
- duplicates. return the index of the literal in the Array"
-
- |index class|
+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.
- 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
-!
+ This was added to allow emulation of (some) ST-80
+ primitives (to fileIn RemoteInvocation & Monitor41 packages)"
-appendByteCodeFor:codeSymbol
- "append the byteCode for an instructionSymbol to the code-Array"
+ |cls sel|
- |idx "{Class: SmallInteger }"|
-
- idx := codeIndex.
- codeBytes at:idx put:(self byteCodeFor:codeSymbol).
- codeIndex := idx + 1
-!
-
-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
- ]
-!
-
-appendEmptyByte
- "append an empty byte to the code-Array"
-
- |idx "{Class: SmallInteger }"|
-
- idx := codeIndex.
- codeBytes at:idx put:0.
- codeIndex := idx + 1
+ (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
!
appendSignedByte:aByte
@@ -1242,6 +1226,16 @@
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
+!
+
appendWord:aWord
"append an unsigned word (low-high) to the code-Array,
checking for word-range (debug-only)"
@@ -1282,57 +1276,6 @@
self appendWord:w
!
-addReloc:symIndex
- "remember to relocate offset at symIndex later ..."
-
- relocList isNil ifTrue:[
- relocList := OrderedCollection new.
- ].
- relocList add:symIndex
-!
-
-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)].
- ]
- ]
- ]
- ].
-
-"
-!
-
byteCodeFor:aSymbol
"given a symbolic instruction, return the corresponding bytecode.
as a side-effect, leave number of bytes pushed/popped by this instr.
@@ -1593,6 +1536,57 @@
errorFlag := #Error
"Modified: 3.9.1995 / 12:58:47 / claus"
+!
+
+addReloc:symIndex
+ "remember to relocate offset at symIndex later ..."
+
+ relocList isNil ifTrue:[
+ relocList := OrderedCollection new.
+ ].
+ relocList add:symIndex
+!
+
+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)].
+ ]
+ ]
+ ]
+ ].
+
+"
! !
!ByteCodeCompiler methodsFor:'machine code generation'!
@@ -1802,6 +1796,7 @@
newMethod := aClass compiledMethodAt:selector.
newMethod notNil ifTrue:[
newMethod source:aString.
+ aClass updateVersionString.
aClass addChangeRecordForMethod:newMethod.
(silent or:[Smalltalk silentLoading == true]) ifFalse:[
Transcript showCr:(' compiled: ', className,' ',selector,' - machine code')
@@ -1867,6 +1862,7 @@
"
"Modified: 14.9.1995 / 22:33:04 / claus"
+ "Modified: 29.10.1995 / 19:58:56 / cg"
!
trappingStubMethodFor:aString inCategory:cat
@@ -1892,3 +1888,4 @@
].
^ newMethod
! !
+