"

    Copyright (C) 2015-now Jan Vrany

    This code is not an open-source (yet). You may use this code

    for your own experiments and projects, given that:

    * all modification to the code will be sent to the

      original author for inclusion in future releases

    * this is not used in any commercial software

    This license is provisional and may (will) change in

    a future.

"

"{ Package: 'jv:tea/compiler/cli' }"

"{ NameSpace: Smalltalk }"

StandaloneStartup subclass:#TCompilerCommand

	instanceVariableNames:''

	classVariableNames:''

	poolDictionaries:''

	category:'Languages-Tea-Compiler'

!

TCompilerCommand class instanceVariableNames:'debugging includes options'

"

 The following class instance variables are inherited by this class:

	StandaloneStartup - MutexHandle

	Object - 

"

!

!TCompilerCommand class methodsFor:'documentation'!

copyright

"

    Copyright (C) 2015-now Jan Vrany

    This code is not an open-source (yet). You may use this code

    for your own experiments and projects, given that:

    * all modification to the code will be sent to the

      original author for inclusion in future releases

    * this is not used in any commercial software

    This license is provisional and may (will) change in

    a future.

"

! !

!TCompilerCommand class methodsFor:'initialization'!

initialize

    super initialize.

    debugging := Transcript notNil and:[Transcript isView].    

    self setupSignalHandlers.

    "Created: / 06-11-2011 / 22:07:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!TCompilerCommand class methodsFor:'compiling'!

process: files

    "Actually compile files using `options` and `includes`."

    | env ctx compiler units |

    env := TEnvironment new.

    env provider classpath addAll: includes.

    ctx := TCompilerContext new.

    ctx options: options.

    ctx environment: env.

    compiler := TCompiler new.

    compiler context: ctx.

    files isEmpty ifTrue:[ 

        TCompilerError raiseErrorString:'no input files'.

    ].

    units := OrderedCollection new: files size.

    files do:[:filename | 

        | file |

        file := filename asFilename.

        file isRegularFile ifFalse:[ 

            TCompilerError raiseErrorString: ('file does not exist: %1' bindWith: filename).

        ].

        file isReadable ifFalse:[ 

            TCompilerError raiseErrorString: ('file not readable: %1' bindWith: filename).

        ].

        file readingFileDo:[ :stream |

            units add: (TSourceReader read: stream).

        ].

    ].

    files with: units do:[:infile :unit | 

        compiler compile: unit.

        options output isNil ifTrue:[ 

            | outfile |

            outfile := infile asFilename withSuffix: (options emitIR ifTrue:[ 'll' ] ifFalse: [ 'bc' ]).

            self write: ctx llvmModule as: outfile.

            ctx llvmModule: nil.

        ].

    ].

    options output notNil ifTrue:[ 

        self write: ctx llvmModule as: options output.

    ].

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

!

write: anLLVMModule as: aString

    options emitIR ifTrue:[ 

        aString asFilename writingFileDo:[:s|anLLVMModule dumpOn: s].  

    ] ifFalse:[ 

        anLLVMModule writeBitcodeToFile: aString

    ]

    "Created: / 24-09-2015 / 17:06:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!TCompilerCommand class methodsFor:'debugging'!

dumpProcess: aProcess

    Stderr cr; cr

    "Created: / 27-06-2013 / 23:41:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

dumpProcess: aProcess on: aStream

    | ctx |

    aStream cr; cr.

    aStream nextPutAll: '== ['; nextPutAll: aProcess id printString; nextPutAll:'] '; nextPutAll: aProcess name; nextPutAll: ' =='; cr.

    aStream cr.

    aStream nextPutAll: '  State:   '; nextPutAll: aProcess state printString; cr.

    aStream nextPutAll: '  Group:   '; nextPutAll: aProcess processGroupId printString; cr.

    aStream nextPutAll: '  Creator: '; nextPutAll: aProcess processGroupId printString; cr.

    aStream nextPutAll: '  Stack:   '; cr; cr.

    aProcess == Processor activeProcess ifTrue:[ctx := thisContext] ifFalse:[ctx := aProcess suspendedContext].

    [ ctx notNil ] whileTrue:[

        aStream nextPutAll: '  '.

        ctx fullPrintOn: aStream.

        aStream cr.

        ctx := ctx sender.

    ].

    aStream cr.

    "

        self dumpProcess: Processor activeProcess on: Transcript.

    "

    "Created: / 28-06-2013 / 01:00:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 06-06-2014 / 09:14:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

dumpProcesses

    self dumpProcessesOn: Stderr

    "

    self dumpProcessesOn: Transcript.

    "

    "Created: / 27-06-2013 / 23:41:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified (comment): / 28-06-2013 / 01:06:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

