56 lines
2.2 KiB
Racket
56 lines
2.2 KiB
Racket
#lang racket/base
|
|
(require compiler/cm
|
|
racket/match
|
|
racket/fasl
|
|
racket/serialize)
|
|
|
|
(define prev-uncaught-exception-handler (uncaught-exception-handler))
|
|
(uncaught-exception-handler (lambda (x)
|
|
(when (exn:break? x) (exit 1))
|
|
(prev-uncaught-exception-handler x)))
|
|
|
|
(let ([cmc (make-caching-managed-compile-zo)]
|
|
[worker-id (deserialize (fasl->s-exp (read)))])
|
|
(let loop ()
|
|
(match (read)
|
|
[(list 'DIE) void]
|
|
[(list name dir file)
|
|
(let ([dir (bytes->path dir)]
|
|
[file (bytes->path file)])
|
|
(let ([out-str-port (open-output-string)]
|
|
[err-str-port (open-output-string)])
|
|
(let ([cip (current-input-port)]
|
|
[cop (current-output-port)]
|
|
[cep (current-error-port)])
|
|
(define (send/msg msg)
|
|
(write msg cop)
|
|
(flush-output cop))
|
|
(define (send/resp type)
|
|
(send/msg (list type (get-output-string out-str-port) (get-output-string err-str-port))))
|
|
(define (pp x)
|
|
(fprintf cep "COMPILING ~a ~a ~a ~a\n" worker-id name file x))
|
|
(define (lock-client cmd fn)
|
|
(match cmd
|
|
['lock
|
|
(send/msg (list (list 'LOCK (path->bytes fn)) "" ""))
|
|
(match (read cip)
|
|
[(list 'locked) #t]
|
|
[(list 'compiled) #f])]
|
|
['unlock (send/msg (list (list 'UNLOCK (path->bytes fn)) "" ""))]))
|
|
(with-handlers ([exn:fail? (lambda (x)
|
|
(send/resp (list 'ERROR (exn-message x))))])
|
|
(parameterize ([parallel-lock-client lock-client]
|
|
[current-namespace (make-base-empty-namespace)]
|
|
[current-directory dir]
|
|
[current-load-relative-directory dir]
|
|
[current-input-port (open-input-string "")]
|
|
[current-output-port out-str-port]
|
|
[current-error-port err-str-port]
|
|
;[manager-compile-notify-handler pp]
|
|
)
|
|
|
|
(cmc (build-path dir file)))
|
|
(send/resp 'DONE))))
|
|
(flush-output)
|
|
(loop))])))
|