summaryrefslogtreecommitdiff
path: root/module/system
diff options
context:
space:
mode:
Diffstat (limited to 'module/system')
-rw-r--r--module/system/base/optimize.scm7
-rw-r--r--module/system/foreign-library.scm2
-rw-r--r--module/system/repl/command.scm17
-rw-r--r--module/system/repl/common.scm26
-rw-r--r--module/system/vm/assembler.scm7
-rw-r--r--module/system/vm/trace.scm2
6 files changed, 40 insertions, 21 deletions
diff --git a/module/system/base/optimize.scm b/module/system/base/optimize.scm
index 03c57bf1b..8da908da6 100644
--- a/module/system/base/optimize.scm
+++ b/module/system/base/optimize.scm
@@ -1,6 +1,6 @@
;;; Optimization flags
-;; Copyright (C) 2018, 2020 Free Software Foundation, Inc.
+;; Copyright (C) 2018, 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
@@ -28,12 +28,15 @@
(match lang-name
('tree-il
'((#:cps? 2)
+ (#:resolve-free-vars? 1)
(#:resolve-primitives? 1)
(#:expand-primitives? 1)
(#:letrectify? 2)
(#:seal-private-bindings? 3)
(#:partial-eval? 1)
- (#:eta-expand? 2)))
+ (#:eta-expand? 2)
+ (#:inlinable-exports? 1)
+ (#:cross-module-inlining? 2)))
('cps
'( ;; (#:split-rec? #t)
(#:simplify? 2)
diff --git a/module/system/foreign-library.scm b/module/system/foreign-library.scm
index d53e293ef..dc426385f 100644
--- a/module/system/foreign-library.scm
+++ b/module/system/foreign-library.scm
@@ -48,7 +48,7 @@
(define system-library-extensions
(cond
- ((string-contains %host-type "-darwin-")
+ ((string-contains %host-type "-darwin")
'(".bundle" ".so" ".dylib"))
((or (string-contains %host-type "cygwin")
(string-contains %host-type "mingw")
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index ac1fa0933..0024fd165 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
@@ -22,10 +22,12 @@
(define-module (system repl command)
#:use-module (system base syntax)
#:use-module (system base pmatch)
- #:use-module (system base compile)
+ #:autoload (system base compile) (compile-file)
#:use-module (system repl common)
#:use-module (system repl debug)
- #:use-module (system vm disassembler)
+ #:autoload (system vm disassembler) (disassemble-image
+ disassemble-program
+ disassemble-file)
#:use-module (system vm loader)
#:use-module (system vm program)
#:use-module (system vm trap-state)
@@ -42,7 +44,7 @@
#:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp)))
#:use-module ((system vm inspect) #:select ((inspect . %inspect)))
#:use-module (rnrs bytevectors)
- #:use-module (statprof)
+ #:autoload (statprof) (statprof)
#:export (meta-command define-meta-command))
@@ -55,7 +57,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 +490,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 29ae104c5..7f785b53e 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))))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index ad34a549d..be1b79e34 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -2061,8 +2061,9 @@ should be .data or .rodata), and return the resulting linker object.
((array? obj)
(let-values
- ;; array tag + rank + contp flag: see libguile/arrays.h .
- (((tag) (logior tc7-array (ash (array-rank obj) 17) (ash 1 16)))
+ ;; array tag + rank
+ ;; see libguile/arrays.h: SCM_I_ARRAY_NDIM, SCM_I_ARRAYP, scm_i_raw_array
+ (((tag) (logior tc7-array (ash (array-rank obj) 17)))
((bv-set! bvs-set!)
(case word-size
((4) (values bytevector-u32-set! bytevector-s32-set!))
@@ -2284,7 +2285,7 @@ needed."
;; FIXME: Define these somewhere central, shared with C.
(define *bytecode-major-version* #x0300)
-(define *bytecode-minor-version* 5)
+(define *bytecode-minor-version* 6)
(define (link-dynamic-section asm text rw rw-init frame-maps)
"Link the dynamic section for an ELF image with bytecode @var{text},
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index e9f17dae8..54840d8fd 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -73,7 +73,7 @@
(max-indent (- width 40)))
(define (apply-handler frame depth)
(print-application frame depth width prefix max-indent))
- (define (return-handler frame depth values)
+ (define (return-handler frame depth)
(print-return frame depth width prefix max-indent))
(trap-calls-to-procedure proc apply-handler return-handler))