123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735 |
- ;;; 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 guile-vm 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 ...)))))
- (define-syntax-rule (define-branching-primcall-alias def use ...)
- (let ((proc (or (hashq-ref *branching-primcall-lowerers* 'def)
- (error "def not found" 'def))))
- (hashq-set! *branching-primcall-lowerers* 'use proc)
- ...))
- ;; 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 res)
- (letk ktest
- ($kargs ('res) (res)
- ($branch kf kt src
- 'u64-imm-= vtable-validated-value (res))))
- (letk kflags
- ($kargs ('flags) (flags)
- ($continue ktest src
- ($primcall 'ulogand/immediate vtable-validated-mask (flags)))))
- (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 res)
- (letk ktest
- ($kargs ('res) (res)
- ($branch kf kt src 'u64-imm-= 0 (res))))
- (letk kbits
- ($kargs ('bits) (bits)
- ($continue ktest src
- ($primcall 'ulogand/immediate (ash 1 (logand idx 31)) (bits)))))
- (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 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 ktag
- ($kargs ('tag) (tag)
- ($continue kcmp src
- ($primcall 'ulogand/immediate stringbuf-f-wide (tag)))))
- (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: sym is a symbol.
- (define-primcall-lowerer (symbol-hash cps k src #f (sym))
- (with-cps cps
- (build-term
- ($continue k src
- ($primcall 'word-ref/immediate '(symbol . 2) (sym))))))
- ;; 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 . nfree) (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 . nfree) (closure val))
- (let ((pos (+ idx 2)))
- (with-cps cps
- (build-term
- ($continue k src
- ($primcall 'scm-set!/immediate `(closure . ,pos) (closure val)))))))
- (define-primcall-lowerer (f64->scm cps k src #f (f64))
- (with-cps cps
- (letv scm tag ptr uidx)
- (letk kdone ($kargs () ()
- ($continue k src ($values (scm)))))
- (letk kinit ($kargs ('uidx) (uidx)
- ($continue kdone src
- ($primcall 'f64-set! 'flonum (scm ptr uidx f64)))))
- (letk kidx ($kargs ('ptr) (ptr)
- ($continue kinit src ($primcall 'load-u64 0 ()))))
- (letk kptr ($kargs () ()
- ($continue kidx src
- ($primcall 'tail-pointer-ref/immediate
- `(flonum . ,(match (target-word-size)
- (4 2)
- (8 1)))
- (scm)))))
- (letk ktag1 ($kargs ('tag) (tag)
- ($continue kptr src
- ($primcall 'word-set!/immediate '(flonum . 0) (scm tag)))))
- (letk ktag0 ($kargs ('scm) (scm)
- ($continue ktag1 src
- ($primcall 'load-u64 %tc16-flonum ()))))
- (build-term
- ($continue ktag0 src
- ($primcall 'allocate-pointerless-words/immediate
- `(flonum . ,(match (target-word-size)
- (4 4)
- (8 2)))
- ())))))
- (define-primcall-lowerer (keyword->symbol cps k src #f (kw))
- (with-cps cps
- (build-term
- ($continue k src
- ($primcall 'scm-ref/immediate '(keyword . 1) (kw))))))
- (define-branching-primcall-lowerer (procedure? cps kf kt src #f (x))
- (with-cps cps
- (letv procedure? result)
- (letk kresult
- ($kargs ('result) (result)
- ($branch kt kf src 'eq-constant? #f (result))))
- (letk krecv
- ($kreceive '(result) '() kresult))
- (letk kcall
- ($kargs ('procedure?) (procedure?)
- ($continue krecv src
- ($call procedure? (x)))))
- (build-term
- ($continue kcall src ($prim 'procedure?)))))
- (define-branching-primcall-lowerer (number? cps kf kt src #f (x))
- (with-cps cps
- (letk kheap-num
- ($kargs () ()
- ($branch kf kt src 'heap-number? #f (x))))
- (letk kheap
- ($kargs () ()
- ($branch kf kheap-num src 'heap-object? #f (x))))
- (build-term
- ($branch kheap kt src 'fixnum? #f (x)))))
- (define-branching-primcall-alias number? complex?)
- (define-branching-primcall-lowerer (real? cps kf kt src #f (x))
- (with-cps cps
- (letk kcomp
- ($kargs () ()
- ($branch kt kf src 'compnum? #f (x))))
- (letk kheap-num
- ($kargs () ()
- ($branch kf kcomp src 'heap-number? #f (x))))
- (letk kheap
- ($kargs () ()
- ($branch kf kheap-num src 'heap-object? #f (x))))
- (build-term
- ($branch kheap kt src 'fixnum? #f (x)))))
- (define-branching-primcall-lowerer (rational? cps kf kt src #f (x))
- (with-cps cps
- (letv res prim)
- (letk ktest
- ($kargs ('res) (res)
- ($branch kt kf src 'false? #f (res))))
- (letk krecv
- ($kreceive '(val) #f ktest))
- (letk kcall
- ($kargs ('prim) (prim)
- ($continue krecv src ($call prim (x)))))
- (build-term
- ($continue kcall src ($prim 'rational?)))))
- (define-branching-primcall-lowerer (integer? cps kf kt src #f (x))
- (with-cps cps
- (letv res prim)
- (letk ktest
- ($kargs ('res) (res)
- ($branch kt kf src 'false? #f (res))))
- (letk krecv
- ($kreceive '(val) #f ktest))
- (letk kcall
- ($kargs ('prim) (prim)
- ($continue krecv src ($call prim (x)))))
- (build-term
- ($continue kcall src ($prim 'integer?)))))
- (define-branching-primcall-lowerer (exact-integer? cps kf kt src #f (x))
- (with-cps cps
- (letk kbig
- ($kargs () ()
- ($branch kf kt src 'bignum? #f (x))))
- (letk kheap
- ($kargs () ()
- ($branch kf kbig src 'heap-object? #f (x))))
- (build-term
- ($branch kheap kt src 'fixnum? #f (x)))))
- (define-branching-primcall-lowerer (exact? cps kf kt src #f (x))
- (with-cps cps
- (letk kfrac
- ($kargs () ()
- ($branch kf kt src 'fracnum? #f (x))))
- (letk kbig
- ($kargs () ()
- ($branch kfrac kt src 'bignum? #f (x))))
- (build-term
- ($branch kbig kt src 'fixnum? #f (x)))))
- (define-branching-primcall-lowerer (inexact? cps kf kt src #f (x))
- (with-cps cps
- (letk kcomp
- ($kargs () ()
- ($branch kf kt src 'compnum? #f (x))))
- (letk kflo
- ($kargs () ()
- ($branch kcomp kt src 'flonum? #f (x))))
- (build-term
- ($branch kflo kf src 'fixnum? #f (x)))))
- (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 ($ $calli)))
- (error "$calli unsupported by guile-vm backend"))
- (($ $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))))
|