Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Preliminary native windows support, part 1: building bach with MSVC… #1290

Merged
merged 2 commits into from
Jan 8, 2025
Merged

Preliminary native windows support, part 1: building bach with MSVC… #1290

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
e4718f5
Preliminary native windows support, part 1: building `bach` with MSVC…
Jan 3, 2025
40340f8
Improve code and add comments
Jan 6, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
49 changes: 41 additions & 8 deletions src/build/build-bach.ss
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand All @@ -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)
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This function is Windows specific, so should either be in a cond-expand, or, preferably, have a name that reflects it is windows-specific. I suspect the 100% correct code is closer to escape-windows-token-within-double-quotes from uiop/launch-program.lisp: https://gitlab.common-lisp.net/asdf/asdf/-/blob/master/uiop/launch-program.lisp
I understand if you don't use the 100% correct version, but then at the very least, there should be a comment in the code that explains within which parameters the function is correct enough that we stick to.

Alternatively, object->string might work well enough.

(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"
Expand Down Expand Up @@ -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|)"
Expand All @@ -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)
Expand Down
31 changes: 22 additions & 9 deletions src/gerbil/compiler/driver.ss
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Expand Down Expand Up @@ -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))
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Name this function, e.g. path-extension-to-object or replace-extension-with-object while you're at it, similarly for the other functions?

(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))
Expand All @@ -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
Expand Down Expand Up @@ -393,17 +406,17 @@ 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))
(deps (filter (? (not file-empty?)) deps))
(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)))
Expand Down
Loading