wingo pushed a commit to branch main in repository guile. commit b974405bce5e2b86c0efdf684bd7eef8bd886a47 Author: Andy Wingo <wi...@pobox.com> AuthorDate: Tue Jun 20 12:23:51 2023 +0200
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 | 1 + module/language/cps/lower-primcalls.scm | 592 ++++++++++++++++++++++++++++++++ 2 files changed, 593 insertions(+) diff --git a/am/bootstrap.am b/am/bootstrap.am index 16e632f25..ff0d1799e 100644 --- a/am/bootstrap.am +++ b/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 \ diff --git a/module/language/cps/lower-primcalls.scm b/module/language/cps/lower-primcalls.scm new file mode 100644 index 000000000..0b013cc85 --- /dev/null +++ b/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))))