"

 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

		BuiltinCIncludeDirectories'

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

builtinCFlags

    "Return C compiler flags that are always passed to the C compiler

     when a (ST)C file is compiled."

    ^ OperatingSystem getCPUDefine , ' ', OperatingSystem getOSDefine

    "Created: / 04-12-2015 / 16:41:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

builtinCIncludeDirectories

    "Return C compiler include directories that are always passed to the C compiler

     when a (ST)C file is compiled."

    BuiltinCIncludeDirectories isNil ifTrue:[ 

        | executablePath |

        (executablePath := OperatingSystem pathOfSTXExecutable) notNil ifTrue:[

            executablePath := executablePath asFilename directory.

            ((executablePath / 'include' / 'stc.h') exists

              or:[((executablePath := executablePath directory) / 'include' / 'stc.h') exists

              or:[((executablePath := executablePath directory) / 'include' / 'stc.h') exists]])

                ifTrue:[

                    BuiltinCIncludeDirectories := '-I' , (executablePath / 'include') pathName.

                    ^ BuiltinCIncludeDirectories

                ]

        ].

        ^ ''

    ].

    ^ BuiltinCIncludeDirectories

    "

    STCCompilerInterface builtinCIncludeDirectories

    "

    "Created: / 09-12-2015 / 16:54:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

builtinCIncludeDirectories: aString

    "Set C compiler include directories that are always passed to the C compiler

     when a (ST)C file is compiled. 

     This is an entry for init scripts for custom Smalltalk/X distributions which use

     different directory layout than just a plain St/X worktree (such as Smalltalk/X jv-branch).

     Note, that this is a string, so it must include '-I'

     "

     BuiltinCIncludeDirectories := aString

    "Created: / 09-12-2015 / 16:59:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

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"

!

verbose

    "if on, trace command execution on the Transcript"

    ^ Verbose

!

verbose:aBoolean 

    "if on, trace command execution on the Transcript"

    Verbose := aBoolean

    "

    STCCompilerInterface verbose: true.

    STCCompilerInterface verbose: false.

    "

    "Modified (comment): / 04-12-2015 / 16:44:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!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