1(module compile-unit racket/base 2 (require racket/unit 3 racket/system 4 "private/dirs.rkt" 5 "private/stdio.rkt" 6 "private/cmdargs.rkt") 7 8 (require "compile-sig.rkt") 9 10 (provide dynext:compile@) 11 12 (define-unit dynext:compile@ 13 (import) 14 (export dynext:compile^) 15 16 (define (get-unix-compile) 17 (or (find-executable-path "gcc" #f) 18 (find-executable-path "cc" #f))) 19 20 (define (get-windows-compile) 21 (or (find-executable-path "cl.exe" #f) 22 (find-executable-path "gcc.exe" #f) 23 (find-executable-path "bcc32.exe" #f))) 24 25 (define current-extension-compiler 26 (make-parameter 27 (or (let ([p (or (getenv "MZSCHEME_DYNEXT_COMPILER") 28 (getenv "CC"))]) 29 (and p 30 (if (absolute-path? p) 31 (string->path p) 32 (find-executable-path p #f)))) 33 (case (system-type) 34 [(unix macosx) (get-unix-compile)] 35 [(windows) (get-windows-compile)] 36 [else #f])) 37 (lambda (v) 38 (when v 39 (if (path-string? v) 40 (unless (and (file-exists? v) 41 (memq 'execute (file-or-directory-permissions v))) 42 (error 'current-extension-compiler 43 "compiler not found or not executable: ~s" v)) 44 (raise-type-error 'current-extension-compiler "path, valid-path string, or #f" v))) 45 v))) 46 47 (define win-gcc? 48 (let ([c (current-extension-compiler)]) 49 (and c (regexp-match #"gcc.exe$" (path->bytes c))))) 50 (define win-borland? 51 (let ([c (current-extension-compiler)]) 52 (and c (regexp-match #"bcc32.exe$" (path->bytes c))))) 53 (define unix-cc? 54 (let ([c (current-extension-compiler)]) 55 (and c (regexp-match #"[^g]cc$" (path->bytes c))))) 56 57 (define (add-variant-flags l) 58 (append l (list (lambda () 59 (if (eq? '3m (specific-compile-variant)) 60 '("-DMZ_PRECISE_GC") 61 null))))) 62 63 (define gcc-cpp-flags 64 (add-variant-flags (case (string->symbol (path->string (system-library-subpath #f))) 65 [(parisc-hpux) '("-D_HPUX_SOURCE")] 66 [(ppc-macosx x86_64-macosx) '("-DOS_X")] 67 [(i386-macosx) '("-DOS_X" "-m32")] 68 [(ppc-darwin x86_64-darwin) '("-DOS_X" "-DXONX")] 69 [(i386-darwin) '("-DOS_X" "-DXONX" "-m32")] 70 [else null]))) 71 72 (define gcc-compile-flags (append '("-c" "-O2" "-fPIC") 73 (case (string->symbol (path->string (system-library-subpath #f))) 74 [(i386-macosx i386-darwin) '("-m32" "-fno-common")] 75 [(ppc-macosx ppc-darwin x86_64-macosx x86_64-darwin) '("-fno-common")] 76 [(win32\\i386) '("-DAS_MSVC_EXTENSION")] 77 [else null]) 78 gcc-cpp-flags)) 79 80 (define unix-cpp-flags 81 (add-variant-flags (case (string->symbol (path->string (system-library-subpath #f))) 82 [(parisc-hpux) '("-D_HPUX_SOURCE")] 83 [else gcc-cpp-flags]))) 84 85 (define unix-compile-flags (case (string->symbol (path->string (system-library-subpath #f))) 86 [(parisc-hpux) (append '("-c" "-O2" "-Aa" "+z" "+e") 87 unix-cpp-flags)] 88 [else gcc-compile-flags])) 89 90 (define msvc-compile-flags 91 (add-variant-flags '("/c" "/MT" "/O2"))) 92 93 (define (make-flags-guard who) 94 (lambda (l) 95 (unless (and (list? l) (andmap (lambda (s) (or (path-string? s) 96 (and (procedure? s) (procedure-arity-includes? s 0)))) 97 l)) 98 (raise-type-error who "list of paths/strings and thunks" l)) 99 l)) 100 101 (define (get-env-compile-flags) 102 (let ([v (or (getenv "MZSCHEME_DYNEXT_COMPILER_FLAGS") 103 (getenv "CFLAGS"))]) 104 (if v 105 (split-command-line-args v) 106 null))) 107 108 (define current-extension-compiler-flags 109 (make-parameter 110 (append 111 (get-env-compile-flags) 112 (case (system-type) 113 [(unix macosx) (if unix-cc? 114 unix-compile-flags 115 gcc-compile-flags)] 116 [(windows) (if (or win-gcc? win-borland?) 117 gcc-compile-flags 118 msvc-compile-flags)] 119 [(macos) '()])) 120 (make-flags-guard 'current-extension-compiler-flags))) 121 122 (define current-extension-preprocess-flags 123 (make-parameter 124 (case (system-type) 125 [(unix macosx) (cons "-E" (if unix-cc? 126 unix-cpp-flags 127 gcc-cpp-flags))] 128 [(windows) (if (or win-gcc? win-borland?) 129 (cons "-E" gcc-cpp-flags) 130 '("/E"))] 131 [(macos) '()]) 132 (make-flags-guard 'current-extension-preprocess-flags))) 133 134 (define compile-variant (make-parameter 135 'normal 136 (lambda (s) 137 (unless (memq s '(normal cgc 3m)) 138 (raise-type-error 'compile-variant "'normal, 'cgc, or '3m" s)) 139 s))) 140 141 (define (specific-compile-variant) 142 (let ([v (compile-variant)]) 143 (if (eq? v 'normal) 144 (system-type 'gc) 145 v))) 146 147 (define (expand-for-compile-variant l) 148 (apply append (map (lambda (s) (if (path-string? s) (list s) (s))) l))) 149 150 (define current-make-extra-extension-compiler-flags 151 (make-parameter 152 (lambda () (case (specific-compile-variant) 153 [(3m) '("-DMZ_PRECISE_GC")] 154 [else null])) 155 (lambda (p) 156 (unless (and (procedure? p) (procedure-arity-includes? p 0)) 157 (raise-type-error 'current-make-extra-extension-compiler-flags "procedure (arity 0)" p)) 158 p))) 159 160 (define (path-string->string s) 161 (if (string? s) s (path->string s))) 162 163 (define unix-compile-include-strings (lambda (s) 164 (list (string-append "-I" (path-string->string s))))) 165 (define msvc-compile-include-strings (lambda (s) 166 (list (string-append "/I" (path-string->string s))))) 167 168 (define current-make-compile-include-strings 169 (make-parameter 170 (case (system-type) 171 [(unix macosx) unix-compile-include-strings] 172 [(windows) (if (or win-gcc? win-borland?) 173 unix-compile-include-strings 174 msvc-compile-include-strings)] 175 [(macos) unix-compile-include-strings]) 176 (lambda (p) 177 (unless (procedure-arity-includes? p 1) 178 (raise-type-error 'current-make-compile-include-strings "procedure of arity 1" p)) 179 p))) 180 181 (define current-make-compile-input-strings 182 (make-parameter 183 (lambda (s) (list (path-string->string s))) 184 (lambda (p) 185 (unless (procedure-arity-includes? p 1) 186 (raise-type-error 'current-make-compile-input-strings "procedure of arity 1" p)) 187 p))) 188 189 (define unix-compile-output-strings (lambda (s) (list "-o" (path-string->string s)))) 190 (define msvc-compile-output-strings (lambda (s) (list (string-append "/Fo" (path-string->string s))))) 191 192 (define current-make-compile-output-strings 193 (make-parameter 194 (case (system-type) 195 [(unix macosx) unix-compile-output-strings] 196 [(windows) (if (or win-gcc? win-borland?) 197 unix-compile-output-strings 198 msvc-compile-output-strings)] 199 [(macos) unix-compile-output-strings]) 200 (lambda (p) 201 (unless (procedure-arity-includes? p 1) 202 (raise-type-error 'current-make-compile-output-strings "procedure of arity 1" p)) 203 p))) 204 205 (define (get-standard-compilers) 206 (case (system-type) 207 [(unix macosx) '(gcc cc)] 208 [(windows) '(gcc msvc borland)] 209 [(macos) '(cw)])) 210 211 (define (use-standard-compiler name) 212 (define (bad-name name) 213 (error 'use-standard-compiler "unknown compiler: ~a" name)) 214 (case (system-type) 215 [(unix macosx) 216 (case name 217 [(cc gcc) (let* ([n (if (eq? name 'gcc) "gcc" "cc")] 218 [f (find-executable-path n n)]) 219 (unless f 220 (error 'use-standard-compiler "cannot find ~a" n)) 221 (current-extension-compiler f)) 222 (current-extension-compiler-flags (add-variant-flags 223 (if (eq? name 'gcc) 224 gcc-compile-flags 225 unix-compile-flags))) 226 (current-make-compile-include-strings unix-compile-include-strings) 227 (current-make-compile-input-strings (lambda (s) (list (path-string->string s)))) 228 (current-make-compile-output-strings unix-compile-output-strings)] 229 [else (bad-name name)])] 230 [(windows) 231 (case name 232 [(gcc) (let ([f (find-executable-path "gcc.exe" #f)]) 233 (unless f 234 (error 'use-standard-compiler "cannot find gcc.exe")) 235 (current-extension-compiler f)) 236 (current-extension-compiler-flags (add-variant-flags gcc-compile-flags)) 237 (current-make-compile-include-strings unix-compile-include-strings) 238 (current-make-compile-input-strings (lambda (s) (list (path-string->string s)))) 239 (current-make-compile-output-strings unix-compile-output-strings)] 240 [(borland) (let ([f (find-executable-path "bcc32.exe" #f)]) 241 (unless f 242 (error 'use-standard-compiler "cannot find bcc32.exe")) 243 (current-extension-compiler f)) 244 (current-extension-compiler-flags (add-variant-flags gcc-compile-flags)) 245 (current-make-compile-include-strings unix-compile-include-strings) 246 (current-make-compile-input-strings (lambda (s) (list (path-string->string s)))) 247 (current-make-compile-output-strings unix-compile-output-strings)] 248 [(msvc) (let ([f (find-executable-path "cl.exe" #f)]) 249 (unless f 250 (error 'use-standard-compiler "cannot find MSVC's cl.exe")) 251 (current-extension-compiler f)) 252 (current-extension-compiler-flags (add-variant-flags msvc-compile-flags)) 253 (current-make-compile-include-strings msvc-compile-include-strings) 254 (current-make-compile-input-strings (lambda (s) (list (path-string->string s)))) 255 (current-make-compile-output-strings msvc-compile-output-strings)] 256 [else (bad-name name)])] 257 [(macos) 258 (case name 259 [(cw) (current-extension-compiler #f) 260 (current-extension-compiler-flags (add-variant-flags unix-compile-flags)) 261 (current-make-compile-include-strings unix-compile-include-strings) 262 (current-make-compile-input-strings (lambda (s) (list (path-string->string s)))) 263 (current-make-compile-output-strings unix-compile-output-strings)] 264 [else (bad-name name)])])) 265 266 (define-values (my-process* stdio-compile) 267 (let-values ([(p* do-stdio) (get-stdio)]) 268 (values 269 p* 270 (lambda (start-process quiet?) 271 (do-stdio start-process quiet? (lambda (s) (error 'compile-extension "~a" s))))))) 272 273 (define (make-compile-extension current-extension-compiler-flags) 274 (lambda (quiet? in out includes) 275 (let ([c (current-extension-compiler)]) 276 (if c 277 (stdio-compile (lambda (quiet?) 278 (let ([command (append 279 (list c) 280 (expand-for-compile-variant 281 (current-extension-compiler-flags)) 282 (apply append 283 (map 284 (lambda (s) 285 ((current-make-compile-include-strings) s)) 286 includes)) 287 ((current-make-compile-include-strings) (include-dir)) 288 ((current-make-compile-input-strings) in) 289 ((current-make-compile-output-strings) out))]) 290 (unless quiet? 291 (printf "compile-extension: ~a\n" command)) 292 (apply my-process* command))) 293 quiet?) 294 (error 'compile-extension "can't find an installed C compiler"))))) 295 296 (define compile-extension (make-compile-extension 297 current-extension-compiler-flags)) 298 (define preprocess-extension (make-compile-extension 299 current-extension-compiler-flags)))) 300 301