[Guile-commits] 09/09: Add ,optimize-cps REPL meta-command

[Andy Wingo]

wingo pushed a commit to branch wip-tailify
in repository guile.

commit d4bec054b6b8379d72d6fe35e8cbf48697c80eaa
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Thu Jun 17 21:57:26 2021 +0200

    Add ,optimize-cps REPL meta-command
    
    * module/system/repl/command.scm (*command-table*): Add optimize-cps /
    optx.
    (optimize-cps): Define meta-command.
    * module/system/repl/common.scm (optimize*): New helper.
    (repl-optimize): Use helper.
    (repl-optimize-cps): New public function.
---
 module/system/repl/command.scm |  9 +++++++--
 module/system/repl/common.scm  | 26 +++++++++++++++++---------
 2 files changed, 24 insertions(+), 11 deletions(-)

diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index ac1fa09..831944c 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -1,6 +1,6 @@
 ;;; Repl commands
 
-;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2020 Free Software 
Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 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
@@ -55,7 +55,7 @@
     (module   (module m) (import use) (load l) (reload re) (binding b) (in))
     (language (language L))
     (compile  (compile c) (compile-file cc)
-              (expand exp) (optimize opt)
+              (expand exp) (optimize opt) (optimize-cps optx)
              (disassemble x) (disassemble-file xx))
     (profile  (time t) (profile pr) (trace tr))
     (debug    (backtrace bt) (up) (down) (frame fr)
@@ -488,6 +488,11 @@ Run the optimizer on a piece of code and print the result."
     (run-hook before-print-hook x)
     (pp x)))
 
+(define-meta-command (optimize-cps repl (form))
+  "optimize-cps EXP
+Run the CPS optimizer on a piece of code and print the result."
+  (repl-optimize-cps repl (repl-parse repl form)))
+
 (define-meta-command (disassemble repl (form))
   "disassemble EXP
 Disassemble a compiled procedure."
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 29ae104..7f785b5 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -32,7 +32,7 @@
             repl-tm-stats repl-gc-stats repl-debug
             repl-welcome repl-prompt
             repl-read repl-compile repl-prepare-eval-thunk repl-eval
-            repl-expand repl-optimize
+            repl-expand repl-optimize repl-optimize-cps
             repl-parse repl-print repl-option-ref repl-option-set!
             repl-default-option-set! repl-default-prompt-set!
             puts ->string user-error
@@ -204,7 +204,7 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more 
details.")
                         #:env (current-module))
                #:from lang #:to from)))
 
-(define* (repl-optimize repl form #:key (lang 'tree-il))
+(define (optimize* repl form lang print)
   (let ((from (repl-language repl))
         (make-lower (language-lowerer (lookup-language lang)))
         (optimization-level (repl-optimization-level repl))
@@ -212,13 +212,21 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more 
details.")
         (opts (repl-compile-options repl)))
     (unless make-lower
       (error "language has no optimizer" lang))
-    (decompile ((make-lower optimization-level opts)
-                (compile form #:from from #:to lang #:opts opts
-                         #:optimization-level optimization-level
-                         #:warning-level warning-level
-                         #:env (current-module))
-                (current-module))
-               #:from lang #:to from)))
+    (print ((make-lower optimization-level opts)
+            (compile form #:from from #:to lang #:opts opts
+                     #:optimization-level optimization-level
+                     #:warning-level warning-level
+                     #:env (current-module))
+            (current-module)))))
+
+(define* (repl-optimize repl form #:key (lang 'tree-il))
+  (optimize* repl form lang
+            (lambda (exp)
+              (decompile exp #:from lang #:to (repl-language repl)))))
+
+(define* (repl-optimize-cps repl form)
+  (optimize* repl form 'cps
+            (module-ref (resolve-interface '(language cps dump)) 'dump)))
 
 (define (repl-parse repl form)
   (let ((parser (language-parser (repl-language repl))))