diff options
author | Andy Wingo <wingo@pobox.com> | 2021-06-15 15:31:02 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2021-10-01 11:33:10 +0200 |
commit | 426867ac7de8281cd5d8be1e152c7c04835782e9 (patch) | |
tree | 4436422eb2c377241b304056c921d5111cb09032 /module/language/cps/dump.scm | |
parent | c8c35c6987a1f072aacb5d8d2a41b245d255dac2 (diff) | |
download | guile-426867ac7de8281cd5d8be1e152c7c04835782e9.tar.gz |
Add CPS pretty-printer
* module/language/cps/dump.scm: New file.
* module/Makefile.am (SOURCES): Add to build.
Diffstat (limited to 'module/language/cps/dump.scm')
-rw-r--r-- | module/language/cps/dump.scm | 317 |
1 files changed, 317 insertions, 0 deletions
diff --git a/module/language/cps/dump.scm b/module/language/cps/dump.scm new file mode 100644 index 000000000..d5217fe23 --- /dev/null +++ b/module/language/cps/dump.scm @@ -0,0 +1,317 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019, 2020, 2021 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 library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Helper facilities for working with CPS. +;;; +;;; Code: + +(define-module (language cps dump) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (language cps) + #:use-module (language cps intset) + #:use-module (language cps intmap) + #:use-module (language cps graphs) + #:use-module (language cps utils) + #:export (dump)) + +;; ideas: unused vars print as _ +;; print all labels +;; call bb headers with values +;; annotate blocks with available bindings? live bindings? +;; how to print calls... +;; dot graph + +(define (cont-successors cont) + (match cont + (($ $kargs _ _ term) + (match term + (($ $continue k) (list k)) + (($ $branch kf kt) (list kf kt)) + (($ $switch kf kt*) (cons kf kt*)) + (($ $prompt k kh) (list k kh)) + (($ $throw) '()))) + (($ $kclause _ kbody kalternate) + (if kalternate + (list kbody kalternate) + (list kbody))) + (($ $kfun src meta self ktail kentry) + (list ktail kentry)) + (($ $kreceive arity kargs) (list kargs)) + (($ $ktail) '()))) + +(define (compute-block-entries cps kfun body all-labels?) + (if all-labels? + body + (let ((preds (compute-predecessors cps kfun #:labels body))) + ;; Conts whose predecessor count is not 1 start blocks. + (define (add-entry label blocks) + (match (intmap-ref preds label) + ((_) blocks) + (_ (intset-add! blocks label)))) + ;; Continuations of branches start blocks. + (define (add-exits label blocks) + (fold1 (lambda (succ blocks) + (intset-add! blocks succ)) + (match (cont-successors (intmap-ref cps label)) + ((_) '()) + (succs succs)) + blocks)) + (persistent-intset + (intset-fold + (lambda (label blocks) + (add-exits label (add-entry label blocks))) + body + empty-intset))))) + +(define (collect-blocks cps entries) + (define (collect-block entry) + (let ((cont (intmap-ref cps entry))) + (acons entry cont + (match (cont-successors (intmap-ref cps entry)) + ((succ) + (if (intset-ref entries succ) + '() + (collect-block succ))) + (_ '()))))) + (persistent-intmap + (intset-fold + (lambda (start blocks) + (intmap-add! blocks start (collect-block start))) + entries + empty-intmap))) + +(define (compute-block-succs blocks) + (intmap-map (lambda (entry conts) + (match conts + (((_ . _) ... (exit . cont)) + (fold1 (lambda (succ succs) + (intset-add succs succ)) + (cont-successors cont) + empty-intset)))) + blocks)) + +(define (dump-block cps port labelled-conts) + (define (format-label label) (format #f "L~a" label)) + (define (format-name name) (if name (symbol->string name) "_")) + (define (format-var var) (format #f "v~a" var)) + (define (format-loc src) + (and src + (format #f "~a:~a:~a" + (or (assq-ref src 'filename) "<unknown>") + (1+ (assq-ref src 'line)) + (assq-ref src 'column)))) + (define (arg-list strs) (string-join strs ", ")) + (define (false-if-empty str) (if (string-null? str) #f str)) + (define (format-arity arity) + (match arity + (($ $arity req opt rest kw aok?) + (arg-list + `(,@(map format-name req) + ,@(map (lambda (name) + (format #f "[~a]" (format-name name))) + opt) + ,@(map (match-lambda + ((kw name var) + (format #f "~a" kw))) + kw) + ,@(if aok? '("[#:allow-other-keys]") '()) + ,@(if rest + (list (string-append (format-name rest) "...")) + '())))))) + (define (format-primcall op param args) + (format #f "~a~@[[~s]~](~a)" op param (arg-list (map format-var args)))) + (define (format-exp exp) + (match exp + (($ $const val) + (format #f "const ~s" val)) + (($ $prim name) + (format #f "prim ~s" name)) + (($ $fun body) + (format #f "fun ~a" (format-label body))) + (($ $rec names syms funs) + (format #f "rec(~a)" (arg-list (map format-exp funs)))) + (($ $const-fun label) + (format #f "const-fun ~a" (format-label label))) + (($ $code label) + (format #f "code ~a" (format-label label))) + (($ $call proc args) + (format #f "call ~a(~a)" + (format-var proc) (arg-list (map format-var args)))) + (($ $callk k proc args) + (format #f "callk ~a(~a)" (format-label k) + (arg-list + (cons (if proc (format-var proc) "_") + (map format-var args))))) + (($ $primcall name param args) + (format-primcall name param args)) + (($ $values args) + (arg-list (map format-var args))))) + (define (dump-annotation ann src) + (when (or ann src) + (format port "~45t ; ~@[~a ~]" ann) + (when src + (let* ((src (format-loc src)) + (col (- 80 4 (string-length src)))) + (format port "~vt at ~a" col src)))) + (newline port)) + (define (dump-definition src names vars fmt . args) + (define (take formatter val) + (cond + ((not val) #f) + ((string? val) (false-if-empty val)) + ((null? val) #f) + (else (arg-list (map formatter val))))) + (let ((names (take format-name names)) + (vars (take format-var vars))) + (format port " ~@[~a := ~]~?" vars fmt args) + (dump-annotation names src))) + (define (dump-statement src ann fmt . args) + (format port " ~?" fmt args) + (dump-annotation (and ann (false-if-empty ann)) src)) + (define (dump-block-header label cont) + (match cont + (($ $kargs names vars) + (format port "~a(~a):" + (format-label label) + (arg-list (map format-var vars))) + (dump-annotation (false-if-empty (arg-list (map format-name names))) + #f)) + (($ $ktail) + (values)) + (($ $kfun src meta self ktail kentry) + (let ((name (assq-ref meta 'name))) + (format port "~a:" (format-label label)) + (dump-annotation name src))) + ((or ($ $kreceive) ($ $kclause)) + (format port "~a:\n" (format-label label))))) + (define (dump-block-body label cont) + (match cont + (($ $kargs _ _ ($ $continue k src exp)) + (match (intmap-ref cps k) + (($ $kargs names vars) + (dump-definition src names vars "~a" (format-exp exp))) + (_ + (dump-definition src #f #f "~a" (format-exp exp))))) + (($ $kreceive arity kargs) + (match (intmap-ref cps kargs) + (($ $kargs names vars) + (dump-definition #f names vars + "receive(~a)" (format-arity arity))))) + (($ $ktail) + (values)) + (($ $kclause arity kbody #f) + (match (intmap-ref cps kbody) + (($ $kargs names vars) + (dump-definition #f names vars + "receive(~a)" (format-arity arity))))))) + (define (dump-block-exit label cont) + (match cont + (($ $kargs _ _ term) + (match term + (($ $continue k src exp) + (match (intmap-ref cps k) + (($ $ktail) + (match exp + (($ $values vals) + (dump-statement src #f + "return ~a" (arg-list (map format-var vals)))) + (_ + (dump-statement src #f + "tail ~a" (format-exp exp))))) + (_ + (dump-statement src #f + "~a(~a)" (format-label k) (format-exp exp))))) + (($ $branch kf kt src op param args) + (dump-statement src #f + "~a ? ~a() : ~a()" + (format-primcall op param args) + (format-label kt) + (format-label kf))) + (($ $switch kf kt* src arg) + (dump-statement src #f + "[~a]~a() or ~a()" + (arg-list (map format-label kt*)) + (format-var arg) + (format-label kf))) + (($ $prompt k kh src escape? tag) + (dump-statement src #f + "~a(prompt(kh:~a,~a tag:~a)" + (format-label k) + (format-label kh) + (if escape? ", escape-only" "") + (format-var tag))) + (($ $throw src op param args) + (dump-statement src #f + "throw ~a" (format-primcall op param args))))) + (($ $kreceive arity kargs) + (dump-statement #f #f + "~a(receive(~a))" + (format-label kargs) + (format-arity arity))) + (($ $kfun src meta self ktail kentry) + (for-each (match-lambda + ((k . v) + (unless (eq? k 'name) + (format port " meta: ~a: ~s\n" k v)))) + meta) + ;; (format port " tail: ~a:\n" (format-label ktail)) + (when self + (format port " ~a := self\n" (format-var self))) + (format port " ~a(...)\n" (format-label kentry))) + (($ $kclause arity kbody kalt) + (dump-statement #f #f + "~a(receive(~a))~@[or ~a()~]\n" + (format-label kbody) + (format-arity arity) + (and=> kalt format-label))) + (($ $ktail) + (values)))) + (match labelled-conts + (((label . cont) . _) + (dump-block-header label cont))) + (let lp ((labelled-conts labelled-conts)) + (match labelled-conts + (((label . cont)) + (dump-block-exit label cont)) + (((label . cont) . labelled-conts) + (dump-block-body label cont) + (lp labelled-conts))))) + +(define (dump-function cps port kfun body all-labels?) + (define entries (compute-block-entries cps kfun body all-labels?)) + (define blocks (collect-blocks cps entries)) + (define block-succs (compute-block-succs blocks)) + (define block-order (compute-reverse-post-order block-succs kfun)) + (for-each (lambda (entry) + (dump-block cps port (intmap-ref blocks entry))) + block-order) + (values)) + +(define* (dump cps #:key + (port (current-output-port)) + (entry (intmap-next cps)) + (all-labels? #f)) + (let ((functions (compute-reachable-functions cps entry))) + (intmap-fold (lambda (kfun body) + (unless (eqv? kfun entry) (newline port)) + (dump-function cps port kfun body all-labels?)) + functions))) |