mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
317 lines
12 KiB
Scheme
317 lines
12 KiB
Scheme
;;; 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)))
|