zilch/lang/go/src/core.sld

(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"))))))