diff options
Diffstat (limited to 'module/system')
-rw-r--r-- | module/system/base/optimize.scm | 7 | ||||
-rw-r--r-- | module/system/foreign-library.scm | 2 | ||||
-rw-r--r-- | module/system/repl/command.scm | 17 | ||||
-rw-r--r-- | module/system/repl/common.scm | 26 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 7 | ||||
-rw-r--r-- | module/system/vm/trace.scm | 2 |
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)) |