puck/zilch
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial commit

Browse source
This commit is contained in:
puck 2024-10-03 23:57:22 +00:00
commit 55a1efa08f
60 changed files with 5485 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

153
lang/go/src/core.sld Normal file
View file

@ -0,0 +1,153 @@
(define-library (zilch lang go core)
(import
(scheme base) (scheme write) (scheme process-context) (scheme lazy)
(zilch file) (zilch magic) (zilch nix drv) (zilch nix path)
(zilch nixpkgs) (zilch zexpr)
json
(chicken foreign)
(srfi 4))
(export
build-importcfg
build-embedcfg
rewrite-package-name
%goarch
env-for-goarch
defines-for-goarch
go-compile
go-generate-symabi
go-compile-assembly
go-toolchain)
(begin
(define %goarch (make-parameter "amd64"))
; Import the existing Go from nixpkgs.
(define go-toolchain (cdr (assoc "out" (nixpkgs "go_1_23"))))
;; Builds an importcfg file, containing an alist of packages to .a files,
;; and an alist of package names to actual package names.
;; `++packagefiles++` is a alist of package name to .a file (api type),
;; `++importmap++` is an alist of package name to actual package name (used in cases of e.g. replace)
(define (build-importcfg packagefiles importmap)
(call-with-port (open-output-string)
(lambda (outstr)
(write-string "# import config\n" outstr)
(for-each
(lambda (v)
(write-string "packagefile " outstr)
(write-string (car v) outstr)
(write-char #\= outstr)
(write-string (cdr v) outstr)
(write-char #\newline outstr))
packagefiles)
(for-each
(lambda (v)
(write-string "importmap " outstr)
(write-string (car v) outstr)
(write-char #\= outstr)
(write-string (cdr v) outstr)
(write-char #\newline outstr))
importmap)
(get-output-string outstr))))
;; `++patterns++` is an alist of the pattern used to match files (e.g. `++foo/++`, or `++a.*++`) to a list of filenames.
;; `++files++` is an alist of file name to actual path.
(define (build-embedcfg patterns files)
(call-with-port (open-output-string)
(lambda (outstr)
(json-write
(vector
(cons "Patterns" (list->vector patterns))
(cons "Files" (list->vector files)))
outstr)
(get-output-string outstr))))
; Clean up the package name to use in drv names.
(define (rewrite-package-name name)
(set! name (string-copy name))
(do ((x 0 (+ x 1)))
((>= x (string-length name)) name)
(when (char=? (string-ref name x) #\/) (string-set! name x #\_))
(when (char=? (string-ref name x) #\[) (string-set! name x #\_))
(when (char=? (string-ref name x) #\space) (string-set! name x #\_))
(when (char=? (string-ref name x) #\]) (string-set! name x #\_))))
;; An empty go_asm.h file used to generate symabis.
(define empty-asmhdr (zdir `(("go_asm.h" . ,(zfile "")))))
;; Environment to append to the build environment for Go.
(define (env-for-goarch)
`(("GOARCH" . ,(%goarch))))
;; Extra defines to add to `++go tool asm++` uses.
(define (defines-for-goarch)
`(
"-D" "GOOS_linux"
"-D" ,(string-append "GOARCH_" (%goarch))
,@(if (string=? (%goarch) "amd64") '("-D" "GOAMD64_v1") '())))
;; Returns an alist of three store paths; `++api++` containing the compiler's output,
;; `++code++` containing the linkobj, and `++asmhdr++` containing the headers needed for assembly
;; code to properly use Go functions and variables.
(define (go-compile std package-name importcfg symabis embeds files)
(define args
#~(
,@(if std '("-std") '())
#$@(if symabis `("-symabis" ,#$symabis) '())
#$@(if embeds `("-embedcfg" ,#$embeds) '())
"-buildid" "zilch go-compile" ; this goes into both code and __.PKGDEF, so can't be a reference to the code output, sadly
"-p" #$package-name
"-o" ,(make-placeholder "api")
"-linkobj" ,(make-placeholder "code")
"-importcfg" #$importcfg
"-nolocalimports"
"-asmhdr" ,(make-placeholder "asmhdr")
"-trimpath" ,(apply string-append (map (lambda (f) (string-append (cdr f) "=>" package-name "/" (car f) ";")) #$files))
. ,(map cdr #$files)))
(store-path-for-ca-drv*
(string-append (rewrite-package-name package-name) "-src")
"x86_64-linux"
#~(,(string-append #$go-toolchain "/bin/go") "tool" "compile" . #$args)
(env-for-goarch) '("api" "code" "asmhdr")))
;; Returns a store path containing the symabi for the files provided.
(define (go-generate-symabi package-name include-path files)
(define args
#~(
,@(defines-for-goarch)
"-gensymabis"
"-p" #$package-name
"-o" ,(make-placeholder "symabi")
"-I" ,(string-append #$go-toolchain "/share/go/pkg/include")
"-I" #$empty-asmhdr
,@(if include-path (list "-I" #$include-path) '())
. #$files))
(cdar (store-path-for-ca-drv*
(string-append (rewrite-package-name package-name) "-asm-symabis")
"x86_64-linux"
#~(,(string-append #$go-toolchain "/bin/go") "tool" "asm" . #$args)
(env-for-goarch) '("symabi"))))
;; Returns a store path containing the `++code++` of the provided assembly files.
(define (go-compile-assembly package-name include-path include-path2 files)
(define args
#~(
,@(defines-for-goarch)
"-p" #$package-name
"-o" ,(make-placeholder "code")
"-I" ,(string-append #$go-toolchain "/share/go/pkg/include")
,@(if include-path (list "-I" #$include-path) '())
,@(if include-path2 (list "-I" #$include-path2) '())
"-trimpath" ,(apply string-append (map (lambda (f) (string-append (cdr f) "=>" package-name "/" (car f) ";")) #$files))
. ,(map cdr #$files)))
(cdar (store-path-for-ca-drv*
(string-append (rewrite-package-name package-name) "-asm")
"x86_64-linux"
#~(,(string-append #$go-toolchain "/bin/go") "tool" "asm" . #$args)
(env-for-goarch) '("code"))))))

33
lang/go/src/fetch.sld Normal file
View file

@ -0,0 +1,33 @@
(define-library (zilch lang go fetch)
(import
(scheme base) (scheme write) (scheme read) (scheme file) (scheme char)
(zilch magic) (zilch zexpr)
(zilch nixpkgs)
(chicken format))
(export
fetch-with-known-url rewrite-module-name-for-url)
(begin
(define fetch-cache (call-with-input-file "/home/.zilchcache" read))
(define (fetch-with-known-url name url)
(define cache-entry (assoc url fetch-cache))
(define hash (if cache-entry
(cdr cache-entry)
(begin (printf "..fetching ~S ~S\n" name url)
(nix-prefetch-url name url #f))))
(unless cache-entry
(set! fetch-cache (cons (cons url hash) fetch-cache))
(call-with-output-file "/home/.zilchcache" (lambda (out) (write fetch-cache out))))
(store-path-for-fod name "builtin" '("builtin:fetchurl") `(("url" . ,url) ("outputHashMode" . "flat")) "sha256" hash #f))
(define (rewrite-module-name-for-url name)
(define out "")
(string-for-each
(lambda (ch)
(if
(char-upper-case? ch)
(set! out (string-append out (string #\! (char-downcase ch))))
(set! out (string-append out (string ch)))))
name)
out)))

124
lang/go/src/go.sld Normal file
View file

@ -0,0 +1,124 @@
(define-library (zilch lang go)
(import
(scheme base) (scheme write) (scheme process-context) (scheme lazy)
(chicken file) (chicken format)
(zilch magic) (zilch file) (zilch zexpr)
(zilch nix drv) (zilch nix path) (zilch nixpkgs)
(json)
(chicken base) (chicken format) (chicken foreign)
(srfi-4)
(zilch lang go core))
(export
make-go-package go-package?
go-package-name go-package-import-path
go-package-api go-package-code go-package-dependencies
go-dependency-closure
go-package-compile go-package-link)
(begin
;; A go package consists of a few separate `++(zilch magic)++` store paths.
;; The `++name++` is the package name as compiled, and `++import-path++` is a nicer
;; package name for "main" packages. The `++go-package-api++` is a store path consisting
;; of a `++.a++` containing the output of the compiler's `++__.PKGDEF++` only, which
;; contains the exported types and functions, along with a slight amount of LTO and
;; inlining metadata. the `++go-package-code++` store path contains the actual assembly
;; of the package.
(define-record-type <go-package>
(make-go-package name import-path api code dependencies)
go-package?
(name go-package-name)
(import-path go-package-import-path)
(api go-package-api)
(code go-package-code)
(dependencies go-package-dependencies))
(define-record-printer (<go-package> pkg out)
(fprintf out "#<go-package ~A api: ~S code: ~S deps: ~S>"
(if (string=? (go-package-import-path pkg) (go-package-name pkg))
(go-package-name pkg)
(string-append (go-package-name pkg) " (" (go-package-import-path pkg) ")"))
(go-package-api pkg)
(go-package-code pkg)
(map go-package-name (go-package-dependencies pkg))))
;; Recursively walk over the dependencies of a `++go-package++`, prepending to the `++vals++` list.
(define (go-dependency-closure package vals)
(unless (member package vals)
(set! vals (cons package vals))
(for-each
(lambda (pkg)
(set! vals (go-dependency-closure pkg vals)))
(go-package-dependencies package)))
vals)
;; `(go-package-compile name deps source-files)`
;; or `(go-package-compile name path deps source-files assembly-files assembly-includes embed-filenames embed-patterns)`
;; Build a Zilch-defined Go package of one store path as source code, and a list of dependencies.
(define go-package-compile
(case-lambda
((name deps source-files) (go-package-compile name name deps source-files '() '() '() '()))
((name path deps source-files assembly-files assembly-includes embed-filenames embed-patterns)
(define api-importcfg
(zfile #~,(build-importcfg #$(map (lambda (pkg) (cons (go-package-import-path pkg) (go-package-api pkg))) deps) '())))
(define api-embedcfg
(zfile #~,(build-embedcfg #$embed-patterns #$embed-filenames)))
(define symabis #f)
(unless assembly-files (set! assembly-files '()))
(define path-or-name (if (string=? name "main") name path))
(define assembly-includes-dir
(if (list? assembly-includes)
(zdir (map (lambda (pair) (cons (car pair) (zsymlink (cdr pair)))) assembly-includes))
assembly-includes))
(unless (eq? assembly-files '())
(set! symabis (go-generate-symabi path-or-name assembly-includes-dir #~,(map cdr #$assembly-files))))
(define compiled-go
(go-compile #f path-or-name api-importcfg symabis api-embedcfg source-files))
(define merged-asmhdr
(zdir "go_asm.h" (zsymlink (cdr (assoc "asmhdr" compiled-go)))))
;; ISSUE: this needs the source dir for assembly imports reasons (filter out .h files?)
(define compiled-assembly
(map
(lambda (f) (go-compile-assembly path-or-name assembly-includes-dir merged-asmhdr (list f)))
assembly-files))
; Assembly code doesn't have an API, so use the Go code's API only.
(define go-api (cdr (assoc "api" compiled-go)))
; Make a list of the "code" output from the Go with the compiled assembly files.
; NOTE: .go has to be compiled in one go; but .s is compiled one file at a time.
(define all-code (cons (cdr (assoc "code" compiled-go)) compiled-assembly))
; (printf " -> (store-path-for-ca-drv* meow meow ~S ~S meow)\n" all-code (env-for-goarch))
; Use `go tool pack` to merge the code together.
(define merged-code
(if (length assembly-files)
(cdar (store-path-for-ca-drv*
(string-append "go-" (rewrite-package-name path) "-code") "x86_64-linux"
#~(,(string-append #$go-toolchain "/bin/go") "tool" "pack" "c" ,(make-placeholder "code") . #$all-code)
(env-for-goarch)
'("code")))
(cdr (assoc "code" compiled-go))))
; (printf " -> (make-go-package ~S ~S ~S ~S ~S)\n" name path (cdr (assoc "api" compiled-go)) merged-code deps)
(make-go-package name path (cdr (assoc "api" compiled-go)) merged-code deps))))
;; Link a `++go-package++` into a binary that can be (statically) executed.
(define (go-package-link pkg)
(define code-importcfg
(zfile #~,(build-importcfg #$(map (lambda (pkg) (cons (go-package-import-path pkg) (go-package-code pkg))) (go-dependency-closure pkg '())) '())))
(cdar (store-path-for-ca-drv* (rewrite-package-name (go-package-import-path pkg)) "x86_64-linux"
#~(,(string-append #$go-toolchain "/bin/go") "tool" "link" "-buildid" ,(string-append "zilch out=" (make-placeholder "out")) "-importcfg" #$code-importcfg "-o" ,(make-placeholder "out") #$(go-package-code pkg)) (env-for-goarch) '("out"))))))

230
lang/go/src/mod.sld Normal file
View file

@ -0,0 +1,230 @@
;; Processes go modules.
(define-library (zilch lang go mod)
(import
(scheme base) (scheme write) (scheme read) (scheme file) (scheme process-context) (scheme lazy) (scheme case-lambda)
(chicken file)
(zilch magic) (zilch file) (zilch zexpr)
(zilch nix drv) (zilch nix path) (zilch nixpkgs)
(json)
(chicken base) (chicken format) (chicken foreign)
(scheme char)
(srfi 4) (srfi 128) (srfi 132) (srfi 133) (srfi 146) (srfi 152) (srfi 207)
(zilch lang go) (zilch lang go core) (zilch lang go stdlib) (zilch lang go vfs) (zilch lang go sum) (zilch lang go fetch) (zilch lang go package)
(zilch lang go version)
(chicken foreign))
(export
collect-requirements-for-module collect-packages-from-requires)
(begin
(define (is-builtin str)
(not (string-index str (lambda (ch) (char=? ch #\.)))))
(define (filter proc lis)
(cond
((eq? lis '()) lis)
((proc (car lis))
(cons (car lis) (filter proc (cdr lis))))
(else (filter proc (cdr lis)))))
;; Read a go.mod file. This returns a processed json object, like `go mod edit -json` outputs by default.
(define (read-go-mod mod-file)
(call-with-port
;; TODO(puck): don't use /bin/sh here.
(store-path-open (cdar (store-path-for-ca-drv* "go.mod.json" "x86_64-linux" #~("/bin/sh" "-c" ,(string-append #$go-toolchain "/bin/go mod edit -json " #$mod-file " > $out")) '() '("out"))))
(lambda (p) (json-read p))))
(define (vector-get-kv-value key vec)
(vector-any (lambda (v) (and (string=? (car v) key) (cdr v))) vec))
;; Reads in the module rooted by the vfs, and resolves its requirements list.
;; This returns two values: the name of the root module, and a mapping of module name to a pair of its version and the vfs.
(define (collect-requirements-for-module vfs replaces)
(define sum-lines '())
(define (parse-sumfile go-sum)
(vector-for-each
(lambda (line)
(define loc (assoc (go-sum-module line) sum-lines))
(unless (go-sum-path line)
(unless loc
(set! sum-lines (cons (list (go-sum-module line)) sum-lines))
(set! loc (car sum-lines)))
(unless (assoc (go-sum-version line) (cdr loc))
(set-cdr! loc (cons (cons (go-sum-version line) (delay (vfs-from-dirhash line))) (cdr loc))))))
go-sum))
(define (add-modules-from-sum nvfs dir)
(define sumfile (vector-get-kv-value "go.sum" (vector-get-kv-value dir nvfs)))
(when sumfile
(parse-sumfile (call-with-port (store-path-open sumfile) parse-go-sum-file))))
(define collected-requires (mapping (make-default-comparator)))
(fprintf (current-error-port) "Collecting required modules\n")
(define (find-requires-from-mod vfs dir)
(define modfile (vector-get-kv-value "go.mod" (vector-get-kv-value dir vfs)))
(define pathname #f)
(when modfile
(let*
((go-mod (read-go-mod modfile))
(module-obj (vector-get-kv-value "Module" go-mod))
(path (vector-get-kv-value "Path" module-obj))
(require-data (vector-get-kv-value "Require" go-mod))
(require-list (if (list? require-data) require-data '())))
(fprintf (current-error-port) "- found ~S (requires ~S modules)\n" path (length require-list))
(for-each
(lambda (req)
(define require-path (vector-get-kv-value "Path" req))
(define require-version (vector-get-kv-value "Version" req))
(define dep (mapping-ref/default collected-requires require-path #f))
(unless dep (set! dep (cons require-version #f))
(set! collected-requires (mapping-set! collected-requires require-path dep)))
(when (and (car dep) (version<? (car dep) require-version))
(set-car! dep require-version)
(set-cdr! dep #f)))
require-list)
(set! pathname path)))
pathname)
(define root-path-name #f)
(define (handle-vfs nvfs)
(add-modules-from-sum nvfs "/")
(find-requires-from-mod nvfs "/"))
(for-each
(lambda (vfs)
(define path-name (handle-vfs vfs))
(set! collected-requires (mapping-set! collected-requires path-name (cons #f vfs))))
replaces)
; we have the right module versions and their files now. Iterate over the packages we have,
; until we have none left that need iterating. Once that's done, iterate all the packages and fetch the go.sum for them.
(define (tick)
(define found-valid #f)
(define found-missing '())
(define-values (keys values) (mapping-entries collected-requires))
(for-each
(lambda (key value)
(unless (cdr value)
(let* ((module-data (assoc key sum-lines))
(vfs-for-version (and module-data (assoc (car value) (cdr module-data)))))
(if vfs-for-version
(begin
(handle-vfs (force (cdr vfs-for-version)))
(set-cdr! value (force (cdr vfs-for-version)))
(set! found-valid #t))
(begin
(set! found-missing (cons (cons key (car value)) found-missing)))))))
keys values)
(cond
((and found-valid (not (eqv? found-missing '())))
(tick))
((and found-valid (eqv? found-missing '()))
(tick))
((and (not found-valid) (eqv? found-missing '()))
#f)
((and (not found-valid) (not (eqv? found-missing '())))
(for-each
(lambda (pair)
(fprintf (current-error-port) " (fetching go.sum from sumdb for ~S ~S)\n" (car pair) (cdr pair))
(let ((file (fetch-with-known-url "go.sum" (string-append "https://sum.golang.org/lookup/" (rewrite-module-name-for-url (car pair)) "@" (cdr pair)))))
(call-with-port (store-path-open file) (lambda (port) (read-line port) (parse-sumfile (vector (parse-go-sum-line (read-line port)) (parse-go-sum-line (read-line port))))))))
found-missing)
(tick))))
(set! root-path-name (handle-vfs vfs))
(set! collected-requires (mapping-set! collected-requires root-path-name (cons #f vfs)))
(tick)
(values root-path-name collected-requires))
;; Processes a mapping of module name to a pair of version and vfs, and returns a procedure that takes a package name and returns its go-package.
(define (collect-packages-from-requires collected-requires)
(define (process-package vfs last-part full-path pairs headers)
(define name (cdr (assoc "name" pairs)))
(define go-files (cdr (assoc "goFiles" pairs)))
(define s-files (if (and (assoc "sFiles" pairs) (list? (cdr (assoc "sFiles" pairs)))) (cdr (assoc "sFiles" pairs)) '()))
(define imports (cdr (assoc "imports" pairs)))
; format: ((pattern . (fname file dir)))
(define embed-vectors (cdr (assoc "embeds" pairs)))
(define embeds (if (vector? embed-vectors) (vector->list embed-vectors) '()))
(define embed-filenames '())
(define embed-patterns (map (lambda (pattern) (cons (car pattern) (if (list? (cdr pattern)) (map car (cdr pattern)) '()))) embeds))
(for-each
(lambda (pattern)
(when (list? pattern)
(for-each
(lambda (fname)
(define new-fname (cadr fname))
(if (string=? "//" new-fname) (set! new-fname "/"))
(define dir (vector-get-kv-value new-fname vfs))
(define file-obj (vector-get-kv-value (car (cddr fname)) dir))
(unless (assoc (car fname) embed-filenames) (set! embed-filenames (cons (cons (car fname) file-obj) embed-filenames))))
(cdr pattern))))
embeds)
(define vfsdir (vector-get-kv-value last-part vfs))
(let
((collected-files (map (lambda (name) (cons name (vector-get-kv-value name vfsdir))) go-files))
(collected-assembly-files (map (lambda (name) (cons name (vector-get-kv-value name vfsdir))) s-files))
(collected-assembly-includes (if (= (length s-files) 0) '() #~,(string-append #$(force headers) last-part)))
(collected-imports (map (lambda (name) (if (is-builtin name) (go-stdlib-ref name) (find-package name)))
(filter (lambda (name) (not (member name '("builtin" "unsafe")))) imports))))
(go-package-compile name full-path collected-imports collected-files collected-assembly-files collected-assembly-includes embed-filenames embed-patterns)))
(define packages (mapping (make-default-comparator)))
(define (process-packages-for-module root-path vfs)
(define (dir-has-valid-contents contents)
(vector-any
(lambda (entry)
(or
(eq? (car entry) "go.mod")
(string-suffix? ".go" (car entry))))
contents))
(define module-packages
(find-packages-inside-vfs
(vector-map
(lambda (pair)
(cons
(car pair)
(if (dir-has-valid-contents (cdr pair))
(cdr pair)
(vector-map (lambda (pair) (cons (car pair) "/dev/null")) (cdr pair)))))
vfs)))
(define headers (delay (vfs-to-store (filter-vfs vfs (lambda (dir fname) (string-suffix? ".h" fname))))))
(vector-for-each
(lambda (pair)
(define full-path (string-append root-path (car pair)))
(set! full-path (string-copy full-path 0 (- (string-length full-path) 1)))
(define pairs (vector->list (cdr pair)))
(set! packages (mapping-set! packages full-path (delay (process-package vfs (car pair) full-path pairs headers)))))
module-packages))
(define (find-longest-prefix name)
(define prefixes (mapping-entries (mapping-filter (lambda (key value) (string-prefix? key name)) collected-requires)))
(unless (eq? prefixes '())
(set! prefixes (list-sort! (lambda (left right) (> (string-length left) (string-length right))) prefixes)))
(if (eq? prefixes '())
#f
(car prefixes)))
(define (find-package full-path)
(define package (mapping-ref/default packages full-path #f))
(unless package
(let ((module-key (find-longest-prefix full-path)))
(when module-key
(process-packages-for-module module-key (cdr (mapping-ref/default collected-requires module-key #f)))
(set! package (mapping-ref/default packages full-path #f)))))
(unless package
(error (string-append "Could not find package " full-path)))
(force package))
(define (find-packages-for-module pkg)
(define modules (mapping-filter (lambda (k v) (string-prefix? pkg k)) packages))
(when (= (mapping-size modules) 0)
(let ((module-key (find-longest-prefix pkg)))
(when module-key
(process-packages-for-module module-key (cdr (mapping-ref/default collected-requires module-key #f)))))
(set! modules (mapping-filter (lambda (k v) (string-prefix? pkg k)) packages)))
(mapping-keys modules))
(values find-package find-packages-for-module))))

30
lang/go/src/package.sld Normal file
View file

@ -0,0 +1,30 @@
(define-library (zilch lang go package)
(import
(scheme base)
(zilch file) (zilch magic)
(zilch nixpkgs) (zilch zexpr)
json
(chicken foreign)
(zilch lang go core) (zilch lang go) (zilch lang go vfs) (zilch lang go stdlib))
(export find-packages-inside-vfs)
(begin
(foreign-declare "#include \"parser_source.h\"")
(define go-import-parser
(go-package-link
(go-package-compile "main"
(map go-stdlib-ref '("encoding/json" "fmt" "go/build" "io" "io/fs" "os" "path" "path/filepath" "sort" "strings" "time"))
(list (cons "main.go" (zfile (foreign-value "parser_source" nonnull-c-string)))))))
(define (find-packages-inside-vfs vfs)
(define input
#~,(call-with-port
(open-output-bytevector)
(lambda (bv)
(json-write (vector (cons "GOARCH" (%goarch)) (cons "GOOS" "linux") (cons "files" #$(filter-vfs-for-package-reading vfs))) bv)
(get-output-bytevector bv))))
(define input-file (zfile input))
(define store-path (cdar (store-path-for-ca-drv* "find-packages" "x86_64-linux" #~(#$go-import-parser #$input-file) '() '("out"))))
(call-with-port (store-path-open store-path)
(lambda (p) (json-read p))))))

159
lang/go/src/stdlib.sld Normal file
View file

@ -0,0 +1,159 @@
(define-library (zilch lang go stdlib)
(import
(scheme base) (scheme file) (scheme write) (scheme process-context) (scheme lazy)
(chicken file) (chicken format)
(zilch magic) (zilch file) (zilch zexpr)
(zilch nix drv) (zilch nix path) (zilch nixpkgs)
(json)
(chicken foreign)
(srfi-4)
(zilch lang go core)
(zilch lang go))
(export
go-stdlib-ref)
(begin
;; Helper to read JSON objects until EOF.
(define (read-all-objects port out)
(if (eof-object? (peek-char port))
out
(read-all-objects port (cons (json-read port) out))))
;; Runs `++go list++` (thru `++/bin/sh++`) and reads (IFD) the output to fetch the metadata of the Go standard library and commands.
(define stdlib-objects
(map vector->list
(call-with-port
(store-path-open
(cdar (store-path-for-ca-drv*
"stdenv"
"x86_64-linux"
#~("/bin/sh" "-c" ,(string-append "GOCACHE=$TMPDIR/go-cache " #$go-toolchain "/bin/go list -json -deps std cmd > $out"))
(env-for-goarch) '("out"))))
(lambda (port) (read-all-objects port '())))))
(define (assoc-or-empty name obj)
(define res (assoc name obj))
(if res (cdr res) '()))
;; Extract everything until the first space.
;; Space characters are illegal in Go package names, and `++go list -json std++`
;; uses it to disambiguate multiple versions of some internal packages.
(define (strip-space-bits name)
(do
((x 0 (+ 1 x)))
((or
(>= x (string-length name))
(char=? (string-ref name x) #\space))
(if (>= x (string-length name))
name
(substring name 0 x)))))
;; Tail-recursively remove any packages that, if ignoring the postfixed origin
;; (e.g. `++unsafe [cmd/compile]++`), match either `++unsafe++` or `++builtin++`;
;; these have no source code and are compiler-internal.
(define (remove-builtin-packages pkgs)
(if (eq? pkgs '())
'()
(let ((stripped (strip-space-bits (car pkgs))))
(if (or (string=? stripped "unsafe") (string=? stripped "builtin"))
(remove-builtin-packages (cdr pkgs))
(cons (car pkgs) (remove-builtin-packages (cdr pkgs)))))))
(define (starts-with left right)
(and
(>= (string-length right) (string-length left))
(string=? left (string-copy right 0 (string-length left)))))
(define (filter condition lst)
(if (eq? lst '())
'()
(if (condition (car lst))
(cons (car lst) (filter condition (cdr lst)))
(filter condition (cdr lst)))))
;; Helper that parses the JSON returned by `++go list -json -deps++` and builds a `++go-package++` record.
;; This is distinct from `go-package-compile` because of format differences,
(define (make-stdlib-inner meta)
(define files (assoc-or-empty "GoFiles" meta)) ; .go files
(define sfiles (assoc-or-empty "SFiles" meta)) ; .s files
(define imports (assoc-or-empty "Imports" meta)) ; imports (denormalised)
(define importmap (assoc-or-empty "ImportMap" meta)) ; import map
; Rewrite the import map to be normalised; we use the normalised import path later on.
(when (vector? importmap)
(set! importmap (map (lambda (v) (cons (car v) (strip-space-bits (cdr v)))) (vector->list importmap))))
(define import-path (cdr (assoc "ImportPath" meta)))
(define package-name (cdr (assoc "Name" meta)))
(define name (strip-space-bits import-path))
; Deal with commands properly. (Their package name is "main", but we track import path in other cases)
(when (string=? package-name "main")
(set! name package-name))
(define dir (cdr (assoc "Dir" meta)))
; Fetch dependencies from the rest of the stdlib data.
; We only need the `++api++` at this point.
(define resolved-imports (map (lambda (v) (cons (strip-space-bits v) (go-package-api (go-stdlib-ref v)))) (remove-builtin-packages imports)))
; The importcfg encodes the list of (direct) dependencies. Generate this from the "Imports" entry in the `go list -json` output.
; This uses a workaround for fetchurl behavior having been changed.
(define importcfg (zfile #~,(build-importcfg #$resolved-imports importmap)))
; If this package uses embeds, process them.
(define embed-patterns (assoc-or-empty "EmbedPatterns" meta))
(define embed-files (assoc-or-empty "EmbedFiles" meta))
; alist of (<embed pattern>. values)
(define embedprocessed (map (lambda (l) (cons (strip-space-bits l) (map strip-space-bits (filter (lambda (v) (starts-with l v)) embed-files)))) embed-patterns))
(define embeds #f)
(unless (eq? embed-files '())
(set! embeds
(zfile #~,(build-embedcfg embedprocessed (map (lambda (k) (cons k (string-append dir "/" k))) embed-files)))))
; When compiling assembly code, we first need to generate the symabi; then compile the Go code using that,
; and use the go_asm.h output from the Go compilation to compile the rest of the assembly.
(define symabis #f)
(unless (eq? sfiles '())
(set! symabis (go-generate-symabi name dir (map (lambda (f) (string-append dir "/" f)) sfiles))))
; Compile the go code. Currently done in one single go, rather than per-file; this is a TODO.
(define compiled-go (go-compile #t name importcfg symabis embeds (map (lambda (f) (cons f (string-append dir "/" f))) files)))
(define asmhdrs (cdr (assoc "asmhdr" compiled-go)))
; Move the asmhdr output to the right path for the assembly.
; TODO: use zfile logic, once this works again.
(define merged-asmhdr
(zdir "go_asm.h" (zsymlink asmhdrs)))
; Now compile every assembly file, in order.
(define compiled-assembly
(map
(lambda (f) (go-compile-assembly name dir merged-asmhdr (list (cons f (string-append dir "/" f)))))
sfiles))
; Assembly code doesn't have an API, so use the Go code's API only.
(define go-api (cdr (assoc "api" compiled-go)))
; Make a list of the "code" output from the Go with the compiled assembly files.
; NOTE: .go has to be compiled in one go; but .s is compiled one file at a time.
(define all-code (cons (cdr (assoc "code" compiled-go)) compiled-assembly))
; Use `go tool pack` to merge the code together.
(define merged-code
(cdar
(store-path-for-ca-drv*
(string-append "go-" (rewrite-package-name name) "-code") "x86_64-linux"
#~(,(string-append #$go-toolchain "/bin/go") "tool" "pack" "c" ,(make-placeholder "code") . #$all-code)
(env-for-goarch)
'("code"))))
(make-go-package name import-path go-api merged-code (map go-stdlib-ref (remove-builtin-packages imports))))
; Each entry is a list (name metadata (api code)).
; Use `++delay++` to resolve the DAG lazily on use.
(define stdlib-data (map (lambda (v) (list (cdr (assoc "ImportPath" v)) v (delay (make-stdlib-inner v)))) stdlib-objects))
;; Wrapper that forces evaluation of the promise fetching from a Go stdlib entry.
(define (go-stdlib-ref name)
(define entry (assoc name stdlib-data))
(unless entry (error (string-append "Could not find package " name " in stdlib")))
(force (list-ref entry 2)))))

60
lang/go/src/sum.sld Normal file
View file

@ -0,0 +1,60 @@
(define-library (zilch lang go sum)
(import
(scheme base) (scheme write) (scheme read) (scheme file) (scheme process-context) (scheme lazy) (scheme case-lambda)
(chicken file)
(zilch magic) (zilch file) (zilch zexpr)
(zilch nix drv) (zilch nix path) (zilch nixpkgs)
(json)
(chicken base) (chicken format) (chicken foreign)
(scheme char)
(srfi 4) (srfi 128) (srfi 146) (srfi 207)
(chicken foreign))
(export
parse-go-sum-line parse-go-sum-file go-sum-line? go-sum-module go-sum-version go-sum-path go-sum-hash)
(begin
(define-record-type <go-sum-line>
(make-go-sum-line module version path hash)
go-sum-line?
(module go-sum-module)
(version go-sum-version)
(path go-sum-path)
(hash go-sum-hash))
(define-record-printer (<go-sum-line> sum out)
(fprintf out "#<go-sum ~A ~A~A h1:~A>"
(go-sum-module sum)
(go-sum-version sum)
(if (go-sum-path sum) (go-sum-path sum) "")
(bytevector->base64 (go-sum-hash sum))))
(define (string-find str index char)
(cond
((= index (string-length str)) #f)
((char=? (string-ref str index) char) index)
(else (string-find str (+ index 1) char))))
(define (parse-go-sum-line line)
(define version-space-index (string-find line 0 #\space))
(unless version-space-index (error "go.sum line contains no space characters"))
(define hash-space-index (string-find line (+ version-space-index 1) #\space))
(unless hash-space-index (error "go.sum line contains only one space character"))
(when (string-find line (+ hash-space-index 1) #\space) (error "go.sum line contains too many space characters"))
(define module-path (string-copy line 0 version-space-index))
(define version (string-copy line (+ version-space-index 1) hash-space-index))
(define hash (string-copy line (+ hash-space-index 1)))
(unless (string=? (string-copy hash 0 3) "h1:") (error "go.sum line has invalid algorithm for hash" hash))
(define path #f)
(define path-index (string-find version 0 #\/))
(when path-index
(set! path (string-copy version path-index))
(set! version (string-copy version 0 path-index)))
(make-go-sum-line module-path version path (base64->bytevector (string-copy hash 3))))
(define (parse-go-sum-file port)
(do ((parsed '())
(line "" (read-line port)))
((eof-object? line) (list->vector (reverse parsed)))
(unless (string=? line "") (set! parsed (cons (parse-go-sum-line line) parsed)))))))

46
lang/go/src/version.sld Normal file
View file

@ -0,0 +1,46 @@
(define-library (zilch lang go version)
(import
(scheme base) (srfi 152))
(export parse-version version<?)
(begin
(define (parse-version vstr)
(unless (char=? (string-ref vstr 0) #\v) (error "not a valid version" vstr))
(define first-period (string-index vstr (lambda (ch) (char=? ch #\.)) 1))
(define second-period (string-index vstr (lambda (ch) (char=? ch #\.)) (+ 1 first-period)))
(define prerelease-dash (string-index vstr (lambda (ch) (char=? ch #\-)) (+ 1 second-period)))
(define build-dash (string-index vstr (lambda (ch) (char=? ch #\+)) (+ 1 (or prerelease-dash second-period))))
(define major (string->number (string-copy vstr 1 first-period)))
(define minor (string->number (string-copy vstr (+ first-period 1) second-period)))
(define patch (string->number (string-copy vstr (+ second-period 1) (or prerelease-dash build-dash (string-length vstr)))))
(define prerelease (and prerelease-dash (string-copy vstr (+ prerelease-dash 1) (or build-dash (string-length vstr)))))
(define build (and build-dash (string-copy vstr (+ build-dash 1))))
(list major minor patch prerelease build))
(define (version<? left right)
(set! left (parse-version left))
(set! right (parse-version right))
(or
; left.major < right.major, or
(< (list-ref left 0) (list-ref right 0))
(and
; left.major = right.major, and
(= (list-ref left 0) (list-ref right 0))
(or
; left.minor < right.minor, or
(< (list-ref left 1) (list-ref right 1))
(and
; left.minor = right.minor, and
(= (list-ref left 1) (list-ref right 1))
(or
; left.patch < right.patch, or
(< (list-ref left 2) (list-ref right 2))
(and
; left.patch = right.patch, and
(= (list-ref left 2) (list-ref right 2))
(or
; left has prerelease, right doesn't
(and (list-ref left 3) (not (list-ref right 3)))
; or both have a prerelease and it's comparable
(and (list-ref left 3) (string<? (list-ref left 3) (list-ref right 3)))))))))))))

151
lang/go/src/vfs.sld Normal file
View file

@ -0,0 +1,151 @@
(define-library (zilch lang go vfs)
(import
(scheme base) (scheme write) (scheme read) (scheme file) (scheme process-context) (scheme lazy) (scheme case-lambda)
(chicken file)
(zilch magic) (zilch file) (zilch zexpr)
(zilch nix drv) (zilch nix path) (zilch nixpkgs)
(json)
(chicken base) (chicken format) (chicken foreign)
(scheme char)
(srfi 4) (srfi 128) (srfi 133) (srfi 146) (srfi 152) (srfi 207)
(zilch lang go) (zilch lang go core) (zilch lang go stdlib) (zilch lang go sum) (zilch lang go fetch)
(chicken foreign))
(export vfs-from-dirhash vfs-from-directory filter-vfs filter-vfs-for-package-reading vfs-to-store)
(begin
(define (read-full-file port)
(define buf (make-bytevector 2048 0))
(call-with-port (open-output-bytevector)
(lambda (outport)
(do ((read-bytes 0 (read-bytevector! buf port))) ((eof-object? read-bytes) (get-output-bytevector outport))
(unless (eof-object? read-bytes) (write-bytevector buf outport 0 read-bytes))))))
(foreign-declare "#include \"dirhash_source.h\"")
(define dirhash-generator
(go-package-link
(go-package-compile "main"
(map go-stdlib-ref '("archive/zip" "crypto/sha256" "fmt" "io" "os" "sort"))
(list (cons "main.go" (zfile (foreign-value "dirhash_source" nonnull-c-string)))))))
(foreign-declare "#include \"unzip_one_source.h\"")
(define unpack-zip
(go-package-link
(go-package-compile "main"
(map go-stdlib-ref '("archive/zip" "io" "os"))
(list (cons "main.go" (zfile (foreign-value "unzip_one_source" nonnull-c-string)))))))
(define (rewrite-name name)
(define out "")
(string-for-each (lambda (ch)
(if (char-upper-case? ch) (set! out (string-append out (string #\! (char-downcase ch)))) (set! out (string-append out (string ch))))) name)
out)
(define (vfs-to-store vfs)
(define dirmap (mapping (make-default-comparator)))
(vector-for-each
(lambda (pair)
(define key (car pair))
(define separator (if (string=? key "/") 0 (string-index-right key (lambda (ch) (char=? ch #\/)) 0 (- (string-length key) 1))))
(unless (string=? key "/")
(let
((dirname (string-copy key 0 (+ 1 separator)))
(fname (string-copy key (+ 1 separator) (- (string-length key) 1))))
(set! dirmap (mapping-set! dirmap dirname (cons (cons fname key) (mapping-ref/default dirmap dirname '())))))))
vfs)
(define (translate-dir name)
(define files (vector-any (lambda (f) (and (string=? (car f) name) (cdr f))) vfs))
(define dirs (mapping-ref/default dirmap name '()))
(zdir (append
(map (lambda (kv) (cons (car kv) (zsymlink (cdr kv)))) (vector->list files))
(map (lambda (k) (cons (car k) (translate-dir (cdr k)))) dirs))))
(translate-dir "/"))
(define (fetch-dirhash-for-sum sum-line)
(when (go-sum-path sum-line) (error "go.sum line is invalid for fetch-dirhash-for-sum" sum-line))
(define url (string-append "https://proxy.golang.org/" (rewrite-name (go-sum-module sum-line)) "/@v/" (go-sum-version sum-line) ".zip"))
(define known (fetch-with-known-url "module.zip" url))
(store-path-for-fod "module" "x86_64-linux" #~(#$dirhash-generator) #~(("src" . #$known)) "sha256" (go-sum-hash sum-line) #f))
(define (vfs-from-dirhash sum-line)
(define dirhash-file (fetch-dirhash-for-sum sum-line))
(define url (string-append "https://proxy.golang.org/" (rewrite-name (go-sum-module sum-line)) "/@v/" (go-sum-version sum-line) ".zip"))
(define zip (fetch-with-known-url "module.zip" url))
(define lines '())
(define prefix-length (string-length (string-append (go-sum-module sum-line) "@" (go-sum-version sum-line) "/")))
(call-with-port (store-path-open dirhash-file)
(lambda (port)
(do ((line "" (read-line port)) (hash #f) (file #f))
((eof-object? line) #f)
(unless (string=? "" line)
(set! hash (hex-string->bytevector (string-copy line 0 64)))
(set! file (string-copy line 66))
(set! lines (cons (cons file hash) lines))))))
(define dirs '())
(for-each
(lambda (pair)
(define fpath (string-copy (car pair) prefix-length))
(define slashindex (string-index-right fpath (lambda (c) (char=? c #\/))))
(define dirname "/")
(define filename fpath)
(when slashindex
(set! dirname (string-append "/" (string-copy fpath 0 slashindex) "/"))
(set! filename (string-copy fpath (+ slashindex 1))))
(define dir (assoc dirname dirs))
(define file (store-path-for-fod "file" "x86_64-linux" #~(#$unpack-zip #$zip ,(car pair)) '() "sha256" (cdr pair) #f))
(unless dir
(set! dirs (cons (list dirname) dirs))
(set! dir (car dirs)))
; Skip files we know for sure won't be used.
(unless (or (string-contains dirname "/_") (string-contains dirname "/.") (string-contains dirname "/testdata/") (char=? #\. (string-ref filename 0)) (char=? #\_ (string-ref filename 0)))
(set-cdr! dir (cons (cons filename file) (cdr dir)))))
lines)
(list->vector (map (lambda (pair) (cons (car pair) (list->vector (cdr pair)))) dirs)))
(define (vfs-from-directory osdir)
(define iter-dir #f)
(define output '())
(set! iter-dir
(lambda (dirpath)
(define reldir (string-append osdir "/" dirpath))
(define files '())
(define contents (directory (string-append osdir dirpath)))
(for-each
(lambda (name)
(unless (string=? (string-copy name 0 1) ".")
(if (directory-exists? (string-append reldir "/" name))
(iter-dir (string-append dirpath "/" name))
(set! files (cons (cons name (zfile #~,(call-with-input-file (string-append reldir "/" name) read-full-file))) files)))))
contents)
(set! output (cons (cons (string-append dirpath "/") (list->vector files)) output))))
(iter-dir "")
(list->vector output))
(define (filter-vfs vfs filter)
(vector-map
(lambda (dir)
(cons (car dir)
(vector-map
(lambda (pair)
(if (filter (car dir) (car pair))
(cons (car pair) (cdr pair))
(cons (car pair) "/dev/null")))
(cdr dir))))
vfs))
; List extracted from go src/go/build/build.go.
(define good-extensions '("go" "c" "cc" "cpp" "cxx" "m" "h" "hh" "hpp" "hxx" "f" "F" "for" "f90" "s" "S" "sx" "swig" "swigcxx" "syso"))
(define (extract-extension name i)
(cond ((char=? (string-ref name i) #\.) (string-copy name (+ i 1)))
((= i 0) #f)
(else (extract-extension name (- i 1)))))
(define (filter-vfs-for-package-reading vfs)
(filter-vfs vfs
(lambda (dir fname)
(define extension (extract-extension fname (- (string-length fname) 1)))
(member extension good-extensions))))))