Guile-hoot/module/hoot/ffi.scm

;;; Hoot foreign function interface
;;; Copyright (C) 2023, 2024 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:
;;;
;;; Foreign function interface for declaring Wasm host imports and
;;; handling (ref extern) values.
;;;
;;; Code:

(library (hoot ffi)
  (export external?
          external-null?
          external-non-null?
          procedure->external
          define-foreign)
  (import (hoot primitives)
          (hoot not)
          (hoot procedures)
          (hoot strings)
          (hoot errors)
          (hoot pairs)
          (only (hoot lists) map)
          (hoot numbers))

  (define (external? obj)
    (%inline-wasm
     '(func (param $obj (ref eq)) (result (ref eq))
            (ref.i31
             (if i32
                 (ref.test $extern-ref (local.get $obj))
                 (then (i32.const 17))
                 (else (i32.const 1)))))
     obj))

  (define (external-null? extern)
    (check-type extern external? 'external-null?)
    (%inline-wasm
     '(func (param $extern (ref $extern-ref)) (result (ref eq))
            (if (ref eq)
                (ref.is_null
                 (struct.get $extern-ref $val (local.get $extern)))
                (then (ref.i31 (i32.const 17)))
                (else (ref.i31 (i32.const 1)))))
     extern))

  (define (external-non-null? extern)
    (not (external-null? extern)))

  (define (procedure->external proc)
    (check-type proc procedure? 'procedure->external)
    (%inline-wasm
     '(func (param $f (ref $proc)) (result (ref eq))
            (struct.new $extern-ref
                        (i32.const 0)
                        (call $procedure->extern (local.get $f))))
     proc))

  (define-syntax define-foreign
    (lambda (x)
      (define (type-check exp proc-name)
        (define (check param predicate)
          #`(check-type #,param #,predicate '#,proc-name))
        (syntax-case exp (i32 i64 f32 f64 ref null eq string extern)
          ((x i32) (check #'x #'exact-integer?))
          ((x i64) (check #'x #'exact-integer?))
          ((x f32) (check #'x #'real?))
          ((x f64) (check #'x #'real?))
          ((x (ref eq)) #'#t)
          ((x (ref extern)) (check #'x #'external-non-null?))
          ((x (ref null extern)) (check #'x #'external?))
          ((x (ref string)) (check #'x #'string?))
          ((x type) (%error "unsupported param type" #'type))))
      (define (import-result-types exp)
        (syntax-case exp (none)
          (none #'())
          (type #'((result type)))))
      (define (result-types exp)
        (syntax-case exp (none i32 i64 f32 f64 ref null string extern)
          (none #'())
          (i32 #'((result i64)))
          (i64 #'((result i64)))
          (f32 #'((result f64)))
          (f64 #'((result f64)))
          ((ref string) #'((result (ref eq))))
          ((ref extern) #'((result (ref eq))))
          ((ref null extern) #'((result (ref eq))))
          ((ref eq) #'((result (ref eq))))
          (type (%error "unsupported result type" #'type))))
      (define (lift-result exp)
        (syntax-case exp (none i32 i64 f32 f64 ref null string extern)
          ((x none) #'x)
          ((x i32) #'(i64.extend_i32_s x))
          ((x i64) #'x)
          ((x f32) #'(f64.promote_f32 x))
          ((x f64) #'x)
          ((x (ref string)) #'(struct.new $string (i32.const 0) x))
          ((x (ref extern)) #'(struct.new $extern-ref (i32.const 0) x))
          ((x (ref null extern)) #'(struct.new $extern-ref (i32.const 0) x))
          ((x (ref eq)) #'(ref.cast $heap-object x))
          (type (%error "unsupported result type" #'type))))
      (define (fresh-wasm-id prefix)
        (datum->syntax x (gensym prefix)))
      (define (fresh-wasm-ids prefix lst)
        (map (lambda (_) (fresh-wasm-id prefix)) lst))
      (syntax-case x (->)
        ((_ proc-name mod name ptype ... -> rtype)
         (with-syntax ((iname (fresh-wasm-id "$import-"))
                       ((pname ...) (fresh-wasm-ids "$param-" #'(ptype ...))))
           #`(begin
               (%wasm-import
                '(func iname (import mod name)
                       (param ptype) ...
                       #,@(import-result-types #'rtype)))
               (define (proc-name pname ...)
                 #,@(map (lambda (exp) (type-check exp #'proc-name))
                         #'((pname ptype) ...))
                 (%inline-wasm
                  '(func (param pname ptype) ...
                         #,@(result-types #'rtype)
                         #,(lift-result
                            #'((call iname (local.get pname) ...) rtype)))
                  pname ...)))))))))