Guile-hoot/module/hoot/compile.scm

;;; WebAssembly compiler
;;; Copyright (C) 2023, 2024, 2025, 2025 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 (hoot frontend)
  #:use-module (hoot config)
  #:use-module (wasm assemble)
  #:use-module (language tree-il)
  #:export (%default-program-imports
            scheme->sealed-tree-il
            read-and-compile
            compile-file
            compile
            library-load-path-extension))

(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-path (append (hoot-system-load-path) (hoot-load-path))
                          filename
                          (hoot-load-extensions))
             (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 '((scheme base)))

(define (features-module-loader import-abi?)
  (lambda* (name #:key (features '()))
    (and (equal? name '(hoot features))
         (let ((trusted? #t))
           (parse-library
            `((library (hoot features)
                (export features)
                (import (hoot syntax))
                (define (features) ',features)))
            trusted?)))))

(define* (%library-load-path-extension load-path #:key (trusted? #f))
  (define (relativize-filename filename)
    (or (or-map (lambda (dir)
                  (let ((dir (false-if-exception (canonicalize-path dir))))
                    (and dir
                         (not (string-null? dir))
                         (string-prefix? dir filename)
                         (cond
                          ((file-name-separator?
                            (string-ref dir (1- (string-length dir))))
                           (substring filename (string-length dir)))
                          ((file-name-separator?
                            (string-ref filename (string-length dir)))
                           (substring filename (1+ (string-length dir))))
                          (else #f)))))
                load-path)
        filename))

  (define (read-forms-from-file filename)
    (call-with-include-port
     (datum->syntax #f (canonicalize-path filename))
     (lambda (p)
       (set-port-filename! p (relativize-filename (port-filename p)))
       (let lp ()
         (match (read-syntax p)
           ((? eof-object?) #'())
           (x (cons x (lp))))))))

  (define (name-component->string x)
    (cond
     ((symbol? x)
      (let ((str (symbol->string x)))
        (when (or (equal? str "")
                  (equal? str ".")
                  (equal? str "..")
                  (string-any file-name-separator? str)
                  (absolute-file-name? str))
          (error "invalid name component" x))
        str))
     ((and (exact-integer? x) (not (negative? x)))
      (number->string x))
     (else
      (error "invalid name component" x))))

  (define (library-name->file-name name)
    (string-join (map name-component->string name) file-name-separator-string))

  (define (locate-library name)
    (search-path load-path (library-name->file-name name) %load-extensions))

  (lambda (load-library)
    (lambda* (name #:key (features '()))
      (define (load-library-from-file filename)
        (parse-library (read-forms-from-file filename) trusted?
                       #:include-file (include-relative-to-file filename)
                       #:features features))

      (cond
       ((load-library name #:features features))
       ((locate-library name) => load-library-from-file)
       (else #f)))))

(define (builtin-module-loader import-abi?)
  ((%library-load-path-extension %stdlib-path #:trusted? #t)
   (features-module-loader import-abi?)))

(define* (library-load-path-extension load-path #:key (features '()))
  (%library-load-path-extension load-path))

(define (rewrite-expander-primitives exp make-module-ref)
  (match exp
    (($ <primitive-ref> src name)
     (case name
       ((list->vector)
        (make-module-ref src '(hoot vectors) name #f))
       ((list cons)
        (make-module-ref src '(hoot pairs) name #f))
       ((map)
        (make-module-ref src '(hoot lists) name #f))
       ((syntax-violation)
        (make-module-ref src '(hoot core-syntax-helpers) name #f))
       (($sc-dispatch)
        (make-module-ref src '(hoot expander) name #f))
       (else
        exp)))))

(define (rewrite-expander-host-reference exp make-module-ref)
  (match exp
    (($ <module-ref> src '(guile) name #f)
     (make-primitive-ref src name))
    (exp
     (error "unexpected host module reference!" exp))))

(define* (scheme->sealed-tree-il expr #:key
                                 (imports %default-program-imports)
                                 (import-abi? #f)
                                 (include-file %include-from-path)
                                 (features
                                  (hoot-features #:import-abi? import-abi?))
                                 (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
                        #:features features
                        #:allow-dangling-import?
                        (lambda (name)
                          (equal? name '(hoot primitives)))))
  (expand-library-group linked
                        #:primitives '(hoot primitives)
                        #:rewrite-primitive rewrite-expander-primitives
                        #:rewrite-host-reference rewrite-expander-host-reference
                        #: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)
                  (features (hoot-features #:import-abi? import-abi?))
                  (extend-load-library
                   (library-load-path-extension (hoot-load-path)))
                  (load-library
                   (extend-load-library (builtin-module-loader import-abi?)))
                  (optimization-level (default-optimization-level))
                  (warning-level (default-warning-level))
                  (dump-tree-il? #f)
                  (dump-cps? #f)
                  (dump-wasm? #f)
                  (emit-names? #f)
                  (opts '()))
  (define tree-il
    (scheme->sealed-tree-il expr #:imports imports
                            #:import-abi? import-abi?
                            #:features features
                            #: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
               #:opts (if dump-tree-il?
                          (cons* #:dump-optimized-tree-il? #t opts)
                          opts)))
   (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))
                           (features
                            (hoot-features #:import-abi? import-abi?))
                           (extend-load-library (lambda (f) f))
                           (load-library
                            (extend-load-library (builtin-module-loader import-abi?)))
                           (dump-tree-il? #f)
                           (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
                            #:features features))
      (((import . imports) . body)
       (symbolic-match? import)
       (parse-library-group #'(library-group (import . imports) . body)))
      (((use-modules . imports) . body)
       (symbolic-match? use-modules)
       (parse-library-group #'(library-group (use-modules . 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
           #:features features
           #:dump-tree-il? dump-tree-il?
           #:dump-cps? dump-cps?
           #:dump-wasm? dump-wasm?
           #:emit-names? emit-names?
           #:opts opts))

(define* (compile-file input-file #:key
                       (output-file #f)
                       (import-abi? #f)
                       (export-abi? #t)
                       (optimization-level (default-optimization-level))
                       (warning-level (default-warning-level))
                       (include-file (include-relative-to-file input-file))
                       (features (hoot-features #:import-abi? import-abi?))
                       (extend-load-library (lambda (f) f))
                       (load-library
                        (extend-load-library (builtin-module-loader import-abi?)))
                       (dump-tree-il? #f)
                       (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
                                    #:features features
                                    #:load-library load-library
                                    #:dump-tree-il? dump-tree-il?
                                    #:dump-cps? dump-cps?
                                    #:dump-wasm? dump-wasm?
                                    #:emit-names? emit-names?
                                    #:opts opts)))
        (when output-file
          (let ((bytes (assemble-wasm wasm)))
            (call-with-output-file output-file
              (lambda (out)
                (put-bytevector out bytes)))))
        wasm))))

(install-inline-wasm!)