--- a/ByteCodeCompiler.st Wed Feb 08 16:13:58 2006 +0100
+++ b/ByteCodeCompiler.st Wed Feb 08 16:16:39 2006 +0100
@@ -448,20 +448,10 @@
NewPrimitives := false.
].
ShareCode := true.
- STCKeepCIntermediate := false.
- STCKeepOIntermediate := false.
- STCKeepSTIntermediate := false.
- STCModulePath := './modules'.
ListCompiledMethods := false.
AllowExtensionsToPrivateClasses := true.
RestartCompilationSignal := Signal new.
- "
- STCKeepCIntermediate := true.
- STCKeepOIntermediate := true.
- STCKeepSTIntermediate := true.
- "
-
"Modified: / 15.11.2001 / 17:20:51 / cg"
!
@@ -657,17 +647,14 @@
!
stcCompileMethod:aMethod
- |prevFlag|
-
- prevFlag := self stcCompilation:#always.
- [
- self
- compile:(aMethod source)
- forClass:(aMethod mclass)
- inCategory:(aMethod category)
- ] ensure:[
- self stcCompilation:prevFlag
- ].
+ ParserFlags
+ withSTCCompilation:#always
+ do:[
+ self
+ compile:(aMethod source)
+ forClass:(aMethod mclass)
+ inCategory:(aMethod category)
+ ].
! !
!ByteCodeCompiler class methodsFor:'constants'!
@@ -865,7 +852,7 @@
This can be set from your private.rc file or from a workspace
for selective compilation to machine code."
- ^ STCCompilation
+ ^ ParserFlags stcCompilation
"
Compiler stcCompilation
@@ -885,8 +872,8 @@
|ret|
- ret := STCCompilation.
- STCCompilation := how.
+ ret := ParserFlags stcCompilation.
+ ParserFlags stcCompilation:how.
^ ret
"
@@ -3303,493 +3290,25 @@
!ByteCodeCompiler methodsFor:'machine code generation'!
compileToMachineCode:aString forClass:aClass inCategory:cat
- notifying:requestor install:install skipIfSame:skipIfSame silent:silent
+ 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 stcFlags cFlags def
- command oFileName cFileName
- initName oldMethod newMethod ok status className sep class stcPath ccPath
- errorStream errorMessages eMsg supers mP moduleFileName
- mapFileName libFileName pkg t s|
-
- install ifFalse:[
- "/ cannot do it uninstalled. reason:
- "/ if it is loaded twice, the first version could be unloaded by
- "/ finalization, which would also unload the second version
- "/ (because the first unload would unload the second version too)
- ^ #CannotLoad
- ].
-
- (mP := STCModulePath asFilename) exists ifFalse:[
- mP makeDirectory
- ].
- (mP isDirectory and:[mP isReadable and:[mP isWritable]]) ifFalse:[
- self parseError:('no access to temporary module directory: ' , mP pathName) position:1.
- ^ #CannotLoad
- ].
- "/ create a small README there ...
- (t := mP construct:'README') exists ifFalse:[
- s := t writeStream.
- s nextPutAll:
-'This temporary ST/X directory contains machine code for
-accepted methods with embedded C-code
-(i.e. dynamic compiled code for inline-C methods).
-
-Files here are not automatically removed, since ST/X
-cannot determine if any (other) snapshot image still
-requires a file here.
-
-Please be careful when removing files here - a snapshot
-image which was saved with accepted embedded C-code
-may not be able to restart correctly if you remove a
-required file.
-Also, when you export a snapshot image for execution
-on another machine, make certain that the required
-module-files are also present there.
-
-You should periodically clean dead entries here.
-i.e. remove files, when you are certain that none
-of your snapshot images refers to any module here.
-
-See the launchers File-Modules dialog for a list of
-modules which are still required by your running image.
-
-With kind regards - your ST/X.
-'.
- s close.
- ].
-
- ObjectFileLoader isNil ifTrue:[^ #CannotLoad].
STCCompilation == #never ifTrue:[^ #CannotLoad].
- (stcPath := self class incrementalStcPath) isNil ifTrue:[
- self parseError:'no stc compiler available - cannot create machine code' position:1.
- ^ #CannotLoad
- ].
- (ccPath := self class ccPath) isNil ifTrue:[
- self parseError:'no cc compiler available - cannot create machine code' position:1.
- ^ #CannotLoad
- ].
-
- (ObjectFileLoader notNil and:[ObjectFileLoader canLoadObjectFiles]) ifFalse:[
- self parseError:'no dynamic loader configured - cannot create machine code' position:1.
- ^ #CannotLoad
- ].
-
- "/ generate a unique name, consisting of my processID and a sequence number
- "/ the processId is added to allow filein of modules from different
- "/ lifes
-
- SequenceNumber isNil ifTrue:[SequenceNumber := 0].
- SequenceNumber := SequenceNumber + 1.
-
- initName := 'm_' , OperatingSystem getProcessId printString, '_' , SequenceNumber printString.
-
- stFileName := (Filename currentDirectory construct:(initName , '.st')) name.
- [
- stream := stFileName asFilename writeStream.
- ] on:FileStream openErrorSignal do:[:ex|
- self parseError:'cannot create temporary sourcefile for compilation'.
- ^ #CannotLoad
- ].
-
- [
- |definedClasses|
-
- definedClasses := IdentitySet new.
-
- sep := stream class chunkSeparator.
-
- class := aClass theNonMetaclass.
-
- Class fileOutNameSpaceQuerySignal answer:true
- do:[
- supers := class allSuperclasses.
- supers reverseDo:[:cls|
- true "cls ~~ Object" ifTrue:[
- cls isLoaded ifFalse:[
- stream close.
- ^ #CannotLoad
- ].
- "/ cls fileOutDefinitionOn:stream.
- cls
- basicFileOutDefinitionOn:stream
- withNameSpace:false withPackage:false
- syntaxHilighting:false.
-
- stream nextPut:sep; cr.
- definedClasses add:cls.
- ]
- ].
- "/ class fileOutDefinitionOn:stream.
- class
- basicFileOutDefinitionOn:stream
- withNameSpace:false withPackage:false
- syntaxHilighting:false.
- stream nextPut:sep; cr.
- definedClasses add:class.
-
- class privateClassesSorted do:[:aPrivateClass |
- supers := aPrivateClass allSuperclasses.
- supers notNil ifTrue:[
- supers reverseDo:[:cls|
- (definedClasses includes:cls) ifFalse:[
- true "cls ~~ Object" ifTrue:[
- cls isLoaded ifFalse:[
- stream close.
- ^ #CannotLoad
- ].
- "/ cls fileOutDefinitionOn:stream.
- cls
- basicFileOutDefinitionOn:stream
- withNameSpace:false withPackage:false
- syntaxHilighting:false.
-
- stream nextPut:sep; cr.
- definedClasses add:cls.
- ]
- ]
- ]
- ].
- (definedClasses includes:aPrivateClass) ifFalse:[
- "/ aPrivateClass fileOutDefinitionOn:stream.
- aPrivateClass
- basicFileOutDefinitionOn:stream
- withNameSpace:false withPackage:false
- syntaxHilighting:false.
- stream nextPut:sep; cr.
- definedClasses add:aPrivateClass.
- ]
- ].
-
- class fileOutPrimitiveDefinitionsOn:stream.
- ].
-
- (aClass isNil or:[AllowExtensionsToPrivateClasses or:[aClass owningClass isNil]]) ifTrue:[
- (requestor respondsTo:#packageToInstall) ifFalse:[
- pkg := Class packageQuerySignal query.
- ] ifTrue:[
- pkg := requestor packageToInstall
- ].
- ] ifFalse:[
- pkg := aClass owningClass package
- ].
-false ifTrue:[
- stream cr.
- stream nextPutLine:'"{ Package: ''' , pkg , ''' }"'.
- stream cr.
-].
-
- stream nextPut:sep.
- className := class name.
-
- stream nextPutAll:className.
- aClass isMeta ifTrue:[
- stream nextPutAll:' class'.
- ].
- stream nextPutAll:' methodsFor:'''; nextPutAll:cat; nextPutAll:''''.
- stream nextPut:sep; cr.
-
- stream nextPutLine:'"{ Line: 0 }"';
- nextChunkPut:aString;
- space; nextPut:sep.
-
- stream close.
-
- "
- call stc to compile it
- "
- oFileName := stFileName asFilename withoutSuffix name , (ObjectFileLoader objectFileExtension).
- cFileName := (stFileName asFilename withSuffix:'c') name.
- mapFileName := (stFileName asFilename withSuffix:'map') name.
- libFileName := (stFileName asFilename withSuffix:'lib') name.
- oFileName asFilename delete.
- cFileName asFilename delete.
-
- "/ stcFlags := '-commonSymbols +sharedLibCode +newIncremental -E:errorOutput -N' , initName .
- stcFlags := '+newIncremental -E:errorOutput -N' , initName .
- cFlags := OperatingSystem getOSDefine.
- cFlags isNil ifTrue:[
- cFlags := ''
- ].
- (def := OperatingSystem getCPUDefine) notNil ifTrue:[
- cFlags := cFlags , ' ' , def
- ].
-
- STCCompilationDefines notNil ifTrue:[
- cFlags := cFlags , ' ' , STCCompilationDefines
- ].
- STCCompilationIncludes notNil ifTrue:[
- stcFlags := STCCompilationIncludes , ' ' , stcFlags.
- cFlags := cFlags , ' ' , STCCompilationIncludes.
- ].
- STCCompilationOptions notNil ifTrue:[
- stcFlags := STCCompilationOptions , ' ' , stcFlags
- ].
- CCCompilationOptions notNil ifTrue:[
- cFlags := cFlags , ' ' , CCCompilationOptions
- ].
-
- command := stcPath , ' ' , stcFlags , ' -C ' , stFileName.
-
- Verbose == true ifTrue:[
- 'executing: ' infoPrint. command infoPrintCR.
- ].
- errorStream := 'errorOutput' asFilename writeStream.
-
- self activityNotification:'compiling (stc)'.
- ok := OperatingSystem
- executeCommand:command
- inputFrom:nil
- outputTo:errorStream
- errorTo:errorStream
- onError:[:stat|
- status := stat.
- false
- ].
-
- cFileName asFilename exists ifTrue:[
- ok ifFalse:[
- 'Compiler [info]: oops - system says stc failed - but c-file is there ...' infoPrintCR.
- ok := true
- ]
- ] ifFalse:[
- ok ifTrue:[
- 'Compiler [info]: oops - system says stc ok - but no c-file is there ...' infoPrintCR.
- ].
- ok := false
- ].
-
- ok ifTrue:[
- "/ now compile to machine code
-
- command := ccPath , ' ' , cFlags , ' -D__INCREMENTAL_COMPILE__ -c ' , cFileName.
- Verbose == true ifTrue:[
- 'executing: ' infoPrint. command infoPrintCR.
- ].
- self activityNotification:'compiling (' , ccPath , ')'.
- ok := OperatingSystem
- executeCommand:command
- inputFrom:nil
- outputTo:errorStream
- errorTo:errorStream
- onError:[:stat|
- status := stat.
- false
- ].
-
- oFileName asFilename exists ifTrue:[
- ok ifFalse:[
- 'Compiler [info]: system says compile failed - but o-file is there ...' infoPrintCR.
- ok := true
- ]
- ] ifFalse:[
- ok ifTrue:[
- 'Compiler [info]: system says compile ok - but no o-file is there ...' infoPrintCR.
- ].
- ok := false
- ].
- ].
-
- ok ifFalse:[
- (status notNil and:[status couldNotExecute]) ifTrue:[
- eMsg := 'oops, no STC - cannot create machine code'
- ] ifFalse:[
- errorMessages := 'errorOutput' asFilename contents.
- errorMessages notNil ifTrue:[
- errorMessages size > 20 ifTrue:[
- errorMessages := (errorMessages copyTo:20) copyWith:'... more messages skipped'
- ].
-"/ errorMessages := errorMessages collect:[:line |
-"/ (line startsWith:(stFileName , ':')) ifTrue:[
-"/ 'Line: ' , (line copyFrom:(stFileName size + 2))
-"/ ] ifFalse:[
-"/ line
-"/ ]
-"/ ].
- errorMessages := errorMessages asString
- ].
- errorMessages isNil ifTrue:[
- errorMessages := ''
- ].
- errorMessages isEmpty ifTrue:[
- eMsg := 'STC / CC error during compilation:\\unspecified error' withCRs
- ] ifFalse:[
- eMsg := 'STC / CC error during compilation:\\'withCRs,errorMessages
- ].
- "/ eMsg := eMsg withCRs
- ].
- self activityNotification:'compilation failed'.
- self parseError:eMsg position:1.
-
- self activityNotification:''.
- ^ #Error
- ].
-
- self activityNotification:''.
- OperatingSystem removeFile:'errorOutput'.
-
- "
- if required, make a shared or otherwise loadable object file for it
- "
- self activityNotification:'linking'.
-
- oFileName := ObjectFileLoader createLoadableObjectFor:initName.
- oFileName isNil ifTrue:[
- "/ something went wrong
- self parseError:('link error: ' , ObjectFileLoader lastError) position:1.
- ^ #CannotLoad
- ].
- oFileName asFilename exists ifFalse:[
- self parseError:'link failed - cannot create machine code' position:1.
- ^ #CannotLoad
- ].
-
- "
- move it into the modules directory
- "
- moduleFileName := (STCModulePath asFilename construct:(initName , '.' , (oFileName asFilename suffix))) name.
- oFileName asFilename moveTo:moduleFileName.
- (moduleFileName asFilename exists
- and:[moduleFileName asFilename isReadable]) ifFalse:[
- self parseError:'link failed - cannot move shared library module to ''modules'' directory' position:1.
- ^ #CannotLoad
- ].
-
- oldMethod := aClass compiledMethodAt:selector.
- oldMethod notNil ifTrue:[pkg := oldMethod package].
-
- "
- load the method objectfile
- "
- self activityNotification:'loading'.
-
- handle := ObjectFileLoader loadMethodObjectFile:moduleFileName.
- handle isNil ifTrue:[
- OperatingSystem removeFile:moduleFileName.
- self parseError:'dynamic load of machine code failed' position:1.
- ^ #CannotLoad
- ].
-
- "
- did it work ?
- "
- newMethod := aClass compiledMethodAt:selector.
-
- "/ if install is false, we have to undo the install (which is always done, when loading machine code)
- install ifFalse:[
- oldMethod isNil ifTrue:[
- aClass removeSelector:selector
- ] ifFalse:[
- newMethod setPackage:oldMethod package.
- aClass addSelector:selector withMethod:oldMethod.
- oldMethod setPackage:pkg.
- ]
- ].
-
- newMethod notNil ifTrue:[
- handle method ~~ newMethod ifTrue:[
- 'Compiler [warning]: loaded method installed itself in another class' errorPrintCR.
- ].
-
- newMethod source:aString string.
- newMethod setPackage:pkg.
-"/ Project notNil ifTrue:[
-"/ newMethod package:(Project currentPackageName)
-"/ ].
-
- "/ aClass updateRevisionString.
- install ifTrue:[
- aClass addChangeRecordForMethod:newMethod fromOld:oldMethod.
-
- "/ kludge-sigh: must send change messages manually here (stc-loaded code does not do it)
- "/ see addMethod:... in ClassDescription
- aClass changed:#methodDictionary with:(Array with:selector with:oldMethod).
- Smalltalk changed:#methodInClass with:(Array with:aClass with:selector with:oldMethod).
- ].
-
- (silent or:[Smalltalk silentLoading == true]) ifFalse:[
- Transcript showCR:(' compiled: ', className,' ',selector,' - machine code')
- ].
- ObjectMemory flushCaches.
-
- 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:moduleFileName.
- self parseError:'dynamic load failed' position:1.
- ^ #CannotLoad
- ] ensure:[
- STCKeepSTIntermediate ifFalse:[
- OperatingSystem removeFile:stFileName.
- OperatingSystem removeFile:'errorOutput'.
- ].
- STCKeepOIntermediate == true ifFalse:[
- (oFileName notNil and:[oFileName asFilename exists]) ifTrue:[oFileName asFilename delete].
- ].
- STCKeepCIntermediate == true ifFalse:[
- (cFileName notNil and:[cFileName asFilename exists]) ifTrue:[cFileName asFilename delete].
- ].
- OperatingSystem isMSDOSlike ifTrue:[
-"/ (mapFileName notNil and:[mapFileName asFilename exists]) ifTrue:[mapFileName asFilename delete].
-"/ (libFileName notNil and:[libFileName asFilename exists]) ifTrue:[libFileName asFilename delete].
- ].
- ].
-
- "
- |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: / 19.3.1999 / 08:31:42 / stefan"
- "Modified: / 10.11.2001 / 01:46:00 / cg"
+
+ (STCCompilerInterface new
+ originator:self;
+ parserFlags:parserFlags)
+ compileToMachineCode:aString
+ forClass:aClass
+ inCategory:cat
+ notifying:requestor
+ install:install
+ skipIfSame:skipIfSame
+ silent:silent
!
trappingStubMethodFor:aString inCategory:cat
@@ -3829,7 +3348,7 @@
!ByteCodeCompiler class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libcomp/ByteCodeCompiler.st,v 1.230 2005-08-16 15:59:13 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libcomp/ByteCodeCompiler.st,v 1.231 2006-02-08 15:16:39 cg Exp $'
! !
ByteCodeCompiler initialize!