dumpProcessesOn: aStream

    Process allInstancesDo:[:process|

        process isDead ifFalse:[

            self dumpProcess: process on: aStream

        ]

    ]

    "Created: / 27-06-2013 / 23:42:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!TCompilerCommand class methodsFor:'defaults'!

allowCoverageMeasurementOption

    ^false "CoverageReport will do that"

    "Created: / 13-01-2012 / 11:48:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

allowDebugOption

    ^true

    "Created: / 21-07-2011 / 09:48:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!TCompilerCommand class methodsFor:'multiple applications support'!

applicationRegistryPath

    "the key under which this application stores its process ID in the registry

     as a collection of path-components.

     i.e. if #('foo' 'bar' 'baz') is returned here, the current applications ID will be stored

     in HKEY_CURRENT_USER\Software\foo\bar\baz\CurrentID.

     (would also be used as a relative path for a temporary lock file under unix).

     Used to detect if another instance of this application is already running."

    ^ #('jv' 'tea' 'compiler')

    "Modified: / 01-09-2015 / 18:33:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

applicationUUID

    "answer an application-specific unique uuid.

     This is used as the name of some exclusive OS-resource, which is used to find out,

     if another instance of this application is already running.

     Under win32, a mutex is used; under unix, an exclusive file in the tempDir could be used."

    ^ '8a084bc0-50cf-11e5-bf6b-606720e43e2c' asUUID

    "Modified: / 01-09-2015 / 18:33:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!TCompilerCommand class methodsFor:'options'!

cmdlineOptionEmitLLVMIR

    ^CmdLineOption new

        long: 'emit-llvm-ir';

        description: 'Emit LLVM IR (.ll) instead of bitcode (.bc)';

        action:[options emitIR: true];

        yourself

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

    "Modified: / 24-09-2015 / 18:46:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

cmdlineOptionOutput

    ^CmdLineOption new

        short: $o;

        long: 'output';

        description: 'Place output in specified file';

        action:[:file | options output: file];

        yourself

    "Created: / 24-09-2015 / 16:32:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!TCompilerCommand class methodsFor:'startup'!

handleSIGTERM

    self dumpProcesses.

    debugging ifFalse:[

        Smalltalk exit:127.

    ].

    "Created: / 27-06-2013 / 23:10:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 28-06-2013 / 01:08:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

handleSIGUSR2

    self dumpProcesses

    "Created: / 27-06-2013 / 23:10:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

setupSignalHandlers

    "On UNIX, this sets up a custom signal handler on SIGUSR2 and SIGTERM that

     dumps stacks on all threads"

    | sigusr2 sigterm |

    OperatingSystem isUNIXlike ifTrue:[

        sigterm := Signal new.

        sigterm handlerBlock: [:ex | self handleSIGTERM].

        OperatingSystem operatingSystemSignal:OperatingSystem sigTERM install: sigterm.

        OperatingSystem enableSignal: OperatingSystem sigTERM.

        sigusr2 := Signal new.

        sigusr2 handlerBlock: [:ex | self handleSIGUSR2].

        OperatingSystem operatingSystemSignal:OperatingSystem sigUSR2 install: sigusr2.

        OperatingSystem enableSignal: OperatingSystem sigUSR2.

    ].

    "

    OperatingSystem sendSignal: OperatingSystem sigUSR2 to: OperatingSystem getProcessId

    "

    "Created: / 27-06-2013 / 20:57:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 28-06-2013 / 01:11:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified (format): / 01-09-2015 / 18:34:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

setupToolsForDebug

    super setupToolsForDebug.

    debugging := true.

    "Created: / 06-11-2011 / 22:06:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

start

    Smalltalk silentLoading: true.

    ^ super start.

    "Created: / 22-01-2014 / 09:17:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

usage

    Stderr nextPutAll:'usage: tc';

           nextPutAll: '[options] [FILE1 [FILE2 [...]]]'; cr.

    Stderr nextPutLine:'Common options:'; cr.

    Stderr nextPutLine:'  --help .................. output this message'.

"/    Stderr nextPutLine:'  --verbose ............... verbose startup'.

"/    Stderr nextPutLine:'  --noBanner .............. no splash screen'.

"/    Stderr nextPutLine:'  --newAppInstance ........ start as its own application process (do not reuse'.

"/    Stderr nextPutLine:'                            a running instance)'.

"/    self allowScriptingOption ifTrue:[

"/        Stderr nextPutLine:'  --scripting portNr ...enable scripting via port (or stdin/stdOut if 0)'.

