mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
Add CPS pretty-printer
* module/language/cps/dump.scm: New file. * module/Makefile.am (SOURCES): Add to build.
This commit is contained in:
Andy Wingo
parent
c8c35c6987
commit
426867ac7d
2 changed files with 318 additions and 0 deletions
|
|
@ -52,6 +52,7 @@ SOURCES = \
|
|||
language/cps/cse.scm \
|
||||
language/cps/dce.scm \
|
||||
language/cps/devirtualize-integers.scm \
|
||||
language/cps/dump.scm \
|
||||
language/cps/elide-arity-checks.scm \
|
||||
language/cps/effects-analysis.scm \
|
||||
language/cps/graphs.scm \
|
||||
|
|
|
|||
317
module/language/cps/dump.scm
Normal file
317
module/language/cps/dump.scm
Normal file
|
|
@ -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)))
|
||||
Loading…
Add table
Add a link
Reference in a new issue