guile/module/language/cps/dump.scm

;;; 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)))