"/    ].

    self allowDebugOption ifTrue:[

        Stderr nextPutLine:'  --debug ................. enable Debugger'.

    ].

    "/                 '  ......................... '

    Stderr nextPutLine:'  -I<dir> ................. adds <dir> to the list of directories searched for'.

    Stderr nextPutLine:'                            sources'.

    Stderr nextPutLine:'  -o'.

    Stderr nextPutLine:'  --output <file>  ........ place output to file <file>'.

    Stderr nextPutLine:'  --emit-llvm-ir .......... emit LLVM IR (.ll) instead of LLVM bitcode (.bc, default)'.

    debugging ifFalse:[

        Smalltalk exit:1.

    ].

    "

    self usage

    "

    "Created: / 13-01-2012 / 11:48:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 24-09-2015 / 16:35:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

usageForReportClass: class

    | options |

    "/ '.........................' size  25

    options := CmdLineOption optionsFor: class new.

    options := options reject:[:option | 'pF' includes: option short  ].

    options notEmptyOrNil ifTrue:[

        Stderr cr.

        Stderr nextPutAll: class name; nextPutLine:' options:'; cr.

        options do:[:option |                

            | optlen |  

            option short notNil ifTrue:[ 

                Stderr nextPutAll: '  '.

                Stderr nextPut: $-; nextPut: option short; space.

                optlen := 2.

                option hasParam ifTrue:[ 

                    | paramName |

                    paramName := 'val'.

                    Stderr nextPut:$<; nextPutAll: paramName; nextPut:$>; space.

                    optlen := optlen + 3 + paramName size.

                ].

            ].

            option long notNil ifTrue:[ 

                 option short notNil ifTrue:[ 

                    Stderr cr.

                ].

                Stderr nextPutAll: '  --'.

                Stderr nextPutAll: option long.

                optlen := option long size + 2.

                option hasParam ifTrue:[ 

                    | paramName |

                    paramName := 'val'.

                    Stderr nextPut:$=; nextPut:$<; nextPutAll: paramName; nextPut:$>.

                    optlen := optlen + 3 + paramName size.

                ].

                Stderr space.

            ].

            Stderr next: (26 - 1"space" -2"--" - optlen) put: $..    

            Stderr space.

            option description notNil ifTrue:[

                Stderr nextPutAll: option description

            ].

            Stderr cr.

        ]

    ]

    "

    ReportRunner usageForReportClass: TestReport.

    "

    "Created: / 27-05-2014 / 16:42:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 16-06-2014 / 11:25:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!TCompilerCommand class methodsFor:'startup-to be redefined'!

main:argv0

    "Process command line arguments"

    | argv parser i files |

    argv := argv0 asOrderedCollection.

    argv isEmpty ifTrue:[ 

        self usage.

    ].

    argv remove: '--abortOnSEGV' ifAbsent:[nil].

    parser := CmdLineParser new.

    CmdLineOptionError autoload.

    includes := OrderedCollection new.

    options := TCompilerOptions new.

    [

        "/ Parse -I as they cannot be handled by option parser, sigh

        i := 1.

        [ i <= argv size ] whileTrue:[ 

            | option |

            option := argv at: i.

            (option = '-I') ifTrue:[ 

                i = argv size ifTrue:[ 

                    Stderr nextPutAll:'Error: -I must be followed by path'.

                ] ifFalse:[ 

                    includes add: (argv at: i + 1)

                ].

                argv removeAtIndex: i + 1. 

                argv removeAtIndex: i.

            ] ifFalse:[ 

                (option startsWith: '-I') ifTrue:[ 

                    | include |

                    include := option copyFrom: 3.

                    include isEmptyOrNil ifTrue:[ 

                        Stderr nextPutAll:'Error: -I must be followed by path'.

                    ] ifFalse:[ 

                        includes add: include.

                    ].  

                    argv removeAtIndex: i.

                ] ifFalse:[ 

                    i := i + 1.

                ].

            ]

        ].

        files := parser parse: argv for: self.

    ] on:CmdLineOptionError do:[:ex|

        Stderr nextPutLine:'Error when processing options: ', ex description.

        debugging ifFalse:[

            ex suspendedContext fullPrintAllOn: Stderr.

            Stderr nextPutLine:'Exiting'.

            Smalltalk exit:1.

        ] ifTrue:[

            ex pass

        ]

    ].

    debugging ifFalse:[ 

        NoHandlerError emergencyHandler:(NoHandlerError abortingEmergencyHandler)

    ].

    [

        self process: files.

        debugging ifFalse:[

            Smalltalk exit:0.

        ].

    ] on: Error do:[:ex|

        Stderr nextPutAll:'Error when compiling: '.

        Stderr nextPutAll:ex description; cr.

        ex suspendedContext printAllOn:Stderr.

        debugging ifFalse:[

            Smalltalk exit:1.

        ] ifTrue:[

            ex pass

        ]

    ]

    "Modified: / 24-09-2015 / 16:40:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!TCompilerCommand class methodsFor:'documentation'!

version_HG

    ^ '$Changeset: <not expanded> $'

! !

TCompilerCommand initialize!