├── .github ├── FUNDING.yml └── workflows │ ├── deploy-docs.yml │ └── ci.yml ├── .gitignore ├── loci ├── info.rkt ├── main.rkt ├── private │ ├── loci-log.rkt │ ├── locus-transferable_gen.rkt │ ├── locus_gen.rkt │ ├── path.rkt │ ├── utils.rkt │ ├── locus-channel.rkt │ └── locus-local.rkt └── scribblings │ └── loci.scrbl ├── info.rkt ├── test ├── test_locus-print.rkt ├── test_locus-error.rkt ├── test_locus-context.rkt └── test_locus-messaging.rkt ├── README.md └── LICENSE /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | github: pmatos 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore temps 2 | *~ 3 | 4 | # Ignore compiled zo files 5 | compiled/ -------------------------------------------------------------------------------- /loci/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "loci") 4 | (define scribblings '(("scribblings/loci.scrbl" ()))) 5 | -------------------------------------------------------------------------------- /loci/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; --------------------------------------------------------------------------------------------------- 3 | 4 | (require "private/locus-local.rkt") 5 | (provide (all-from-out "private/locus-local.rkt")) 6 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define pkg-desc "Racket parallel code execution as separate OS processes") 6 | (define version "0.1") 7 | (define pkg-authors '(pmatos)) 8 | 9 | (define deps '("base" "unix-socket-lib")) 10 | (define build-deps '("scribble-lib" "racket-doc" "rackunit-lib" "unix-socket-lib")) 11 | (define compile-omit-paths '("tests")) 12 | -------------------------------------------------------------------------------- /test/test_locus-print.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;; --------------------------------------------------------------------------------------------------- 3 | 4 | (require loci) 5 | 6 | ;; --------------------------------------------------------------------------------------------------- 7 | 8 | (define (go) 9 | (printf "Hello World from Locus~n")) 10 | 11 | (define (main) 12 | (define l 13 | (locus ch 14 | (go))) 15 | (locus-wait l)) 16 | 17 | (module+ main 18 | (printf "starting up~n") 19 | (main)) 20 | -------------------------------------------------------------------------------- /test/test_locus-error.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;; --------------------------------------------------------------------------------------------------- 3 | 4 | (require loci) 5 | 6 | ;; --------------------------------------------------------------------------------------------------- 7 | 8 | (define (go) 9 | (locus l 10 | (printf "Testing stdout") 11 | (fprintf (current-error-port) "Testing stderr") 12 | (error 'go "locus failed on purpose"))) 13 | 14 | (module+ main 15 | 16 | (printf "Starting core~n") 17 | (define r (locus-wait (go))) 18 | (printf "Locus finished with ~a~n" r) 19 | (exit r)) 20 | -------------------------------------------------------------------------------- /loci/private/loci-log.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; --------------------------------------------------------------------------------------------------- 3 | 4 | (require (for-syntax racket/base) 5 | racket/os) 6 | 7 | (provide log-debug) 8 | 9 | ;; --------------------------------------------------------------------------------------------------- 10 | 11 | ;; Locus Logger 12 | (define-logger loci) 13 | (error-print-width 1024) 14 | 15 | (define-syntax (log-debug stx) 16 | (syntax-case stx () 17 | [(_ msg) 18 | #'(log-loci-debug (string-append "[~a]: " msg) (getpid))] 19 | [(_ msg as ...) 20 | #'(log-loci-debug (string-append "[~a]: " msg) (getpid) as ...)])) 21 | -------------------------------------------------------------------------------- /loci/private/locus-transferable_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; --------------------------------------------------------------------------------------------------- 3 | 4 | (require racket/generic) 5 | 6 | (provide gen:locus-transferable 7 | locus-transferable/c 8 | locus-transferable? 9 | byte-encode 10 | byte-decode) 11 | 12 | ;; --------------------------------------------------------------------------------------------------- 13 | 14 | ;; A locus transferable is any message that can be sent accross a locus channel 15 | ;; Any such message needs to implement the locus-transferable methods 16 | (define-generics locus-transferable 17 | (byte-encode locus-transferable) 18 | (byte-decode locus-transferable)) 19 | -------------------------------------------------------------------------------- /loci/private/locus_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; --------------------------------------------------------------------------------------------------- 3 | 4 | (require racket/generic) 5 | 6 | 7 | (provide gen:locus 8 | locus/c 9 | locus? 10 | locus-pid 11 | locus-wait 12 | locus-running? 13 | locus-exit-code 14 | locus-kill) 15 | 16 | ;; --------------------------------------------------------------------------------------------------- 17 | 18 | ;; A locus wraps a call to a subprocess, whose executable is the racket 19 | ;; executable that's running when the call is made 20 | (define-generics locus 21 | (locus-pid locus) 22 | (locus-wait locus) 23 | (locus-running? locus) 24 | (locus-exit-code locus) 25 | (locus-kill locus)) 26 | -------------------------------------------------------------------------------- /test/test_locus-context.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;; --------------------------------------------------------------------------------------------------- 3 | 4 | (require loci) 5 | 6 | ;; --------------------------------------------------------------------------------------------------- 7 | 8 | (define (go n) 9 | (locus/context l 10 | (let ([v (vector 0.0)]) 11 | (let loop ([i 3000000000]) 12 | (unless (zero? i) 13 | (vector-set! v 0 (+ (vector-ref v 0) 1.0)) 14 | (loop (sub1 i))))) 15 | (printf "Locus ~a done~n" n) 16 | n)) 17 | 18 | (module+ main 19 | 20 | (define cores 21 | (command-line 22 | #:args (cores) 23 | (string->number cores))) 24 | 25 | (time 26 | (map locus-wait 27 | (for/list ([i (in-range cores)]) 28 | (printf "Starting core ~a~n" i) 29 | (go i))))) 30 | -------------------------------------------------------------------------------- /loci/private/path.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; --------------------------------------------------------------------------------------------------- 3 | 4 | (require racket/match 5 | racket/path 6 | syntax/modresolve) 7 | 8 | (provide mod->bytes bytes->mod) 9 | 10 | ;; --------------------------------------------------------------------------------------------------- 11 | 12 | ;; In order to send the module path through the channel we need to serialize and 13 | ;; deserialize paths. So we use bytes for serialization. 14 | (define (mod->bytes mod-path) 15 | (match (resolve-module-path-index (module-path-index-join mod-path #false)) 16 | [`(submod ,(? path? ps) ,ss ...) 17 | `(submod ,(path->bytes ps) ,@ss)] 18 | [`(submod ,(? symbol? ps) ,ss ...) 19 | `(submod ,ps ,@ss)] 20 | [(? path? p) (path->bytes p)] 21 | [(? symbol? s) s])) 22 | 23 | ;; We need this to be called on the remote side to massage the received value 24 | (define (bytes->mod mod-path) 25 | (match mod-path 26 | [`(submod ,(? bytes? p) ,ss ...) 27 | `(submod ,(bytes->path p) ,@ss)] 28 | [`(submod ,(? symbol? s) ,ss ...) 29 | `(submod ,s ,@ss)] 30 | [(? bytes? p) (bytes->path p)] 31 | [(? symbol? s) s])) 32 | -------------------------------------------------------------------------------- /.github/workflows/deploy-docs.yml: -------------------------------------------------------------------------------- 1 | name: Deploy Documentation 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | 8 | jobs: 9 | deploy: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - name: Checkout 🛎️ 13 | uses: actions/checkout@v2.3.1 # If you're using actions/checkout@v2 you must set persist-credentials to false in most cases for the deployment to work correctly. 14 | with: 15 | persist-credentials: false 16 | - uses: Bogdanp/setup-racket@v0.10 17 | with: 18 | architecture: 'x64' 19 | distribution: 'full' 20 | variant: 'CS' 21 | version: 'current' 22 | - name: Install package locally 23 | run: raco pkg install --auto --link -D loci 24 | - name: Build docs 25 | run: raco scribble --html --dest documentation --dest-name index loci/scribblings/loci.scrbl 26 | - name: Install SSH Client 🔑 27 | uses: webfactory/ssh-agent@v0.2.0 28 | with: 29 | ssh-private-key: ${{ secrets.DEPLOY_KEY }} 30 | 31 | - name: Deploy 🚀 32 | uses: JamesIves/github-pages-deploy-action@3.5.9 33 | with: 34 | SSH: true 35 | BRANCH: gh-pages # The branch the action should deploy to. 36 | FOLDER: documentation # The folder the action should deploy. 37 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![CI](https://github.com/pmatos/racket-loci/workflows/CI/badge.svg?branch=master)](https://github.com/pmatos/racket-loci/actions) 2 | [![Scribble](https://img.shields.io/badge/Docs-Scribble-blue.svg)](https://pmatos.github.io/racket-loci) 3 | 4 | # racket-loci 5 | 6 | Implementation of local and remote loci for Racket. 7 | 8 | > **locus** (noun) 9 | > pl. *loci* 10 | > 11 | > Definition of locus 12 | > 1. the place where something is situated or occurs 13 | > 14 | > from [Merriam-Webster Dictionary](https://www.merriam-webster.com/dictionary/locus) 15 | 16 | This library implements `loci`, which resemble racket `places` but do not have the same problematic behaviour as `places` when used on many-core machines. `places` are based on OS threads, while `loci` are based on OS processes. The reason to implement `loci` is that `places` do not scale above 12 core machines due to memory allocation locking. More information can be found in the [mailing list](https://groups.google.com/d/msg/racket-users/oE72JfIKDO4/zbFI6knhAQAJ). 17 | 18 | A `locus` is a distinct racket instance running on a different process communicating via OS pipes. Hopefully there will be more documentation soon... this is still the early stages and this library **is not yet usable**. Happy to receive questions, comments, complaints and pull requests. 19 | 20 | Most of this work was inspired on the implementation of racket places from which ideas and code were copied shamelessly. Thanks to the original authors. 21 | 22 | ## Future Work 23 | 24 | * Implement remote loci 25 | 26 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | test: 7 | runs-on: ${{ matrix.os }} 8 | 9 | strategy: 10 | matrix: 11 | os: [ubuntu-18.04, macos-latest] 12 | racket-version: ['7.0', '7.1', '7.2', '7.3', '7.4', '7.5', '7.6', '7.7', '7.8', 'current'] 13 | variant: ['regular', 'CS'] 14 | exclude: 15 | - racket-version: '7.0' 16 | variant: 'CS' 17 | - racket-version: '7.1' 18 | variant: 'CS' 19 | - racket-version: '7.2' 20 | variant: 'CS' 21 | - racket-version: '7.3' 22 | variant: 'CS' 23 | 24 | name: Racket ${{ matrix.racket-version }} [ ${{ matrix.variant }} ] / ${{ matrix.os }} 25 | steps: 26 | - uses: actions/checkout@master 27 | - name: Setup Racket 28 | uses: Bogdanp/setup-racket@v0.10 29 | with: 30 | architecture: x64 31 | version: ${{ matrix.racket-version }} 32 | variant: ${{ matrix.variant }} 33 | - name: Install 34 | run: raco pkg install --link -n loci 35 | - name: Test (expect success) 36 | run: | 37 | racket test/test_locus-context.rkt 4 38 | racket test/test_locus-messaging.rkt 1 10 39 | racket test/test_locus-messaging.rkt 2 10 40 | racket test/test_locus-messaging.rkt 10 10 41 | racket test/test_locus-messaging.rkt 15 10 42 | racket test/test_locus-messaging.rkt 10 20 43 | racket test/test_locus-print.rkt 44 | - name: Test (expect failure) 45 | run: | 46 | ! racket test/test_locus-error.rkt 47 | 48 | 49 | -------------------------------------------------------------------------------- /loci/private/utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; --------------------------------------------------------------------------------------------------- 3 | 4 | (require racket/contract) 5 | 6 | (provide 7 | (contract-out 8 | [copy-port (->* (input-port? output-port? #:flush? boolean?) #:rest (listof output-port?) void?)])) 9 | 10 | ;; --------------------------------------------------------------------------------------------------- 11 | 12 | (define (copy-port src dest #:flush? [flush? #false] . dests*) 13 | (unless (input-port? src) 14 | (raise-type-error 'copy-port "input-port" src)) 15 | (for-each 16 | (lambda (dest) 17 | (unless (output-port? dest) 18 | (raise-type-error 'copy-port "output-port" dest))) 19 | (cons dest dests*)) 20 | 21 | (define sz 4096) 22 | (define s (make-bytes sz)) 23 | (define dests (cons dest dests*)) 24 | 25 | (let loop () 26 | (define c (read-bytes-avail! s src)) 27 | (cond 28 | [(number? c) 29 | (for ([dest (in-list dests)]) 30 | (let write-loop ([bytes-written 0]) 31 | (unless (= bytes-written c) 32 | (define c2 (write-bytes-avail s dest bytes-written c)) 33 | (when flush? 34 | (flush-output dest)) 35 | (write-loop (+ bytes-written c2))))) 36 | (loop)] 37 | [(procedure? c) 38 | (define-values (l col p) (port-next-location src)) 39 | (define v (c (object-name src) l col p)) 40 | (for ([dest (in-list dests)]) 41 | (write-special v dest) 42 | (when flush? 43 | (flush-output dest))) 44 | (loop)] 45 | [else 46 | ;; Must be EOF 47 | (void)]))) 48 | -------------------------------------------------------------------------------- /loci/private/locus-channel.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; --------------------------------------------------------------------------------------------------- 3 | 4 | (require racket/contract 5 | racket/fasl 6 | racket/serialize) 7 | 8 | (provide 9 | (contract-out 10 | [struct locus-channel ((in input-port?) 11 | (out output-port?))] 12 | [locus-channel-put (locus-channel? locus-message-allowed? . -> . void?)] 13 | [locus-channel-get (locus-channel? . -> . locus-message-allowed?)] 14 | [locus-message-allowed? (any/c . -> . boolean?)])) 15 | 16 | ;; --------------------------------------------------------------------------------------------------- 17 | 18 | ;; A locus channel consists of two file-streams to communicate with the locus 19 | ;; in is connected to the locus stdout 20 | ;; out is connected to the locus stdin 21 | ;; therefore one reads from in and writes to out 22 | (struct locus-channel (in out) 23 | #:property prop:evt 24 | (lambda (s) 25 | (wrap-evt (locus-channel-in s) 26 | (lambda (ch) (locus-channel-get s))))) 27 | 28 | (define (locus-channel-put ch datum) 29 | (define out (locus-channel-out ch)) 30 | (s-exp->fasl datum out) 31 | (flush-output out)) 32 | 33 | (define (locus-channel-get ch) 34 | (fasl->s-exp (locus-channel-in ch))) 35 | 36 | (define (locus-message-allowed? v) 37 | (or (char? v) 38 | (void? v) 39 | (number? v) 40 | (eof-object? v) 41 | (symbol? v) 42 | (keyword? v) 43 | (string? v) 44 | (bytes? v) 45 | (path? v) 46 | (null? v) 47 | (boolean? v) 48 | (and (pair? v) 49 | (locus-message-allowed? (car v)) 50 | (locus-message-allowed? (cdr v))) 51 | (and (vector? v) 52 | (for/and ([i (in-vector v)]) 53 | (locus-message-allowed? i))) 54 | (and (hash? v) 55 | (for/and ([(k i) (in-hash v)]) 56 | (and (locus-message-allowed? k) 57 | (locus-message-allowed? i)))) 58 | (and (box? v) 59 | (locus-message-allowed? (unbox v))) 60 | (and (prefab-struct-key v) #true))) 61 | -------------------------------------------------------------------------------- /test/test_locus-messaging.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;; --------------------------------------------------------------------------------------------------- 3 | 4 | (require loci 5 | racket/serialize) 6 | 7 | ;; --------------------------------------------------------------------------------------------------- 8 | 9 | (struct msg-id 10 | (worker-id) 11 | #:prefab) 12 | (struct compute-v 13 | (sender v) 14 | #:prefab) 15 | (struct ask-factorial 16 | (sender v) 17 | #:prefab) 18 | (struct answer-factorial 19 | (sender v fact-v) 20 | #:prefab) 21 | (struct worker-done 22 | (sender) 23 | #:prefab) 24 | 25 | (define (igensym) 26 | (string->symbol 27 | (symbol->string 28 | (gensym)))) 29 | 30 | ;; Test of loci calculating the factorial of every number between 0 - 100 31 | ;; except that they won't calculate a factorial if it's already done, so they ask the 32 | ;; master first to see if the master knows the answer first. 33 | (define (worker-factorial-go ch) 34 | (printf "worker-factorial-go~n") 35 | 36 | ;; Get id 37 | (define id 38 | (match (locus-channel-get ch) 39 | [(struct msg-id (id)) id] 40 | [m (error 'worker-factorial-go "unexpected message, expected msg-id, got: ~a" m)])) 41 | (printf "worker ~a here~n" id) 42 | 43 | ;; Get value 44 | (define v 45 | (match (locus-channel-get ch) 46 | [(struct compute-v (_ v)) v] 47 | [m (error 'worker-factorial-go "unexpected message, expected compute-v, got: ~a" m)])) 48 | 49 | (define factorial 50 | (compute-factorial id ch v)) 51 | 52 | (locus-channel-put ch (answer-factorial id v factorial)) 53 | (locus-channel-put ch (worker-done id))) 54 | 55 | (define (compute-factorial id ch v) 56 | (printf "compute-factorial ~a ~a~n" id v) 57 | 58 | ;; Ask master for the factorial of v 59 | (define v-fact (locus-channel-put/get ch (ask-factorial id v))) 60 | 61 | (match v-fact 62 | [(struct answer-factorial (_ _ #false)) (* v (compute-factorial id ch (- v 1)))] 63 | [(struct answer-factorial (_ _ f)) f] 64 | [m (error 'compute-factorial "unexpected message, expected answer-factorial, got: ~a" m)])) 65 | 66 | (define (print-factorial-table table) 67 | (for ([i (range 1 (add1 (hash-count table)))]) 68 | (printf "~a ~a~n" i (hash-ref table i)))) 69 | 70 | (define (main cores* N) 71 | (define cores (min cores* N)) 72 | (define cache (make-hasheq (list (cons 1 1)))) 73 | 74 | (define workers 75 | (for/hasheq ([i (range cores)]) 76 | (values (igensym) (locus ch (worker-factorial-go ch))))) 77 | 78 | (define work (shuffle (range 1 (add1 N)))) 79 | (define-values (work-now work-later) 80 | (split-at work cores)) 81 | 82 | ;; Send initial message to all 83 | (for ([(id w) (in-hash workers)] 84 | [v (in-list work-now)]) 85 | (locus-channel-put w (msg-id id)) 86 | (locus-channel-put w (compute-v 'master v))) 87 | 88 | (let loop ([active-workers workers] 89 | [remaining-work work-later]) 90 | 91 | (printf "Remaining workers: ~a~n" active-workers) 92 | (printf "Remaining work: ~a~n" remaining-work) 93 | (printf "cache: ~a~n" cache) 94 | 95 | (cond 96 | [(and (null? remaining-work) 97 | (hash-empty? active-workers)) 98 | (printf "All done~n") 99 | (print-factorial-table cache)] 100 | [else 101 | ; like locus-dead-evt but whose sync value 102 | ; is the dead locus 103 | (define evt-dead 104 | (lambda (p) 105 | (wrap-evt (locus-dead-evt p) 106 | (lambda (v) p)))) 107 | 108 | (sync 109 | (handle-evt 110 | (apply choice-evt (map evt-dead (hash-values active-workers))) 111 | (lambda (l) 112 | (printf "A locus died~n") 113 | (if (zero? (locus-wait l)) 114 | (loop active-workers remaining-work) 115 | (error "Locus died unexpectedly with result" (locus-wait l))))) 116 | 117 | (handle-evt 118 | (apply choice-evt (hash-values active-workers)) 119 | (match-lambda 120 | [(struct ask-factorial (w v)) 121 | (printf "Worker asking for ~a!~n" v) 122 | (cond 123 | [(hash-ref cache v #false) 124 | => (lambda (f) 125 | (printf "master knows ~a! = ~a~n" v f) 126 | (locus-channel-put (hash-ref active-workers w) 127 | (answer-factorial 'master v f)))] 128 | [else 129 | (printf "master does not know ~a!~n" v) 130 | (locus-channel-put (hash-ref active-workers w) 131 | (answer-factorial 'master v #false))]) 132 | (loop active-workers remaining-work)] 133 | 134 | [(struct answer-factorial (w v f)) 135 | (printf "Worker giving factorial answer ~a! = ~a~n" v f) 136 | (hash-set! cache v f) 137 | 138 | (match (locus-channel-get (hash-ref active-workers w)) 139 | [(struct worker-done (wid)) 140 | (when (not (eq? wid w)) 141 | (error "expected some id from done worker")) 142 | (define r (locus-wait (hash-ref active-workers w))) 143 | (printf "Worker ~a is finished with status: ~a~n" w r)] 144 | [_ (error "unexpected message from worker before finish")]) 145 | 146 | (cond 147 | [(null? remaining-work) (loop (hash-remove active-workers w) '())] 148 | [else 149 | (define new-locus (locus ch (worker-factorial-go ch))) 150 | (define id (igensym)) 151 | (locus-channel-put new-locus (msg-id id)) 152 | (locus-channel-put new-locus (compute-v 'master (car remaining-work))) 153 | (printf "Requesting new locus ~a for ~a~n" id (car remaining-work)) 154 | (loop (hash-set 155 | (hash-remove active-workers w) 156 | id new-locus) 157 | (rest remaining-work))])] 158 | 159 | [msg 160 | (error 'main "unexpected msg, got: ~a" msg)])))]))) 161 | 162 | 163 | (module+ main 164 | 165 | (require racket/os) 166 | 167 | (printf "Parent PID: ~a~n" (getpid)) 168 | 169 | (define-values (cores N) 170 | (command-line 171 | #:args (cores factmax) 172 | (values 173 | (string->number cores) 174 | (string->number factmax)))) 175 | 176 | 177 | (main cores N)) 178 | -------------------------------------------------------------------------------- /loci/scribblings/loci.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @require[@for-label[loci 4 | racket/base]] 5 | 6 | @title{loci} 7 | @author[(author+email "Paulo Matos" "pmatos@linki.tools")] 8 | 9 | @emph{Locus (pl. loci): the place where something is situated or occurs;} - @hyperlink["https://www.merriam-webster.com/dictionary/locus"]{Merriam-Webster Dictionary} 10 | 11 | @tech{Loci} enables the development of parallel programs that can take 12 | advantage of machines with multiple processors, cores or hardware 13 | threads... but this time for real! 14 | 15 | @margin-note{Currently, the loci library only works on Linux and 16 | MacOS due to the use of unix channels for communication between loci.} 17 | 18 | This library attempts to follow the places API very closely. When this 19 | is not the case, feel free to 20 | @hyperlink["https://github.com/LinkiTools/racket-loci"]{report a 21 | bug}. As opposed to places from the standard library, loci use OS 22 | processes instead of OS threads to allow the parallelization of 23 | multiple tasks. Up until 16 simultaneous places there's very little 24 | different between loci and places but once you go into 32, 64, 144, 25 | 256, etc. core machines then places will break down and stop working 26 | properly due to memory allocation inter-thread locking. 27 | 28 | @section[#:tag "documentation"]{API Documentation} 29 | @defmodule[loci] 30 | 31 | @defproc[(locus-enabled?) boolean?]{ 32 | Returns @racket[#t]. It exists for compatibility with the place API. 33 | Loci are always enabled. 34 | } 35 | 36 | @defproc[(locus? [v any/c]) boolean?]{ 37 | Returns @racket[#t] if @racket[v] is a @deftech{locus descriptor} 38 | value, @racket[#f] otherwise. Every @tech{locus descriptor} is also 39 | a @tech{locus channel}. 40 | } 41 | 42 | @defproc[(dynamic-locus [module-path (or/c module-path? path?)] 43 | [start-name symbol?]) 44 | locus?]{ 45 | Creates a @tech{locus} to run the procedure that is identified by 46 | @racket[module-path] and @racket[start-name]. The result is a 47 | @tech{locus descriptor} value that represents the new parallel task; 48 | the locus descriptor is returned immediatelly. The locus descriptor is also a 49 | @tech{locus channel} that permits communication with the locus. 50 | 51 | The module indicated by @racket[module-path] must export a function 52 | with the name @racket[start-name]. The function must accept a single 53 | argument, which is a @tech{locus channel} that corresponds to the 54 | other end of communication for the @tech{locus descriptor} returned 55 | by @racket[locus]. 56 | 57 | When the @tech{locus} is created, the initial @tech{exit handler} 58 | terminates the locus, using the argument to the exit handler as the 59 | locus' @deftech{completion value}. Use @racket[(exit _v)] to 60 | immediatelly terminate a locus with the completion value 61 | @racket[_v]. Since a completion value is limited to an exact integer 62 | between @racket[0] and @racket[255], any other value for @racket[v] 63 | is converted to @racket[0]. 64 | 65 | If the function indicated by @racket[module-path] and 66 | @racket[start-name] returns, the the locus terminates with the 67 | @tech{completion value} @racket[0]. 68 | 69 | In the created locus, the @racket[current-input-port] parameter is 70 | set to an empty input port, while the values of the 71 | @racket[current-output-port] and @racket[current-error-port] 72 | parameters are connected to the ports in the creating locus. 73 | } 74 | 75 | @defform[(locus id body ...+)] { 76 | Creates a locus that evaluates @racket[body] 77 | expressions with @racket[id] bound to a locus channel. The 78 | @racket[body]s close only over @racket[id] plus the top-level 79 | bindings of the enclosing module, because the 80 | @racket[body]s are lifted to a submodule. 81 | The result of @racket[locus] is a locus descriptor, 82 | like the result of @racket[dynamic-locus]. 83 | 84 | The generated submodule has the name @racketidfont{locus-body-@racket[_n]} 85 | for an integer @racket[_n], and the submodule exports a @racket[main] 86 | function that takes a locus channel for the new locus. The submodule 87 | is not intended for use, however, except by the expansion of the 88 | @racket[locus] form. 89 | 90 | The @racket[locus] binding is protected in the same way as 91 | @racket[dynamic-locus]. 92 | } 93 | 94 | @defform[(locus/context id body ...+)]{ 95 | Like @racket[locus], but @racket[body ...] may have free lexical 96 | variables, which are automatically sent to the newly-created locus. 97 | Note that these variables must have values accepted by 98 | @racket[locus-message-allowed?], otherwise an @racket[exn:fail:contract] exception is raised. 99 | } 100 | 101 | @defproc[(locus-wait [l locus?]) exact-integer?]{ 102 | Returns the @tech{completion value} of the locus indicated by @racket[l], 103 | blocking until the locus has terminated. 104 | 105 | If any pumping threads were created to connect a 106 | non-@tech{file-stream port} to the ports in the locus for @racket[l] 107 | (see @racket[dynamic-locus]), @racket[locus-wait] returns only when 108 | the pumping threads have completed. } 109 | 110 | @defproc[(locus-dead-evt [l locus?]) evt?]{ 111 | 112 | Returns a @tech{synchronizable event} (see @secref["sync"]) that is 113 | @tech{ready for synchronization} if and only if @racket[l] has terminated. 114 | The @tech{synchronization result} of a locus-dead event is the locus-dead event itself. 115 | 116 | If any pumping threads were created to connect a non-@tech{file-stream 117 | port} to the ports in the locus for @racket[l] (see 118 | @racket[dynamic-locus]), the event returned by 119 | @racket[locus-dead-evt] may become ready even if a pumping thread is 120 | still running.} 121 | 122 | @defproc[(locus-kill [l locus?]) void?]{ 123 | Immediately terminates the locus, setting the locus' 124 | @tech{completion value} to @racket[1] if the locus does not have a 125 | completion value already.} 126 | 127 | 128 | @section[#:tag "motivation"]{Motivation} 129 | 130 | Given a problem that requires parallelism, where you use all the 131 | available cores in your machine, the Racket answer as been places. 132 | I happily used places for a long time until I started stressing tests 133 | by getting larger and larger machines (up to 144 cores) and starting 134 | 144 places simultaneously. I noticed that once I exceeded 12 cores 135 | something started to go wrong, in particular the cores were idle most 136 | of the time and there was a lot of kernel locking taking place. This 137 | triggered me sending a 138 | @hyperlink["https://groups.google.com/d/msg/racket-users/oE72JfIKDO4/zbFI6knhAQAJ"]{message} 139 | to the Racket mailing list for help. 140 | 141 | 142 | 143 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | -------------------------------------------------------------------------------- /loci/private/locus-local.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; --------------------------------------------------------------------------------------------------- 3 | 4 | (require (for-syntax racket/base 5 | racket/syntax 6 | syntax/free-vars 7 | syntax/parse) 8 | racket/contract 9 | racket/file 10 | racket/function 11 | racket/list 12 | racket/match 13 | racket/path 14 | racket/unix-socket 15 | "loci-log.rkt" 16 | (prefix-in ch: "locus-channel.rkt") 17 | "locus-transferable_gen.rkt" 18 | "locus_gen.rkt" 19 | "path.rkt" 20 | "utils.rkt") 21 | 22 | (provide 23 | locus 24 | locus/context 25 | 26 | locus-pid 27 | locus-running? 28 | locus-exit-code 29 | locus-kill 30 | 31 | locus-enabled? 32 | 33 | (contract-out 34 | [dynamic-locus ((or/c module-path? path?) symbol? . -> . locus?)] 35 | [struct locus-dead-evt ((locus locus?))] 36 | [locus-wait (locus? . -> . exact-nonnegative-integer?)] 37 | [locus? (any/c . -> . boolean?)] 38 | [locus-channel-put/get ((or/c ch:locus-channel? locus?) any/c . -> . any/c)] 39 | [rename ch:locus-message-allowed? locus-message-allowed? (any/c . -> . boolean?)] 40 | [rename ch:locus-channel? locus-channel? (any/c . -> . boolean?)] 41 | [locus-channel-put ((or/c ch:locus-channel? locus?) ch:locus-message-allowed? . -> . void?)] 42 | [locus-channel-get ((or/c ch:locus-channel? locus?) . -> . any/c)])) 43 | 44 | ;; --------------------------------------------------------------------------------------------------- 45 | ;; For compatibility with places 46 | (define (locus-enabled?) #true) 47 | 48 | ;; Extend locus channels 49 | (define (locus-channel-put/get ch datum) 50 | (locus-channel-put ch datum) 51 | (locus-channel-get ch)) 52 | 53 | (define (resolve->channel o) 54 | (match o 55 | [(? locus? l) (local-locus-ch l)] 56 | [(? ch:locus-channel? l) l])) 57 | 58 | (define (locus-channel-put ch datum) 59 | (log-debug "writing datum ~e to channel" datum) 60 | (ch:locus-channel-put (resolve->channel ch) datum)) 61 | (define (locus-channel-get ch) 62 | (log-debug "starting a read") 63 | (define d (ch:locus-channel-get (resolve->channel ch))) 64 | (log-debug "read datum ~e from channel" d) 65 | d) 66 | 67 | ;; --------------------------------------------------------------------------------------------------- 68 | ;; This file implement locus which run on the same machine as the master locus 69 | (struct local-locus (ch subproc out-pump err-pump) 70 | #:methods gen:locus 71 | [(define (locus-pid ll) 72 | (subprocess-pid (local-locus-subproc ll))) 73 | (define (locus-wait ll) 74 | (subprocess-wait (local-locus-subproc ll)) 75 | (subprocess-status (local-locus-subproc ll))) 76 | (define (locus-running? ll) 77 | (eq? (subprocess-status (local-locus-subproc ll)) 'running)) 78 | (define (locus-exit-code ll) 79 | (cond 80 | [(locus-running? ll) #false] 81 | [else (subprocess-status (local-locus-subproc ll))])) 82 | (define (locus-kill ll) 83 | (subprocess-kill (local-locus-subproc ll) #true))] 84 | #:property prop:input-port (struct-field-index ch) 85 | #:property prop:output-port (struct-field-index ch) 86 | #:property prop:evt 87 | (lambda (s) 88 | (wrap-evt (ch:locus-channel-in (local-locus-ch s)) 89 | (lambda (unix-ch) 90 | (ch:locus-channel-get (local-locus-ch s)))))) 91 | 92 | (struct locus-dead-evt (locus) 93 | #:property prop:evt 94 | (lambda (s) 95 | (wrap-evt (local-locus-subproc (locus-dead-evt-locus s)) 96 | (lambda (subproc) s)))) 97 | 98 | ;; dynamic-locus 99 | ;; Based on the implementation of place-process in 100 | ;; https://github.com/racket/racket/blob/master/pkgs/racket-benchmarks/tests/racket/ 101 | ;; /benchmarks/places/place-processes.rkt 102 | (define (dynamic-locus mod func-name) 103 | (define (current-executable-path) 104 | (parameterize ([current-directory (find-system-path 'orig-dir)]) 105 | (find-executable-path (find-system-path 'exec-file) #false))) 106 | (define (current-collects-path) 107 | (define p (find-system-path 'collects-dir)) 108 | (if (complete-path? p) 109 | p 110 | (path->complete-path p (or (path-only (resolve-path (current-executable-path))) 111 | (find-system-path 'orig-dir))))) 112 | (define worker-cmdline-list (list (current-executable-path) 113 | "-X" 114 | (path->string (current-collects-path)) 115 | "-e" 116 | "(eval (read))")) 117 | (log-debug "starting racket subprocess: ~e" worker-cmdline-list) 118 | (match-define-values (process-handle out in err) 119 | (apply subprocess 120 | #false 121 | #false 122 | #false 123 | worker-cmdline-list)) 124 | (define stdout-pump 125 | (thread 126 | (thunk 127 | (log-debug "pump for stdout starting") 128 | (copy-port out (current-output-port) #:flush? #true) 129 | (log-debug "pump for stdout dying")))) 130 | (define stderr-pump 131 | (thread 132 | (thunk 133 | (log-debug "pump for stderr starting") 134 | (copy-port err (current-error-port) #:flush? #true) 135 | (log-debug "pump for stderr dying")))) 136 | 137 | (define tmp (make-temporary-file "loci~a")) 138 | (delete-file tmp) 139 | 140 | (log-debug "creating listener") 141 | (define listener (unix-socket-listen tmp)) 142 | 143 | (define start-thread 144 | (thread 145 | (thunk 146 | (log-debug "sending debug message to locus") 147 | (define msg `(begin 148 | (require loci/private/locus-channel 149 | loci/private/path 150 | racket/unix-socket) 151 | (file-stream-buffer-mode (current-output-port) 'none) 152 | (define-values (from-sock to-sock) 153 | (unix-socket-connect ,(path->string tmp))) 154 | ((dynamic-require (bytes->mod (quote ,(mod->bytes mod))) 155 | (quote ,func-name)) 156 | (locus-channel from-sock to-sock)))) 157 | (log-debug "sending message into racket input port: ~e" msg) 158 | (write msg in) 159 | (flush-output in) 160 | (close-output-port in)))) 161 | 162 | (log-debug "waiting for locus to accept connection") 163 | (define-values (from-sock to-sock) 164 | (unix-socket-accept listener)) 165 | (thread-wait start-thread) 166 | 167 | (log-debug "successfully created locus") 168 | (local-locus (ch:locus-channel from-sock to-sock) process-handle stdout-pump stderr-pump)) 169 | 170 | (define-for-syntax locus-body-counter 0) 171 | 172 | (define-syntax (locus stx) 173 | (syntax-case stx () 174 | [(who ch body1 body ...) 175 | (if (eq? (syntax-local-context) 'module-begin) 176 | ;; when a `place' form is the only thing in a module body: 177 | #`(begin #,stx) 178 | ;; normal case: 179 | (let () 180 | (unless (syntax-transforming-module-expression?) 181 | (raise-syntax-error #false "can only be used in a module" stx)) 182 | (unless (identifier? #'ch) 183 | (raise-syntax-error #false "expected an identifier" stx #'ch)) 184 | (set! locus-body-counter (add1 locus-body-counter)) 185 | (define module-name-stx 186 | (datum->syntax stx 187 | (string->symbol 188 | (format "locus-body-~a" locus-body-counter)))) 189 | (with-syntax ([internal-def-name 190 | (syntax-local-lift-module 191 | #`(module* #,module-name-stx #false 192 | (provide main) 193 | (define (main ch) 194 | body1 body ...) 195 | ;; The existence of this submodule makes the 196 | ;; enclosing submodule preserved by `raco exe`: 197 | (module declare-preserve-for-embedding '#%kernel)))]) 198 | #`(locus/proc (#%variable-reference) '#,module-name-stx 'who))))] 199 | [(_ ch) 200 | (raise-syntax-error #false "expected at least one body expression" stx)])) 201 | 202 | (define (locus/proc vr submod-name who) 203 | (define name 204 | (resolved-module-path-name 205 | (variable-reference->resolved-module-path 206 | vr))) 207 | (when (and (symbol? name) 208 | (not (module-predefined? `(quote ,name)))) 209 | (error who "the enclosing module's resolved name is not a path or predefined")) 210 | (define submod-ref 211 | (match name 212 | [(? symbol?) `(submod (quote ,name) ,submod-name)] 213 | [(? path?) `(submod ,name ,submod-name)] 214 | [`(,p ,s ...) `(submod ,(if (symbol? p) `(quote ,p) p) ,@s ,submod-name)])) 215 | (dynamic-locus submod-ref 'main)) 216 | 217 | (define-syntax (locus/context stx) 218 | (syntax-parse stx 219 | [(_ ch:id body:expr ...) 220 | (define b #'(lambda (ch) body ...)) 221 | (define/with-syntax b* (local-expand b 'expression null)) 222 | (define/with-syntax (fvs ...) (free-vars #'b*)) 223 | (define/with-syntax (i ...) 224 | (for/list ([(v i) (in-indexed (syntax->list #'(fvs ...)))]) i)) 225 | (define/with-syntax (v l) (generate-temporaries '(v l))) 226 | #'(let () 227 | (define l 228 | (locus ch 229 | (let* ([v (locus-channel-get ch)] 230 | [fvs (vector-ref v i)] ...) 231 | (b* ch)))) 232 | (define vec (vector fvs ...)) 233 | (for ([e (in-vector vec)] 234 | [n (in-list (syntax->list (quote-syntax (fvs ...))))]) 235 | (unless (ch:locus-message-allowed? e) 236 | (raise-arguments-error 'locus/context 237 | "free variable values must be allowable as locus messages" 238 | (symbol->string (syntax-e n)) e))) 239 | (locus-channel-put l vec) 240 | l)])) 241 | --------------------------------------------------------------------------------