"

 COPYRIGHT (c) 1989 by Claus Gittinger

 COPYRIGHT (c) 2006 by eXept Software AG

 COPYRIGHT (c) 2015-2016 Jan Vrany

 COPYRIGHT (c) 2018 Jan Vrany

              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

 COPYRIGHT (c) 2015-2016 Jan Vrany

 COPYRIGHT (c) 2018 Jan Vrany

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

    ^ self getCPUDefine , ' ', self getOSDefine , ' ' , self getBuildTargetDefine

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

    "Modified: / 17-01-2018 / 22:23:46 / 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 directory) / 'include' / 'stc.h') exists

              or:[((executablePath := executablePath directory 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>"

    "Modified: / 22-05-2020 / 22:58:03 / 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>"

!

getBuildTargetDefine

    ^ '-DBUILD_TARGET=\"', Smalltalk configuration , '\"'

    "Created: / 17-01-2018 / 22:24:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

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

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

    ].

    ^ 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 notNil ifTrue:[

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

    ^ self 

        compileToMachineCode:aString forClass:aClass selector:selector inCategory:categoryArg 

        notifying:requestorArg install:install skipIfSame:skipIfSame silent:silent

        generateCOnly:false

    "

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

    "Modified: / 16-05-2018 / 13:48:25 / stefan"

!

compileToMachineCode:aString forClass:aClass selector:selector inCategory:categoryArg 

                             notifying:requestorArg install:install skipIfSame:skipIfSame silent:silent

                             generateCOnly:generateCOnly

    "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 not and:[generateCOnly not]) ifTrue:[

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

                ].

        (generateCOnly or:[parserFlags stcKeepSIntermediate]) ifTrue:[ 

            self compileToS_onError:[:errorFile | ]

        ].

        generateCOnly ifTrue:[

            ^ cFileName asFilename

        ].

        "/ 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:[