From e4718f5709425542acdba07dcf861d5dceb58ba0 Mon Sep 17 00:00:00 2001 From: Rujia Liu Date: Fri, 3 Jan 2025 11:58:09 +0800 Subject: [PATCH 1/2] Preliminary native windows support, part 1: building `bach` with MSVC (sys-type: visualc) --- src/build/build-bach.ss | 49 +++++++++++++++++++++++++++++------ src/gerbil/compiler/driver.ss | 31 +++++++++++++++------- 2 files changed, 63 insertions(+), 17 deletions(-) diff --git a/src/build/build-bach.ss b/src/build/build-bach.ss index 18ac42a7d..98ff619d0 100644 --- a/src/build/build-bach.ss +++ b/src/build/build-bach.ss @@ -13,7 +13,10 @@ (getenv "GERBIL_GSC" default-gerbil-gsc)) (def (gerbil-gcc) - (getenv "GERBIL_GCC" "gcc")) + (getenv "GERBIL_GCC" + (cond-expand + (visualc "cl") + (else "gcc")))) (def gerbil-bindir (path-expand "bin" build-home)) @@ -28,9 +31,39 @@ (def default-ld-options ["-lutil" "-lm"])) (netbsd (def default-ld-options ["-lm"])) + (visualc + (def default-ld-options ["Kernel32.Lib" "User32.Lib" "Gdi32.Lib" "WS2_32.Lib" "/subsystem:console" "/entry:WinMainCRTStartup"])) (else (def default-ld-options ["-ldl" "-lm"]))) +(def compiler-obj-suffix + (cond-expand + (visualc ".obj") + (else ".o"))) + +(def (path->string-literal path) + (string-append + "\"" + (string-map + (lambda (c) (if (char=? c #\\) #\/ c)) + path) + "\"")) + +(def (link-output-options output-bin) + (cond-expand + (visualc [(string-append "/Fe" output-bin)]) + (else ["-o" output-bin]))) + +(def (link-with-libgambit-options) + (cond-expand + (visualc ["/link" (string-append "/LIBPATH:" "\"" gerbil-libdir "\"") "libgambit.lib"]) + (else ["-L" gerbil-libdir "-lgambit"]))) + +(def compiler-debug-option + (cond-expand + (visualc "/Zi") + (else "-g"))) + (def builtin-modules '(;; :gerbil/runtime "gerbil/runtime/gambit" @@ -109,15 +142,15 @@ ;; and then compile the binary (let* ((builtin-modules-scm (map static-file-name builtin-modules)) (builtin-modules-c (map (cut replace-extension <> ".c") builtin-modules-scm)) - (builtin-modules-o (map (cut replace-extension <> ".o") builtin-modules-scm)) + (builtin-modules-o (map (cut replace-extension <> compiler-obj-suffix) builtin-modules-scm)) (bach-main-scm (static-file-name bach-main)) (bach-main-c (replace-extension bach-main-scm ".c")) - (bach-main-o (replace-extension bach-main-scm ".o")) + (bach-main-o (replace-extension bach-main-scm compiler-obj-suffix)) (bach-link-c (path-expand "gerbil-link.c" gerbil-libdir)) - (bach-link-o (replace-extension bach-link-c ".o")) + (bach-link-o (replace-extension bach-link-c compiler-obj-suffix)) (gambit-sharp (path-expand "_gambit#.scm" gerbil-libdir)) (include-gambit-sharp - (string-append "(include \"" gambit-sharp "\")")) + (string-append "(include " (path->string-literal gambit-sharp) ")")) (gsc-gx-macros (if (gerbil-runtime-smp?) ["-e" "(define-cond-expand-feature|enable-smp|)" @@ -141,18 +174,18 @@ bach-main-scm]) (for-each (lambda (path-c) (add-compile-job! - (lambda () (invoke (gerbil-gsc) ["-obj" "-cc-options" "-g" path-c])) + (lambda () (invoke (gerbil-gsc) ["-obj" "-cc-options" compiler-debug-option path-c])) `(compile ,path-c))) [builtin-modules-c ... bach-main-c bach-link-c]) (execute-pending-compile-jobs!) (displayln "... build " output-bin) (invoke (gerbil-gcc) - ["-o" output-bin + [(link-output-options output-bin) ... rpath-options ... builtin-modules-o ... bach-main-o bach-link-o - "-L" gerbil-libdir "-lgambit" + (link-with-libgambit-options) ... default-ld-options ...]) ;; clean up (delete-file bach-main-scm) diff --git a/src/gerbil/compiler/driver.ss b/src/gerbil/compiler/driver.ss index 66a4ff329..05e6df6f3 100644 --- a/src/gerbil/compiler/driver.ss +++ b/src/gerbil/compiler/driver.ss @@ -58,6 +58,19 @@ namespace: gxc (cond-expand (darwin "-Wl,-rpath,") (else "-Wl,-rpath=")) gerbil-libdir)) +(def compiler-obj-suffix + (cond-expand + (visualc ".obj") + (else ".o"))) + +(def (path->string-literal path) + (string-append + "\"" + (string-map + (lambda (c) (if (char=? c #\\) #\/ c)) + path) + "\"")) + (def gerbil-runtime-modules '("gerbil/runtime/gambit" "gerbil/runtime/util" @@ -222,23 +235,23 @@ namespace: gxc (libgerbil-scm (map find-static-module-file libgerbil-deps)) (libgerbil-scm (fold-libgerbil-runtime-scm gerbil-staticdir libgerbil-scm)) (libgerbil-c (map (cut replace-extension <> ".c") libgerbil-scm)) - (libgerbil-o (map (cut replace-extension <> ".o") libgerbil-scm)) + (libgerbil-o (map (cut replace-extension <> compiler-obj-suffix) libgerbil-scm)) (src-deps (filter userlib-module? deps)) (src-deps-scm (map find-static-module-file src-deps)) (src-deps-scm (filter not-file-empty? src-deps-scm)) (src-deps-scm (map path-expand src-deps-scm)) (src-deps-c (map (cut replace-extension <> ".c") src-deps-scm)) - (src-deps-o (map (cut replace-extension <> ".o") src-deps-scm)) + (src-deps-o (map (cut replace-extension <> compiler-obj-suffix) src-deps-scm)) (src-bin-scm (find-static-module-file ctx)) (src-bin-scm (path-expand src-bin-scm)) (src-bin-c (replace-extension src-bin-scm ".c")) - (src-bin-o (replace-extension src-bin-scm ".o")) + (src-bin-o (replace-extension src-bin-scm compiler-obj-suffix)) (output-bin (path-expand output-bin)) (output-scm (path-expand output-scm)) (output-c (replace-extension output-scm ".c")) - (output-o (replace-extension output-scm ".o")) + (output-o (replace-extension output-scm compiler-obj-suffix)) (output_-c (replace-extension output-scm "_.c")) - (output_-o (replace-extension output-scm "_.o")) + (output_-o (replace-extension output-scm (string-append "_" compiler-obj-suffix))) (gsc-link-opts (gsc-link-options)) (gsc-cc-opts (gsc-cc-options static: #t)) (gsc-static-opts (gsc-static-include-options gerbil-staticdir)) @@ -252,7 +265,7 @@ namespace: gxc (cons ctx deps)))))) (def (compile-obj scm-path c-path) - (let (o-path (replace-extension c-path ".o")) + (let (o-path (replace-extension c-path compiler-obj-suffix)) (let* ((lock (string-append o-path ".lock")) (locked #f) (unlock @@ -393,7 +406,7 @@ namespace: gxc (gerbil-libdir (path-expand "lib" gerbil-home)) (runtime (map find-static-module-file gerbil-runtime-modules)) (gambit-sharp (path-expand "lib/_gambit#.scm" gerbil-home)) - (include-gambit-sharp (string-append "(include \"" gambit-sharp "\")")) + (include-gambit-sharp (string-append "(include " (path->string-literal gambit-sharp) ")")) (bin-scm (find-static-module-file ctx)) (deps (find-runtime-module-deps ctx)) (deps (map find-static-module-file deps)) @@ -401,9 +414,9 @@ namespace: gxc (deps (filter (lambda (f) (not (member f runtime))) deps)) (output-base (string-append (path-strip-extension output-scm))) (output-c (string-append output-base ".c")) - (output-o (string-append output-base ".o")) + (output-o (string-append output-base compiler-obj-suffix)) (output-c_ (string-append output-base "_.c")) - (output-o_ (string-append output-base "_.o")) + (output-o_ (string-append output-base (string-append "_" compiler-obj-suffix))) (gsc-link-opts (gsc-link-options)) (gsc-cc-opts (gsc-cc-options static: #t)) (gsc-static-opts (gsc-static-include-options (path-expand "static" gerbil-libdir))) From 40340f8ad9d4a10a3cd746b91bed92abedfa07b4 Mon Sep 17 00:00:00 2001 From: Rujia Liu Date: Mon, 6 Jan 2025 13:07:20 +0800 Subject: [PATCH 2/2] Improve code and add comments --- src/build/build-bach.ss | 34 ++++++++++++++++++----------- src/gerbil/compiler/driver.ss | 41 +++++++++++++++++++++-------------- 2 files changed, 46 insertions(+), 29 deletions(-) diff --git a/src/build/build-bach.ss b/src/build/build-bach.ss index 98ff619d0..774c17f43 100644 --- a/src/build/build-bach.ss +++ b/src/build/build-bach.ss @@ -41,13 +41,16 @@ (visualc ".obj") (else ".o"))) -(def (path->string-literal path) - (string-append - "\"" - (string-map - (lambda (c) (if (char=? c #\\) #\/ c)) - path) - "\"")) +; generates an `include` form for use in a source code, gsc's -e option etc. +; It takes care of windows paths where we need to escape the path. +; e.g. (displayln (include-source "d:\\gerbil\\mycode.scm")) should print +; (include "d:\\gerbil\\mycode.scm") +; instead of: +; (include "d:\gerbil\mycode.scm") +; which results in an error: +; *** ERROR -- Invalid escaped character: #\g +(def (include-source path) + (string-append "(include " (object->string path) ")")) (def (link-output-options output-bin) (cond-expand @@ -131,6 +134,12 @@ (def (replace-extension path ext) (string-append (path-strip-extension path) ext)) +(def (replace-extension-with-c path) + (replace-extension path ".c")) + +(def (replace-extension-with-object path) + (replace-extension path compiler-obj-suffix)) + ;; first compile the module (displayln "... compile " bach-main) (compile-module (string-append bach-main ".ss") @@ -141,16 +150,15 @@ ;; and then compile the binary (let* ((builtin-modules-scm (map static-file-name builtin-modules)) - (builtin-modules-c (map (cut replace-extension <> ".c") builtin-modules-scm)) - (builtin-modules-o (map (cut replace-extension <> compiler-obj-suffix) builtin-modules-scm)) + (builtin-modules-c (map replace-extension-with-c builtin-modules-scm)) + (builtin-modules-o (map replace-extension-with-object builtin-modules-scm)) (bach-main-scm (static-file-name bach-main)) - (bach-main-c (replace-extension bach-main-scm ".c")) - (bach-main-o (replace-extension bach-main-scm compiler-obj-suffix)) + (bach-main-c (replace-extension-with-c bach-main-scm)) + (bach-main-o (replace-extension-with-object bach-main-scm)) (bach-link-c (path-expand "gerbil-link.c" gerbil-libdir)) (bach-link-o (replace-extension bach-link-c compiler-obj-suffix)) (gambit-sharp (path-expand "_gambit#.scm" gerbil-libdir)) - (include-gambit-sharp - (string-append "(include " (path->string-literal gambit-sharp) ")")) + (include-gambit-sharp (include-source gambit-sharp)) (gsc-gx-macros (if (gerbil-runtime-smp?) ["-e" "(define-cond-expand-feature|enable-smp|)" diff --git a/src/gerbil/compiler/driver.ss b/src/gerbil/compiler/driver.ss index 05e6df6f3..34ef4b5e6 100644 --- a/src/gerbil/compiler/driver.ss +++ b/src/gerbil/compiler/driver.ss @@ -63,13 +63,16 @@ namespace: gxc (visualc ".obj") (else ".o"))) -(def (path->string-literal path) - (string-append - "\"" - (string-map - (lambda (c) (if (char=? c #\\) #\/ c)) - path) - "\"")) +; generates an `include` form for use in a source code, gsc's -e option etc. +; It takes care of windows paths where we need to escape the path. +; e.g. (displayln (include-source "d:\\gerbil\\mycode.scm")) should print +; (include "d:\\gerbil\\mycode.scm") +; instead of: +; (include "d:\gerbil\mycode.scm") +; which results in an error: +; *** ERROR -- Invalid escaped character: #\g +(def (include-source path) + (string-append "(include " (object->string path) ")")) (def gerbil-runtime-modules '("gerbil/runtime/gambit" @@ -187,6 +190,12 @@ namespace: gxc (def (replace-extension path ext) (string-append (path-strip-extension path) ext)) + (def (replace-extension-with-c path) + (replace-extension path ".c")) + + (def (replace-extension-with-object path) + (replace-extension path compiler-obj-suffix)) + (def (userlib-module? ctx) (and (not (exclude-module? ctx)) (not (libgerbil-module? ctx)))) @@ -234,22 +243,22 @@ namespace: gxc (libgerbil-deps (filter libgerbil-module? deps)) (libgerbil-scm (map find-static-module-file libgerbil-deps)) (libgerbil-scm (fold-libgerbil-runtime-scm gerbil-staticdir libgerbil-scm)) - (libgerbil-c (map (cut replace-extension <> ".c") libgerbil-scm)) - (libgerbil-o (map (cut replace-extension <> compiler-obj-suffix) libgerbil-scm)) + (libgerbil-c (map replace-extension-with-c libgerbil-scm)) + (libgerbil-o (map replace-extension-with-object libgerbil-scm)) (src-deps (filter userlib-module? deps)) (src-deps-scm (map find-static-module-file src-deps)) (src-deps-scm (filter not-file-empty? src-deps-scm)) (src-deps-scm (map path-expand src-deps-scm)) - (src-deps-c (map (cut replace-extension <> ".c") src-deps-scm)) - (src-deps-o (map (cut replace-extension <> compiler-obj-suffix) src-deps-scm)) + (src-deps-c (map replace-extension-with-c src-deps-scm)) + (src-deps-o (map replace-extension-with-object src-deps-scm)) (src-bin-scm (find-static-module-file ctx)) (src-bin-scm (path-expand src-bin-scm)) - (src-bin-c (replace-extension src-bin-scm ".c")) - (src-bin-o (replace-extension src-bin-scm compiler-obj-suffix)) + (src-bin-c (replace-extension-with-c src-bin-scm)) + (src-bin-o (replace-extension-with-object src-bin-scm)) (output-bin (path-expand output-bin)) (output-scm (path-expand output-scm)) - (output-c (replace-extension output-scm ".c")) - (output-o (replace-extension output-scm compiler-obj-suffix)) + (output-c (replace-extension-with-c output-scm)) + (output-o (replace-extension-with-object output-scm)) (output_-c (replace-extension output-scm "_.c")) (output_-o (replace-extension output-scm (string-append "_" compiler-obj-suffix))) (gsc-link-opts (gsc-link-options)) @@ -406,7 +415,7 @@ namespace: gxc (gerbil-libdir (path-expand "lib" gerbil-home)) (runtime (map find-static-module-file gerbil-runtime-modules)) (gambit-sharp (path-expand "lib/_gambit#.scm" gerbil-home)) - (include-gambit-sharp (string-append "(include " (path->string-literal gambit-sharp) ")")) + (include-gambit-sharp (include-source gambit-sharp)) (bin-scm (find-static-module-file ctx)) (deps (find-runtime-module-deps ctx)) (deps (map find-static-module-file deps))