"
COPYRIGHT (c) 1989 by Claus Gittinger
COPYRIGHT (c) 2006 by eXept Software AG
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.
"
"{ Package: 'stx:libcomp' }"
Object subclass:#STCCompilerInterface
instanceVariableNames:'originator parserFlags initName theNonMetaclassToCompileFor
classToCompileFor stFileName cFileName oFileName stcFlags cFlags
stcPath ccPath requestor methodCategory executionStatus package'
classVariableNames:'SequenceNumber Verbose'
poolDictionaries:''
category:'System-Compiler'
!
!STCCompilerInterface class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
COPYRIGHT (c) 2006 by eXept Software AG
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
"
a refactored complex method - originally found in ByteCodeCompiler.
"
! !
!STCCompilerInterface class methodsFor:'accessing'!
stcPathOf:command
"return the path to an stc command, or nil if not found."
|f d reqdSuffix cmd|
"/
"/ care for executable suffix
"/
cmd := command.
OperatingSystem isMSDOSlike ifTrue:[
reqdSuffix := 'exe'
] ifFalse:[
OperatingSystem isVMSlike ifTrue:[
reqdSuffix := 'EXE'
].
].
reqdSuffix notNil ifTrue:[
(f := cmd asFilename) suffix isEmpty ifTrue:[
cmd := (f withSuffix:reqdSuffix) name
]
].
"/
"/ for our convenience, also check in current
"/ and parent directories; even if PATH does not
"/ include them ...
"/
"/ look in current ...
d := Filename currentDirectory.
(f := d construct:cmd) isExecutable ifTrue:[
^ f pathName
].
"/ look in ../stc ...
d := d construct:'..'.
(f := (d construct:'stc') construct:cmd) isExecutable ifTrue:[
^ f pathName
].
"/ look in ../../stc ...
d := d construct:'..'.
(f := (d construct:'stc') construct:cmd) isExecutable ifTrue:[
^ f pathName
].
"/
"/ ok, stc must be installed in some directory along the PATH
"/
^ OperatingSystem pathOfCommand:command
"
STCCompilerInterface stcPathOf:'stc'
"
"Created: 13.9.1995 / 14:37:16 / claus"
! !
!STCCompilerInterface class methodsFor:'class initialization'!
initialize
Verbose := false.
! !
!STCCompilerInterface methodsFor:'accessing'!
incrementalStcPath
"return the path to the stc command for incremental method compilation,
or nil if not found."
|f cmd|
(cmd := parserFlags stcPath) isEmptyOrNil ifTrue:[
(f := self class stcPathOf:'stc') notNil ifTrue:[
cmd := f
] ifFalse:[
cmd := self class stcPathOf:'demostc'
]
].
(cmd notNil and:[cmd includes:Character space]) ifTrue:[
cmd := '"' , cmd , '"'.
].
^ cmd
"Created: 13.9.1995 / 14:36:36 / claus"
"Modified: 13.9.1995 / 15:15:04 / claus"
!
originator:something
originator := something.
!
parserFlags:something
parserFlags := something.
! !
!STCCompilerInterface methodsFor:'machine code generation'!
compileToMachineCode:aString forClass:aClass selector:selector inCategory:categoryArg
notifying:requestorArg 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)."
|handle oldMethod newMethod ok moduleFileName|
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
].
parserFlags stcCompilation == #never ifTrue:[^ #CannotLoad].
classToCompileFor := aClass.
requestor := requestorArg.
methodCategory := categoryArg.
self ensureModuleDirectoryExists.
self ensureExternalToolsArePresent ifFalse:[^ #CannotLoad].
theNonMetaclassToCompileFor := classToCompileFor theNonMetaclass.
self ensureSuperClassesAreLoadedOf:theNonMetaclassToCompileFor.
theNonMetaclassToCompileFor privateClassesSorted do:[:aPrivateClass |
self ensureSuperClassesAreLoadedOf:aPrivateClass.
].
(classToCompileFor isNil
or:[parserFlags allowExtensionsToPrivateClasses
or:[classToCompileFor owningClass isNil]]) ifTrue:[
(requestor respondsTo:#packageToInstall) ifFalse:[
package := Class packageQuerySignal query.
] ifTrue:[
package := requestor packageToInstall
].
] ifFalse:[
package := classToCompileFor owningClass package
].
[
self generateSTSource:aString.
self setupCompilationCommandArguments.
ok := self compileToC.
ok ifTrue:[
"/ now compile to machine code
ok := self compileToObj.
].
ok ifFalse:[
self reportCompilationError.
^ #Error
].
originator activityNotification:''.
OperatingSystem removeFile:'errorOutput'.
"
if required, make a shared or otherwise loadable object file for it
"
originator activityNotification:'linking'.
oFileName := ObjectFileLoader createLoadableObjectFor:initName.
oFileName isNil ifTrue:[
"/ something went wrong
originator parseError:('link error: ' , ObjectFileLoader lastError) position:1.
^ #CannotLoad
].
oFileName asFilename exists ifFalse:[
originator parseError:'link failed - cannot create machine code' position:1.
^ #CannotLoad
].
"
move it into the modules directory
"
moduleFileName := (parserFlags stcModulePath asFilename construct:(initName , '.' , (oFileName asFilename suffix))) name.
oFileName asFilename moveTo:moduleFileName.
(moduleFileName asFilename exists
and:[moduleFileName asFilename isReadable]) ifFalse:[
originator parseError:'link failed - cannot move shared library module to ''modules'' directory' position:1.
^ #CannotLoad
].
oldMethod := classToCompileFor compiledMethodAt:selector.
oldMethod notNil ifTrue:[package := oldMethod package].
"
load the method objectfile
"
originator activityNotification:'loading'.
handle := ObjectFileLoader loadMethodObjectFile:moduleFileName.
handle isNil ifTrue:[
OperatingSystem removeFile:moduleFileName.
originator parseError:'dynamic load of machine code failed' position:1.
^ #CannotLoad
].
"
did it work ?
"
newMethod := classToCompileFor 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:[
classToCompileFor removeSelector:selector
] ifFalse:[
newMethod setPackage:oldMethod package.
classToCompileFor addSelector:selector withMethod:oldMethod.
oldMethod setPackage:package.
]
].
newMethod notNil ifTrue:[
handle method ~~ newMethod ifTrue:[
'Compiler [warning]: loaded method installed itself in another class' errorPrintCR.
].
newMethod source:aString string.
newMethod setPackage:package.
"/ Project notNil ifTrue:[
"/ newMethod package:(Project currentPackageName)
"/ ].
"/ classToCompileFor updateRevisionString.
install ifTrue:[
classToCompileFor addChangeRecordForMethod:newMethod fromOld:oldMethod.
"/ kludge-sigh: must send change messages manually here (stc-loaded code does not do it)
"/ see addMethod:... in ClassDescription
classToCompileFor changed:#methodDictionary with:(Array with:selector with:oldMethod).
Smalltalk changed:#methodInClass with:(Array with:classToCompileFor with:selector with:oldMethod).
].
silent ifFalse:[
Transcript showCR:(' compiled: ', aClass name,' ',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.
originator parseError:'dynamic load failed' position:1.
^ #CannotLoad
] ensure:[
parserFlags stcKeepSTIntermediate ifFalse:[
OperatingSystem removeFile:stFileName.
OperatingSystem removeFile:'errorOutput'.
].
parserFlags stcKeepOIntermediate == true ifFalse:[
(oFileName notNil and:[oFileName asFilename exists]) ifTrue:[oFileName asFilename delete].
].
parserFlags 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-09-1995 / 22:33:04 / claus"
"Modified: / 19-03-1999 / 08:31:42 / stefan"
"Modified: / 07-11-2006 / 14:21:46 / cg"
! !
!STCCompilerInterface methodsFor:'machine code generation-helpers'!
compileToC
"compile st to C using stc"
|command errorStream ok|
command := stcPath , ' ' , stcFlags , ' -C ' , stFileName.
errorStream := 'errorOutput' asFilename writeStream.
Verbose == true ifTrue:[
'executing: ' infoPrint. command infoPrintCR.
].
originator activityNotification:'compiling (stc)'.
ok := OperatingSystem
executeCommand:command
inputFrom:nil
outputTo:errorStream
errorTo:errorStream
onError:[:stat|
executionStatus := stat.
false
].
errorStream close.
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
"Created: / 07-11-2006 / 12:11:24 / cg"
"Modified: / 07-11-2006 / 14:20:55 / cg"
!
compileToObj
"compile C to obj, using cc"
|command errorStream ok|
errorStream := 'errorOutput' asFilename writeStream.
command := ccPath , ' ' , cFlags , ' -D__INCREMENTAL_COMPILE__ -c ' , cFileName.
Verbose == true ifTrue:[
'executing: ' infoPrint. command infoPrintCR.
].
originator activityNotification:'compiling (' , ccPath , ')'.
ok := OperatingSystem
executeCommand:command
inputFrom:nil
outputTo:errorStream
errorTo:errorStream
onError:[:stat|
executionStatus := stat.
false
].
errorStream close.
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
"Created: / 07-11-2006 / 12:14:51 / cg"
!
ensureExternalToolsArePresent
(stcPath := self incrementalStcPath) isNil ifTrue:[
originator parseError:'no stc compiler available - cannot create machine code' position:1.
^ false
].
(ccPath := parserFlags ccPath) isNil ifTrue:[
originator parseError:'no cc compiler available - cannot create machine code' position:1.
^ false
].
(ObjectFileLoader notNil and:[ObjectFileLoader canLoadObjectFiles]) ifFalse:[
originator parseError:'no dynamic loader configured - cannot create machine code' position:1.
^ false
].
^ true
"Created: / 07-11-2006 / 12:31:48 / cg"
!
ensureModuleDirectoryExists
|mP t s|
(mP := parserFlags stcModulePath asFilename) exists ifFalse:[
mP makeDirectory
].
(mP isDirectory and:[ mP isReadable and:[ mP isWritable ] ]) ifFalse:[
Parser::ParseError raiseErrorString:('No access to temporary module directory: ' , mP pathName).
].
"/ 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.
].
!
ensureSuperClassesAreLoadedOf:aClass
|supers|
supers := aClass allSuperclasses.
supers reverseDo:[:cls|
cls isLoaded ifFalse:[
Parser::ParseError raiseErrorString:'Cannot stc-compile (Some superclass is unloaded)'.
]
].
!
fileOutAllDefinitionsOf:aClass to:aStream rememberIn:definedClasses
|defineAction|
defineAction :=
[:cls|
(definedClasses includes:cls) ifFalse:[
cls
basicFileOutDefinitionOn:aStream
withNameSpace:false withPackage:false
syntaxHilighting:false.
aStream nextPut:(aStream class chunkSeparator); cr.
definedClasses add:cls.
].
].
aClass allSuperclasses reverseDo:defineAction.
defineAction value:aClass.
!
generateSTSource:aString
|stream definedClasses sep className|
"/ 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 := (SequenceNumber ? 0) + 1.
initName := 'm_' , OperatingSystem getProcessId printString, '_' , SequenceNumber printString.
stFileName := (Filename currentDirectory construct:(initName , '.st')) name.
[
stream := stFileName asFilename writeStream.
] on:FileStream openErrorSignal do:[:ex|
originator parseError:'cannot create temporary sourcefile for compilation'.
^ #CannotLoad
].
definedClasses := IdentitySet new.
sep := stream class chunkSeparator.
Class fileOutNameSpaceQuerySignal answer:true
do:[
theNonMetaclassToCompileFor realSharedPools do:[:eachPoolname |
|pool|
pool := Smalltalk at:eachPoolname.
self
fileOutAllDefinitionsOf:pool
to:stream
rememberIn:definedClasses.
].
self
fileOutAllDefinitionsOf:theNonMetaclassToCompileFor
to:stream
rememberIn:definedClasses.
theNonMetaclassToCompileFor privateClassesSorted do:[:aPrivateClass |
self
fileOutAllDefinitionsOf:aPrivateClass
to:stream
rememberIn:definedClasses.
].
theNonMetaclassToCompileFor fileOutPrimitiveDefinitionsOn:stream.
"/ If a method uses a static primitive function... - but this doesn't work
"/ theNonMetaclassToCompileFor fileOutPrimitiveSpecsOn:stream.
].
"/ stream cr.
"/ stream nextPutLine:'"{ Package: ''' , package , ''' }"'.
"/ stream cr.
stream nextPut:sep.
className := theNonMetaclassToCompileFor name.
stream nextPutAll:className.
classToCompileFor isMeta ifTrue:[
stream nextPutAll:' class'.
].
stream nextPutAll:' methodsFor:'''; nextPutAll:methodCategory; nextPutAll:''''.
stream nextPut:sep; cr.
stream nextPutLine:'"{ Line: 0 }"';
nextChunkPut:aString;
space; nextPut:sep.
stream close.
"Modified: / 07-11-2006 / 12:45:04 / cg"
!
reportCompilationError
|eMsg errorMessages lNr|
(executionStatus notNil and:[executionStatus couldNotExecute]) ifTrue:[
eMsg := 'oops, no STC - cannot create machine code'
] ifFalse:[
errorMessages := 'errorOutput' asFilename contents.
OperatingSystem removeFile:'errorOutput'.
errorMessages notNil ifTrue:[
errorMessages := errorMessages reject:[:line | line includesString:'Warning:'].
errorMessages size > 20 ifTrue:[
errorMessages := errorMessages select:[:line | line asLowercase startsWith:'error'].
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 isNil ifTrue:[
errorMessages := #('')
].
"/ try to extract a line number"
(errorMessages contains:[:line | line includesString:'Borland']) ifTrue:[
|i i2 s|
i := errorMessages findFirst:[:l | l startsWith:(cFileName,':')].
i ~~ 0 ifTrue:[
((errorMessages at:i+1) startsWith:'Error') ifTrue:[
i2 := (errorMessages at:i+1) indexOfSubCollection:(stFileName).
i2 ~~ 0 ifTrue:[
s := (errorMessages at:i+1) copyFrom:(i2+stFileName size+1).
s := s readStream.
lNr := Integer readFrom:s.
s skipSeparators.
].
]
].
].
errorMessages isEmpty ifTrue:[
eMsg := 'Error during compilation:\\Unspecified error (no output)' withCRs
] ifFalse:[
eMsg := 'Error during compilation:\\' withCRs ,
(errorMessages asStringCollection asString).
].
"/ eMsg := eMsg withCRs
].
originator activityNotification:'compilation failed'.
lNr notNil ifTrue:[
originator parseError:eMsg line:lNr
] ifFalse:[
originator parseError:eMsg position:1.
].
originator activityNotification:''.
"Created: / 07-11-2006 / 12:29:04 / cg"
!
setupCompilationCommandArguments
|stFn mapFileName libFileName def libDir incDir incDirArg|
stFn := stFileName asFilename.
oFileName := stFn nameWithoutSuffix , (ObjectFileLoader objectFileExtension).
cFileName := (stFn withSuffix:'c') name.
mapFileName := (stFn withSuffix:'map') name.
libFileName := (stFn 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
].
parserFlags stcCompilationDefines notNil ifTrue:[
cFlags := cFlags , ' ' , parserFlags stcCompilationDefines
].
parserFlags stcCompilationIncludes notNil ifTrue:[
stcFlags := parserFlags stcCompilationIncludes , ' ' , stcFlags.
cFlags := cFlags , ' ' , parserFlags stcCompilationIncludes.
"/ if STX_LIBDIR is defined, and not in passed argument,
"/ add it here.
libDir := OperatingSystem getEnvironment:'STX_LIBDIR'.
(libDir notNil and:[libDir asFilename exists]) ifTrue:[
incDir := libDir asFilename construct:'include'.
incDir exists ifTrue:[
incDirArg := '-I' , incDir pathName.
(parserFlags stcCompilationIncludes asCollectionOfWords includes:incDirArg) ifFalse:[
stcFlags := stcFlags , ' ' , incDirArg.
cFlags := cFlags , ' ' , incDirArg.
]
]
].
].
parserFlags stcCompilationOptions notNil ifTrue:[
stcFlags := parserFlags stcCompilationOptions , ' ' , stcFlags
].
parserFlags ccCompilationOptions notNil ifTrue:[
cFlags := cFlags , ' ' , parserFlags ccCompilationOptions
].
"Created: / 07-11-2006 / 12:24:47 / cg"
"Modified: / 07-11-2006 / 13:58:54 / cg"
! !
!STCCompilerInterface class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libcomp/STCCompilerInterface.st,v 1.10 2008-01-24 14:16:30 cg Exp $'
! !
STCCompilerInterface initialize!