|
1 " |
|
2 Copyright (C) 2015-now Jan Vrany |
|
3 |
|
4 This code is not an open-source (yet). You may use this code |
|
5 for your own experiments and projects, given that: |
|
6 |
|
7 * all modification to the code will be sent to the |
|
8 original author for inclusion in future releases |
|
9 * this is not used in any commercial software |
|
10 |
|
11 This license is provisional and may (will) change in |
|
12 a future. |
|
13 " |
|
14 "{ Package: 'jv:tea/compiler/cli' }" |
|
15 |
|
16 "{ NameSpace: Smalltalk }" |
|
17 |
|
18 StandaloneStartup subclass:#TCompilerCommand |
|
19 instanceVariableNames:'' |
|
20 classVariableNames:'' |
|
21 poolDictionaries:'' |
|
22 category:'Languages-Tea-Compiler' |
|
23 ! |
|
24 |
|
25 TCompilerCommand class instanceVariableNames:'debugging includes options' |
|
26 |
|
27 " |
|
28 The following class instance variables are inherited by this class: |
|
29 |
|
30 StandaloneStartup - MutexHandle |
|
31 Object - |
|
32 " |
|
33 ! |
|
34 |
|
35 !TCompilerCommand class methodsFor:'documentation'! |
|
36 |
|
37 copyright |
|
38 " |
|
39 Copyright (C) 2015-now Jan Vrany |
|
40 |
|
41 This code is not an open-source (yet). You may use this code |
|
42 for your own experiments and projects, given that: |
|
43 |
|
44 * all modification to the code will be sent to the |
|
45 original author for inclusion in future releases |
|
46 * this is not used in any commercial software |
|
47 |
|
48 This license is provisional and may (will) change in |
|
49 a future. |
|
50 " |
|
51 ! ! |
|
52 |
|
53 !TCompilerCommand class methodsFor:'initialization'! |
|
54 |
|
55 initialize |
|
56 |
|
57 super initialize. |
|
58 debugging := Transcript notNil and:[Transcript isView]. |
|
59 self setupSignalHandlers. |
|
60 |
|
61 "Created: / 06-11-2011 / 22:07:14 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
62 "Modified: / 01-09-2015 / 18:42:09 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
63 ! ! |
|
64 |
|
65 !TCompilerCommand class methodsFor:'compiling'! |
|
66 |
|
67 process: files |
|
68 "Actually compile files using `options` and `includes`." |
|
69 |
|
70 | env ctx compiler units | |
|
71 |
|
72 env := TEnvironment new. |
|
73 env provider classpath addAll: includes. |
|
74 |
|
75 ctx := TCompilerContext new. |
|
76 ctx options: options. |
|
77 ctx environment: env. |
|
78 |
|
79 compiler := TCompiler new. |
|
80 compiler context: ctx. |
|
81 |
|
82 files isEmpty ifTrue:[ |
|
83 TCompilerError raiseErrorString:'no input files'. |
|
84 ]. |
|
85 units := OrderedCollection new: files size. |
|
86 files do:[:filename | |
|
87 | file | |
|
88 |
|
89 file := filename asFilename. |
|
90 file isRegularFile ifFalse:[ |
|
91 TCompilerError raiseErrorString: ('file does not exist: %1' bindWith: filename). |
|
92 ]. |
|
93 file isReadable ifFalse:[ |
|
94 TCompilerError raiseErrorString: ('file not readable: %1' bindWith: filename). |
|
95 ]. |
|
96 file readingFileDo:[ :stream | |
|
97 units add: (TSourceReader read: stream). |
|
98 ]. |
|
99 ]. |
|
100 files with: units do:[:infile :unit | |
|
101 compiler compile: unit. |
|
102 options output isNil ifTrue:[ |
|
103 | outfile | |
|
104 |
|
105 outfile := infile asFilename withSuffix: (options emitIR ifTrue:[ 'll' ] ifFalse: [ 'bc' ]). |
|
106 self write: ctx llvmModule as: outfile. |
|
107 ctx llvmModule: nil. |
|
108 ]. |
|
109 ]. |
|
110 options output notNil ifTrue:[ |
|
111 self write: ctx llvmModule as: options output. |
|
112 ]. |
|
113 |
|
114 "Created: / 24-09-2015 / 16:46:48 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
115 "Modified: / 24-09-2015 / 18:45:53 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
116 ! |
|
117 |
|
118 write: anLLVMModule as: aString |
|
119 options emitIR ifTrue:[ |
|
120 aString asFilename writingFileDo:[:s|anLLVMModule dumpOn: s]. |
|
121 ] ifFalse:[ |
|
122 anLLVMModule writeBitcodeToFile: aString |
|
123 ] |
|
124 |
|
125 "Created: / 24-09-2015 / 17:06:23 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
126 ! ! |
|
127 |
|
128 !TCompilerCommand class methodsFor:'debugging'! |
|
129 |
|
130 dumpProcess: aProcess |
|
131 Stderr cr; cr |
|
132 |
|
133 "Created: / 27-06-2013 / 23:41:15 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
134 ! |
|
135 |
|
136 dumpProcess: aProcess on: aStream |
|
137 | ctx | |
|
138 aStream cr; cr. |
|
139 aStream nextPutAll: '== ['; nextPutAll: aProcess id printString; nextPutAll:'] '; nextPutAll: aProcess name; nextPutAll: ' =='; cr. |
|
140 aStream cr. |
|
141 aStream nextPutAll: ' State: '; nextPutAll: aProcess state printString; cr. |
|
142 aStream nextPutAll: ' Group: '; nextPutAll: aProcess processGroupId printString; cr. |
|
143 aStream nextPutAll: ' Creator: '; nextPutAll: aProcess processGroupId printString; cr. |
|
144 aStream nextPutAll: ' Stack: '; cr; cr. |
|
145 |
|
146 aProcess == Processor activeProcess ifTrue:[ctx := thisContext] ifFalse:[ctx := aProcess suspendedContext]. |
|
147 [ ctx notNil ] whileTrue:[ |
|
148 aStream nextPutAll: ' '. |
|
149 ctx fullPrintOn: aStream. |
|
150 aStream cr. |
|
151 ctx := ctx sender. |
|
152 ]. |
|
153 aStream cr. |
|
154 |
|
155 " |
|
156 self dumpProcess: Processor activeProcess on: Transcript. |
|
157 " |
|
158 |
|
159 "Created: / 28-06-2013 / 01:00:35 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
160 "Modified: / 06-06-2014 / 09:14:23 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
161 ! |
|
162 |
|
163 dumpProcesses |
|
164 self dumpProcessesOn: Stderr |
|
165 |
|
166 " |
|
167 self dumpProcessesOn: Transcript. |
|
168 " |
|
169 |
|
170 "Created: / 27-06-2013 / 23:41:15 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
171 "Modified (comment): / 28-06-2013 / 01:06:40 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
172 ! |
|
173 |
|
174 dumpProcessesOn: aStream |
|
175 Process allInstancesDo:[:process| |
|
176 process isDead ifFalse:[ |
|
177 self dumpProcess: process on: aStream |
|
178 ] |
|
179 ] |
|
180 |
|
181 "Created: / 27-06-2013 / 23:42:21 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
182 ! ! |
|
183 |
|
184 !TCompilerCommand class methodsFor:'defaults'! |
|
185 |
|
186 allowCoverageMeasurementOption |
|
187 |
|
188 ^false "CoverageReport will do that" |
|
189 |
|
190 "Created: / 13-01-2012 / 11:48:40 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
191 ! |
|
192 |
|
193 allowDebugOption |
|
194 |
|
195 ^true |
|
196 |
|
197 "Created: / 21-07-2011 / 09:48:21 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
198 ! ! |
|
199 |
|
200 !TCompilerCommand class methodsFor:'multiple applications support'! |
|
201 |
|
202 applicationRegistryPath |
|
203 "the key under which this application stores its process ID in the registry |
|
204 as a collection of path-components. |
|
205 i.e. if #('foo' 'bar' 'baz') is returned here, the current applications ID will be stored |
|
206 in HKEY_CURRENT_USER\Software\foo\bar\baz\CurrentID. |
|
207 (would also be used as a relative path for a temporary lock file under unix). |
|
208 Used to detect if another instance of this application is already running." |
|
209 |
|
210 ^ #('jv' 'tea' 'compiler') |
|
211 |
|
212 "Modified: / 01-09-2015 / 18:33:12 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
213 ! |
|
214 |
|
215 applicationUUID |
|
216 "answer an application-specific unique uuid. |
|
217 This is used as the name of some exclusive OS-resource, which is used to find out, |
|
218 if another instance of this application is already running. |
|
219 Under win32, a mutex is used; under unix, an exclusive file in the tempDir could be used." |
|
220 |
|
221 ^ '8a084bc0-50cf-11e5-bf6b-606720e43e2c' asUUID |
|
222 |
|
223 "Modified: / 01-09-2015 / 18:33:26 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
224 ! ! |
|
225 |
|
226 !TCompilerCommand class methodsFor:'options'! |
|
227 |
|
228 cmdlineOptionEmitLLVMIR |
|
229 ^CmdLineOption new |
|
230 long: 'emit-llvm-ir'; |
|
231 description: 'Emit LLVM IR (.ll) instead of bitcode (.bc)'; |
|
232 action:[options emitIR: true]; |
|
233 yourself |
|
234 |
|
235 "Created: / 24-09-2015 / 16:35:13 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
236 "Modified: / 24-09-2015 / 18:46:33 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
237 ! |
|
238 |
|
239 cmdlineOptionOutput |
|
240 ^CmdLineOption new |
|
241 short: $o; |
|
242 long: 'output'; |
|
243 description: 'Place output in specified file'; |
|
244 action:[:file | options output: file]; |
|
245 yourself |
|
246 |
|
247 "Created: / 24-09-2015 / 16:32:26 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
248 ! ! |
|
249 |
|
250 !TCompilerCommand class methodsFor:'startup'! |
|
251 |
|
252 handleSIGTERM |
|
253 self dumpProcesses. |
|
254 debugging ifFalse:[ |
|
255 Smalltalk exit:127. |
|
256 ]. |
|
257 |
|
258 "Created: / 27-06-2013 / 23:10:48 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
259 "Modified: / 28-06-2013 / 01:08:03 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
260 ! |
|
261 |
|
262 handleSIGUSR2 |
|
263 self dumpProcesses |
|
264 |
|
265 "Created: / 27-06-2013 / 23:10:48 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
266 ! |
|
267 |
|
268 setupSignalHandlers |
|
269 "On UNIX, this sets up a custom signal handler on SIGUSR2 and SIGTERM that |
|
270 dumps stacks on all threads" |
|
271 |
|
272 | sigusr2 sigterm | |
|
273 |
|
274 OperatingSystem isUNIXlike ifTrue:[ |
|
275 sigterm := Signal new. |
|
276 sigterm handlerBlock: [:ex | self handleSIGTERM]. |
|
277 OperatingSystem operatingSystemSignal:OperatingSystem sigTERM install: sigterm. |
|
278 OperatingSystem enableSignal: OperatingSystem sigTERM. |
|
279 |
|
280 sigusr2 := Signal new. |
|
281 sigusr2 handlerBlock: [:ex | self handleSIGUSR2]. |
|
282 OperatingSystem operatingSystemSignal:OperatingSystem sigUSR2 install: sigusr2. |
|
283 OperatingSystem enableSignal: OperatingSystem sigUSR2. |
|
284 ]. |
|
285 |
|
286 " |
|
287 OperatingSystem sendSignal: OperatingSystem sigUSR2 to: OperatingSystem getProcessId |
|
288 " |
|
289 |
|
290 "Created: / 27-06-2013 / 20:57:09 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
291 "Modified: / 28-06-2013 / 01:11:04 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
292 "Modified (format): / 01-09-2015 / 18:34:09 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
293 ! |
|
294 |
|
295 setupToolsForDebug |
|
296 |
|
297 super setupToolsForDebug. |
|
298 debugging := true. |
|
299 |
|
300 "Created: / 06-11-2011 / 22:06:19 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
301 ! |
|
302 |
|
303 start |
|
304 Smalltalk silentLoading: true. |
|
305 ^ super start. |
|
306 |
|
307 "Created: / 22-01-2014 / 09:17:12 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
308 ! |
|
309 |
|
310 usage |
|
311 |
|
312 Stderr nextPutAll:'usage: tc'; |
|
313 nextPutAll: '[options] [FILE1 [FILE2 [...]]]'; cr. |
|
314 |
|
315 Stderr nextPutLine:'Common options:'; cr. |
|
316 |
|
317 Stderr nextPutLine:' --help .................. output this message'. |
|
318 "/ Stderr nextPutLine:' --verbose ............... verbose startup'. |
|
319 "/ Stderr nextPutLine:' --noBanner .............. no splash screen'. |
|
320 "/ Stderr nextPutLine:' --newAppInstance ........ start as its own application process (do not reuse'. |
|
321 "/ Stderr nextPutLine:' a running instance)'. |
|
322 "/ self allowScriptingOption ifTrue:[ |
|
323 "/ Stderr nextPutLine:' --scripting portNr ...enable scripting via port (or stdin/stdOut if 0)'. |
|
324 "/ ]. |
|
325 self allowDebugOption ifTrue:[ |
|
326 Stderr nextPutLine:' --debug ................. enable Debugger'. |
|
327 ]. |
|
328 "/ ' ......................... ' |
|
329 Stderr nextPutLine:' -I<dir> ................. adds <dir> to the list of directories searched for'. |
|
330 Stderr nextPutLine:' sources'. |
|
331 Stderr nextPutLine:' -o'. |
|
332 Stderr nextPutLine:' --output <file> ........ place output to file <file>'. |
|
333 Stderr nextPutLine:' --emit-llvm-ir .......... emit LLVM IR (.ll) instead of LLVM bitcode (.bc, default)'. |
|
334 debugging ifFalse:[ |
|
335 Smalltalk exit:1. |
|
336 ]. |
|
337 " |
|
338 self usage |
|
339 " |
|
340 |
|
341 "Created: / 13-01-2012 / 11:48:07 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
342 "Modified: / 24-09-2015 / 16:35:58 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
343 ! |
|
344 |
|
345 usageForReportClass: class |
|
346 | options | |
|
347 |
|
348 "/ '.........................' size 25 |
|
349 options := CmdLineOption optionsFor: class new. |
|
350 options := options reject:[:option | 'pF' includes: option short ]. |
|
351 options notEmptyOrNil ifTrue:[ |
|
352 Stderr cr. |
|
353 Stderr nextPutAll: class name; nextPutLine:' options:'; cr. |
|
354 options do:[:option | |
|
355 | optlen | |
|
356 |
|
357 option short notNil ifTrue:[ |
|
358 Stderr nextPutAll: ' '. |
|
359 Stderr nextPut: $-; nextPut: option short; space. |
|
360 optlen := 2. |
|
361 option hasParam ifTrue:[ |
|
362 | paramName | |
|
363 |
|
364 paramName := 'val'. |
|
365 Stderr nextPut:$<; nextPutAll: paramName; nextPut:$>; space. |
|
366 optlen := optlen + 3 + paramName size. |
|
367 ]. |
|
368 ]. |
|
369 option long notNil ifTrue:[ |
|
370 option short notNil ifTrue:[ |
|
371 Stderr cr. |
|
372 ]. |
|
373 Stderr nextPutAll: ' --'. |
|
374 Stderr nextPutAll: option long. |
|
375 optlen := option long size + 2. |
|
376 option hasParam ifTrue:[ |
|
377 | paramName | |
|
378 |
|
379 paramName := 'val'. |
|
380 Stderr nextPut:$=; nextPut:$<; nextPutAll: paramName; nextPut:$>. |
|
381 optlen := optlen + 3 + paramName size. |
|
382 ]. |
|
383 Stderr space. |
|
384 ]. |
|
385 Stderr next: (26 - 1"space" -2"--" - optlen) put: $.. |
|
386 Stderr space. |
|
387 option description notNil ifTrue:[ |
|
388 Stderr nextPutAll: option description |
|
389 ]. |
|
390 Stderr cr. |
|
391 ] |
|
392 ] |
|
393 |
|
394 " |
|
395 ReportRunner usageForReportClass: TestReport. |
|
396 " |
|
397 |
|
398 "Created: / 27-05-2014 / 16:42:27 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
399 "Modified: / 16-06-2014 / 11:25:36 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
400 ! ! |
|
401 |
|
402 !TCompilerCommand class methodsFor:'startup-to be redefined'! |
|
403 |
|
404 main:argv0 |
|
405 "Process command line arguments" |
|
406 |
|
407 | argv parser i files | |
|
408 |
|
409 |
|
410 argv := argv0 asOrderedCollection. |
|
411 argv isEmpty ifTrue:[ |
|
412 self usage. |
|
413 ]. |
|
414 argv remove: '--abortOnSEGV' ifAbsent:[nil]. |
|
415 parser := CmdLineParser new. |
|
416 CmdLineOptionError autoload. |
|
417 includes := OrderedCollection new. |
|
418 options := TCompilerOptions new. |
|
419 [ |
|
420 "/ Parse -I as they cannot be handled by option parser, sigh |
|
421 i := 1. |
|
422 [ i <= argv size ] whileTrue:[ |
|
423 | option | |
|
424 |
|
425 option := argv at: i. |
|
426 (option = '-I') ifTrue:[ |
|
427 i = argv size ifTrue:[ |
|
428 Stderr nextPutAll:'Error: -I must be followed by path'. |
|
429 ] ifFalse:[ |
|
430 includes add: (argv at: i + 1) |
|
431 ]. |
|
432 argv removeAtIndex: i + 1. |
|
433 argv removeAtIndex: i. |
|
434 ] ifFalse:[ |
|
435 (option startsWith: '-I') ifTrue:[ |
|
436 | include | |
|
437 |
|
438 include := option copyFrom: 3. |
|
439 include isEmptyOrNil ifTrue:[ |
|
440 Stderr nextPutAll:'Error: -I must be followed by path'. |
|
441 ] ifFalse:[ |
|
442 includes add: include. |
|
443 ]. |
|
444 argv removeAtIndex: i. |
|
445 ] ifFalse:[ |
|
446 i := i + 1. |
|
447 ]. |
|
448 ] |
|
449 ]. |
|
450 files := parser parse: argv for: self. |
|
451 ] on:CmdLineOptionError do:[:ex| |
|
452 Stderr nextPutLine:'Error when processing options: ', ex description. |
|
453 debugging ifFalse:[ |
|
454 ex suspendedContext fullPrintAllOn: Stderr. |
|
455 Stderr nextPutLine:'Exiting'. |
|
456 Smalltalk exit:1. |
|
457 ] ifTrue:[ |
|
458 ex pass |
|
459 ] |
|
460 ]. |
|
461 |
|
462 debugging ifFalse:[ |
|
463 NoHandlerError emergencyHandler:(NoHandlerError abortingEmergencyHandler) |
|
464 ]. |
|
465 |
|
466 [ |
|
467 self process: files. |
|
468 debugging ifFalse:[ |
|
469 Smalltalk exit:0. |
|
470 ]. |
|
471 ] on: Error do:[:ex| |
|
472 Stderr nextPutAll:'Error when compiling: '. |
|
473 Stderr nextPutAll:ex description; cr. |
|
474 ex suspendedContext printAllOn:Stderr. |
|
475 debugging ifFalse:[ |
|
476 Smalltalk exit:1. |
|
477 ] ifTrue:[ |
|
478 ex pass |
|
479 ] |
|
480 ] |
|
481 |
|
482 "Modified: / 24-09-2015 / 16:40:46 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
483 ! ! |
|
484 |
|
485 |
|
486 TCompilerCommand initialize! |