Guile-hoot/module/hoot/compile.scm

;;; WebAssembly compiler
;;; Copyright (C) 2023, 2024 Igalia, S.L.
;;; Copyright (C) 2023 Robin Templeton <robin@spritely.institute>
;;; Copyright (C) 2023 David Thompson <dave@spritely.institute>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;;
;;; Scheme to WebAssembly compiler.
;;;
;;; Code:

(define-module (hoot compile)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 match)
  #:use-module ((system base compile)
                #:select ((compile . %compile)
                          default-warning-level
                          default-optimization-level))
  #:use-module (system base target)
  #:use-module (hoot library-group)
  #:use-module (hoot inline-wasm)
  #:use-module (hoot backend)
  #:use-module (wasm assemble)
  #:export (%default-program-imports
            scheme->sealed-tree-il
            read-and-compile
            compile-file
            compile))

(define-syntax-rule (with-hoot-target . body)
  (with-target "wasm32-unknown-hoot"
    (lambda ()
      (parameterize ((target-runtime 'hoot))
        . body))))

(define (%include-from-path filename)
  (let ((filename
         (or (%search-load-path filename)
             (error 'include "file not found in path" filename))))
    (call-with-include-port
     (datum->syntax #f (canonicalize-path filename))
     (lambda (p)
       (let lp ()
         (match (read-syntax p)
           ((? eof-object?) #'())
           (x (cons x (lp)))))))))

(define (include-relative-to-file base)
  (lambda (filename)
    (let ((filename (if (absolute-file-name? filename)
                        filename
                        (in-vicinity (dirname (canonicalize-path base))
                                     filename))))
      (unless (file-exists? filename)
        (error "file not found" filename))
      (call-with-include-port
       (datum->syntax #f filename)
       (lambda (p)
         (let lp ()
           (match (read-syntax p)
             ((? eof-object?) #'())
             (x (cons x (lp))))))))))

(define (include-relative-to-port port)
  (cond
   ((port-filename port) => include-relative-to-file)
   (else (lambda (filename) (error "port has no file name" port)))))

(define* (hoot-features #:key (import-abi? #f))
  (let ((features '(r7rs exact-closed ieee-float full-unicode ratios
                         wasm hoot hoot-1.0)))
    (cons (if import-abi? 'hoot-aux 'hoot-main) features)))

(define %default-program-imports
  '((hoot match)
    (scheme base)
    (scheme case-lambda)
    (scheme char)
    (scheme complex)
    (scheme cxr)
    (scheme eval)
    (scheme file)
    (scheme inexact)
    (scheme lazy)
    (scheme load)
    (scheme read)
    (scheme repl)
    (scheme process-context)
    (scheme time)
    (scheme write)
    (only (hoot syntax) lambda* case-lambda* define* define-syntax-rule)
    (only (hoot primitives) %inline-wasm %wasm-export)
    (only (hoot numbers) 1+ 1-)
    (only (hoot pairs) cons*)
    (only (hoot debug) pk)))

(define (builtin-module-loader import-abi?)
  (define (load-module-from-path filename)
    (define trusted? #t)
    (match (%include-from-path filename)
      ((form) (parse-r6rs-library form trusted?))
      (forms (error "expected exactly one form" forms))))

  (define <- load-module-from-path)

  (define-syntax-rule (library-name-case x (name exp) ...)
    (cond
     ((equal? x 'name) exp)
     ...
     (else #f)))

  (lambda (name)
    (library-name-case
     name
     ((hoot features)
      (let ((trusted? #t))
        (parse-r6rs-library
         `(library (hoot features)
            (export features)
            (import (hoot syntax))
            (define (features)
              ',(hoot-features #:import-abi? import-abi?)))
         trusted?)))
     ((hoot assoc) (<- "hoot/assoc"))
     ((hoot atomics) (<- "hoot/atomics"))
     ((hoot bitvectors) (<- "hoot/bitvectors"))
     ((hoot bitwise) (<- "hoot/bitwise"))
     ((hoot boxes) (<- "hoot/boxes"))
     ((hoot bytevectors) (<- "hoot/bytevectors"))
     ((hoot char) (<- "hoot/char"))
     ((hoot cond-expand) (<- "hoot/cond-expand"))
     ((hoot control) (<- "hoot/control"))
     ((hoot debug) (<- "hoot/debug"))
     ((hoot dynamic-wind) (<- "hoot/dynamic-wind"))
     ((hoot eq) (<- "hoot/eq"))
     ((hoot equal) (<- "hoot/equal"))
     ((hoot error-handling) (<- "hoot/error-handling"))
     ((hoot errors) (<- "hoot/errors"))
     ((hoot exceptions) (<- "hoot/exceptions"))
     ((hoot ffi) (<- "hoot/ffi"))
     ((hoot fluids) (<- "hoot/fluids"))
     ((hoot hashtables) (<- "hoot/hashtables"))
     ((hoot keywords) (<- "hoot/keywords"))
     ((hoot lists) (<- "hoot/lists"))
     ((hoot match) (<- "hoot/match"))
     ((hoot not) (<- "hoot/not"))
     ((hoot numbers) (<- "hoot/numbers"))
     ((hoot pairs) (<- "hoot/pairs"))
     ((hoot parameters) (<- "hoot/parameters"))
     ((hoot ports) (<- "hoot/ports"))
     ((hoot procedures) (<- "hoot/procedures"))
     ((hoot read) (<- "hoot/read"))
     ((hoot records) (<- "hoot/records"))
     ((hoot strings) (<- "hoot/strings"))
     ((hoot symbols) (<- "hoot/symbols"))
     ((hoot syntax) (<- "hoot/syntax"))
     ((hoot values) (<- "hoot/values"))
     ((hoot vectors) (<- "hoot/vectors"))
     ((hoot write) (<- "hoot/write"))
     ((scheme base) (<- "hoot/r7rs-base"))
     ((scheme case-lambda) (<- "hoot/r7rs-case-lambda"))
     ((scheme char) (<- "hoot/r7rs-char"))
     ((scheme complex) (<- "hoot/r7rs-complex"))
     ((scheme cxr) (<- "hoot/r7rs-cxr"))
     ((scheme eval) (<- "hoot/r7rs-eval"))
     ((scheme file) (<- "hoot/r7rs-file"))
     ((scheme inexact) (<- "hoot/r7rs-inexact"))
     ((scheme lazy) (<- "hoot/r7rs-lazy"))
     ((scheme load) (<- "hoot/r7rs-load"))
     ((scheme process-context) (<- "hoot/r7rs-process-context"))
     ((scheme r5rs) (<- "hoot/r7rs-r5rs"))
     ((scheme read) (<- "hoot/r7rs-read"))
     ((scheme repl) (<- "hoot/r7rs-repl"))
     ((scheme time) (<- "hoot/r7rs-time"))
     ((scheme write) (<- "hoot/r7rs-write")))))

(define* (scheme->sealed-tree-il expr #:key
                                 (imports %default-program-imports)
                                 (import-abi? #f)
                                 (include-file %include-from-path)
                                 (extend-load-library (lambda (f) f))
                                 (load-library
                                  (extend-load-library
                                   (builtin-module-loader import-abi?))))
  (define group
    (match expr
      ((? library-group?) expr)
      (_ (parse-library-group `(library-group (import . ,imports) ,expr)
                              #:include-file include-file))))
  (define linked
    (link-library-group group
                        #:load-library load-library
                        #:allow-dangling-import?
                        (lambda (name)
                          (equal? name '(hoot primitives)))))
  (expand-library-group linked
                        #:primitives '(hoot primitives)
                        #:call-with-target (lambda (f)
                                             (with-hoot-target (f)))))

(define* (compile expr #:key
                  (imports %default-program-imports)
                  (import-abi? #f)
                  (export-abi? #t)
                  (include-file %include-from-path)
                  (extend-load-library (lambda (f) f))
                  (load-library
                   (extend-load-library (builtin-module-loader import-abi?)))
                  (optimization-level (default-optimization-level))
                  (warning-level (default-warning-level))
                  (dump-cps? #f)
                  (dump-wasm? #f)
                  (emit-names? #f)
                  (opts '()))
  (define tree-il
    (scheme->sealed-tree-il expr #:imports imports
                            #:import-abi? import-abi?
                            #:include-file include-file
                            #:load-library load-library))
  (with-hoot-target
   (define cps
     (%compile tree-il #:env #f #:from 'tree-il #:to 'cps
               #:optimization-level optimization-level
               #:warning-level warning-level))
   (high-level-cps->wasm cps
                         #:import-abi? import-abi?
                         #:export-abi? export-abi?
                         #:optimization-level optimization-level
                         #:warning-level warning-level
                         #:dump-cps? dump-cps?
                         #:dump-wasm? dump-wasm?
                         #:emit-names? emit-names?
                         #:opts opts)))

(define* (read-and-compile port #:key
                           (import-abi? #f)
                           (export-abi? #t)
                           (optimization-level (default-optimization-level))
                           (warning-level (default-warning-level))
                           (include-file (include-relative-to-port port))
                           (extend-load-library (lambda (f) f))
                           (load-library
                            (extend-load-library (builtin-module-loader import-abi?)))
                           (dump-cps? #f)
                           (dump-wasm? #f)
                           (emit-names? #f)
                           (opts '()))
  (define (name-matches? stx sym)
    (eq? (syntax->datum stx) sym))
  (define-syntax-rule (symbolic-match? name)
    (name-matches? #'name 'name))

  (define forms
    (let lp ()
      (let ((expr (read-syntax port)))
        (if (eof-object? expr)
            '()
            (cons expr (lp))))))

  (define group
    (syntax-case forms ()
      (((library-group . _))
       (symbolic-match? library-group)
       (parse-library-group (car forms) #:include-file include-file))
      (((import . imports) . body)
       (symbolic-match? import)
       (parse-library-group #'(library-group (import . imports) . body)))
      (_
       (parse-library-group
        `(library-group (import . ,%default-program-imports) . ,forms)))))

  (compile group
           #:import-abi? import-abi?
           #:export-abi? export-abi?
           #:optimization-level optimization-level
           #:warning-level warning-level
           #:load-library load-library
           #:dump-cps? dump-cps?
           #:dump-wasm? dump-wasm?
           #:emit-names? emit-names?
           #:opts opts))

(define* (compile-file input-file #:key
                       (output-file (error "missing output file"))
                       (import-abi? #f)
                       (export-abi? #t)
                       (optimization-level (default-optimization-level))
                       (warning-level (default-warning-level))
                       (include-file (include-relative-to-file input-file))
                       (extend-load-library (lambda (f) f))
                       (load-library
                        (extend-load-library (builtin-module-loader import-abi?)))
                       (dump-cps? #f)
                       (dump-wasm? #f)
                       (emit-names? #f)
                       (opts '()))
  (call-with-input-file input-file
    (lambda (in)
      (set-port-encoding! in (or (file-encoding in) "UTF-8"))
      (let ((wasm (read-and-compile in
                                    #:import-abi? import-abi?
                                    #:export-abi? export-abi?
                                    #:optimization-level optimization-level
                                    #:warning-level warning-level
                                    #:include-file include-file
                                    #:load-library load-library
                                    #:dump-cps? dump-cps?
                                    #:dump-wasm? dump-wasm?
                                    #:emit-names? emit-names?
                                    #:opts opts)))
        (let ((bytes (assemble-wasm wasm)))
          (call-with-output-file output-file
            (lambda (out)
              (put-bytevector out bytes))))))))

(install-inline-wasm!)