"

 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' }"

"{ NameSpace: Smalltalk }"

Object subclass:#STCCompilerInterface

	instanceVariableNames:'originator parserFlags initName theNonMetaclassToCompileFor

		classToCompileFor stFileName cFileName oFileName stcFlags cFlags

		stcPath ccPath requestor methodCategory executionStatus package'

	classVariableNames:'SequenceNumber Verbose KeepIntermediateFiles'

	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 ...

    "/

    #('.' '../stc' '../../stc') do:[:relPath |

        d := Filename currentDirectory construct:relPath.

        (f := d 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"

!

verbose

    "if on, trace command execution on the Transcript"

    ^ Verbose

!

verbose:aBoolean 

    "if on, trace command execution on the Transcript"

    Verbose := aBoolean

! !

!STCCompilerInterface class methodsFor:'class initialization'!

initialize

    Verbose := false.

! !

!STCCompilerInterface methodsFor:'accessing'!

cFileName:something

    cFileName := something.

!

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.

!

stFileName:something

    stFileName := something.

! !

!STCCompilerInterface methodsFor:'error raising'!

parseError:messageText position:position

    originator parseError:messageText position:position.

    "not normally reached"

    ParseError raiseErrorString:messageText.

! !

!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.

     It saves the code to a tmporary, calls stc to create C-code, compiles it, links

     it to a tiny little dll and loads it.

     As you already see, this takes some time and is therefore ONLY done for code containing prims;

     all pure smalltalk code is compiled to bytecode and jitted by the VM."

    |handle oldMethod newMethod ok dllFileName|

    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 isNil ifTrue:[

        parserFlags := ParserFlags new

    ].

    parserFlags stcCompilation == #never ifTrue:[^ #CannotLoad].

    classToCompileFor := aClass.

    requestor := requestorArg.

    methodCategory := categoryArg.

    self ensureExternalToolsArePresent.

    self ensureModuleDirectoryExists.

    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 ifFalse:[

            self reportCompilationErrorFor:stcPath.

        ].

        parserFlags stcKeepSIntermediate ifTrue:[ self compileToS ].

        "/ now compile to machine code

        ok := self compileToObj.

        ok ifFalse:[

            self reportCompilationErrorFor:ccPath.

        ].

        originator activityNotification:''.

        OperatingSystem removeFile:'errorOutput'.

        "

         if required, make a shared or otherwise loadable object file for it

        "

        originator activityNotification:'linking'.

        dllFileName := ObjectFileLoader createLoadableObjectFor:(oFileName asFilename withoutSuffix name).

        dllFileName isNil ifTrue:[

            "/ something went wrong

            self parseError:('link error: ' , ObjectFileLoader lastError) position:1.

        ].

        dllFileName asFilename exists ifFalse:[

            self parseError:'link failed - cannot create machine code' position:1.

        ].

        oldMethod := classToCompileFor compiledMethodAt:selector.

        oldMethod notNil ifTrue:[package := oldMethod package].

        install ifTrue:[

            (Smalltalk

                    changeRequest:#methodInClass

                    with:(Array with:classToCompileFor with:selector with:oldMethod)) ifFalse:[

                ^ #CannotLoad

            ].

        ].

        "

         load the method objectfile

        "

        originator activityNotification:'loading'.

        handle := ObjectFileLoader loadMethodObjectFile:dllFileName.

        originator activityNotification:''.

        handle isNil ifTrue:[

            KeepIntermediateFiles ~~ true ifTrue:[ OperatingSystem removeFile:dllFileName ].

            "catch, so that #CannotLoad processing is done"

            ParseError catch:[

                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).

            ] ifFalse:[

                oldMethod := nil.

            ].

            silent ifFalse:[

                Transcript showCR:('    compiled: ', aClass name,' ',selector,' - machine code')

            ].

            ObjectMemory flushCaches.

            handle method:newMethod.

            "/ check for obsolete compiled method code and unload the

            "/ corresponding ObjectFileHandle.

            "/ The old method with its source code is usually kept in the method history.

            "/ and will be recompiled on an undo

            ObjectFileLoader loadedObjectHandlesDo:[:anotherHandle |

                anotherHandle isMethodHandle ifTrue:[

                    anotherHandle method == oldMethod ifTrue:[

                        "break association betwen old method, code and handle"

                        anotherHandle removeConnectedObjects.

                    ].

                    anotherHandle isObsolete ifTrue:[

                        anotherHandle unload.

                        anotherHandle removeUnusedObjectFile.

                    ].

                ].

            ].

            ^ newMethod.

        ].

        "/ OperatingSystem removeFile:moduleFileName.

        self parseError:'dynamic load failed' position:1.

    ] ensure:[

        KeepIntermediateFiles == true ifTrue:[ 

            Transcript showCR:'keeping files'

        ] ifFalse:[

            parserFlags stcKeepSTIntermediate ifTrue:[

                Transcript showCR:'keeping st file: ', stFileName asFilename pathName

            ] ifFalse:[

                OperatingSystem removeFile:stFileName.

                OperatingSystem removeFile:'errorOutput'.

            ].

            cFileName notNil ifTrue:[

                parserFlags stcKeepCIntermediate == true ifTrue:[

                    Transcript showCR:'keeping c file: ', cFileName asFilename pathName

                ] ifFalse:[

                    OperatingSystem removeFile:cFileName.

                ]

            ].

            oFileName notNil ifTrue:[

                parserFlags stcKeepOIntermediate == true ifTrue:[

                    Transcript showCR:'keeping o file: ', oFileName asFilename pathName

                ] ifFalse:[

                    OperatingSystem removeFile:oFileName.

                ].

            ].

"/            OperatingSystem isMSDOSlike ifTrue:[

"/                mapFileName notNil ifTrue:[

"/                   OperatingSystem removeFile:mapFileName.

"/                ].

"/                libFileName notNil ifTrue:[

"/                   OperatingSystem removeFile:libFileName.

"/                ].

"/            ].

        ]

    ].

    "

     |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: / 17-09-2011 / 10:39:25 / cg"

! !

!STCCompilerInterface methodsFor:'machine code generation-helpers'!

compileToC

    "compile st to C using stc"

    |command errorStream ok|

    command := (self possiblyQuotedPath:stcPath) , ' ' , stcFlags 

                , ' -defdir=', (self possiblyQuotedPath:cFileName asFilename directory pathName).

    cFileName asFilename suffix ~= 'c' ifTrue:[

        command := command , ' -cSuffix=',cFileName asFilename suffix.

    ].

    command := command ,

                ' -C ' , (self possiblyQuotedPath:stFileName asFilename pathName).

    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: / 08-08-2011 / 22:12:01 / cg"

!

compileToExe

    "compile C to exe, using cc"

    |command errorStream ok|

    errorStream := 'errorOutput' asFilename newReadWriteStream.

    command := (self possiblyQuotedPath:ccPath) , ' ' , cFlags , ' -D__INCREMENTAL_COMPILE__ ' , (self possiblyQuotedPath: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

                ].

    ok ifFalse:[

        errorStream reset.

        errorStream copyToEndInto:Transcript.

    ].

    errorStream close.

    ^ ok

!

compileToObj

    "compile C to obj, using cc"

    |errorStream ok commandTemplate command ccDefine env|

    errorStream := 'errorOutput' asFilename newReadWriteStream.

    "/ bcc does not like -D__BORLANDC__ (needs to be set to a version, such as 0x0505