"{ Encoding: utf8 }"

"

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

getCCDefine

    "return a string which was used to identify the C-Compiler used

     when STX was compiled, and which should be passed down when compiling methods.

     For example, when compiled with GNUC, this is '__GNUC__';

     on windows, this is either '__VISUAL__', '__BORLANDC__' or '__MINGW64__'"

%{  /* NOCONTEXT */

#ifndef CC_DEFINE

# ifdef __win32__

#  if defined( __BORLANDC__ )

#   define CC_DEFINE    "__BORLANDC__"

#  else

#   if defined( __VISUALC__ )

#    define CC_DEFINE     "__VISUALC__"

#   else

#    if defined( __MINGW64__ )

#     define CC_DEFINE     "__MINGW64__"

#    else

#     if defined( __MINGW32__ )

#      define CC_DEFINE     "__MINGW32__"

#     else

#      define CC_DEFINE     "__CC__"

#     endif

#    endif

#   endif

#  endif

# else /* not __win32__ */

#  if defined(__CLANG__) || defined( __clang__ )

#   define CC_DEFINE     "__CLANG__"

#  else

#   ifdef __GNUC__

    // https://expeccoalm.exept.de/D252306

    // must not redefine __GNUC__, because gcc defines this anyway with the gcc version 

    // contained in this macro (which is used by glibc includes).

    // also defined in STCCompilerInterface class >> #getCCDefine

#    define CC_DEFINE     "STX__GNUC__"

#   else

#    define CC_DEFINE     "__CC__"

#   endif

#  endif

# endif

#endif

    RETURN ( __MKSTRING(CC_DEFINE));

%}

    "

     STCCompilerInterface getCCDefine

    "

    "Modified: / 11-05-2018 / 10:12:47 / stefan"

!

getCPUDefine

    "return a string which was used to identify this CPU type when STX was

     compiled, and which should be passed down when compiling methods.

     For example, on a 386 (and successors), this may be '-D__x86__'; 

     on a vax, this would be '-D__vax__'.

     This is normally not of interest to 'normal' users; however, it is passed

     down to the c-compiler when methods are incrementally compiled to machine code.

     Do not use this for CPU determination; only to pass on to stc for compilation.

     (see OperatingSystem getCPUType for this)"

%{  /* NOCONTEXT */

#   ifndef CPU_DEFINE

#       define CPU_DEFINE "-DunknownCPU"

#   endif

    RETURN ( __MKSTRING(CPU_DEFINE));

%}

    "

     STCCompilerInterface getCPUDefine

    "

!

getOSDefine

    "return a string which was used to identify this machine when stx was

     compiled, and which should be passed down when compiling methods.

     For example, on linux, this is '-D__linux__'; on osx, it is '-D__osx__'.

     Do not use this for OS determination; only to pass on to stc for compilation.

     (see OperatingSystem getOSType for this)"

%{  /* NOCONTEXT */

#ifndef OS_DEFINE

# ifdef __win32__

#  define OS_DEFINE "-D__win32__"

# endif

# ifndef OS_DEFINE

#  define OS_DEFINE "-DunknownOS"

# endif

#endif

    RETURN ( __MKSTRING(OS_DEFINE));

#undef OS_DEFINE

%}

    "

     STCCompilerInterface getOSDefine

    "

!

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.

    KeepIntermediateFiles := false.

    "Modified: / 11-05-2018 / 09:34:34 / stefan"

! !

!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_onError:[:errorFile |

                    self reportCompilationErrorFor:stcPath fromFile:errorFile

                ].

        parserFlags stcKeepSIntermediate ifTrue:[ 

            self compileToS_onError:[:errorFile | ]

        ].

        "/ now compile to machine code

        ok := self 

                compileToObj_onError:[:errorFile |

                    self reportCompilationErrorFor:ccPath, cFlags fromFile:errorFile.

                ].

        originator activityNotification:''.

        "

         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 ifFalse:[ dllFileName asFilename remove ].

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

        ].

        "/ moduleFileName asFilename remove.

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

    ] ensure:[

        KeepIntermediateFiles ifTrue:[ 

            Transcript showCR:'keeping files'

        ] ifFalse:[

            parserFlags stcKeepSTIntermediate ifTrue:[

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

            ] ifFalse:[

                stFileName asFilename remove.

            ].

            cFileName notNil ifTrue:[

                parserFlags stcKeepCIntermediate == true ifTrue:[

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

                ] ifFalse:[

                    cFileName asFilename remove.

                ]

            ].

            oFileName notNil ifTrue:[

                parserFlags stcKeepOIntermediate == true ifTrue:[

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

                ] ifFalse:[

                    oFileName asFilename remove.

                ].

            ].

"/            OperatingSystem isMSDOSlike ifTrue:[

"/                mapFileName notNil ifTrue:[

"/                   mapFileName asFilename remove.

"/                ].

"/                libFileName notNil ifTrue:[

"/                   libFileName asFilename remove.

"/                ].

"/            ].

        ]

    ].

    "

     |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