New CPS pass: lower-primcalls

This pass will implement the specialized lowering of object accessors to
Guile's VM primitives.

* am/bootstrap.am (SOURCES): Add new file.
* module/language/cps/lower-primcalls.scm: New file.

am/bootstrap.am

@@ -99,6 +99,7 @@ SOURCES =					\
   language/cps/intset.scm			\
   language/cps/licm.scm				\
   language/cps/loop-instrumentation.scm		\
+  language/cps/lower-primcalls.scm		\
   language/cps/optimize.scm			\
   language/cps/peel-loops.scm			\
   language/cps/prune-top-level-scopes.scm	\

module/language/cps/lower-primcalls.scm

@@ -0,0 +1,592 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;;; This library is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU Lesser General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; When targetting Guile's virtual machine, we can get maximum
+;;; performance by expanding out some compound primcalls, both so that
+;;; they are available to common subexpression elimination and so that
+;;; their lowered forms can be implemented using Guile's low-level VM
+;;; capabilities instead of by call-outs to library routines.
+;;;
+;;; Code:
+
+(define-module (language cps lower-primcalls)
+  #:use-module (ice-9 match)
+  #:use-module (language cps)
+  #:use-module (language cps intmap)
+  #:use-module (language cps utils)
+  #:use-module (language cps with-cps)
+  #:use-module (system base target)
+  #:use-module (system base types internal)
+  #:export (lower-primcalls))
+
+(define *primcall-lowerers* (make-hash-table))
+(define-syntax-rule (define-primcall-lowerer* name proc)
+  (hashq-set! *primcall-lowerers* 'name proc))
+(define-syntax-rule (define-primcall-lowerer (name cps k src param-pat args-pat)
+                      body ...)
+  (define-primcall-lowerer* name
+    (lambda (cps k src param args)
+      (match (cons param args)
+        ((param-pat . args-pat)
+         body ...)))))
+
+(define *branching-primcall-lowerers* (make-hash-table))
+(define-syntax-rule (define-branching-primcall-lowerer* name proc)
+  (hashq-set! *branching-primcall-lowerers* 'name proc))
+(define-syntax-rule (define-branching-primcall-lowerer
+                      (name cps kf kt src param-pat args-pat)
+                      body ...)
+  (define-branching-primcall-lowerer* name
+    (lambda (cps kf kt src param args)
+      (match (cons param args)
+        ((param-pat . args-pat)
+         body ...)))))
+
+;; precondition: v is vector.  result is u64
+(define-primcall-lowerer (vector-length cps k src #f (v))
+  (with-cps cps
+    (letv w0 ulen)
+    (letk kassume
+          ($kargs ('ulen) (ulen)
+            ($continue k src
+              ($primcall 'assume-u64 `(0 . ,(target-max-vector-length)) (ulen)))))
+    (letk krsh
+          ($kargs ('w0) (w0)
+            ($continue kassume src ($primcall 'ursh/immediate 8 (w0)))))
+    (build-term
+      ($continue krsh src
+        ($primcall 'word-ref/immediate '(vector . 0) (v))))))
+
+;; precondition: v is vector, uidx is u64 in range
+(define-primcall-lowerer (vector-ref cps k src #f (v uidx))
+  (with-cps cps
+    (letv upos)
+    (letk kref ($kargs ('pos) (upos)
+                 ($continue k src
+                   ($primcall 'scm-ref 'vector (v upos)))))
+    (build-term
+      ($continue kref src
+        ($primcall 'uadd/immediate 1 (uidx))))))
+
+;; precondition: v is vector, idx is in range
+(define-primcall-lowerer (vector-ref/immediate cps k src idx (v))
+  (let ((pos (1+ idx)))
+    (with-cps cps
+      (build-term
+        ($continue k src
+          ($primcall 'scm-ref/immediate `(vector . ,pos) (v)))))))
+
+;; precondition: v is vector, uidx is u64 and is in range
+(define-primcall-lowerer (vector-set! cps k src #f (v uidx val))
+  (with-cps cps
+    (letv upos)
+    (letk kset ($kargs ('pos) (upos)
+                 ($continue k src
+                   ($primcall 'scm-set! 'vector (v upos val)))))
+    (build-term
+      ($continue kset src
+        ($primcall 'uadd/immediate 1 (uidx))))))
+
+;; precondition: v is vector, idx is in range
+(define-primcall-lowerer (vector-set!/immediate cps k src idx (v val))
+  (let ((pos (1+ idx)))
+    (with-cps cps
+      (build-term
+        ($continue k src
+          ($primcall 'scm-set!/immediate `(vector . ,pos) (v val)))))))
+
+(define-primcall-lowerer (allocate-vector/immediate cps k src size ())
+  (define nwords (1+ size))
+  (unless (and (exact-integer? size) (<= 0 size (target-max-vector-length)))
+    (error "precondition failed" size))
+  (with-cps cps
+    (letv v w0)
+    (letk kdone
+          ($kargs () ()
+            ($continue k src ($values (v)))))
+    (letk ktag1
+          ($kargs ('w0) (w0)
+            ($continue kdone src
+              ($primcall 'word-set!/immediate '(vector . 0) (v w0)))))
+    (letk ktag0
+          ($kargs ('v) (v)
+            ($continue ktag1 src
+              ($primcall 'load-u64 (+ %tc7-vector (ash size 8)) ()))))
+    (build-term
+      ($continue ktag0 src
+        ($primcall 'allocate-words/immediate `(vector . ,nwords) ())))))
+
+;; precondition: usize is u64 within range
+(define-primcall-lowerer (allocate-vector cps k src #f (usize))
+  (with-cps cps
+    (letv nwords v w0-high w0)
+    (letk kdone
+          ($kargs () ()
+            ($continue k src ($values (v)))))
+    (letk ktag2
+          ($kargs ('w0) (w0)
+            ($continue kdone src
+              ($primcall 'word-set!/immediate '(vector . 0) (v w0)))))
+    (letk ktag1
+          ($kargs ('w0-high) (w0-high)
+            ($continue ktag2 src
+              ($primcall 'uadd/immediate %tc7-vector (w0-high)))))
+    (letk ktag0
+          ($kargs ('v) (v)
+            ($continue ktag1 src
+              ($primcall 'ulsh/immediate 8 (usize)))))
+    (letk kalloc
+          ($kargs ('nwords) (nwords)
+            ($continue ktag0 src
+              ($primcall 'allocate-words 'vector (nwords)))))
+    (build-term
+      ($continue kalloc src
+        ;; Header word.
+        ($primcall 'uadd/immediate 1 (usize))))))
+
+;; precondition: none
+(define-primcall-lowerer (cons cps k src #f (head tail))
+  (with-cps cps
+    (letv pair)
+    (letk kdone
+          ($kargs () ()
+            ($continue k src ($values (pair)))))
+    (letk ktail
+          ($kargs () ()
+            ($continue kdone src
+              ($primcall 'scm-set!/immediate '(pair . 1) (pair tail)))))
+    (letk khead
+          ($kargs ('pair) (pair)
+            ($continue ktail src
+              ($primcall 'scm-set!/immediate '(pair . 0) (pair head)))))
+    (build-term
+      ($continue khead src
+        ($primcall 'allocate-words/immediate '(pair . 2) ())))))
+
+;; precondition: pair is pair
+(define-primcall-lowerer (car cps k src #f (pair))
+  (with-cps cps
+    (build-term
+      ($continue k src
+        ($primcall 'scm-ref/immediate '(pair . 0) (pair))))))
+
+;; precondition: pair is pair
+(define-primcall-lowerer (cdr cps k src #f (pair))
+  (with-cps cps
+    (build-term
+      ($continue k src
+        ($primcall 'scm-ref/immediate '(pair . 1) (pair))))))
+
+;; precondition: pair is mutable pair
+(define-primcall-lowerer (set-car! cps k src #f (pair val))
+  (with-cps cps
+    (build-term
+      ($continue k src
+        ($primcall 'scm-set!/immediate '(pair . 0) (pair val))))))
+
+;; precondition: pair is mutable pair
+(define-primcall-lowerer (set-cdr! cps k src #f (pair val))
+  (with-cps cps
+    (build-term
+      ($continue k src
+        ($primcall 'scm-set!/immediate '(pair . 1) (pair val))))))
+
+;; precondition: none
+(define-primcall-lowerer (box cps k src #f (val))
+  (with-cps cps
+    (letv obj tag)
+    (letk kdone
+          ($kargs () ()
+            ($continue k src ($values (obj)))))
+    (letk kval
+          ($kargs () ()
+            ($continue kdone src
+              ($primcall 'scm-set!/immediate '(box . 1) (obj val)))))
+    (letk ktag1
+          ($kargs ('tag) (tag)
+            ($continue kval src
+              ($primcall 'word-set!/immediate '(box . 0) (obj tag)))))
+    (letk ktag0
+          ($kargs ('obj) (obj)
+            ($continue ktag1 src
+              ($primcall 'load-u64 %tc7-variable ()))))
+    (build-term
+      ($continue ktag0 src
+        ($primcall 'allocate-words/immediate '(box . 2) ())))))
+
+;; precondition: box is box.  note: no checking for unbound!
+(define-primcall-lowerer (box-ref cps k src #f (box))
+  (with-cps cps
+    (build-term
+      ($continue k src
+        ($primcall 'scm-ref/immediate '(box . 1) (box))))))
+
+;; precondition: box is box
+(define-primcall-lowerer (box-set! cps k src #f (box val))
+  (with-cps cps
+    (build-term
+      ($continue k src
+        ($primcall 'scm-set!/immediate '(box . 1) (box val))))))
+
+;; precondition: struct is a struct.
+(define-primcall-lowerer (struct-vtable cps k src #f (struct))
+  (with-cps cps
+    (build-term
+      ($continue k src
+        ($primcall 'scm-ref/tag 'struct (struct))))))
+
+;; precondition: vtable is a vtable.  result is u64
+(define-primcall-lowerer (vtable-size cps k src #f (vtable))
+  (define vtable-index-size 5) ; FIXME: pull from struct.h
+  (define vtable-offset-size (1+ vtable-index-size))
+  (with-cps cps
+    (letv rfields)
+    (letk kassume
+          ($kargs ('rfields) (rfields)
+            ($continue k src
+              ($primcall 'assume-u64 `(0 . ,(target-max-size-t/scm))
+                         (rfields)))))
+    (build-term
+      ($continue kassume src
+        ($primcall 'word-ref/immediate
+                   `(struct . ,vtable-offset-size) (vtable))))))
+
+;; precondition: vtable is a vtable.
+(define-branching-primcall-lowerer (vtable-vtable? cps kf kt src #f (vtable))
+  (define vtable-index-flags 1)         ; FIXME: pull from struct.h
+  (define vtable-offset-flags (1+ vtable-index-flags))
+  (define vtable-validated-mask #b11)
+  (define vtable-validated-value #b11)
+  (with-cps cps
+    (letv flags mask res)
+    (letk ktest
+          ($kargs ('res) (res)
+            ($branch kf kt src
+              'u64-imm-= vtable-validated-value (res))))
+    (letk kand
+          ($kargs ('mask) (mask)
+            ($continue ktest src
+              ($primcall 'ulogand #f (flags mask)))))
+    (letk kflags
+          ($kargs ('flags) (flags)
+            ($continue kand src
+              ($primcall 'load-u64 vtable-validated-mask ()))))
+    (build-term
+      ($continue kflags src
+        ($primcall 'word-ref/immediate
+                   `(struct . ,vtable-offset-flags) (vtable))))))
+
+;; precondition: vtable is a vtable.
+(define-branching-primcall-lowerer (vtable-has-unboxed-fields? cps kf kt src
+                                                               nfields (vtable))
+  (define vtable-index-unboxed-fields 6) ; FIXME: pull from struct.h
+  (define vtable-offset-unboxed-fields (1+ vtable-index-unboxed-fields))
+  (define (check-any-unboxed cps ptr word)
+    (if (< (* word 32) nfields)
+        (with-cps cps
+          (letv idx bits)
+          (let$ checkboxed (check-any-unboxed ptr (1+ word)))
+          (letk kcheckboxed ($kargs () () ,checkboxed))
+          (letk kcheck
+                ($kargs ('bits) (bits)
+                  ($branch kt kcheckboxed src 'u64-imm-= 0 (bits))))
+          (letk kword
+                ($kargs ('idx) (idx)
+                  ($continue kcheck src
+                    ($primcall 'u32-ref 'bitmask (vtable ptr idx)))))
+          (build-term
+            ($continue kword src
+              ($primcall 'load-u64 word ()))))
+        (with-cps cps
+          (build-term ($continue kf src ($values ()))))))
+  (with-cps cps
+    (letv ptr)
+    (let$ checkboxed (check-any-unboxed ptr 0))
+    (letk kcheckboxed ($kargs ('ptr) (ptr) ,checkboxed))
+    (build-term
+      ($continue kcheckboxed src
+        ($primcall 'pointer-ref/immediate
+                   `(struct . ,vtable-offset-unboxed-fields)
+                   (vtable))))))
+
+;; precondition: vtable is a vtable, no unboxed fields, nfields matches
+;; vtable size.
+(define-primcall-lowerer (allocate-struct cps k src nfields (vtable))
+  (define nwords (1+ nfields))
+  (with-cps cps
+    (letv s)
+    (letk kdone
+          ($kargs () () ($continue k src ($values (s)))))
+    (letk ktag
+          ($kargs ('s) (s)
+            ($continue kdone src
+              ($primcall 'scm-set!/tag 'struct (s vtable)))))
+    (build-term
+      ($continue ktag src
+        ($primcall 'allocate-words/immediate `(struct . ,nwords) ())))))
+
+;; precondition: vtable is vtable, idx less than vtable size
+(define-branching-primcall-lowerer (vtable-field-boxed? cps kf kt src idx (vtable))
+  (define vtable-index-unboxed-fields 6) ; FIXME: pull from struct.h
+  (define vtable-offset-unboxed-fields (1+ vtable-index-unboxed-fields))
+  (with-cps cps
+    (letv ptr word bits mask res)
+    (letk ktest
+          ($kargs ('res) (res)
+            ($branch kf kt src 'u64-imm-= 0 (res))))
+    (letk kand
+          ($kargs ('mask) (mask)
+            ($continue ktest src
+              ($primcall 'ulogand #f (mask bits)))))
+    (letk kbits
+          ($kargs ('bits) (bits)
+            ($continue kand src
+              ($primcall 'load-u64 (ash 1 (logand idx 31)) ()))))
+    (letk kword
+          ($kargs ('word) (word)
+            ($continue kbits src
+              ($primcall 'u32-ref 'bitmask (vtable ptr word)))))
+    (letk kptr
+          ($kargs ('ptr) (ptr)
+            ($continue kword src
+              ($primcall 'load-u64 (ash idx -5) ()))))
+    (build-term
+      ($continue kptr src
+        ($primcall 'pointer-ref/immediate
+                   `(struct . ,vtable-offset-unboxed-fields)
+                   (vtable))))))
+
+;; precondition: struct a struct, idx in range, field unboxed.
+(define-primcall-lowerer (struct-ref cps k src idx (struct))
+  (define pos (1+ idx)) ; get past vtable
+  (with-cps cps
+    (build-term
+      ($continue k src
+        ($primcall 'scm-ref/immediate `(struct . ,pos) (struct))))))
+
+;; precondition: struct a struct, idx in range, field unboxed.
+(define-primcall-lowerer (struct-set! cps k src idx (struct val))
+  (define pos (1+ idx)) ; get past vtable
+  (with-cps cps
+    (build-term
+      ($continue k src
+        ($primcall 'scm-set!/immediate `(struct . ,pos) (struct val))))))
+
+;; precondition: bv is bytevector.  result is ptr
+(define-primcall-lowerer (bv-contents cps k src #f (bv))
+  (with-cps cps
+    (build-term
+      ($continue k src
+        ($primcall 'pointer-ref/immediate '(bytevector . 2) (bv))))))
+
+;; precondition: bv is bytevector.  result u64
+(define-primcall-lowerer (bv-length cps k src #f (bv))
+  (with-cps cps
+    (letv ulen)
+    (letk kassume
+          ($kargs ('ulen) (ulen)
+            ($continue k src
+              ($primcall 'assume-u64 `(0 . ,(target-max-size-t)) (ulen)))))
+    (build-term
+      ($continue kassume src
+        ($primcall 'word-ref/immediate '(bytevector . 1) (bv))))))
+
+;; precondition: str is a string.  result u64
+(define-primcall-lowerer (string-length cps k src #f (str))
+  (with-cps cps
+    (letv ulen)
+    (letk kassume
+          ($kargs ('ulen) (ulen)
+            ($continue k src
+              ($primcall 'assume-u64 `(0 . ,(target-max-size-t)) (ulen)))))
+    (build-term
+      ($continue kassume src
+        ($primcall 'word-ref/immediate '(string . 3) (str))))))
+
+;; precondition: s a string, uidx in range.  result unboxed.
+(define-primcall-lowerer (string-ref cps k src #f (s uidx))
+  (define stringbuf-f-wide #x400)
+  (with-cps cps
+    (letv start upos buf ptr tag mask bits uwpos u32)
+    (letk kassume
+          ($kargs ('u32) (u32)
+            ($continue k src
+              ($primcall 'assume-u64 '(0 . #xffffff) (u32)))))
+    (letk kwideref
+          ($kargs ('uwpos) (uwpos)
+            ($continue kassume src
+              ($primcall 'u32-ref 'stringbuf (buf ptr uwpos)))))
+    (letk kwide
+          ($kargs () ()
+            ($continue kwideref src
+              ($primcall 'ulsh/immediate 2 (upos)))))
+    (letk knarrow
+          ($kargs () ()
+            ($continue k src
+              ($primcall 'u8-ref 'stringbuf (buf ptr upos)))))
+    (letk kcmp
+          ($kargs ('bits) (bits)
+            ($branch kwide knarrow src 'u64-imm-= 0 (bits))))
+    (letk kmask
+          ($kargs ('mask) (mask)
+            ($continue kcmp src
+              ($primcall 'ulogand #f (tag mask)))))
+    (letk ktag
+          ($kargs ('tag) (tag)
+            ($continue kmask src
+              ($primcall 'load-u64 stringbuf-f-wide ()))))
+    (letk kptr
+          ($kargs ('ptr) (ptr)
+            ($continue ktag src
+              ($primcall 'word-ref/immediate '(stringbuf . 0) (buf)))))
+    (letk kwidth
+          ($kargs ('buf) (buf)
+            ($continue kptr src
+              ($primcall 'tail-pointer-ref/immediate '(stringbuf . 2) (buf)))))
+    (letk kbuf
+          ($kargs ('upos) (upos)
+            ($continue kwidth src
+              ($primcall 'scm-ref/immediate '(string . 1) (s)))))
+    (letk kadd
+          ($kargs ('start) (start)
+            ($continue kbuf src
+              ($primcall 'uadd #f (start uidx)))))
+    (build-term
+      ($continue kadd src
+        ($primcall 'word-ref/immediate '(string . 2) (s))))))
+
+;; precondition: none.
+(define-primcall-lowerer (make-atomic-box cps k src #f (val))
+  (with-cps cps
+    (letv obj tag)
+    (letk kdone
+          ($kargs () ()
+            ($continue k src ($values (obj)))))
+    (letk kval
+          ($kargs () ()
+            ($continue kdone src
+              ($primcall 'atomic-scm-set!/immediate '(atomic-box . 1) (obj val)))))
+    (letk ktag1
+          ($kargs ('tag) (tag)
+            ($continue kval src
+              ($primcall 'word-set!/immediate '(atomic-box . 0) (obj tag)))))
+    (letk ktag0
+          ($kargs ('obj) (obj)
+            ($continue ktag1 src
+              ($primcall 'load-u64 %tc7-atomic-box ()))))
+    (build-term
+      ($continue ktag0 src
+        ($primcall 'allocate-words/immediate '(atomic-box . 2) ())))))
+
+;; precondition: x is atomic box
+(define-primcall-lowerer (atomic-box-ref cps k src #f (x))
+  (with-cps cps
+    (build-term
+      ($continue k src
+        ($primcall 'atomic-scm-ref/immediate '(atomic-box . 1) (x))))))
+
+;; precondition: x is atomic box
+(define-primcall-lowerer (atomic-box-set! cps k src #f (x val))
+  (with-cps cps
+    (build-term
+      ($continue k src
+        ($primcall 'atomic-scm-set!/immediate '(atomic-box . 1)
+                   (x val))))))
+
+;; precondition: x is atomic box
+(define-primcall-lowerer (atomic-box-swap! cps k src param (x val))
+  (with-cps cps
+    (build-term
+      ($continue k src
+        ($primcall 'atomic-scm-swap!/immediate '(atomic-box . 1)
+                   (x val))))))
+
+;; precondition: x is atomic box
+(define-primcall-lowerer (atomic-box-compare-and-swap! cps k src param (x expected desired))
+  (with-cps cps
+    (build-term
+      ($continue k src
+        ($primcall 'atomic-scm-compare-and-swap!/immediate '(atomic-box . 1)
+                   (x expected desired))))))
+
+;; precondition: code is result of $code
+(define-primcall-lowerer (make-closure cps k src nfree (code))
+  (define nwords (+ nfree 2))
+  (with-cps cps
+    (letv closure tag)
+    (letk kdone
+          ($kargs () ()
+            ($continue k src ($values (closure)))))
+    (letk kinit
+          ($kargs () ()
+            ($continue kdone src
+              ($primcall 'word-set!/immediate '(closure . 1) (closure code)))))
+    (letk ktag1
+          ($kargs ('tag) (tag)
+            ($continue kinit src
+              ($primcall 'word-set!/immediate '(closure . 0) (closure tag)))))
+    (letk ktag0
+          ($kargs ('closure) (closure)
+            ($continue ktag1 src
+              ($primcall 'load-u64 (+ %tc7-program (ash nfree 16)) ()))))
+
+    (build-term
+      ($continue ktag0 src
+        ($primcall 'allocate-words/immediate `(closure . ,nwords) ())))))
+
+;; precondition: closure is closure, idx is in range
+(define-primcall-lowerer (closure-ref cps k src idx (closure))
+  (let ((pos (+ idx 2)))
+    (with-cps cps
+      (build-term
+        ($continue k src
+          ($primcall 'scm-ref/immediate `(closure . ,pos) (closure)))))))
+
+;; precondition: closure is clodure, idx is in range
+(define-primcall-lowerer (closure-set! cps k src idx (closure val))
+  (let ((pos (+ idx 2)))
+    (with-cps cps
+      (build-term
+        ($continue k src
+          ($primcall 'scm-set!/immediate `(closure . ,pos) (closure val)))))))
+
+(define (lower-primcalls cps)
+  (with-fresh-name-state cps
+    (persistent-intmap
+     (intmap-fold
+      (lambda (label cont cps)
+        (match cont
+          (($ $kargs names vars
+              ($ $continue k src ($ $primcall op param args)))
+           (match (hashq-ref *primcall-lowerers* op)
+             (#f cps)
+             (lower
+              (with-cps cps
+                (let$ term (lower k src param args))
+                (setk label ($kargs names vars ,term))))))
+          (($ $kargs names vars
+              ($ $branch kf kt src op param args))
+           (match (hashq-ref *branching-primcall-lowerers* op)
+             (#f cps)
+             (lower
+              (with-cps cps
+                (let$ term (lower kf kt src param args))
+                (setk label ($kargs names vars ,term))))))
+          (_ cps)))
+      cps cps))))