Merge.
This commit is contained in:
Dale Mellor
commit
38745ce13f
33 changed files with 1052 additions and 774 deletions
|
|
@ -1,6 +1,6 @@
|
|||
;;; Brainfuck for GNU Guile.
|
||||
|
||||
;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2009-2010,2020 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
|
||||
|
|
@ -34,10 +34,14 @@
|
|||
; in #:compilers. This is the basic set of fields needed to specify a new
|
||||
; language.
|
||||
|
||||
(define (choose-compiler compilers optimization-level opts)
|
||||
(cons 'tree-il compile-tree-il))
|
||||
|
||||
(define-language brainfuck
|
||||
#:title "Brainfuck"
|
||||
#:reader (lambda (port env) (read-brainfuck port))
|
||||
#:compilers `((tree-il . ,compile-tree-il)
|
||||
(scheme . ,compile-scheme))
|
||||
#:compiler-chooser choose-compiler
|
||||
#:printer write
|
||||
)
|
||||
|
|
|
|||
|
|
@ -29,12 +29,6 @@
|
|||
#:use-module (language cps)
|
||||
#:use-module (language cps slot-allocation)
|
||||
#:use-module (language cps utils)
|
||||
#:use-module (language cps closure-conversion)
|
||||
#:use-module (language cps loop-instrumentation)
|
||||
#:use-module (language cps optimize)
|
||||
#:use-module (language cps reify-primitives)
|
||||
#:use-module (language cps renumber)
|
||||
#:use-module (language cps split-rec)
|
||||
#:use-module (language cps intmap)
|
||||
#:use-module (language cps intset)
|
||||
#:use-module (system vm assembler)
|
||||
|
|
@ -192,8 +186,15 @@
|
|||
(emit-cache-ref asm (from-sp dst) key))
|
||||
(($ $primcall 'resolve-module public? (name))
|
||||
(emit-resolve-module asm (from-sp dst) (from-sp (slot name)) public?))
|
||||
(($ $primcall 'module-variable #f (mod name))
|
||||
(emit-module-variable asm (from-sp dst) (from-sp (slot mod))
|
||||
(from-sp (slot name))))
|
||||
(($ $primcall 'lookup #f (mod name))
|
||||
(emit-lookup asm (from-sp dst) (from-sp (slot mod)) (from-sp (slot name))))
|
||||
(emit-lookup asm (from-sp dst) (from-sp (slot mod))
|
||||
(from-sp (slot name))))
|
||||
(($ $primcall 'lookup-bound #f (mod name))
|
||||
(emit-lookup-bound asm (from-sp dst) (from-sp (slot mod))
|
||||
(from-sp (slot name))))
|
||||
(($ $primcall 'add/immediate y (x))
|
||||
(emit-add/immediate asm (from-sp dst) (from-sp (slot x)) y))
|
||||
(($ $primcall 'sub/immediate y (x))
|
||||
|
|
@ -680,7 +681,7 @@
|
|||
|
||||
(intmap-for-each compile-cont cps)))
|
||||
|
||||
(define (emit-bytecode exp env opts)
|
||||
(define (compile-bytecode exp env opts)
|
||||
(let ((asm (make-assembler)))
|
||||
(intmap-for-each (lambda (kfun body)
|
||||
(compile-function (intmap-select exp body) asm opts))
|
||||
|
|
@ -688,20 +689,3 @@
|
|||
(values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
|
||||
env
|
||||
env)))
|
||||
|
||||
(define (lower-cps exp opts)
|
||||
;; FIXME: For now the closure conversion pass relies on $rec instances
|
||||
;; being separated into SCCs. We should fix this to not be the case,
|
||||
;; and instead move the split-rec pass back to
|
||||
;; optimize-higher-order-cps.
|
||||
(set! exp (split-rec exp))
|
||||
(set! exp (optimize-higher-order-cps exp opts))
|
||||
(set! exp (convert-closures exp))
|
||||
(set! exp (optimize-first-order-cps exp opts))
|
||||
(set! exp (reify-primitives exp))
|
||||
(set! exp (add-loop-instrumentation exp))
|
||||
(renumber exp))
|
||||
|
||||
(define (compile-bytecode exp env opts)
|
||||
(set! exp (lower-cps exp opts))
|
||||
(emit-bytecode exp env opts))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Effects analysis on CPS
|
||||
|
||||
;; Copyright (C) 2011-2015,2017-2019 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2011-2015,2017-2020 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
|
||||
|
|
@ -485,7 +485,9 @@ the LABELS that are clobbered by the effects of LABEL."
|
|||
((cache-current-module! m) (&write-object &cache))
|
||||
((resolve name) (&read-object &module) &type-check)
|
||||
((resolve-module mod) (&read-object &module) &type-check)
|
||||
((module-variable mod name) (&read-object &module) &type-check)
|
||||
((lookup mod name) (&read-object &module) &type-check)
|
||||
((lookup-bound mod name) (&read-object &module) &type-check)
|
||||
((cached-toplevel-box) &type-check)
|
||||
((cached-module-box) &type-check)
|
||||
((define! mod name) (&read-object &module)))
|
||||
|
|
|
|||
|
|
@ -1,20 +1,19 @@
|
|||
;;; Continuation-passing style (CPS) intermediate language (IL)
|
||||
|
||||
;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2013-2018,2020 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
|
||||
;;; 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 program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
|
|
@ -24,23 +23,30 @@
|
|||
|
||||
(define-module (language cps optimize)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (language cps closure-conversion)
|
||||
#:use-module (language cps contification)
|
||||
#:use-module (language cps cse)
|
||||
#:use-module (language cps devirtualize-integers)
|
||||
#:use-module (language cps dce)
|
||||
#:use-module (language cps devirtualize-integers)
|
||||
#:use-module (language cps licm)
|
||||
#:use-module (language cps loop-instrumentation)
|
||||
#:use-module (language cps peel-loops)
|
||||
#:use-module (language cps prune-top-level-scopes)
|
||||
#:use-module (language cps reify-primitives)
|
||||
#:use-module (language cps renumber)
|
||||
#:use-module (language cps rotate-loops)
|
||||
#:use-module (language cps self-references)
|
||||
#:use-module (language cps simplify)
|
||||
#:use-module (language cps specialize-primcalls)
|
||||
#:use-module (language cps specialize-numbers)
|
||||
#:use-module (language cps specialize-primcalls)
|
||||
#:use-module (language cps split-rec)
|
||||
#:use-module (language cps type-fold)
|
||||
#:use-module (language cps verify)
|
||||
#:use-module (system base optimize)
|
||||
#:export (optimize-higher-order-cps
|
||||
optimize-first-order-cps
|
||||
cps-optimizations))
|
||||
cps-optimizations
|
||||
make-cps-lowerer))
|
||||
|
||||
(define (kw-arg-ref args kw default)
|
||||
(match (memq kw args)
|
||||
|
|
@ -112,19 +118,28 @@
|
|||
(simplify #:simplify? #t))
|
||||
|
||||
(define (cps-optimizations)
|
||||
'( ;; (#:split-rec? #t)
|
||||
(#:simplify? 2)
|
||||
(#:eliminate-dead-code? 2)
|
||||
(#:prune-top-level-scopes? 2)
|
||||
(#:contify? 2)
|
||||
(#:specialize-primcalls? 2)
|
||||
(#:peel-loops? 2)
|
||||
(#:cse? 2)
|
||||
(#:type-fold? 2)
|
||||
(#:resolve-self-references? 2)
|
||||
(#:devirtualize-integers? 2)
|
||||
(#:specialize-numbers? 2)
|
||||
(#:licm? 2)
|
||||
(#:rotate-loops? 2)
|
||||
;; This one is used by the slot allocator.
|
||||
(#:precolor-calls? 2)))
|
||||
(available-optimizations 'cps))
|
||||
|
||||
(define (lower-cps exp opts)
|
||||
;; FIXME: For now the closure conversion pass relies on $rec instances
|
||||
;; being separated into SCCs. We should fix this to not be the case,
|
||||
;; and instead move the split-rec pass back to
|
||||
;; optimize-higher-order-cps.
|
||||
(set! exp (split-rec exp))
|
||||
(set! exp (optimize-higher-order-cps exp opts))
|
||||
(set! exp (convert-closures exp))
|
||||
(set! exp (optimize-first-order-cps exp opts))
|
||||
(set! exp (reify-primitives exp))
|
||||
(set! exp (add-loop-instrumentation exp))
|
||||
(renumber exp))
|
||||
|
||||
(define (make-cps-lowerer optimization-level opts)
|
||||
(define (enabled-for-level? level) (<= level optimization-level))
|
||||
(let ((opts (let lp ((all-opts (cps-optimizations)))
|
||||
(match all-opts
|
||||
(() '())
|
||||
(((kw level) . all-opts)
|
||||
(acons kw (kw-arg-ref opts kw (enabled-for-level? level))
|
||||
(lp all-opts)))))))
|
||||
(lambda (exp env)
|
||||
(lower-cps exp opts))))
|
||||
|
|
|
|||
|
|
@ -201,34 +201,14 @@
|
|||
(wrap-unary cps k src 's64->u64 'u64->s64 'ulsh/immediate param a))
|
||||
|
||||
(define (reify-lookup cps src mod-var name assert-bound? have-var)
|
||||
(define (%lookup cps kbad k src mod-var name-var var assert-bound?)
|
||||
(if assert-bound?
|
||||
(with-cps cps
|
||||
(letv val)
|
||||
(letk kcheck
|
||||
($kargs ('val) (val)
|
||||
($branch k kbad src 'undefined? #f (val))))
|
||||
(letk kref
|
||||
($kargs () ()
|
||||
($continue kcheck src
|
||||
($primcall 'scm-ref/immediate '(box . 1) (var)))))
|
||||
($ (%lookup kbad kref src mod-var name-var var #f)))
|
||||
(with-cps cps
|
||||
(letk kres
|
||||
($kargs ('var) (var)
|
||||
($branch kbad k src 'heap-object? #f (var))))
|
||||
(build-term
|
||||
($continue kres src
|
||||
($primcall 'lookup #f (mod-var name-var)))))))
|
||||
(define %unbound
|
||||
#(unbound-variable #f "Unbound variable: ~S"))
|
||||
(with-cps cps
|
||||
(letv name-var var)
|
||||
(let$ good (have-var var))
|
||||
(letk kgood ($kargs () () ,good))
|
||||
(letk kbad ($kargs () () ($throw src 'throw/value %unbound (name-var))))
|
||||
(let$ body (%lookup kbad kgood src mod-var name-var var assert-bound?))
|
||||
(letk klookup ($kargs ('name) (name-var) ,body))
|
||||
(let$ body (have-var var))
|
||||
(letk kres ($kargs ('var) (var) ,body))
|
||||
(letk klookup ($kargs ('name) (name-var)
|
||||
($continue kres src
|
||||
($primcall (if assert-bound? 'lookup-bound 'lookup) #f
|
||||
(mod-var name-var)))))
|
||||
(build-term ($continue klookup src ($const name)))))
|
||||
|
||||
(define (reify-resolve-module cps k src module public?)
|
||||
|
|
@ -354,7 +334,8 @@
|
|||
push-dynamic-state pop-dynamic-state
|
||||
lsh rsh lsh/immediate rsh/immediate
|
||||
cache-ref cache-set!
|
||||
resolve-module lookup define! current-module))
|
||||
current-module resolve-module
|
||||
module-variable lookup lookup-bound define!))
|
||||
(let ((table (make-hash-table)))
|
||||
(for-each
|
||||
(match-lambda ((inst . _) (hashq-set! table inst #t)))
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@
|
|||
#:use-module (system base language)
|
||||
#:use-module (language cps)
|
||||
#:use-module (language cps intmap)
|
||||
#:use-module (language cps optimize)
|
||||
#:use-module (language cps compile-bytecode)
|
||||
#:export (cps))
|
||||
|
||||
|
|
@ -48,4 +49,4 @@
|
|||
#:printer write-cps
|
||||
#:compilers `((bytecode . ,compile-bytecode))
|
||||
#:for-humans? #f
|
||||
)
|
||||
#:lowerer make-cps-lowerer)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; TREE-IL -> GLIL compiler
|
||||
|
||||
;; Copyright (C) 2001,2008-2014,2016,2018-2019 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2001,2008-2014,2016,2018-2020 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
|
||||
|
|
@ -37,7 +37,8 @@
|
|||
unbound-variable-analysis
|
||||
macro-use-before-definition-analysis
|
||||
arity-analysis
|
||||
format-analysis))
|
||||
format-analysis
|
||||
make-analyzer))
|
||||
|
||||
;;;
|
||||
;;; Tree analyses for warnings.
|
||||
|
|
@ -1086,3 +1087,23 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME."
|
|||
#t)
|
||||
|
||||
#t))
|
||||
|
||||
(define %warning-passes
|
||||
`(#(unused-variable 3 ,unused-variable-analysis)
|
||||
#(unused-toplevel 2 ,unused-toplevel-analysis)
|
||||
#(shadowed-toplevel 2 ,shadowed-toplevel-analysis)
|
||||
#(unbound-variable 1 ,unbound-variable-analysis)
|
||||
#(macro-use-before-definition 1 ,macro-use-before-definition-analysis)
|
||||
#(arity-mismatch 1 ,arity-analysis)
|
||||
#(format 1 ,format-analysis)))
|
||||
|
||||
(define (make-analyzer warning-level warnings)
|
||||
(define (enabled-for-level? level) (<= level warning-level))
|
||||
(let ((analyses (filter-map (match-lambda
|
||||
(#(kind level analysis)
|
||||
(and (or (enabled-for-level? level)
|
||||
(memq kind warnings))
|
||||
analysis)))
|
||||
%warning-passes)))
|
||||
(lambda (exp env)
|
||||
(analyze-tree analyses exp env))))
|
||||
|
|
|
|||
|
|
@ -2,19 +2,18 @@
|
|||
|
||||
;; Copyright (C) 2020 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
|
||||
;;; 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 program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
|
|
@ -26,27 +25,13 @@
|
|||
;;;
|
||||
;;; Code:
|
||||
|
||||
;; FIXME: Add handle-interrupts, instrument-entry, and instrument-loop.
|
||||
|
||||
;; FIXME: Verify that all SCM values on the stack will be marked.
|
||||
|
||||
;; FIXME: Verify that the stack marker will never misinterpret an
|
||||
;; unboxed temporary (u64 or otherwise) as a SCM.
|
||||
|
||||
;; FIXME: Verify that the debugger will never misinterpret an unboxed
|
||||
;; temporary as a SCM.
|
||||
|
||||
;; FIXME: Add debugging source-location info.
|
||||
|
||||
(define-module (language tree-il compile-bytecode)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (language bytecode)
|
||||
#:use-module (language tree-il)
|
||||
#:use-module (language tree-il analyze)
|
||||
#:use-module (language tree-il optimize)
|
||||
#:use-module ((srfi srfi-1) #:select (filter-map
|
||||
fold
|
||||
lset-union lset-difference))
|
||||
lset-adjoin lset-union lset-difference))
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (system base types internal)
|
||||
#:use-module (system vm assembler)
|
||||
|
|
@ -68,12 +53,14 @@
|
|||
(emit-word-set!/immediate asm dst 0 tmp)
|
||||
(emit-word-set!/immediate asm dst 1 src)))))
|
||||
(define (emit-box-set! asm loc val)
|
||||
(emit-word-set!/immediate asm loc 1 val))
|
||||
(emit-scm-set!/immediate asm loc 1 val))
|
||||
(define (emit-box-ref asm dst loc)
|
||||
(emit-scm-ref/immediate asm dst loc 1))
|
||||
(define (emit-cons asm dst car cdr)
|
||||
(cond
|
||||
((= car dst)
|
||||
(emit-mov asm 1 car)
|
||||
(emit-cons asm dst 1 (if (= cdr dst) 1 dst)))
|
||||
(emit-cons asm dst 1 (if (= cdr dst) 1 cdr)))
|
||||
((= cdr dst)
|
||||
(emit-mov asm 1 cdr)
|
||||
(emit-cons asm dst car 1))
|
||||
|
|
@ -82,7 +69,7 @@
|
|||
(emit-scm-set!/immediate asm dst 0 car)
|
||||
(emit-scm-set!/immediate asm dst 1 cdr))))
|
||||
|
||||
(define (emit-cached-module-box asm dst mod name public? tmp)
|
||||
(define (emit-cached-module-box asm dst mod name public? bound? tmp)
|
||||
(define key (cons mod name))
|
||||
(define cached (gensym "cached"))
|
||||
(emit-cache-ref asm dst key)
|
||||
|
|
@ -91,10 +78,12 @@
|
|||
(emit-load-constant asm dst mod)
|
||||
(emit-resolve-module asm dst dst public?)
|
||||
(emit-load-constant asm tmp name)
|
||||
(emit-lookup asm dst dst tmp)
|
||||
(if bound?
|
||||
(emit-lookup-bound asm dst dst tmp)
|
||||
(emit-lookup asm dst dst tmp))
|
||||
(emit-cache-set! asm key dst)
|
||||
(emit-label asm cached))
|
||||
(define (emit-cached-toplevel-box asm dst scope name tmp)
|
||||
(define (emit-cached-toplevel-box asm dst scope name bound? tmp)
|
||||
(define key (cons scope name))
|
||||
(define cached (gensym "cached"))
|
||||
(emit-cache-ref asm dst key)
|
||||
|
|
@ -102,13 +91,17 @@
|
|||
(emit-je asm cached)
|
||||
(emit-cache-ref asm dst scope)
|
||||
(emit-load-constant asm tmp name)
|
||||
(emit-lookup asm dst dst tmp)
|
||||
(if bound?
|
||||
(emit-lookup-bound asm dst dst tmp)
|
||||
(emit-lookup asm dst dst tmp))
|
||||
(emit-cache-set! asm key dst)
|
||||
(emit-label asm cached))
|
||||
(define (emit-toplevel-box asm dst name tmp)
|
||||
(define (emit-toplevel-box asm dst name bound? tmp)
|
||||
(emit-current-module asm dst)
|
||||
(emit-load-constant asm tmp name)
|
||||
(emit-lookup asm dst dst tmp))
|
||||
(if bound?
|
||||
(emit-lookup-bound asm dst dst tmp)
|
||||
(emit-lookup asm dst dst tmp)))
|
||||
|
||||
(define closure-header-words 2)
|
||||
(define (emit-allocate-closure asm dst nfree label tmp)
|
||||
|
|
@ -261,6 +254,7 @@
|
|||
(push-dynamic-state #:nargs 1 #:emit emit-push-dynamic-state)
|
||||
(pop-dynamic-state #:nargs 0 #:emit emit-pop-dynamic-state)
|
||||
(push-fluid #:nargs 2 #:emit emit-push-fluid)
|
||||
(pop-fluid #:nargs 0 #:emit emit-pop-fluid)
|
||||
(pop-fluid-state #:nargs 0 #:emit emit-pop-dynamic-state)
|
||||
(fluid-ref #:nargs 1 #:has-result? #t #:emit emit-fluid-ref)
|
||||
(fluid-set! #:nargs 2 #:emit emit-fluid-set!)
|
||||
|
|
@ -304,7 +298,7 @@
|
|||
(emit-jne asm kf)))
|
||||
(< #:nargs 2 #:predicate? #t #:emit (lambda (asm a b kf)
|
||||
(emit-<? asm a b)
|
||||
(emit-jl asm kf)))
|
||||
(emit-jnl asm kf)))
|
||||
(<= #:nargs 2 #:predicate? #t #:emit (lambda (asm a b kf)
|
||||
(emit-<? asm b a)
|
||||
(emit-jnge asm kf)))
|
||||
|
|
@ -511,7 +505,7 @@
|
|||
;; expressions. (Escape-only prompt bodies are already
|
||||
;; expressions.)
|
||||
(($ <prompt> src #f tag body handler)
|
||||
(make-prompt src tag #f (make-call src body '()) handler))
|
||||
(make-prompt src #f tag (make-call src body '()) handler))
|
||||
|
||||
(_ exp)))
|
||||
exp))
|
||||
|
|
@ -544,6 +538,7 @@
|
|||
;; lambdas are seen, and adding set! vars to `assigned'.
|
||||
(define (visit-closure exp module-scope)
|
||||
(define (visit exp)
|
||||
(define (adjoin sym f) (lset-adjoin eq? f sym))
|
||||
(define (union f1 f2) (lset-union eq? f1 f2))
|
||||
(define (union3 f1 f2 f3) (union f1 (union f2 f3)))
|
||||
(define (difference f1 f2) (lset-difference eq? f1 f2))
|
||||
|
|
@ -600,7 +595,7 @@
|
|||
|
||||
(($ <lexical-set> src name gensym exp)
|
||||
(hashq-set! assigned gensym #t)
|
||||
(visit exp))
|
||||
(adjoin gensym (visit exp)))
|
||||
|
||||
(($ <seq> src head tail)
|
||||
(union (visit head) (visit tail)))
|
||||
|
|
@ -747,26 +742,21 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
(lookup-lexical sym prev)))
|
||||
(_ (error "sym not found!" sym))))
|
||||
|
||||
(define (frame-base env)
|
||||
(match env
|
||||
(($ <env> _ 'frame-base #f)
|
||||
env)
|
||||
(($ <env> prev)
|
||||
(frame-base prev))))
|
||||
|
||||
(define (compile-body clause module-scope free-vars frame-size)
|
||||
(define (push-free-var sym idx env)
|
||||
(make-env env sym sym idx #t (assigned? sym) #f))
|
||||
(define frame-base
|
||||
(make-env #f 'frame-base #f #f #f #f (- frame-size 1)))
|
||||
|
||||
(define (push-closure env)
|
||||
(push-local 'closure #f
|
||||
(make-env env 'frame-base #f #f #f #f (- frame-size 1))))
|
||||
(define (push-free-var sym idx env)
|
||||
(make-env env sym sym idx #t (assigned? sym) (env-next-local env)))
|
||||
|
||||
(define (push-local name sym env)
|
||||
(let ((idx (env-next-local env)))
|
||||
(emit-definition asm name (- frame-size idx 1) 'scm)
|
||||
(make-env env name sym idx #f (assigned? sym) (1- idx))))
|
||||
|
||||
(define (push-closure env)
|
||||
(push-local 'closure #f env))
|
||||
|
||||
(define (push-local-alias name sym idx env)
|
||||
(make-env env name sym idx #f #f (env-next-local env)))
|
||||
|
||||
|
|
@ -788,7 +778,7 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
((sym . free)
|
||||
(lp (1+ idx) free
|
||||
(push-free-var sym idx env))))))
|
||||
(fold push-local (push-closure (push-free-vars #f)) names syms))
|
||||
(fold push-local (push-closure (push-free-vars frame-base)) names syms))
|
||||
|
||||
(define (stack-height env)
|
||||
(- frame-size (env-next-local env) 1))
|
||||
|
|
@ -798,6 +788,9 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
(emit-current-module asm 0)
|
||||
(emit-cache-set! asm scope 0)))
|
||||
|
||||
(define (maybe-emit-source source)
|
||||
(when source (emit-source asm source)))
|
||||
|
||||
(define (init-free-vars dst free-vars env tmp0 tmp1)
|
||||
(let lp ((free-idx 0) (free-vars free-vars))
|
||||
(unless (null? free-vars)
|
||||
|
|
@ -822,6 +815,7 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
env names syms))
|
||||
(let ((proc-slot (stack-height env))
|
||||
(nreq (length req)))
|
||||
(maybe-emit-source src)
|
||||
(unless (and rest (zero? nreq))
|
||||
(emit-receive-values asm proc-slot (->bool rest) nreq))
|
||||
(when rest
|
||||
|
|
@ -835,6 +829,7 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
(($ <prompt> src escape-only? tag body
|
||||
($ <lambda> hsrc hmeta
|
||||
($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
|
||||
(maybe-emit-source src)
|
||||
(let ((tag (env-idx (for-value tag env)))
|
||||
(proc-slot (stack-height env))
|
||||
(khandler (gensym "handler"))
|
||||
|
|
@ -845,8 +840,9 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
('tail
|
||||
;; Would be nice if we could invoke the body in true tail
|
||||
;; context, but that's not how it currently is.
|
||||
(for-values body env)
|
||||
(for-values-at body env frame-base)
|
||||
(emit-unwind asm)
|
||||
(emit-handle-interrupts asm)
|
||||
(emit-return-values asm))
|
||||
(_
|
||||
(for-context body env ctx)
|
||||
|
|
@ -862,10 +858,12 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
(match exp
|
||||
(($ <conditional> src ($ <primcall> tsrc name args)
|
||||
consequent alternate)
|
||||
(maybe-emit-source tsrc)
|
||||
(let ((emit (primitive-emitter (lookup-primitive name)))
|
||||
(args (for-args args env))
|
||||
(kf (gensym "false"))
|
||||
(kdone (gensym "done")))
|
||||
(maybe-emit-source src)
|
||||
(match args
|
||||
((a) (emit asm a kf))
|
||||
((a b) (emit asm a b kf)))
|
||||
|
|
@ -879,6 +877,7 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
(define (visit-seq exp env ctx)
|
||||
(match exp
|
||||
(($ <seq> src head tail)
|
||||
(maybe-emit-source src)
|
||||
(for-effect head env)
|
||||
(for-context tail env ctx))))
|
||||
|
||||
|
|
@ -893,6 +892,7 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
env names syms vals))
|
||||
(match exp
|
||||
(($ <let> src names syms vals body)
|
||||
(maybe-emit-source src)
|
||||
(for-context body (push-bindings names syms vals env) ctx))))
|
||||
|
||||
(define (visit-fix exp env ctx)
|
||||
|
|
@ -903,6 +903,8 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
(let ((env (push-local name sym env)))
|
||||
(match closure
|
||||
(($ <closure> label code scope free-vars)
|
||||
;; FIXME: Allocate one scope per fix.
|
||||
(maybe-cache-module! scope 0)
|
||||
(emit-maybe-allocate-closure
|
||||
asm (env-idx env) (length free-vars) label 0)
|
||||
env))))
|
||||
|
|
@ -917,12 +919,14 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
env))
|
||||
(match exp
|
||||
(($ <fix> src names syms vals body)
|
||||
(maybe-emit-source src)
|
||||
(for-context body (push-bindings names syms vals env) ctx))))
|
||||
|
||||
(define (visit-let-values exp env ctx)
|
||||
(match exp
|
||||
(($ <let-values> src exp
|
||||
($ <lambda-case> lsrc req #f rest #f () syms body #f))
|
||||
(maybe-emit-source src)
|
||||
(for-values exp env)
|
||||
(visit-values-handler lsrc req rest syms body env ctx))))
|
||||
|
||||
|
|
@ -954,36 +958,42 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
|
||||
(($ <lexical-set> src name sym exp)
|
||||
(let ((env (for-value exp env)))
|
||||
(maybe-emit-source src)
|
||||
(match (lookup-lexical sym env)
|
||||
(($ <env> _ _ _ idx #t #t) ;; Boxed closure.
|
||||
(emit-load-free-variable asm 0 (1- frame-size) idx 0)
|
||||
(emit-$variable-set! asm 0 (env-idx env)))
|
||||
(emit-box-set! asm 0 (env-idx env)))
|
||||
(($ <env> _ _ _ idx #f #t) ;; Boxed local.
|
||||
(emit-$variable-set! asm idx (env-idx env))))))
|
||||
(emit-box-set! asm idx (env-idx env))))))
|
||||
|
||||
(($ <module-set> src mod name public? exp)
|
||||
(let ((env (for-value exp env)))
|
||||
(emit-cached-module-box asm 0 mod name public? 1)
|
||||
(emit-$variable-set! asm 0 (env-idx env))))
|
||||
(maybe-emit-source src)
|
||||
(emit-cached-module-box asm 0 mod name public? #f 1)
|
||||
(emit-box-set! asm 0 (env-idx env))))
|
||||
|
||||
(($ <toplevel-set> src mod name exp)
|
||||
(let ((env (for-value exp env)))
|
||||
(maybe-emit-source src)
|
||||
(if module-scope
|
||||
(emit-cached-toplevel-box asm 0 module-scope name 1)
|
||||
(emit-toplevel-box asm 0 name 1))
|
||||
(emit-$variable-set! asm 0 (env-idx env))))
|
||||
(emit-cached-toplevel-box asm 0 module-scope name #f 1)
|
||||
(emit-toplevel-box asm 0 name #f 1))
|
||||
(emit-box-set! asm 0 (env-idx env))))
|
||||
|
||||
(($ <toplevel-define> src mod name exp)
|
||||
(let ((env (for-value exp env)))
|
||||
(maybe-emit-source src)
|
||||
(emit-current-module asm 0)
|
||||
(emit-load-constant asm 1 name)
|
||||
(emit-define! asm 0 0 1)
|
||||
(emit-$variable-set! asm 0 (env-idx env))))
|
||||
(emit-box-set! asm 0 (env-idx env))))
|
||||
|
||||
(($ <call> src proc args)
|
||||
(let ((proc-slot (let ((env (push-frame env)))
|
||||
(fold for-push (for-push proc env) args)
|
||||
(stack-height env))))
|
||||
(maybe-emit-source src)
|
||||
(emit-handle-interrupts asm)
|
||||
(emit-call asm proc-slot (1+ (length args)))
|
||||
(emit-reset-frame asm frame-size)))
|
||||
|
||||
|
|
@ -1000,23 +1010,27 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
((a ($ <const> _ (? emit/immediate? b)))
|
||||
(let ((emit (primitive-emitter/immediate prim)))
|
||||
(match (for-args (list a) env)
|
||||
((a) (emit asm a b)))))
|
||||
((a)
|
||||
(maybe-emit-source src)
|
||||
(emit asm a b)))))
|
||||
((a ($ <const> _ (? emit/immediate? b)) c)
|
||||
(let ((emit (primitive-emitter/immediate prim)))
|
||||
(match (for-args (list a c) env)
|
||||
((a c) (emit asm a b c)))))
|
||||
((a c)
|
||||
(maybe-emit-source src)
|
||||
(emit asm a b c)))))
|
||||
(_
|
||||
(let ((emit (primitive-emitter prim)))
|
||||
(apply emit asm (for-args args env)))))))))
|
||||
(let ((emit (primitive-emitter prim))
|
||||
(args (for-args args env)))
|
||||
(maybe-emit-source src)
|
||||
(apply emit asm args))))))))
|
||||
|
||||
(($ <prompt>) (visit-prompt exp env 'effect))
|
||||
(($ <conditional>) (visit-conditional exp env 'effect))
|
||||
(($ <seq>) (visit-seq exp env 'effect))
|
||||
(($ <let>) (visit-let exp env 'effect))
|
||||
(($ <fix>) (visit-fix exp env 'effect))
|
||||
(($ <let-values>) (visit-let-values exp env 'effect)))
|
||||
|
||||
(values))
|
||||
(($ <let-values>) (visit-let-values exp env 'effect))))
|
||||
|
||||
(define (for-value-at exp env base)
|
||||
;; The baseline compiler follows a stack discipline: compiling
|
||||
|
|
@ -1065,31 +1079,36 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
(define dst (env-idx dst-env))
|
||||
(match exp
|
||||
(($ <lexical-ref> src name sym)
|
||||
(maybe-emit-source src)
|
||||
(match (lookup-lexical sym env)
|
||||
(($ <env> _ _ _ idx #t #t)
|
||||
(emit-load-free-variable asm dst (1- frame-size) idx 0)
|
||||
(emit-$variable-ref asm dst dst))
|
||||
(emit-box-ref asm dst dst))
|
||||
(($ <env> _ _ _ idx #t #f)
|
||||
(emit-load-free-variable asm dst (1- frame-size) idx 0))
|
||||
(($ <env> _ _ _ idx #f #t)
|
||||
(emit-$variable-ref asm dst idx))
|
||||
(emit-box-ref asm dst idx))
|
||||
(($ <env> _ _ _ idx #f #f)
|
||||
(emit-mov asm dst idx))))
|
||||
|
||||
(($ <const> src val)
|
||||
(maybe-emit-source src)
|
||||
(emit-load-constant asm dst val))
|
||||
|
||||
(($ <module-ref> src mod name public?)
|
||||
(emit-cached-module-box asm 0 mod name public? 1)
|
||||
(emit-$variable-ref asm dst 0))
|
||||
(maybe-emit-source src)
|
||||
(emit-cached-module-box asm 0 mod name public? #t 1)
|
||||
(emit-box-ref asm dst 0))
|
||||
|
||||
(($ <toplevel-ref> src mod name)
|
||||
(maybe-emit-source src)
|
||||
(if module-scope
|
||||
(emit-cached-toplevel-box asm 0 module-scope name 1)
|
||||
(emit-toplevel-box asm 0 name 1))
|
||||
(emit-$variable-ref asm dst 0))
|
||||
(emit-cached-toplevel-box asm 0 module-scope name #t 1)
|
||||
(emit-toplevel-box asm 0 name #t 1))
|
||||
(emit-box-ref asm dst 0))
|
||||
|
||||
(($ <lambda> src)
|
||||
(maybe-emit-source src)
|
||||
(match (lookup-closure exp)
|
||||
(($ <closure> label code scope free-vars)
|
||||
(maybe-cache-module! scope 0)
|
||||
|
|
@ -1114,12 +1133,15 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
(let ((proc-slot (let ((env (push-frame env)))
|
||||
(fold for-push (for-push proc env) args)
|
||||
(stack-height env))))
|
||||
(emit-call asm proc-slot (length args))
|
||||
(emit-receive src dst proc-slot frame-size)))
|
||||
(maybe-emit-source src)
|
||||
(emit-handle-interrupts asm)
|
||||
(emit-call asm proc-slot (1+ (length args)))
|
||||
(emit-receive asm (stack-height base) proc-slot frame-size)))
|
||||
|
||||
(($ <primcall> src (? variadic-constructor? name) args)
|
||||
;; Stage result in 0 to avoid stompling args.
|
||||
(let ((args (for-args args env)))
|
||||
(maybe-emit-source src)
|
||||
(match name
|
||||
('list
|
||||
(emit-load-constant asm 0 '())
|
||||
|
|
@ -1136,12 +1158,14 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
('make-struct/simple
|
||||
(match args
|
||||
((vtable . args)
|
||||
(let ((len (length args)))
|
||||
(emit-$allocate-struct asm 0 vtable len)
|
||||
(let lp ((i 0) (args args))
|
||||
(when (< i len)
|
||||
(emit-struct-init! asm 0 i (car args) 1)
|
||||
(lp (1+ i) (cdr args)))))))))
|
||||
(emit-load-constant asm 0 (length args))
|
||||
(emit-$allocate-struct asm 0 vtable 0)
|
||||
(let lp ((i 0) (args args))
|
||||
(match args
|
||||
(() #t)
|
||||
((arg . args)
|
||||
(emit-struct-init! asm 0 i arg 1)
|
||||
(lp (1+ i) args))))))))
|
||||
(emit-mov asm dst 0)))
|
||||
|
||||
(($ <primcall> src name args)
|
||||
|
|
@ -1157,22 +1181,25 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
(match args
|
||||
((($ <const> _ (? emit/immediate? a)))
|
||||
(let* ((emit (primitive-emitter/immediate prim)))
|
||||
(maybe-emit-source src)
|
||||
(emit asm dst a)))
|
||||
((a ($ <const> _ (? emit/immediate? b)))
|
||||
(let* ((emit (primitive-emitter/immediate prim))
|
||||
(a (for-value a env)))
|
||||
(maybe-emit-source src)
|
||||
(emit asm dst (env-idx a) b)))
|
||||
(_
|
||||
(let ((emit (primitive-emitter prim)))
|
||||
(apply emit asm dst (for-args args env)))))))))
|
||||
(let ((emit (primitive-emitter prim))
|
||||
(args (for-args args env)))
|
||||
(maybe-emit-source src)
|
||||
(apply emit asm dst args))))))))
|
||||
|
||||
(($ <prompt>) (visit-prompt exp env `(value-at . ,base)))
|
||||
(($ <conditional>) (visit-conditional exp env `(value-at. ,base)))
|
||||
(($ <conditional>) (visit-conditional exp env `(value-at . ,base)))
|
||||
(($ <seq>) (visit-seq exp env `(value-at . ,base)))
|
||||
(($ <let>) (visit-let exp env `(value-at . ,base)))
|
||||
(($ <fix>) (visit-fix exp env `(value-at . ,base)))
|
||||
(($ <let-values>) (visit-let-values exp env `(value-at . ,base))))
|
||||
dst-env)
|
||||
(($ <let-values>) (visit-let-values exp env `(value-at . ,base)))))
|
||||
|
||||
(define (for-value exp env)
|
||||
(match (and (lexical-ref? exp)
|
||||
|
|
@ -1183,7 +1210,8 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
(for-push exp env))))
|
||||
|
||||
(define (for-push exp env)
|
||||
(for-value-at exp env env))
|
||||
(for-value-at exp env env)
|
||||
(push-temp env))
|
||||
|
||||
(define (for-init sym init env)
|
||||
(match (lookup-lexical sym env)
|
||||
|
|
@ -1217,6 +1245,8 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
(env (push-frame env))
|
||||
(from (stack-height env)))
|
||||
(fold for-push (for-push proc env) args)
|
||||
(maybe-emit-source src)
|
||||
(emit-handle-interrupts asm)
|
||||
(emit-call asm from (1+ (length args)))
|
||||
(unless (= from to)
|
||||
(emit-shuffle-down asm from to))))
|
||||
|
|
@ -1226,9 +1256,7 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
(($ <seq>) (visit-seq exp env `(values-at . ,base)))
|
||||
(($ <let>) (visit-let exp env `(values-at . ,base)))
|
||||
(($ <fix>) (visit-fix exp env `(values-at . ,base)))
|
||||
(($ <let-values>) (visit-let-values exp env `(values-at . ,base))))
|
||||
|
||||
(values))
|
||||
(($ <let-values>) (visit-let-values exp env `(values-at . ,base)))))
|
||||
|
||||
(define (for-values exp env)
|
||||
(for-values-at exp env env))
|
||||
|
|
@ -1245,17 +1273,20 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
($ <module-set>)
|
||||
($ <lambda>)
|
||||
($ <primcall>))
|
||||
(for-values-at exp env (frame-base env))
|
||||
(for-values-at exp env frame-base)
|
||||
(emit-handle-interrupts asm)
|
||||
(emit-return-values asm))
|
||||
|
||||
(($ <call> src proc args)
|
||||
(let* ((base (stack-height env))
|
||||
(env (fold for-push (for-push proc env) args)))
|
||||
(maybe-emit-source src)
|
||||
(let lp ((i (length args)) (env env))
|
||||
(when (<= 0 i)
|
||||
(lp (1- i) (env-prev env))
|
||||
(emit-mov asm (+ (env-idx env) base) (env-idx env))))
|
||||
(emit-reset-frame asm (+ 1 (length args)))
|
||||
(emit-handle-interrupts asm)
|
||||
(emit-tail-call asm)))
|
||||
|
||||
(($ <prompt>) (visit-prompt exp env 'tail))
|
||||
|
|
@ -1263,9 +1294,7 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
(($ <seq>) (visit-seq exp env 'tail))
|
||||
(($ <let>) (visit-let exp env 'tail))
|
||||
(($ <fix>) (visit-fix exp env 'tail))
|
||||
(($ <let-values>) (visit-let-values exp env 'tail)))
|
||||
|
||||
(values))
|
||||
(($ <let-values>) (visit-let-values exp env 'tail))))
|
||||
|
||||
(match clause
|
||||
(($ <lambda-case> src req opt rest kw inits syms body alt)
|
||||
|
|
@ -1281,6 +1310,7 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
(list-tail inits (if opt (length opt) 0)))))
|
||||
(unless (= (length names) (length syms) (length inits))
|
||||
(error "unexpected args" names syms inits))
|
||||
(maybe-emit-source src)
|
||||
(let ((env (create-initial-env names syms free-vars)))
|
||||
(for-each (lambda (sym init) (for-init sym init env)) syms inits)
|
||||
(for-tail body env))))))
|
||||
|
|
@ -1298,7 +1328,7 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
(values aok?
|
||||
(map (match-lambda
|
||||
((key name sym)
|
||||
(cons key (list-index syms sym))))
|
||||
(cons key (1+ (list-index syms sym)))))
|
||||
kw)))))
|
||||
(lambda (allow-other-keys? kw-indices)
|
||||
(when label (emit-label asm label))
|
||||
|
|
@ -1316,35 +1346,13 @@ in the frame with for the lambda-case clause @var{clause}."
|
|||
(emit-clause #f body module-scope free)
|
||||
(emit-end-program asm))))
|
||||
|
||||
(define %warning-passes
|
||||
`((unused-variable . ,unused-variable-analysis)
|
||||
(unused-toplevel . ,unused-toplevel-analysis)
|
||||
(shadowed-toplevel . ,shadowed-toplevel-analysis)
|
||||
(unbound-variable . ,unbound-variable-analysis)
|
||||
(macro-use-before-definition . ,macro-use-before-definition-analysis)
|
||||
(arity-mismatch . ,arity-analysis)
|
||||
(format . ,format-analysis)))
|
||||
|
||||
(define (optimize-tree-il x e opts)
|
||||
(define warnings
|
||||
(or (and=> (memq #:warnings opts) cadr)
|
||||
'()))
|
||||
|
||||
;; Go through the warning passes.
|
||||
(let ((analyses (filter-map (lambda (kind)
|
||||
(assoc-ref %warning-passes kind))
|
||||
warnings)))
|
||||
(analyze-tree analyses x e))
|
||||
|
||||
(optimize x e opts))
|
||||
|
||||
(define (kw-arg-ref args kw default)
|
||||
(match (memq kw args)
|
||||
((_ val . _) val)
|
||||
(_ default)))
|
||||
|
||||
(define (compile-bytecode exp env opts)
|
||||
(let* ((exp (canonicalize (optimize-tree-il exp env opts)))
|
||||
(let* ((exp (canonicalize exp))
|
||||
(asm (make-assembler)))
|
||||
(call-with-values (lambda () (split-closures exp))
|
||||
(lambda (closures assigned)
|
||||
|
|
|
|||
|
|
@ -60,8 +60,6 @@
|
|||
#:use-module (language cps utils)
|
||||
#:use-module (language cps with-cps)
|
||||
#:use-module (language tree-il cps-primitives)
|
||||
#:use-module (language tree-il analyze)
|
||||
#:use-module (language tree-il optimize)
|
||||
#:use-module (language tree-il)
|
||||
#:use-module (language cps intmap)
|
||||
#:export (compile-cps))
|
||||
|
|
@ -1403,36 +1401,16 @@
|
|||
scope-id))
|
||||
|
||||
(define (toplevel-box cps src name bound? have-var)
|
||||
(define %unbound
|
||||
#(unbound-variable #f "Unbound variable: ~S"))
|
||||
(match (current-topbox-scope)
|
||||
(#f
|
||||
(with-cps cps
|
||||
(letv mod name-var box)
|
||||
(letk kbad ($kargs () () ($throw src 'throw/value %unbound (name-var))))
|
||||
(let$ body
|
||||
((if bound?
|
||||
(lambda (cps)
|
||||
(with-cps cps
|
||||
(letv val)
|
||||
(let$ body (have-var box))
|
||||
(letk kdef ($kargs () () ,body))
|
||||
(letk ktest ($kargs ('val) (val)
|
||||
($branch kdef kbad src
|
||||
'undefined? #f (val))))
|
||||
(build-term
|
||||
($continue ktest src
|
||||
($primcall 'scm-ref/immediate
|
||||
'(box . 1) (box))))))
|
||||
(lambda (cps)
|
||||
(with-cps cps
|
||||
($ (have-var box)))))))
|
||||
(letk ktest ($kargs () () ,body))
|
||||
(letk kbox ($kargs ('box) (box)
|
||||
($branch kbad ktest src 'heap-object? #f (box))))
|
||||
(let$ body (have-var box))
|
||||
(letk kbox ($kargs ('box) (box) ,body))
|
||||
(letk kname ($kargs ('name) (name-var)
|
||||
($continue kbox src
|
||||
($primcall 'lookup #f (mod name-var)))))
|
||||
($primcall (if bound? 'lookup-bound 'lookup) #f
|
||||
(mod name-var)))))
|
||||
(letk kmod ($kargs ('mod) (mod)
|
||||
($continue kname src ($const name))))
|
||||
(build-term
|
||||
|
|
@ -2324,28 +2302,6 @@ integer."
|
|||
|
||||
(define *comp-module* (make-fluid))
|
||||
|
||||
(define %warning-passes
|
||||
`((unused-variable . ,unused-variable-analysis)
|
||||
(unused-toplevel . ,unused-toplevel-analysis)
|
||||
(shadowed-toplevel . ,shadowed-toplevel-analysis)
|
||||
(unbound-variable . ,unbound-variable-analysis)
|
||||
(macro-use-before-definition . ,macro-use-before-definition-analysis)
|
||||
(arity-mismatch . ,arity-analysis)
|
||||
(format . ,format-analysis)))
|
||||
|
||||
(define (optimize-tree-il x e opts)
|
||||
(define warnings
|
||||
(or (and=> (memq #:warnings opts) cadr)
|
||||
'()))
|
||||
|
||||
;; Go through the warning passes.
|
||||
(let ((analyses (filter-map (lambda (kind)
|
||||
(assoc-ref %warning-passes kind))
|
||||
warnings)))
|
||||
(analyze-tree analyses x e))
|
||||
|
||||
(optimize x e opts))
|
||||
|
||||
(define (canonicalize exp)
|
||||
(define-syntax-rule (with-lexical src id . body)
|
||||
(let ((k (lambda (id) . body)))
|
||||
|
|
@ -2560,10 +2516,7 @@ integer."
|
|||
exp))
|
||||
|
||||
(define (compile-cps exp env opts)
|
||||
(values (cps-convert/thunk
|
||||
(canonicalize (optimize-tree-il exp env opts)))
|
||||
env
|
||||
env))
|
||||
(values (cps-convert/thunk (canonicalize exp)) env env))
|
||||
|
||||
;;; Local Variables:
|
||||
;;; eval: (put 'convert-arg 'scheme-indent-function 2)
|
||||
|
|
|
|||
|
|
@ -27,7 +27,9 @@
|
|||
#:use-module (language tree-il peval)
|
||||
#:use-module (language tree-il primitives)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (system base optimize)
|
||||
#:export (optimize
|
||||
make-lowerer
|
||||
tree-il-optimizations))
|
||||
|
||||
(define (kw-arg-ref args kw default)
|
||||
|
|
@ -61,17 +63,15 @@
|
|||
x)
|
||||
|
||||
(define (tree-il-optimizations)
|
||||
;; Avoid resolve-primitives until -O2, when CPS optimizations kick in.
|
||||
;; Otherwise, inlining the primcalls during Tree-IL->CPS compilation
|
||||
;; will result in a lot of code that will never get optimized nicely.
|
||||
;; Similarly letrectification is great for generated code quality, but
|
||||
;; as it gives the compiler more to work with, it increases compile
|
||||
;; time enough that we reserve it for -O2. Also, this makes -O1 avoid
|
||||
;; assumptions about top-level values, in the same way that avoiding
|
||||
;; resolve-primitives does.
|
||||
'((#:resolve-primitives? 2)
|
||||
(#:expand-primitives? 1)
|
||||
(#:letrectify? 2)
|
||||
(#:seal-private-bindings? 3)
|
||||
(#:partial-eval? 1)
|
||||
(#:eta-expand? 2)))
|
||||
(available-optimizations 'tree-il))
|
||||
|
||||
(define (make-lowerer optimization-level opts)
|
||||
(define (enabled-for-level? level) (<= level optimization-level))
|
||||
(let ((opts (let lp ((all-opts (tree-il-optimizations)))
|
||||
(match all-opts
|
||||
(() '())
|
||||
(((kw level) . all-opts)
|
||||
(acons kw (kw-arg-ref opts kw (enabled-for-level? level))
|
||||
(lp all-opts)))))))
|
||||
(lambda (exp env)
|
||||
(optimize exp env opts))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Tree Intermediate Language
|
||||
|
||||
;; Copyright (C) 2009, 2010, 2011, 2013, 2015 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2009-2011,2013,2015,2020 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
|
||||
|
|
@ -20,21 +20,31 @@
|
|||
|
||||
(define-module (language tree-il spec)
|
||||
#:use-module (system base language)
|
||||
#:use-module (system base pmatch)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (language tree-il)
|
||||
#:use-module (language tree-il compile-cps)
|
||||
#:use-module ((language tree-il analyze) #:select (make-analyzer))
|
||||
#:use-module ((language tree-il optimize) #:select (make-lowerer))
|
||||
#:export (tree-il))
|
||||
|
||||
(define (write-tree-il exp . port)
|
||||
(apply write (unparse-tree-il exp) port))
|
||||
|
||||
(define (join exps env)
|
||||
(pmatch exps
|
||||
(match exps
|
||||
(() (make-void #f))
|
||||
((,x) x)
|
||||
((,x . ,rest)
|
||||
((x) x)
|
||||
((x . rest)
|
||||
(make-seq #f x (join rest env)))
|
||||
(else (error "what!" exps env))))
|
||||
(_ (error "what!" exps env))))
|
||||
|
||||
(define (choose-compiler target optimization-level opts)
|
||||
(define (load-compiler compiler)
|
||||
(module-ref (resolve-interface `(language tree-il ,compiler)) compiler))
|
||||
(if (match (memq #:cps? opts)
|
||||
((_ cps? . _) cps?)
|
||||
(#f (<= 1 optimization-level)))
|
||||
(cons 'cps (load-compiler 'compile-cps))
|
||||
(cons 'bytecode (load-compiler 'compile-bytecode))))
|
||||
|
||||
(define-language tree-il
|
||||
#:title "Tree Intermediate Language"
|
||||
|
|
@ -42,5 +52,7 @@
|
|||
#:printer write-tree-il
|
||||
#:parser parse-tree-il
|
||||
#:joiner join
|
||||
#:compilers `((cps . ,compile-cps))
|
||||
#:compiler-chooser choose-compiler
|
||||
#:analyzer make-analyzer
|
||||
#:lowerer make-lowerer
|
||||
#:for-humans? #f)
|
||||
|
|
|
|||
|
|
@ -29,8 +29,10 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (scripts compile)
|
||||
#:use-module ((system base language) #:select (lookup-language))
|
||||
#:use-module ((system base compile) #:select (compile-file))
|
||||
#:use-module ((system base compile) #:select (compute-compiler
|
||||
compile-file
|
||||
default-warning-level
|
||||
default-optimization-level))
|
||||
#:use-module (system base target)
|
||||
#:use-module (system base message)
|
||||
#:use-module (system base optimize)
|
||||
|
|
@ -44,8 +46,8 @@
|
|||
(define %summary "Compile a file.")
|
||||
|
||||
|
||||
(define (fail . messages)
|
||||
(format (current-error-port) "error: ~{~a~}~%" messages)
|
||||
(define (fail message . args)
|
||||
(format (current-error-port) "error: ~?~%" message args)
|
||||
(exit 1))
|
||||
|
||||
(define %options
|
||||
|
|
@ -81,14 +83,21 @@
|
|||
|
||||
(option '(#\W "warn") #t #f
|
||||
(lambda (opt name arg result)
|
||||
(if (string=? arg "help")
|
||||
(begin
|
||||
(show-warning-help)
|
||||
(exit 0))
|
||||
(let ((warnings (assoc-ref result 'warnings)))
|
||||
(alist-cons 'warnings
|
||||
(cons (string->symbol arg) warnings)
|
||||
(alist-delete 'warnings result))))))
|
||||
(match arg
|
||||
("help"
|
||||
(show-warning-help)
|
||||
(exit 0))
|
||||
((? string->number)
|
||||
(let ((n (string->number arg)))
|
||||
(unless (and (exact-integer? n) (<= 0 n))
|
||||
(fail "Bad warning level `~a'" n))
|
||||
(alist-cons 'warning-level n
|
||||
(alist-delete 'warning-level result))))
|
||||
(_
|
||||
(let ((warnings (assoc-ref result 'warnings)))
|
||||
(alist-cons 'warnings
|
||||
(cons (string->symbol arg) warnings)
|
||||
(alist-delete 'warnings result)))))))
|
||||
|
||||
(option '(#\O "optimize") #t #f
|
||||
(lambda (opt name arg result)
|
||||
|
|
@ -104,10 +113,12 @@
|
|||
((string=? arg "help")
|
||||
(show-optimization-help)
|
||||
(exit 0))
|
||||
((equal? arg "0") (return (optimizations-for-level 0)))
|
||||
((equal? arg "1") (return (optimizations-for-level 1)))
|
||||
((equal? arg "2") (return (optimizations-for-level 2)))
|
||||
((equal? arg "3") (return (optimizations-for-level 3)))
|
||||
((string->number arg)
|
||||
=> (lambda (level)
|
||||
(unless (and (exact-integer? level) (<= 0 level 9))
|
||||
(fail "Bad optimization level `~a'" level))
|
||||
(alist-cons 'optimization-level level
|
||||
(alist-delete 'optimization-level result))))
|
||||
((string-prefix? "no-" arg)
|
||||
(return-option (substring arg 3) #f))
|
||||
(else
|
||||
|
|
@ -141,8 +152,10 @@ options."
|
|||
result)))
|
||||
|
||||
;; default option values
|
||||
'((input-files)
|
||||
`((input-files)
|
||||
(load-path)
|
||||
(warning-level . ,(default-warning-level))
|
||||
(optimization-level . ,(default-optimization-level))
|
||||
(warnings unsupported-warning))))
|
||||
|
||||
(define (show-version)
|
||||
|
|
@ -159,7 +172,9 @@ There is NO WARRANTY, to the extent permitted by law.~%"))
|
|||
(format #f "`~A'" (warning-type-name wt))
|
||||
(warning-type-description wt)))
|
||||
%warning-types)
|
||||
(format #t "~%"))
|
||||
(format #t "~%")
|
||||
(format #t "You may also specify warning levels as `-W0`, `-W1',~%")
|
||||
(format #t "`-W2', or `-W3'. The default is `-W1'.~%"))
|
||||
|
||||
(define (show-optimization-help)
|
||||
(format #t "The available optimizations are:~%~%")
|
||||
|
|
@ -184,6 +199,8 @@ There is NO WARRANTY, to the extent permitted by law.~%"))
|
|||
(define (compile . args)
|
||||
(let* ((options (parse-args args))
|
||||
(help? (assoc-ref options 'help?))
|
||||
(warning-level (assoc-ref options 'warning-level))
|
||||
(optimization-level (assoc-ref options 'optimization-level))
|
||||
(compile-opts `(#:warnings
|
||||
,(assoc-ref options 'warnings)
|
||||
,@(append-map
|
||||
|
|
@ -233,21 +250,20 @@ Report bugs to <~A>.~%"
|
|||
(when (assoc-ref options 'install-r7rs?)
|
||||
(install-r7rs!))
|
||||
|
||||
;; Load FROM and TO before we have changed the load path. That way, when
|
||||
;; cross-compiling Guile itself, we can be sure we're loading our own
|
||||
;; language modules and not those of the Guile being compiled, which may
|
||||
;; have incompatible .go files.
|
||||
(lookup-language from)
|
||||
(lookup-language to)
|
||||
;; Compute a compiler before changing the load path, for its side
|
||||
;; effects of loading compiler modules. That way, when
|
||||
;; cross-compiling Guile itself, we can be sure we're loading our
|
||||
;; own language modules and not those of the Guile being compiled,
|
||||
;; which may have incompatible .go files.
|
||||
(compute-compiler from to optimization-level warning-level compile-opts)
|
||||
|
||||
(set! %load-path (append load-path %load-path))
|
||||
(set! %load-should-auto-compile #f)
|
||||
|
||||
(if (and output-file
|
||||
(or (null? input-files)
|
||||
(not (null? (cdr input-files)))))
|
||||
(fail "`-o' option can only be specified "
|
||||
"when compiling a single file"))
|
||||
(when (and output-file
|
||||
(or (null? input-files)
|
||||
(not (null? (cdr input-files)))))
|
||||
(fail "`-o' option can only be specified when compiling a single file"))
|
||||
|
||||
;; Install a SIGINT handler. As a side effect, this gives unwind
|
||||
;; handlers an opportunity to run upon SIGINT; this includes that of
|
||||
|
|
@ -262,11 +278,14 @@ Report bugs to <~A>.~%"
|
|||
(with-fluids ((*current-warning-prefix* ""))
|
||||
(with-target target
|
||||
(lambda ()
|
||||
(compile-file file
|
||||
#:output-file output-file
|
||||
#:from from
|
||||
#:to to
|
||||
#:opts compile-opts))))))
|
||||
(compile-file
|
||||
file
|
||||
#:output-file output-file
|
||||
#:from from
|
||||
#:to to
|
||||
#:warning-level warning-level
|
||||
#:optimization-level optimization-level
|
||||
#:opts compile-opts))))))
|
||||
input-files)))
|
||||
|
||||
(define main compile)
|
||||
|
|
|
|||
|
|
@ -1,39 +1,49 @@
|
|||
;;; High-level compiler interface
|
||||
|
||||
;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2001,2005,2008-2013,2016,2020 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 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.
|
||||
;;; 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
|
||||
;;; You should have received a copy of the GNU Lesser General Public License
|
||||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (system base compile)
|
||||
#:use-module (system base syntax)
|
||||
#:use-module (system base language)
|
||||
#:use-module (system base message)
|
||||
#:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (ice-9 optargs)
|
||||
#:use-module (ice-9 receive)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:export (compiled-file-name
|
||||
compile-file
|
||||
compile-and-load
|
||||
compute-compiler
|
||||
read-and-compile
|
||||
compile
|
||||
decompile))
|
||||
decompile
|
||||
default-warning-level
|
||||
default-optimization-level))
|
||||
|
||||
|
||||
(define (level-validator x)
|
||||
(unless (and (exact-integer? x) (<= 0 x 9))
|
||||
(error
|
||||
"bad warning or optimization level: expected integer between 0 and 9"
|
||||
x))
|
||||
x)
|
||||
|
||||
(define default-warning-level (make-parameter 1 level-validator))
|
||||
(define default-optimization-level (make-parameter 2 level-validator))
|
||||
|
||||
;;;
|
||||
;;; Compiler
|
||||
;;;
|
||||
|
|
@ -42,8 +52,8 @@
|
|||
(let ((entered #f))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(if entered
|
||||
(error "thunk may only be entered once: ~a" thunk))
|
||||
(when entered
|
||||
(error "thunk may only be entered once: ~a" thunk))
|
||||
(set! entered #t))
|
||||
thunk
|
||||
(lambda () #t))))
|
||||
|
|
@ -132,13 +142,38 @@
|
|||
(and (false-if-exception (ensure-directory (dirname f)))
|
||||
f))))
|
||||
|
||||
(define (validate-options opts)
|
||||
(define (validate-warnings warnings)
|
||||
(match warnings
|
||||
(() (values))
|
||||
((w . warnings)
|
||||
(unless (lookup-warning-type w)
|
||||
(warning 'unsupported-warning #f w))
|
||||
(validate-warnings warnings))))
|
||||
(match opts
|
||||
(() (values))
|
||||
((kw arg . opts)
|
||||
(match kw
|
||||
(#:warnings (validate-warnings arg))
|
||||
((? keyword?) (values))
|
||||
(_
|
||||
;; Programming error.
|
||||
(warn "malformed options list: not a keyword" kw)))
|
||||
(validate-options opts))
|
||||
(_
|
||||
;; Programming error.
|
||||
(warn "malformed options list: expected keyword and arg pair" opts))))
|
||||
|
||||
(define* (compile-file file #:key
|
||||
(output-file #f)
|
||||
(from (current-language))
|
||||
(to 'bytecode)
|
||||
(env (default-environment from))
|
||||
(optimization-level (default-optimization-level))
|
||||
(warning-level (default-warning-level))
|
||||
(opts '())
|
||||
(canonicalization 'relative))
|
||||
(validate-options opts)
|
||||
(with-fluids ((%file-port-name-canonicalization canonicalization))
|
||||
(let* ((comp (or output-file (compiled-file-name file)
|
||||
(error "failed to create path for auto-compiled file"
|
||||
|
|
@ -152,18 +187,26 @@
|
|||
(call-with-output-file/atomic comp
|
||||
(lambda (port)
|
||||
((language-printer (ensure-language to))
|
||||
(read-and-compile in #:env env #:from from #:to to #:opts
|
||||
(cons* #:to-file? #t opts))
|
||||
(read-and-compile in #:env env #:from from #:to to
|
||||
#:optimization-level optimization-level
|
||||
#:warning-level warning-level
|
||||
#:opts (cons* #:to-file? #t opts))
|
||||
port))
|
||||
file)
|
||||
comp)))
|
||||
|
||||
(define* (compile-and-load file #:key (from (current-language)) (to 'value)
|
||||
(env (current-module)) (opts '())
|
||||
(env (current-module))
|
||||
(optimization-level (default-optimization-level))
|
||||
(warning-level (default-warning-level))
|
||||
(opts '())
|
||||
(canonicalization 'relative))
|
||||
(validate-options opts)
|
||||
(with-fluids ((%file-port-name-canonicalization canonicalization))
|
||||
(read-and-compile (open-input-file file)
|
||||
#:from from #:to to #:opts opts
|
||||
#:optimization-level optimization-level
|
||||
#:warning-level warning-level
|
||||
#:env env)))
|
||||
|
||||
|
||||
|
|
@ -171,34 +214,79 @@
|
|||
;;; Compiler interface
|
||||
;;;
|
||||
|
||||
(define (compile-passes from to opts)
|
||||
(map cdr
|
||||
(or (lookup-compilation-order from to)
|
||||
(error "no way to compile" from "to" to))))
|
||||
(define (compute-analyzer lang warning-level opts)
|
||||
(level-validator warning-level)
|
||||
(match (language-analyzer lang)
|
||||
(#f (lambda (exp env) (values)))
|
||||
(proc (proc warning-level
|
||||
(let lp ((opts opts))
|
||||
(match opts
|
||||
(() '())
|
||||
((#:warnings warnings . _) warnings)
|
||||
((_ _ . opts) (lp opts))))))))
|
||||
|
||||
(define (compile-fold passes exp env opts)
|
||||
(let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
|
||||
(if (null? passes)
|
||||
(values x e cenv)
|
||||
(receive (x e new-cenv) ((car passes) x e opts)
|
||||
(lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
|
||||
(define (compute-lowerer lang optimization-level opts)
|
||||
(level-validator optimization-level)
|
||||
(match (language-lowerer lang)
|
||||
(#f (lambda (exp env) exp))
|
||||
(proc (proc optimization-level opts))))
|
||||
|
||||
(define (find-language-joint from to)
|
||||
(let lp ((in (reverse (or (lookup-compilation-order from to)
|
||||
(error "no way to compile" from "to" to))))
|
||||
(lang to))
|
||||
(cond ((null? in) to)
|
||||
((language-joiner lang) lang)
|
||||
(else
|
||||
(lp (cdr in) (caar in))))))
|
||||
(define (next-pass from lang to optimization-level opts)
|
||||
(if (eq? lang to)
|
||||
#f ;; Done.
|
||||
(match (language-compilers lang)
|
||||
(((name . pass))
|
||||
(cons (lookup-language name) pass))
|
||||
(compilers
|
||||
(let ((chooser (language-compiler-chooser lang)))
|
||||
(unless chooser
|
||||
(if (null? compilers)
|
||||
(error "no way to compile" from "to" to)
|
||||
(error "multiple compilers; language should supply chooser")))
|
||||
(match (chooser to optimization-level opts)
|
||||
((name . pass)
|
||||
(cons (lookup-language name) pass))))))))
|
||||
|
||||
(define (compute-compiler from to optimization-level warning-level opts)
|
||||
(let ((from (ensure-language from))
|
||||
(to (ensure-language to)))
|
||||
(let lp ((lang from))
|
||||
(match (next-pass from lang to optimization-level opts)
|
||||
(#f (lambda (exp env) (values exp env env)))
|
||||
((next . pass)
|
||||
(let* ((analyze (compute-analyzer lang warning-level opts))
|
||||
(lower (compute-lowerer lang optimization-level opts))
|
||||
(compile (lambda (exp env)
|
||||
(analyze exp env)
|
||||
(pass (lower exp env) env opts)))
|
||||
(tail (lp next)))
|
||||
(lambda (exp env)
|
||||
(let*-values (((exp env cenv) (compile exp env))
|
||||
((exp env cenv*) (tail exp env)))
|
||||
;; Return continuation environment from first pass, to
|
||||
;; compile an additional expression in the same compilation
|
||||
;; unit.
|
||||
(values exp env cenv)))))))))
|
||||
|
||||
(define (find-language-joint from to optimization-level opts)
|
||||
(let ((from (ensure-language from))
|
||||
(to (ensure-language to)))
|
||||
(let lp ((lang from))
|
||||
(match (next-pass from lang to optimization-level opts)
|
||||
(#f #f)
|
||||
((next . pass)
|
||||
(or (lp next)
|
||||
(and (language-joiner next)
|
||||
next)))))))
|
||||
|
||||
(define (default-language-joiner lang)
|
||||
(lambda (exps env)
|
||||
(if (and (pair? exps) (null? (cdr exps)))
|
||||
(car exps)
|
||||
(error
|
||||
"Multiple expressions read and compiled, but language has no joiner"
|
||||
lang))))
|
||||
(match exps
|
||||
((exp) exp)
|
||||
(_
|
||||
(error
|
||||
"Multiple expressions read and compiled, but language has no joiner"
|
||||
lang)))))
|
||||
|
||||
(define (read-and-parse lang port cenv)
|
||||
(let ((exp ((language-reader lang) port cenv)))
|
||||
|
|
@ -211,49 +299,54 @@
|
|||
(from (current-language))
|
||||
(to 'bytecode)
|
||||
(env (default-environment from))
|
||||
(optimization-level (default-optimization-level))
|
||||
(warning-level (default-warning-level))
|
||||
(opts '()))
|
||||
(let ((from (ensure-language from))
|
||||
(to (ensure-language to)))
|
||||
(let ((joint (find-language-joint from to)))
|
||||
(parameterize ((current-language from))
|
||||
(let lp ((exps '()) (env #f) (cenv env))
|
||||
(let ((x (read-and-parse (current-language) port cenv)))
|
||||
(cond
|
||||
((eof-object? x)
|
||||
(close-port port)
|
||||
(compile ((or (language-joiner joint)
|
||||
(default-language-joiner joint))
|
||||
(reverse exps)
|
||||
env)
|
||||
#:from joint #:to to
|
||||
;; env can be false if no expressions were read.
|
||||
#:env (or env (default-environment joint))
|
||||
#:opts opts))
|
||||
(else
|
||||
;; compile-fold instead of compile so we get the env too
|
||||
(receive (jexp jenv jcenv)
|
||||
(compile-fold (compile-passes (current-language) joint opts)
|
||||
x cenv opts)
|
||||
(lp (cons jexp exps) jenv jcenv))))))))))
|
||||
(let* ((from (ensure-language from))
|
||||
(to (ensure-language to))
|
||||
(joint (find-language-joint from to optimization-level opts)))
|
||||
(parameterize ((current-language from))
|
||||
(let lp ((exps '()) (env #f) (cenv env) (from #f) (compile1 #f))
|
||||
(match (read-and-parse (current-language) port cenv)
|
||||
((? eof-object?)
|
||||
(close-port port)
|
||||
(compile ((or (language-joiner joint)
|
||||
(default-language-joiner joint))
|
||||
(reverse exps)
|
||||
env)
|
||||
#:from joint #:to to
|
||||
;; env can be false if no expressions were read.
|
||||
#:env (or env (default-environment joint))
|
||||
#:optimization-level optimization-level
|
||||
#:warning-level warning-level
|
||||
#:opts opts))
|
||||
(exp
|
||||
(let with-compiler ((from from) (compile1 compile1))
|
||||
(cond
|
||||
((eq? from (current-language))
|
||||
(receive (exp env cenv) (compile1 exp cenv)
|
||||
(lp (cons exp exps) env cenv from compile1)))
|
||||
(else
|
||||
;; compute-compiler instead of compile so we get the
|
||||
;; env too.
|
||||
(let ((from (current-language)))
|
||||
(with-compiler
|
||||
from
|
||||
(compute-compiler from joint optimization-level
|
||||
warning-level opts))))))))))))
|
||||
|
||||
(define* (compile x #:key
|
||||
(from (current-language))
|
||||
(to 'value)
|
||||
(env (default-environment from))
|
||||
(optimization-level (default-optimization-level))
|
||||
(warning-level (default-warning-level))
|
||||
(opts '()))
|
||||
|
||||
(let ((warnings (memq #:warnings opts)))
|
||||
(if (pair? warnings)
|
||||
(let ((warnings (cadr warnings)))
|
||||
;; Sanity-check the requested warnings.
|
||||
(for-each (lambda (w)
|
||||
(or (lookup-warning-type w)
|
||||
(warning 'unsupported-warning #f w)))
|
||||
warnings))))
|
||||
|
||||
(receive (exp env cenv)
|
||||
(compile-fold (compile-passes from to opts) x env opts)
|
||||
exp))
|
||||
(validate-options opts)
|
||||
(let ((compile1 (compute-compiler from to optimization-level
|
||||
warning-level opts)))
|
||||
(receive (exp env cenv) (compile1 x env)
|
||||
exp)))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -261,15 +354,16 @@
|
|||
;;;
|
||||
|
||||
(define (decompile-passes from to opts)
|
||||
(map cdr
|
||||
(or (lookup-decompilation-order from to)
|
||||
(error "no way to decompile" from "to" to))))
|
||||
(match (lookup-decompilation-order from to)
|
||||
(((langs . passes) ...) passes)
|
||||
(_ (error "no way to decompile" from "to" to))))
|
||||
|
||||
(define (decompile-fold passes exp env opts)
|
||||
(if (null? passes)
|
||||
(values exp env)
|
||||
(receive (exp env) ((car passes) exp env opts)
|
||||
(decompile-fold (cdr passes) exp env opts))))
|
||||
(match passes
|
||||
(() (values exp env))
|
||||
((pass . passes)
|
||||
(receive (exp env) (pass exp env opts)
|
||||
(decompile-fold passes exp env opts)))))
|
||||
|
||||
(define* (decompile x #:key
|
||||
(env #f)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Multi-language support
|
||||
|
||||
;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2001,2005,2008-2011,2013,2020 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
|
||||
|
|
@ -27,11 +27,11 @@
|
|||
language-compilers language-decompilers language-evaluator
|
||||
language-joiner language-for-humans?
|
||||
language-make-default-environment
|
||||
language-lowerer language-analyzer
|
||||
language-compiler-chooser
|
||||
|
||||
lookup-compilation-order lookup-decompilation-order
|
||||
invalidate-compilation-cache! default-environment
|
||||
|
||||
*current-language*)
|
||||
default-environment)
|
||||
|
||||
#:re-export (current-language))
|
||||
|
||||
|
|
@ -51,12 +51,13 @@
|
|||
(evaluator #f)
|
||||
(joiner #f)
|
||||
(for-humans? #t)
|
||||
(make-default-environment make-fresh-user-module))
|
||||
(make-default-environment make-fresh-user-module)
|
||||
(lowerer #f)
|
||||
(analyzer #f)
|
||||
(compiler-chooser #f))
|
||||
|
||||
(define-macro (define-language name . spec)
|
||||
`(begin
|
||||
(invalidate-compilation-cache!)
|
||||
(define ,name (make-language #:name ',name ,@spec))))
|
||||
(define-syntax-rule (define-language name . spec)
|
||||
(define name (make-language #:name 'name . spec)))
|
||||
|
||||
(define (lookup-language name)
|
||||
(let ((m (resolve-module `(language ,name spec))))
|
||||
|
|
@ -64,12 +65,11 @@
|
|||
(module-ref m name)
|
||||
(error "no such language" name))))
|
||||
|
||||
(define *compilation-cache* '())
|
||||
(define *decompilation-cache* '())
|
||||
|
||||
(define (invalidate-compilation-cache!)
|
||||
(set! *decompilation-cache* '())
|
||||
(set! *compilation-cache* '()))
|
||||
(begin-deprecated
|
||||
(define-public (invalidate-compilation-cache!)
|
||||
(issue-deprecation-warning
|
||||
"invalidate-compilation-cache is deprecated; recompile your modules")
|
||||
(values)))
|
||||
|
||||
(define (compute-translation-order from to language-translators)
|
||||
(cond
|
||||
|
|
@ -87,22 +87,11 @@
|
|||
(language-translators from))))))))
|
||||
|
||||
(define (lookup-compilation-order from to)
|
||||
(let ((key (cons from to)))
|
||||
(or (assoc-ref *compilation-cache* key)
|
||||
(let ((order (compute-translation-order from to language-compilers)))
|
||||
(set! *compilation-cache*
|
||||
(acons key order *compilation-cache*))
|
||||
order))))
|
||||
(compute-translation-order from to language-compilers))
|
||||
|
||||
(define (lookup-decompilation-order from to)
|
||||
(let ((key (cons from to)))
|
||||
(or (assoc-ref *decompilation-cache* key)
|
||||
;; trickery!
|
||||
(let ((order (and=>
|
||||
(compute-translation-order to from language-decompilers)
|
||||
reverse!)))
|
||||
(set! *decompilation-cache* (acons key order *decompilation-cache*))
|
||||
order))))
|
||||
(and=> (compute-translation-order to from language-decompilers)
|
||||
reverse!))
|
||||
|
||||
(define (default-environment lang)
|
||||
"Return the default compilation environment for source language LANG."
|
||||
|
|
@ -116,4 +105,5 @@
|
|||
;;;
|
||||
|
||||
;; Deprecated; use current-language instead.
|
||||
(define *current-language* (parameter-fluid current-language))
|
||||
(begin-deprecated
|
||||
(define-public *current-language* (parameter-fluid current-language)))
|
||||
|
|
|
|||
|
|
@ -1,20 +1,19 @@
|
|||
;;; User interface messages
|
||||
|
||||
;; Copyright (C) 2009, 2010, 2011, 2012, 2018 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2009-2012,2016,2018,2020 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 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.
|
||||
;;; 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
|
||||
;;; You should have received a copy of the GNU Lesser General Public License
|
||||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
|
|
@ -234,5 +233,3 @@ property alist) using the data in ARGS."
|
|||
args)
|
||||
(format port "~A: unknown warning type `~A': ~A~%"
|
||||
(location-string location) type args))))
|
||||
|
||||
;;; message.scm ends here
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Optimization flags
|
||||
|
||||
;; Copyright (C) 2018 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2018, 2020 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
|
||||
|
|
@ -19,15 +19,49 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (system base optimize)
|
||||
#:use-module (language tree-il optimize)
|
||||
#:use-module (language cps optimize)
|
||||
#:use-module (ice-9 match)
|
||||
#:export (available-optimizations
|
||||
pass-optimization-level
|
||||
optimizations-for-level))
|
||||
|
||||
(define (available-optimizations)
|
||||
(append (tree-il-optimizations) (cps-optimizations)))
|
||||
(define* (available-optimizations #:optional lang-name)
|
||||
(match lang-name
|
||||
('tree-il
|
||||
;; Avoid resolve-primitives until -O2, when CPS optimizations kick in.
|
||||
;; Otherwise, inlining the primcalls during Tree-IL->CPS compilation
|
||||
;; will result in a lot of code that will never get optimized nicely.
|
||||
;; Similarly letrectification is great for generated code quality, but
|
||||
;; as it gives the compiler more to work with, it increases compile
|
||||
;; time enough that we reserve it for -O2. Also, this makes -O1 avoid
|
||||
;; assumptions about top-level values, in the same way that avoiding
|
||||
;; resolve-primitives does.
|
||||
'((#:cps? 1)
|
||||
(#:resolve-primitives? 2)
|
||||
(#:expand-primitives? 1)
|
||||
(#:letrectify? 2)
|
||||
(#:seal-private-bindings? 3)
|
||||
(#:partial-eval? 1)
|
||||
(#:eta-expand? 2)))
|
||||
('cps
|
||||
'( ;; (#:split-rec? #t)
|
||||
(#:simplify? 2)
|
||||
(#:eliminate-dead-code? 2)
|
||||
(#:prune-top-level-scopes? 2)
|
||||
(#:contify? 2)
|
||||
(#:specialize-primcalls? 2)
|
||||
(#:peel-loops? 2)
|
||||
(#:cse? 2)
|
||||
(#:type-fold? 2)
|
||||
(#:resolve-self-references? 2)
|
||||
(#:devirtualize-integers? 2)
|
||||
(#:specialize-numbers? 2)
|
||||
(#:licm? 2)
|
||||
(#:rotate-loops? 2)
|
||||
;; This one is used by the slot allocator.
|
||||
(#:precolor-calls? 2)))
|
||||
(#f
|
||||
(append (available-optimizations 'tree-il)
|
||||
(available-optimizations 'cps)))))
|
||||
|
||||
(define (pass-optimization-level kw)
|
||||
(match (assq kw (available-optimizations))
|
||||
|
|
|
|||
|
|
@ -256,7 +256,9 @@
|
|||
emit-lsh/immediate
|
||||
emit-rsh/immediate
|
||||
emit-resolve-module
|
||||
emit-module-variable
|
||||
emit-lookup
|
||||
emit-lookup-bound
|
||||
emit-define!
|
||||
emit-current-module
|
||||
|
||||
|
|
@ -973,6 +975,15 @@ later by the linker."
|
|||
(emit-push asm (+ c 2))
|
||||
(encode-X8_S8_S8_S8-C32 asm 2 1 0 c32 opcode)
|
||||
(emit-drop asm 3))))
|
||||
(define (encode-X8_S8_C8_S8-C32!/shuffle asm a const b c32 opcode)
|
||||
(cond
|
||||
((< (logior a b) (ash 1 8))
|
||||
(encode-X8_S8_C8_S8-C32 asm a const b c32 opcode))
|
||||
(else
|
||||
(emit-push asm a)
|
||||
(emit-push asm (+ b 1))
|
||||
(encode-X8_S8_C8_S8-C32 asm 1 const 0 c32 opcode)
|
||||
(emit-drop asm 2))))
|
||||
(define (encode-X8_S12_S12-C32<-/shuffle asm dst src c32 opcode)
|
||||
(cond
|
||||
((< (logior dst src) (ash 1 12))
|
||||
|
|
@ -1009,9 +1020,9 @@ later by the linker."
|
|||
(('<- 'X8_S8_S8_S8) #'encode-X8_S8_S8_S8<-/shuffle)
|
||||
(('<- 'X8_S8_S8_C8) #'encode-X8_S8_S8_C8<-/shuffle)
|
||||
(('! 'X8_S8_S8_S8 'C32) #'encode-X8_S8_S8_S8-C32!/shuffle)
|
||||
(('! 'X8_S8_C8_S8 'C32) #'encode-X8_S8_C8_S8-C32!/shuffle)
|
||||
(('<- 'X8_S8_S8_S8 'C32) #'encode-X8_S8_S8_S8-C32<-/shuffle)
|
||||
(('<- 'X8_S8_S8_C8 'C32) #'encode-X8_S8_S8_C8-C32<-/shuffle)
|
||||
(('! 'X8_S8_S8_C8 'C32) #'encode-X8_S8_S8_C8-C32!/shuffle)
|
||||
(('<- 'X8_S12_S12 'C32) #'encode-X8_S12_S12-C32<-/shuffle)
|
||||
(('! 'X8_S12_S12 'C32) #'encode-X8_S12_S12-C32!/shuffle)
|
||||
(('! 'X8_S8_C8_S8) #'encode-X8_S8_C8_S8!/shuffle)
|
||||
|
|
@ -1493,7 +1504,9 @@ returned instead."
|
|||
(define-scm<-scm-uimm-intrinsic lsh/immediate)
|
||||
(define-scm<-scm-uimm-intrinsic rsh/immediate)
|
||||
(define-scm<-scm-bool-intrinsic resolve-module)
|
||||
(define-scm<-scm-scm-intrinsic module-variable)
|
||||
(define-scm<-scm-scm-intrinsic lookup)
|
||||
(define-scm<-scm-scm-intrinsic lookup-bound)
|
||||
(define-scm<-scm-scm-intrinsic define!)
|
||||
(define-scm<-thread-intrinsic current-module)
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue