diff options
Diffstat (limited to 'module/language')
-rw-r--r-- | module/language/cps/cse.scm | 8 | ||||
-rw-r--r-- | module/language/cps/dump.scm | 317 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 81 | ||||
-rw-r--r-- | module/language/cps/graphs.scm | 88 | ||||
-rw-r--r-- | module/language/cps/slot-allocation.scm | 214 | ||||
-rw-r--r-- | module/language/cps/types.scm | 2 | ||||
-rw-r--r-- | module/language/cps/utils.scm | 174 | ||||
-rw-r--r-- | module/language/tree-il/compile-bytecode.scm | 6 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 11 | ||||
-rw-r--r-- | module/language/tree-il/inlinable-exports.scm | 869 | ||||
-rw-r--r-- | module/language/tree-il/letrectify.scm | 20 | ||||
-rw-r--r-- | module/language/tree-il/optimize.scm | 11 | ||||
-rw-r--r-- | module/language/tree-il/peval.scm | 192 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 3 | ||||
-rw-r--r-- | module/language/tree-il/resolve-free-vars.scm | 282 |
15 files changed, 1952 insertions, 326 deletions
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 55cf5490e..3c67a043a 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -360,9 +360,9 @@ for a label, it isn't known to be constant at that label." (_ bool)) (match (and (< pred succ) (intmap-ref out pred)) (($ $kargs _ _ ($ $branch kf kt src 'eq-constant? c (v))) - (if (eqv? kt succ) - (adjoin-constant consts v c) - consts)) + (if (eqv? kf succ) + consts + (adjoin-constant consts v c))) (_ consts))))))) (define (propagate-analysis analysis label out) @@ -735,7 +735,7 @@ for a label, it isn't known to be constant at that label." ;; post-order, so the intmap-fold will visit definitions before ;; uses. (let* ((effects (synthesize-definition-effects (compute-effects conts))) - (clobbers (compute-clobber-map effects)) + (clobbers (compute-clobber-map conts effects)) (succs (compute-successors conts kfun)) (preds (invert-graph succs)) (avail (compute-available-expressions succs kfun clobbers)) diff --git a/module/language/cps/dump.scm b/module/language/cps/dump.scm new file mode 100644 index 000000000..d5217fe23 --- /dev/null +++ b/module/language/cps/dump.scm @@ -0,0 +1,317 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019, 2020, 2021 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Helper facilities for working with CPS. +;;; +;;; Code: + +(define-module (language cps dump) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (language cps) + #:use-module (language cps intset) + #:use-module (language cps intmap) + #:use-module (language cps graphs) + #:use-module (language cps utils) + #:export (dump)) + +;; ideas: unused vars print as _ +;; print all labels +;; call bb headers with values +;; annotate blocks with available bindings? live bindings? +;; how to print calls... +;; dot graph + +(define (cont-successors cont) + (match cont + (($ $kargs _ _ term) + (match term + (($ $continue k) (list k)) + (($ $branch kf kt) (list kf kt)) + (($ $switch kf kt*) (cons kf kt*)) + (($ $prompt k kh) (list k kh)) + (($ $throw) '()))) + (($ $kclause _ kbody kalternate) + (if kalternate + (list kbody kalternate) + (list kbody))) + (($ $kfun src meta self ktail kentry) + (list ktail kentry)) + (($ $kreceive arity kargs) (list kargs)) + (($ $ktail) '()))) + +(define (compute-block-entries cps kfun body all-labels?) + (if all-labels? + body + (let ((preds (compute-predecessors cps kfun #:labels body))) + ;; Conts whose predecessor count is not 1 start blocks. + (define (add-entry label blocks) + (match (intmap-ref preds label) + ((_) blocks) + (_ (intset-add! blocks label)))) + ;; Continuations of branches start blocks. + (define (add-exits label blocks) + (fold1 (lambda (succ blocks) + (intset-add! blocks succ)) + (match (cont-successors (intmap-ref cps label)) + ((_) '()) + (succs succs)) + blocks)) + (persistent-intset + (intset-fold + (lambda (label blocks) + (add-exits label (add-entry label blocks))) + body + empty-intset))))) + +(define (collect-blocks cps entries) + (define (collect-block entry) + (let ((cont (intmap-ref cps entry))) + (acons entry cont + (match (cont-successors (intmap-ref cps entry)) + ((succ) + (if (intset-ref entries succ) + '() + (collect-block succ))) + (_ '()))))) + (persistent-intmap + (intset-fold + (lambda (start blocks) + (intmap-add! blocks start (collect-block start))) + entries + empty-intmap))) + +(define (compute-block-succs blocks) + (intmap-map (lambda (entry conts) + (match conts + (((_ . _) ... (exit . cont)) + (fold1 (lambda (succ succs) + (intset-add succs succ)) + (cont-successors cont) + empty-intset)))) + blocks)) + +(define (dump-block cps port labelled-conts) + (define (format-label label) (format #f "L~a" label)) + (define (format-name name) (if name (symbol->string name) "_")) + (define (format-var var) (format #f "v~a" var)) + (define (format-loc src) + (and src + (format #f "~a:~a:~a" + (or (assq-ref src 'filename) "<unknown>") + (1+ (assq-ref src 'line)) + (assq-ref src 'column)))) + (define (arg-list strs) (string-join strs ", ")) + (define (false-if-empty str) (if (string-null? str) #f str)) + (define (format-arity arity) + (match arity + (($ $arity req opt rest kw aok?) + (arg-list + `(,@(map format-name req) + ,@(map (lambda (name) + (format #f "[~a]" (format-name name))) + opt) + ,@(map (match-lambda + ((kw name var) + (format #f "~a" kw))) + kw) + ,@(if aok? '("[#:allow-other-keys]") '()) + ,@(if rest + (list (string-append (format-name rest) "...")) + '())))))) + (define (format-primcall op param args) + (format #f "~a~@[[~s]~](~a)" op param (arg-list (map format-var args)))) + (define (format-exp exp) + (match exp + (($ $const val) + (format #f "const ~s" val)) + (($ $prim name) + (format #f "prim ~s" name)) + (($ $fun body) + (format #f "fun ~a" (format-label body))) + (($ $rec names syms funs) + (format #f "rec(~a)" (arg-list (map format-exp funs)))) + (($ $const-fun label) + (format #f "const-fun ~a" (format-label label))) + (($ $code label) + (format #f "code ~a" (format-label label))) + (($ $call proc args) + (format #f "call ~a(~a)" + (format-var proc) (arg-list (map format-var args)))) + (($ $callk k proc args) + (format #f "callk ~a(~a)" (format-label k) + (arg-list + (cons (if proc (format-var proc) "_") + (map format-var args))))) + (($ $primcall name param args) + (format-primcall name param args)) + (($ $values args) + (arg-list (map format-var args))))) + (define (dump-annotation ann src) + (when (or ann src) + (format port "~45t ; ~@[~a ~]" ann) + (when src + (let* ((src (format-loc src)) + (col (- 80 4 (string-length src)))) + (format port "~vt at ~a" col src)))) + (newline port)) + (define (dump-definition src names vars fmt . args) + (define (take formatter val) + (cond + ((not val) #f) + ((string? val) (false-if-empty val)) + ((null? val) #f) + (else (arg-list (map formatter val))))) + (let ((names (take format-name names)) + (vars (take format-var vars))) + (format port " ~@[~a := ~]~?" vars fmt args) + (dump-annotation names src))) + (define (dump-statement src ann fmt . args) + (format port " ~?" fmt args) + (dump-annotation (and ann (false-if-empty ann)) src)) + (define (dump-block-header label cont) + (match cont + (($ $kargs names vars) + (format port "~a(~a):" + (format-label label) + (arg-list (map format-var vars))) + (dump-annotation (false-if-empty (arg-list (map format-name names))) + #f)) + (($ $ktail) + (values)) + (($ $kfun src meta self ktail kentry) + (let ((name (assq-ref meta 'name))) + (format port "~a:" (format-label label)) + (dump-annotation name src))) + ((or ($ $kreceive) ($ $kclause)) + (format port "~a:\n" (format-label label))))) + (define (dump-block-body label cont) + (match cont + (($ $kargs _ _ ($ $continue k src exp)) + (match (intmap-ref cps k) + (($ $kargs names vars) + (dump-definition src names vars "~a" (format-exp exp))) + (_ + (dump-definition src #f #f "~a" (format-exp exp))))) + (($ $kreceive arity kargs) + (match (intmap-ref cps kargs) + (($ $kargs names vars) + (dump-definition #f names vars + "receive(~a)" (format-arity arity))))) + (($ $ktail) + (values)) + (($ $kclause arity kbody #f) + (match (intmap-ref cps kbody) + (($ $kargs names vars) + (dump-definition #f names vars + "receive(~a)" (format-arity arity))))))) + (define (dump-block-exit label cont) + (match cont + (($ $kargs _ _ term) + (match term + (($ $continue k src exp) + (match (intmap-ref cps k) + (($ $ktail) + (match exp + (($ $values vals) + (dump-statement src #f + "return ~a" (arg-list (map format-var vals)))) + (_ + (dump-statement src #f + "tail ~a" (format-exp exp))))) + (_ + (dump-statement src #f + "~a(~a)" (format-label k) (format-exp exp))))) + (($ $branch kf kt src op param args) + (dump-statement src #f + "~a ? ~a() : ~a()" + (format-primcall op param args) + (format-label kt) + (format-label kf))) + (($ $switch kf kt* src arg) + (dump-statement src #f + "[~a]~a() or ~a()" + (arg-list (map format-label kt*)) + (format-var arg) + (format-label kf))) + (($ $prompt k kh src escape? tag) + (dump-statement src #f + "~a(prompt(kh:~a,~a tag:~a)" + (format-label k) + (format-label kh) + (if escape? ", escape-only" "") + (format-var tag))) + (($ $throw src op param args) + (dump-statement src #f + "throw ~a" (format-primcall op param args))))) + (($ $kreceive arity kargs) + (dump-statement #f #f + "~a(receive(~a))" + (format-label kargs) + (format-arity arity))) + (($ $kfun src meta self ktail kentry) + (for-each (match-lambda + ((k . v) + (unless (eq? k 'name) + (format port " meta: ~a: ~s\n" k v)))) + meta) + ;; (format port " tail: ~a:\n" (format-label ktail)) + (when self + (format port " ~a := self\n" (format-var self))) + (format port " ~a(...)\n" (format-label kentry))) + (($ $kclause arity kbody kalt) + (dump-statement #f #f + "~a(receive(~a))~@[or ~a()~]\n" + (format-label kbody) + (format-arity arity) + (and=> kalt format-label))) + (($ $ktail) + (values)))) + (match labelled-conts + (((label . cont) . _) + (dump-block-header label cont))) + (let lp ((labelled-conts labelled-conts)) + (match labelled-conts + (((label . cont)) + (dump-block-exit label cont)) + (((label . cont) . labelled-conts) + (dump-block-body label cont) + (lp labelled-conts))))) + +(define (dump-function cps port kfun body all-labels?) + (define entries (compute-block-entries cps kfun body all-labels?)) + (define blocks (collect-blocks cps entries)) + (define block-succs (compute-block-succs blocks)) + (define block-order (compute-reverse-post-order block-succs kfun)) + (for-each (lambda (entry) + (dump-block cps port (intmap-ref blocks entry))) + block-order) + (values)) + +(define* (dump cps #:key + (port (current-output-port)) + (entry (intmap-next cps)) + (all-labels? #f)) + (let ((functions (compute-reachable-functions cps entry))) + (intmap-fold (lambda (kfun body) + (unless (eqv? kfun entry) (newline port)) + (dump-function cps port kfun body all-labels?)) + functions))) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 365c280c1..cdbc50159 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -221,7 +221,7 @@ (logior &all-effect-kinds (&object &unknown-memory-kinds)))) (define-inlinable (causes-effect? x effects) - (not (zero? (logand x effects)))) + (logtest x effects)) (define-inlinable (causes-all-effects? x) (eqv? x &all-effects)) @@ -238,13 +238,78 @@ is or might be a read or a write to the same location as A." ;; A negative field indicates "the whole object". ;; Non-negative fields indicate only part of the object. (or (< a 0) (< b 0) (= a b)))))) - (and (not (zero? (logand a &write))) - (not (zero? (logand b (logior &read &write)))) + (and (logtest a &write) + (logtest b (logior &read &write)) (locations-same?))) -(define (compute-clobber-map effects) +(define (compute-known-allocations conts effects) + "Return a map of ACCESS-LABEL to ALLOC-LABEL, indicating stores to and +loads from objects created at known allocation sites." + ;; VAR -> ALLOC map of defining allocations, where ALLOC is a label or + ;; #f. Possibly sparse. + (define allocations + (intmap-fold + (lambda (label fx out) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue k)) + (match (intmap-ref conts k) + (($ $kargs (_) (var)) + (intmap-add out var + (and (not (causes-all-effects? fx)) + (logtest fx &allocation) + label) + (lambda (old new) #f))) + (_ out))) + (_ out))) + effects empty-intmap)) + + (persistent-intmap + (intmap-fold + (lambda (label fx out) + (cond + ((causes-all-effects? fx) out) + ((logtest fx (logior &read &write)) + (match (intmap-ref conts label) + ;; Assume that instructions which cause a known set of effects + ;; and which + (($ $kargs names vars + ($ $continue k src + ($ $primcall name param (obj . args)))) + (match (intmap-ref allocations obj (lambda (_) #f)) + (#f out) + (allocation-label + (intmap-add! out label allocation-label)))) + (_ out))) + (else out))) + effects empty-intmap))) + +(define (compute-clobber-map conts effects) "For the map LABEL->EFFECTS, compute a map LABEL->LABELS indicating the LABELS that are clobbered by the effects of LABEL." + (define known-allocations (compute-known-allocations conts effects)) + (define (filter-may-alias write-label clobbered-labels) + ;; We may be able to remove some entries from CLOBBERED-LABELS, if + ;; we can prove they are not aliased by WRITE-LABEL. + (match (intmap-ref known-allocations write-label (lambda (_) #f)) + (#f + ;; We don't know what object WRITE-LABEL refers to; can't refine. + clobbered-labels) + (clobber-alloc + (intset-fold + (lambda (clobbered-label clobbered-labels) + (match (intmap-ref known-allocations clobbered-label (lambda (_) #f)) + (#f + ;; We don't know what object CLOBBERED-LABEL refers to; + ;; can't refine. + clobbered-labels) + (clobbered-alloc + ;; We know that WRITE-LABEL and CLOBBERED-LABEL refer to + ;; known allocations. The write will only clobber the read + ;; if the two allocations are the same. + (if (eqv? clobber-alloc clobbered-alloc) + clobbered-labels + (intset-remove clobbered-labels clobbered-label))))) + clobbered-labels clobbered-labels)))) (let ((clobbered-by-write (make-hash-table))) (intmap-fold (lambda (label fx) @@ -269,9 +334,11 @@ the LABELS that are clobbered by the effects of LABEL." effects) (intmap-map (lambda (label fx) (if (causes-effect? fx &write) - (hashv-ref clobbered-by-write - (ash fx (- &effect-kind-bits)) - empty-intset) + (filter-may-alias + label + (hashv-ref clobbered-by-write + (ash fx (- &effect-kind-bits)) + empty-intset)) empty-intset)) effects))) diff --git a/module/language/cps/graphs.scm b/module/language/cps/graphs.scm index 8be36c84d..abdca76c9 100644 --- a/module/language/cps/graphs.scm +++ b/module/language/cps/graphs.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013-2015, 2017-2020 Free Software Foundation, Inc. +;; Copyright (C) 2013-2015, 2017-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 @@ -23,6 +23,7 @@ ;;; Code: (define-module (language cps graphs) + #:use-module (ice-9 control) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (language cps intset) @@ -33,6 +34,7 @@ intmap-map intmap-keys invert-bijection invert-partition + rename-keys rename-intset rename-graph intset->intmap intmap-select worklist-fold @@ -43,7 +45,9 @@ compute-reverse-post-order compute-strongly-connected-components compute-sorted-strongly-connected-components - solve-flow-equations)) + compute-reverse-control-flow-order + solve-flow-equations + compute-live-variables)) (define-inlinable (fold1 f l s0) (let lp ((l l) (s0 s0)) @@ -162,6 +166,32 @@ intset of successors, return a graph SUCC->PRED...." succs (intmap-map (lambda (label _) empty-intset) succs))) +(define (rename-keys map old->new) + "Return a fresh intmap containing F(K) -> V for K and V in MAP, where +F is looking up K in the intmap OLD->NEW." + (persistent-intmap + (intmap-fold (lambda (k v out) + (intmap-add! out (intmap-ref old->new k) v)) + map + empty-intmap))) + +(define (rename-intset set old->new) + "Return a fresh intset of F(K) for K in SET, where F is looking up K +in the intmap OLD->NEW." + (intset-fold (lambda (old set) (intset-add set (intmap-ref old->new old))) + set empty-intset)) + +(define (rename-graph graph old->new) + "Return a fresh intmap containing F(K) -> intset(F(V)...) for K and +intset(V...) in GRAPH, where F is looking up K in the intmap OLD->NEW." + (persistent-intmap + (intmap-fold (lambda (pred succs out) + (intmap-add! out + (intmap-ref old->new pred) + (rename-intset succs old->new))) + graph + empty-intmap))) + (define (compute-strongly-connected-components succs start) "Given a LABEL->SUCCESSOR... graph, compute a SCC->LABEL... map partitioning the labels into strongly connected components (SCCs)." @@ -232,6 +262,37 @@ connected components in sorted order." (((? (lambda (id) (eqv? id start))) . ids) (map (lambda (id) (intmap-ref components id)) ids)))) +(define (compute-reverse-control-flow-order preds) + "Return a LABEL->ORDER bijection where ORDER is a contiguous set of +integers starting from 0 and incrementing in sort order. There is a +precondition that labels in PREDS are already renumbered in reverse post +order." + (define (has-back-edge? preds) + (let/ec return + (intmap-fold (lambda (label labels) + (intset-fold (lambda (pred) + (if (<= label pred) + (return #t) + (values))) + labels) + (values)) + preds) + #f)) + (if (has-back-edge? preds) + ;; This is more involved than forward control flow because not all + ;; live labels are reachable from the tail. + (persistent-intmap + (fold2 (lambda (component order n) + (intset-fold (lambda (label order n) + (values (intmap-add! order label n) + (1+ n))) + component order n)) + (reverse (compute-sorted-strongly-connected-components preds)) + empty-intmap 0)) + ;; Just reverse forward control flow. + (let ((max (intmap-prev preds))) + (intmap-map (lambda (label labels) (- max label)) preds)))) + (define (intset-pop set) (match (intset-next set) (#f (values set #f)) @@ -274,3 +335,26 @@ SUBTRACT, ADD, and MEET operates on that state." (run (intset-union worklist changed) in out))) (values (persistent-intmap in) (persistent-intmap out))))))) + +(define (compute-live-variables preds defs uses) + "Compute and return two values mapping LABEL->VAR..., where VAR... are +the definitions that are live before and after LABEL, as intsets." + (let* ((old->new (compute-reverse-control-flow-order preds)) + (init (persistent-intmap (intmap-fold + (lambda (old new init) + (intmap-add! init new empty-intset)) + old->new empty-intmap)))) + (call-with-values + (lambda () + (solve-flow-equations (rename-graph preds old->new) + init init + (rename-keys defs old->new) + (rename-keys uses old->new) + intset-subtract intset-union intset-union)) + (lambda (in out) + ;; As a reverse control-flow problem, the values flowing into a + ;; node are actually the live values after the node executes. + ;; Funny, innit? So we return them in the reverse order. + (let ((new->old (invert-bijection old->new))) + (values (rename-keys out new->old) + (rename-keys in new->old))))))) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index ff32e1ae1..253776769 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -30,6 +30,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (language cps) + #:use-module (language cps graphs) #:use-module (language cps utils) #:use-module (language cps intmap) #:use-module (language cps intset) @@ -121,94 +122,6 @@ (define (lookup-nlocals allocation) (allocation-frame-size allocation)) -(define-syntax-rule (persistent-intmap2 exp) - (call-with-values (lambda () exp) - (lambda (a b) - (values (persistent-intmap a) (persistent-intmap b))))) - -(define (compute-defs-and-uses cps) - "Return two LABEL->VAR... maps indicating values defined at and used -by a label, respectively." - (define (vars->intset vars) - (fold (lambda (var set) (intset-add set var)) empty-intset vars)) - (persistent-intmap2 - (intmap-fold - (lambda (label cont defs uses) - (define (get-defs k) - (match (intmap-ref cps k) - (($ $kargs names vars) (vars->intset vars)) - (_ empty-intset))) - (define (return d u) - (values (intmap-add! defs label d) - (intmap-add! uses label u))) - (match cont - (($ $kfun src meta self tail clause) - (return (intset-union - (if clause (get-defs clause) empty-intset) - (if self (intset self) empty-intset)) - empty-intset)) - (($ $kargs _ _ ($ $continue k src exp)) - (match exp - ((or ($ $const) ($ $const-fun) ($ $code)) - (return (get-defs k) empty-intset)) - (($ $call proc args) - (return (get-defs k) (intset-add (vars->intset args) proc))) - (($ $callk _ proc args) - (let ((args (vars->intset args))) - (return (get-defs k) (if proc (intset-add args proc) args)))) - (($ $primcall name param args) - (return (get-defs k) (vars->intset args))) - (($ $values args) - (return (get-defs k) (vars->intset args))))) - (($ $kargs _ _ ($ $branch kf kt src op param args)) - (return empty-intset (vars->intset args))) - (($ $kargs _ _ ($ $switch kf kt* src arg)) - (return empty-intset (intset arg))) - (($ $kargs _ _ ($ $prompt k kh src escape? tag)) - (return empty-intset (intset tag))) - (($ $kargs _ _ ($ $throw src op param args)) - (return empty-intset (vars->intset args))) - (($ $kclause arity body alt) - (return (get-defs body) empty-intset)) - (($ $kreceive arity kargs) - (return (get-defs kargs) empty-intset)) - (($ $ktail) - (return empty-intset empty-intset)))) - cps - empty-intmap - empty-intmap))) - -(define (compute-reverse-control-flow-order preds) - "Return a LABEL->ORDER bijection where ORDER is a contiguous set of -integers starting from 0 and incrementing in sort order. There is a -precondition that labels in PREDS are already renumbered in reverse post -order." - (define (has-back-edge? preds) - (let/ec return - (intmap-fold (lambda (label labels) - (intset-fold (lambda (pred) - (if (<= label pred) - (return #t) - (values))) - labels) - (values)) - preds) - #f)) - (if (has-back-edge? preds) - ;; This is more involved than forward control flow because not all - ;; live labels are reachable from the tail. - (persistent-intmap - (fold2 (lambda (component order n) - (intset-fold (lambda (label order n) - (values (intmap-add! order label n) - (1+ n))) - component order n)) - (reverse (compute-sorted-strongly-connected-components preds)) - empty-intmap 0)) - ;; Just reverse forward control flow. - (let ((max (intmap-prev preds))) - (intmap-map (lambda (label labels) (- max label)) preds)))) - (define* (add-prompt-control-flow-edges conts succs #:key complete?) "For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL + LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each @@ -272,51 +185,6 @@ body continuation in the prompt." conts succs)) -(define (rename-keys map old->new) - (persistent-intmap - (intmap-fold (lambda (k v out) - (intmap-add! out (intmap-ref old->new k) v)) - map - empty-intmap))) - -(define (rename-intset set old->new) - (intset-fold (lambda (old set) (intset-add set (intmap-ref old->new old))) - set empty-intset)) - -(define (rename-graph graph old->new) - (persistent-intmap - (intmap-fold (lambda (pred succs out) - (intmap-add! out - (intmap-ref old->new pred) - (rename-intset succs old->new))) - graph - empty-intmap))) - -(define (compute-live-variables cps defs uses) - "Compute and return two values mapping LABEL->VAR..., where VAR... are -the definitions that are live before and after LABEL, as intsets." - (let* ((succs (add-prompt-control-flow-edges cps (compute-successors cps))) - (preds (invert-graph succs)) - (old->new (compute-reverse-control-flow-order preds)) - (init (persistent-intmap (intmap-fold - (lambda (old new init) - (intmap-add! init new empty-intset)) - old->new empty-intmap)))) - (call-with-values - (lambda () - (solve-flow-equations (rename-graph preds old->new) - init init - (rename-keys defs old->new) - (rename-keys uses old->new) - intset-subtract intset-union intset-union)) - (lambda (in out) - ;; As a reverse control-flow problem, the values flowing into a - ;; node are actually the live values after the node executes. - ;; Funny, innit? So we return them in the reverse order. - (let ((new->old (invert-bijection old->new))) - (values (rename-keys out new->old) - (rename-keys in new->old))))))) - (define (compute-needs-slot cps defs uses) (define (get-defs k) (intmap-ref defs k)) (define (get-uses label) (intmap-ref uses label)) @@ -746,84 +614,14 @@ are comparable with eqv?. A tmp slot may be used." (persistent-intmap (intmap-fold-right allocate-lazy cps slots))) -(define (compute-var-representations cps) - (define (get-defs k) - (match (intmap-ref cps k) - (($ $kargs names vars) vars) - (_ '()))) - (intmap-fold - (lambda (label cont representations) - (match cont - (($ $kargs _ _ ($ $continue k _ exp)) - (match (get-defs k) - (() representations) - ((var) - (match exp - (($ $values (arg)) - (intmap-add representations var - (intmap-ref representations arg))) - (($ $primcall (or 'scm->f64 'load-f64 's64->f64 - 'f32-ref 'f64-ref - 'fadd 'fsub 'fmul 'fdiv 'fsqrt 'fabs - 'ffloor 'fceiling - 'fsin 'fcos 'ftan 'fasin 'facos 'fatan 'fatan2)) - (intmap-add representations var 'f64)) - (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64 - 's64->u64 - 'assume-u64 - 'uadd 'usub 'umul - 'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh - 'uadd/immediate 'usub/immediate 'umul/immediate - 'ursh/immediate 'ulsh/immediate - 'u8-ref 'u16-ref 'u32-ref 'u64-ref - 'word-ref 'word-ref/immediate - 'untag-char)) - (intmap-add representations var 'u64)) - (($ $primcall (or 'untag-fixnum - 'assume-s64 - 'scm->s64 'load-s64 'u64->s64 - 'srsh 'srsh/immediate - 's8-ref 's16-ref 's32-ref 's64-ref)) - (intmap-add representations var 's64)) - (($ $primcall (or 'pointer-ref/immediate - 'tail-pointer-ref/immediate)) - (intmap-add representations var 'ptr)) - (($ $code) - (intmap-add representations var 'u64)) - (_ - (intmap-add representations var 'scm)))) - (vars - (match exp - (($ $values args) - (fold (lambda (arg var representations) - (intmap-add representations var - (intmap-ref representations arg))) - representations args vars)))))) - (($ $kargs _ _ (or ($ $branch) ($ $switch) ($ $prompt) ($ $throw))) - representations) - (($ $kfun src meta self tail entry) - (let ((representations (if self - (intmap-add representations self 'scm) - representations))) - (fold1 (lambda (var representations) - (intmap-add representations var 'scm)) - (get-defs entry) representations))) - (($ $kclause arity body alt) - (fold1 (lambda (var representations) - (intmap-add representations var 'scm)) - (get-defs body) representations)) - (($ $kreceive arity kargs) - (fold1 (lambda (var representations) - (intmap-add representations var 'scm)) - (get-defs kargs) representations)) - (($ $ktail) representations))) - cps - empty-intmap)) - (define* (allocate-slots cps #:key (precolor-calls? #t)) (let*-values (((defs uses) (compute-defs-and-uses cps)) ((representations) (compute-var-representations cps)) - ((live-in live-out) (compute-live-variables cps defs uses)) + ((live-in live-out) + (let* ((succs (compute-successors cps)) + (succs+ (add-prompt-control-flow-edges cps succs)) + (preds (invert-graph succs+))) + (compute-live-variables preds defs uses))) ((needs-slot) (compute-needs-slot cps defs uses)) ((lazy) (if precolor-calls? (compute-lazy-vars cps live-in live-out defs diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 7657bf409..d3be176bf 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -2014,7 +2014,7 @@ maximum, where type is a bitset as a fixnum." (match (intmap-ref conts k) (($ $kargs _ defs) (infer-primcall types 0 name param args - (match defs ((var) var) (() #f)))) + (match defs ((var) var) (_ #f)))) (_ ;; (pk 'warning-no-restrictions name) types)))) diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm index c72c04434..2b0c91c4b 100644 --- a/module/language/cps/utils.scm +++ b/module/language/cps/utils.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019, 2020 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019, 2020, 2021 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -43,7 +43,9 @@ compute-successors compute-predecessors compute-idoms - compute-dom-edges) + compute-dom-edges + compute-defs-and-uses + compute-var-representations) #:re-export (fold1 fold2 trivial-intset intmap-map @@ -302,42 +304,6 @@ intset." (intmap-fold adjoin-idom preds-map idoms)) empty-intmap))) -;; Precondition: For each function in CONTS, the continuation names are -;; topologically sorted. -(define (compute-idoms conts kfun) - ;; This is the iterative O(n^2) fixpoint algorithm, originally from - ;; Allen and Cocke ("Graph-theoretic constructs for program flow - ;; analysis", 1972). See the discussion in Cooper, Harvey, and - ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001. - (let ((preds-map (compute-predecessors conts kfun))) - (define (compute-idom idoms preds) - (define (idom-ref label) - (intmap-ref idoms label (lambda (_) #f))) - (match preds - (() -1) - ((pred) pred) ; Shortcut. - ((pred . preds) - (define (common-idom d0 d1) - ;; We exploit the fact that a reverse post-order is a - ;; topological sort, and so the idom of a node is always - ;; numerically less than the node itself. - (let lp ((d0 d0) (d1 d1)) - (cond - ;; d0 or d1 can be false on the first iteration. - ((not d0) d1) - ((not d1) d0) - ((= d0 d1) d0) - ((< d0 d1) (lp d0 (idom-ref d1))) - (else (lp (idom-ref d0) d1))))) - (fold1 common-idom preds pred)))) - (define (adjoin-idom label preds idoms) - (let ((idom (compute-idom idoms preds))) - ;; Don't use intmap-add! here. - (intmap-add idoms label idom (lambda (old new) new)))) - (fixpoint (lambda (idoms) - (intmap-fold adjoin-idom preds-map idoms)) - empty-intmap))) - ;; Compute a vector containing, for each node, a list of the nodes that ;; it immediately dominates. These are the "D" edges in the DJ tree. (define (compute-dom-edges idoms) @@ -351,3 +317,135 @@ intset." idoms empty-intmap))) +(define (compute-defs-and-uses cps) + "Return two LABEL->VAR... maps indicating values defined at and used +by a label, respectively." + (define (vars->intset vars) + (fold (lambda (var set) (intset-add set var)) empty-intset vars)) + (define-syntax-rule (persistent-intmap2 exp) + (call-with-values (lambda () exp) + (lambda (a b) + (values (persistent-intmap a) (persistent-intmap b))))) + (persistent-intmap2 + (intmap-fold + (lambda (label cont defs uses) + (define (get-defs k) + (match (intmap-ref cps k) + (($ $kargs names vars) (vars->intset vars)) + (_ empty-intset))) + (define (return d u) + (values (intmap-add! defs label d) + (intmap-add! uses label u))) + (match cont + (($ $kfun src meta self tail clause) + (return (intset-union + (if clause (get-defs clause) empty-intset) + (if self (intset self) empty-intset)) + empty-intset)) + (($ $kargs _ _ ($ $continue k src exp)) + (match exp + ((or ($ $const) ($ $const-fun) ($ $code)) + (return (get-defs k) empty-intset)) + (($ $call proc args) + (return (get-defs k) (intset-add (vars->intset args) proc))) + (($ $callk _ proc args) + (let ((args (vars->intset args))) + (return (get-defs k) (if proc (intset-add args proc) args)))) + (($ $primcall name param args) + (return (get-defs k) (vars->intset args))) + (($ $values args) + (return (get-defs k) (vars->intset args))))) + (($ $kargs _ _ ($ $branch kf kt src op param args)) + (return empty-intset (vars->intset args))) + (($ $kargs _ _ ($ $switch kf kt* src arg)) + (return empty-intset (intset arg))) + (($ $kargs _ _ ($ $prompt k kh src escape? tag)) + (return empty-intset (intset tag))) + (($ $kargs _ _ ($ $throw src op param args)) + (return empty-intset (vars->intset args))) + (($ $kclause arity body alt) + (return (get-defs body) empty-intset)) + (($ $kreceive arity kargs) + (return (get-defs kargs) empty-intset)) + (($ $ktail) + (return empty-intset empty-intset)))) + cps + empty-intmap + empty-intmap))) + +(define (compute-var-representations cps) + (define (get-defs k) + (match (intmap-ref cps k) + (($ $kargs names vars) vars) + (_ '()))) + (intmap-fold + (lambda (label cont representations) + (match cont + (($ $kargs _ _ ($ $continue k _ exp)) + (match (get-defs k) + (() representations) + ((var) + (match exp + (($ $values (arg)) + (intmap-add representations var + (intmap-ref representations arg))) + (($ $primcall (or 'scm->f64 'load-f64 's64->f64 + 'f32-ref 'f64-ref + 'fadd 'fsub 'fmul 'fdiv 'fsqrt 'fabs + 'ffloor 'fceiling + 'fsin 'fcos 'ftan 'fasin 'facos 'fatan 'fatan2)) + (intmap-add representations var 'f64)) + (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64 + 's64->u64 + 'assume-u64 + 'uadd 'usub 'umul + 'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh + 'uadd/immediate 'usub/immediate 'umul/immediate + 'ursh/immediate 'ulsh/immediate + 'u8-ref 'u16-ref 'u32-ref 'u64-ref + 'word-ref 'word-ref/immediate + 'untag-char)) + (intmap-add representations var 'u64)) + (($ $primcall (or 'untag-fixnum + 'assume-s64 + 'scm->s64 'load-s64 'u64->s64 + 'srsh 'srsh/immediate + 's8-ref 's16-ref 's32-ref 's64-ref)) + (intmap-add representations var 's64)) + (($ $primcall (or 'pointer-ref/immediate + 'tail-pointer-ref/immediate)) + (intmap-add representations var 'ptr)) + (($ $code) + (intmap-add representations var 'u64)) + (_ + (intmap-add representations var 'scm)))) + (vars + (match exp + (($ $values args) + (fold (lambda (arg var representations) + (intmap-add representations var + (intmap-ref representations arg))) + representations args vars)))))) + (($ $kargs _ _ (or ($ $branch) ($ $switch) ($ $prompt) ($ $throw))) + representations) + (($ $kfun src meta self tail entry) + (let* ((representations (if self + (intmap-add representations self 'scm) + representations)) + (defs (get-defs entry)) + (reprs (or (assq-ref meta 'arg-representations) + (map (lambda (_) 'scm) defs)))) + (fold (lambda (var repr representations) + (intmap-add representations var repr)) + representations defs reprs))) + (($ $kclause arity body alt) + (fold1 (lambda (var representations) + (intmap-add representations var 'scm)) + (get-defs body) representations)) + (($ $kreceive arity kargs) + (fold1 (lambda (var representations) + (intmap-add representations var 'scm)) + (get-defs kargs) representations)) + (($ $ktail) representations))) + cps + empty-intmap)) diff --git a/module/language/tree-il/compile-bytecode.scm b/module/language/tree-il/compile-bytecode.scm index c495d2ae6..87d903c10 100644 --- a/module/language/tree-il/compile-bytecode.scm +++ b/module/language/tree-il/compile-bytecode.scm @@ -459,10 +459,10 @@ v))) ;; Transform "ash" to lsh / rsh. - (($ <primcall> src 'ash (x ($ <const> src (? exact-integer? y)))) + (($ <primcall> src 'ash (x ($ <const> src* (? exact-integer? y)))) (if (negative? y) - (make-primcall src 'lsh (list x (make-const src (- y)))) - (make-primcall src 'rsh (list x (make-const src y))))) + (make-primcall src 'rsh (list x (make-const src* (- y)))) + (make-primcall src 'lsh (list x (make-const src* y))))) ;; (throw key subr msg (list x) (list x)) (($ <primcall> src 'throw diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index ffc8308a6..918e9044a 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -1581,6 +1581,15 @@ use as the proc slot." (letk ktail ($kargs ('tail) (tail) ,head)) ($ (build-list ktail src vals)))))) +(define (sanitize-meta meta) + (match meta + (() '()) + (((k . v) . meta) + (let ((meta (sanitize-meta meta))) + (case k + ((arg-representations) meta) + (else (acons k v meta))))))) + ;;; The conversion from Tree-IL to CPS essentially wraps every ;;; expression in a $kreceive, which models the Tree-IL semantics that ;;; extra values are simply truncated. In CPS, this means that the @@ -1865,7 +1874,7 @@ use as the proc slot." (letv self) (letk ktail ($ktail)) (let$ kclause (convert-clauses body ktail)) - (letk kfun ($kfun fun-src meta self ktail kclause)) + (letk kfun ($kfun fun-src (sanitize-meta meta) self ktail kclause)) (let$ k (adapt-arity k fun-src 1)) (build-term ($continue k fun-src ($fun kfun)))) (let ((scope-id (fresh-scope-id))) diff --git a/module/language/tree-il/inlinable-exports.scm b/module/language/tree-il/inlinable-exports.scm new file mode 100644 index 000000000..8ea5725f3 --- /dev/null +++ b/module/language/tree-il/inlinable-exports.scm @@ -0,0 +1,869 @@ +;;; Attaching inlinable definitions of exported bindings to modules +;;; Copyright (C) 2021 +;;; Free Software Foundation, Inc. +;;; +;;; This library is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + + + +(define-module (language tree-il inlinable-exports) + #:use-module (ice-9 control) + #:use-module (ice-9 match) + #:use-module (ice-9 binary-ports) + #:use-module (language tree-il) + #:use-module (language tree-il primitives) + #:use-module (language tree-il fix-letrec) + #:use-module (language scheme compile-tree-il) + #:use-module ((srfi srfi-1) #:select (filter-map)) + #:use-module (srfi srfi-9) + #:use-module (system syntax) + #:use-module (rnrs bytevectors) + #:export (inlinable-exports)) + +;;; +;;; Inlining, as implemented by peval, is the mother of all +;;; optimizations. It opens up space for other optimizations to work, +;;; such as constant folding, conditional branch folding, and so on. +;;; +;;; Inlining works naturally for lexical bindings. Inlining of +;;; top-level binding is facilitated by letrectification, which turns +;;; top-level definition sequences to letrec*. Here we facilitate +;;; inlining across module boundaries, so that module boundaries aren't +;;; necessarily optimization boundaries. +;;; +;;; The high-level idea is to attach a procedure to the module being +;;; compiled, which when called with a name of an export of that module +;;; will return a Tree-IL expression that can be copied into the use +;;; site. There are two parts: first we determine the set of inlinable +;;; bindings, and then we compile that mapping to a procedure and attach +;;; it to the program being compiled. +;;; +;;; Because we don't want inter-module inlining to inhibit intra-module +;;; inlining, this pass is designed to run late in the Tree-IL +;;; optimization pipeline -- after letrectification, after peval, and so +;;; on. Unfortunately this does mean that we have to sometimes +;;; pattern-match to determine higher-level constructs from lower-level +;;; residual code, for example to map back from +;;; module-ensure-local-variable! + %variable-set! to toplevel-define, +;;; as reduced by letrectification. Ah well. +;;; +;;; Ultimately we want to leave the decision to peval as to what to +;;; inline or not to inline, based on its size and effort counters. But +;;; still we do need to impose some limits -- there's no sense in +;;; copying a large constant from one module to another, for example. +;;; Similarly there's no sense in copying a very large procedure. +;;; Inspired by peval, we bound size growth via a counter that will +;;; abort an inlinable attempt if the term is too large. +;;; +;;; Note that there are some semantic limitations -- you wouldn't want +;;; to copy a mutable value, nor would you want to copy a closure with +;;; free variables. +;;; +;;; Once the set of inlinables is determined, we copy them and rename +;;; their lexicals. Any reference to an exported binding by lexical +;;; variable is rewritten in terms of a reference to the exported +;;; binding. +;;; +;;; The result is then compiled to a procedure, which internally has a +;;; small interpreter for a bytecode, along with a set of constants. +;;; The assumption is that most of the constants will be written to the +;;; object file anyway, so we aren't taking up more space there. Any +;;; non-immediate is built on demand, so we limit the impact of +;;; including inlinable definitions on load-time relocations, +;;; allocations, and heap space. +;;; + +(define (compute-assigned-lexicals exp) + (define assigned-lexicals '()) + (define (add-assigned-lexical! var) + (set! assigned-lexicals (cons var assigned-lexicals))) + ((make-tree-il-folder) + exp + (lambda (exp) + (match exp + (($ <lexical-set> _ _ var _) + (add-assigned-lexical! var) + (values)) + (_ (values)))) + (lambda (exp) + (values))) + assigned-lexicals) + +(define (compute-assigned-toplevels exp) + (define assigned-toplevels '()) + (define (add-assigned-toplevel! mod name) + (set! assigned-toplevels (acons mod name assigned-toplevels))) + ((make-tree-il-folder) + exp + (lambda (exp) + (match exp + (($ <toplevel-set> _ mod name _) + (add-assigned-toplevel! mod name) + (values)) + (($ <module-set> src mod name public? exp) + (unless public? + (add-assigned-toplevel! mod name)) + (values)) + (_ (values)))) + (lambda (exp) + (values))) + assigned-toplevels) + +;;; FIXME: Record all bindings in a module, to know whether a +;;; toplevel-ref is an import or not. If toplevel-ref to imported +;;; variable, transform to module-ref or primitive-ref. New pass before +;;; peval. + +(define (compute-module-bindings exp) + (define assigned-lexicals (compute-assigned-lexicals exp)) + (define assigned-toplevels (compute-assigned-toplevels exp)) + (define module-definitions '()) + (define lexicals (make-hash-table)) + (define module-lexicals '()) + (define variable-lexicals '()) + (define binding-lexicals '()) + (define binding-values '()) + (define (add-module-definition! mod args) + (set! module-definitions (acons mod args module-definitions))) + (define (add-lexical! var val) + (unless (memq var assigned-lexicals) + (hashq-set! lexicals var val))) + (define (add-module-lexical! var mod) + (unless (memq var assigned-lexicals) + (set! module-lexicals (acons var mod module-lexicals)))) + (define (add-variable-lexical! var mod name) + (unless (memq var assigned-lexicals) + (set! variable-lexicals (acons var (cons mod name) variable-lexicals)))) + (define (add-binding-lexical! var mod name) + (unless (memq var assigned-lexicals) + (set! binding-lexicals (acons var (cons mod name) binding-lexicals)))) + (define (add-binding-value! mod name val) + (set! binding-values (acons (cons mod name) val binding-values))) + + (define (record-bindings! mod gensyms vals) + (for-each + (lambda (var val) + (add-lexical! var val) + (match val + (($ <call> _ ($ <module-ref> _ '(guile) 'define-module* #f) + (($ <const> _ mod) . args)) + (add-module-definition! mod args) + (add-module-lexical! var mod)) + (($ <primcall> _ 'current-module ()) + (when mod + (add-module-lexical! var mod))) + (($ <primcall> _ 'module-ensure-local-variable! + (($ <lexical-ref> _ _ mod-var) ($ <const> _ name))) + (let ((mod (assq-ref module-lexicals mod-var))) + (when mod + (add-variable-lexical! var mod name)))) + (_ #f))) + gensyms vals)) + + ;; Thread a conservative idea of what the current module is through + ;; the visit. Visiting an expression returns the name of the current + ;; module when the expression completes, or #f if unknown. Record the + ;; define-module* forms, if any, and note any assigned or + ;; multiply-defined variables. Record definitions by matching + ;; toplevel-define forms, but also by matching separate + ;; module-ensure-local-variable! + %variable-set, as residualized by + ;; letrectification. + (define (visit exp) (visit/mod exp #f)) + (define (visit* exps) + (unless (null? exps) + (visit (car exps)) + (visit* (cdr exps)))) + (define (visit+ exps mod) + (match exps + (() mod) + ((exp . exps) + (let lp ((mod' (visit/mod exp mod)) (exps exps)) + (match exps + (() mod') + ((exp . exps) + (lp (and (equal? mod' (visit/mod exp mod)) mod') + exps))))))) + (define (visit/mod exp mod) + (match exp + ((or ($ <void>) ($ <const>) ($ <primitive-ref>) ($ <lexical-ref>) + ($ <module-ref>) ($ <toplevel-ref>)) + mod) + + (($ <call> _ ($ <module-ref> _ '(guile) 'set-current-module #f) + (($ <lexical-ref> _ _ var))) + (assq-ref module-lexicals var)) + + (($ <primcall> src '%variable-set! (($ <lexical-ref> _ _ var) + val)) + (match (assq-ref variable-lexicals var) + ((mod . name) + (add-binding-value! mod name val) + ;; Also record lexical for eta-expanded bindings. + (match val + (($ <lambda> _ _ + ($ <lambda-case> _ req #f #f #f () (arg ...) + ($ <call> _ + (and eta ($ <lexical-ref> _ _ var)) + (($ <lexical-ref> _ _ arg) ...)) + #f)) + (add-binding-lexical! var mod name)) + (($ <lambda> _ _ + ($ <lambda-case> _ req #f (not #f) #f () (arg ...) + ($ <primcall> _ 'apply + ((and eta ($ <lexical-ref> _ _ var)) + ($ <lexical-ref> _ _ arg) ...)) + #f)) + (add-binding-lexical! var mod name)) + (($ <lexical-ref> _ _ var) + (add-binding-lexical! var mod name)) + (_ #f))) + (_ #f)) + (visit/mod val mod)) + + (($ <call> _ proc args) + (visit proc) + (visit* args) + #f) + + (($ <primcall> _ _ args) + ;; There is no primcall that sets the current module. + (visit+ args mod)) + + (($ <conditional> src test consequent alternate) + (visit+ (list consequent alternate) (visit/mod test mod))) + + (($ <lexical-set> src name gensym exp) + (visit/mod exp mod)) + + (($ <toplevel-set> src mod name exp) + (visit/mod exp mod)) + + (($ <module-set> src mod name public? exp) + (visit/mod exp mod)) + + (($ <toplevel-define> src mod name exp) + (add-binding-value! mod name exp) + (visit/mod exp mod)) + + (($ <lambda> src meta body) + (when body (visit body)) + mod) + + (($ <lambda-case> src req opt rest kw inits gensyms body alternate) + (visit* inits) + (visit body) + (when alternate (visit alternate)) + (values)) + + (($ <seq> src head tail) + (visit/mod tail (visit/mod head mod))) + + (($ <let> src names gensyms vals body) + (record-bindings! mod gensyms vals) + (visit/mod body (visit+ vals mod))) + + (($ <letrec> src in-order? names gensyms vals body) + (record-bindings! mod gensyms vals) + (visit/mod body (visit+ vals mod))) + + (($ <fix> src names gensyms vals body) + (record-bindings! mod gensyms vals) + (visit/mod body (visit+ vals mod))) + + (($ <let-values> src exp body) + (visit/mod body (visit/mod exp mod)) + #f) + + (($ <prompt> src escape-only? tag body handler) + (visit tag) + (visit body) + (visit handler) + #f) + + (($ <abort> src tag args tail) + (visit tag) + (visit* args) + (visit tail) + #f))) + + (visit exp) + (values module-definitions lexicals binding-lexicals binding-values)) + +;; - define inlinable? predicate: +;; exported && declarative && only references public vars && not too big +;; +;; - public := exported from a module, at -O2 and less. +;; at -O3 and higher public just means defined in any module. +(define (inlinable-exp mod exports lexicals binding-lexicals exp) + (define fresh-var! + (let ((counter 0)) + (lambda () + (let ((name (string-append "t" (number->string counter)))) + (set! counter (1+ counter)) + (string->symbol name))))) + (define (fresh-vars vars) + (match vars + (() '()) + ((_ . vars) (cons (fresh-var!) (fresh-vars vars))))) + (define (add-bound-vars old new bound) + (match (vector old new) + (#(() ()) bound) + (#((old . old*) (new . new*)) + (add-bound-vars old* new* (acons old new bound))))) + (let/ec return + (define (abort!) (return #f)) + (define count! + ;; Same as default operator size limit for peval. + (let ((counter 40)) + (lambda () + (set! counter (1- counter)) + (when (zero? counter) (abort!))))) + (define (residualize-module-private-ref src mod' name) + ;; TODO: At -O3, we could residualize a private + ;; reference. But that could break peoples' + ;; expectations. + (abort!)) + (define (eta-reduce exp) + ;; Undo the result of eta-expansion pass. + (match exp + (($ <lambda> _ _ + ($ <lambda-case> _ req #f #f #f () (sym ...) + ($ <call> _ + (and eta ($ <lexical-ref>)) (($ <lexical-ref> _ _ sym) ...)) + #f)) + eta) + (($ <lambda> _ _ + ($ <lambda-case> _ req #f (not #f) #f () (sym ...) + ($ <primcall> _ 'apply + ((and eta ($ <lexical-ref>)) ($ <lexical-ref> _ _ sym) ...)) + #f)) + eta) + (_ exp))) + + (let copy ((exp (eta-reduce exp)) (bound '()) (in-lambda? #f)) + (define (recur exp) (copy exp bound in-lambda?)) + (count!) + (match exp + ((or ($ <void>) ($ <primitive-ref>) ($ <module-ref>)) + exp) + + (($ <const> src val) + (match val + ;; Don't copy values that could be "too big". + ((? string?) exp) ; Oddly, (array? "") => #t. + ((or (? pair?) (? syntax?) (? array?)) + (abort!)) + (_ exp))) + + (($ <lexical-ref> src name var) + (cond + ;; Rename existing lexicals. + ((assq-ref bound var) + => (lambda (var) + (make-lexical-ref src name var))) + ;; A free variable reference to a lambda, outside a lambda. + ;; Could be the lexical-ref residualized by letrectification. + ;; Copy and rely on size limiter to catch runaways. + ((and (not in-lambda?) (lambda? (hashq-ref lexicals var))) + (recur (hashq-ref lexicals var))) + ((not in-lambda?) + ;; No advantage to "inline" a toplevel to another toplevel. + (abort!)) + ;; Some letrectified toplevels will be bound to lexical + ;; variables, but unless the module has sealed private + ;; bindings, there may be an associated top-level variable + ;; as well. + ((assq-ref binding-lexicals var) + => (match-lambda + ((mod' . name) + (cond + ((and (equal? mod' mod) (assq-ref exports name)) + => (lambda (public-name) + (make-module-ref src mod public-name #t))) + (else + (residualize-module-private-ref src mod' name)))))) + ;; A free variable reference. If it's in the program at this + ;; point, that means that peval didn't see fit to copy it, so + ;; there's no point in trying to do so here. + (else (abort!)))) + + (($ <toplevel-ref> src mod' name) + (cond + ;; Rewrite private references to exported bindings into public + ;; references. Peval can decide whether to continue inlining + ;; or not. + ((and (equal? mod mod') (assq-ref exports name)) + => (lambda (public-name) + (make-module-ref src mod public-name #t))) + (else + (residualize-module-private-ref src mod' name)))) + + (($ <call> src proc args) + (unless in-lambda? (abort!)) + (make-call src (recur proc) (map recur args))) + + (($ <primcall> src name args) + (unless in-lambda? (abort!)) + (make-primcall src name (map recur args))) + + (($ <conditional> src test consequent alternate) + (unless in-lambda? (abort!)) + (make-conditional src (recur test) + (recur consequent) (recur alternate))) + + (($ <lexical-set> src name var exp) + (unless in-lambda? (abort!)) + (cond + ((assq-ref bound var) + => (lambda (var) + (make-lexical-set src name var (recur exp)))) + (else + (abort!)))) + + ((or ($ <toplevel-set>) + ($ <module-set>) + ($ <toplevel-define>)) + (abort!)) + + (($ <lambda> src meta body) + ;; Remove any lengthy docstring. + (let ((meta (filter-map (match-lambda + (('documentation . _) #f) + (pair pair)) + meta))) + (make-lambda src meta (and body (copy body bound #t))))) + + (($ <lambda-case> src req opt rest kw inits vars body alternate) + (unless in-lambda? (abort!)) + (let* ((vars* (fresh-vars vars)) + (bound (add-bound-vars vars vars* bound))) + (define (recur* exp) (copy exp bound #t)) + (make-lambda-case src req opt rest + (match kw + (#f #f) + ((aok? . kws) + (cons aok? + (map + (match-lambda + ((kw name var) + (list kw name (assq-ref var bound)))) + kws)))) + (map recur* inits) + vars* + (recur* body) + (and alternate (recur alternate))))) + + (($ <seq> src head tail) + (unless in-lambda? (abort!)) + (make-seq src (recur head) (recur tail))) + + (($ <let> src names vars vals body) + (unless in-lambda? (abort!)) + (let* ((vars* (fresh-vars vars)) + (bound (add-bound-vars vars vars* bound))) + (define (recur* exp) (copy exp bound #t)) + (make-let src names vars* (map recur vals) (recur* body)))) + + (($ <letrec> src in-order? names vars vals body) + (unless in-lambda? (abort!)) + (let* ((vars* (fresh-vars vars)) + (bound (add-bound-vars vars vars* bound))) + (define (recur* exp) (copy exp bound #t)) + (make-letrec src in-order? names vars* (map recur* vals) + (recur* body)))) + + (($ <fix> src names vars vals body) + (unless in-lambda? (abort!)) + (let* ((vars* (fresh-vars vars)) + (bound (add-bound-vars vars vars* bound))) + (define (recur* exp) (copy exp bound #t)) + (make-fix src names vars* (map recur* vals) + (recur* body)))) + + (($ <let-values> src exp body) + (unless in-lambda? (abort!)) + (make-let-values src (recur exp) (recur body))) + + (($ <prompt> src escape-only? tag body handler) + (unless in-lambda? (abort!)) + (make-prompt src escape-only? + (recur tag) (recur body) (recur handler))) + + (($ <abort> src tag args tail) + (unless in-lambda? (abort!)) + (make-abort src (recur tag) (map recur args) (recur tail))))))) + +(define (compute-inlinable-bindings exp) + "Traverse @var{exp}, extracting module-level definitions." + + (define-values (modules lexicals binding-lexicals bindings) + (compute-module-bindings exp)) + + (define (kwarg-ref args kw kt kf) + (let lp ((args args)) + (match args + (() (kf)) + ((($ <const> _ (? keyword? kw')) val . args) + (if (eq? kw' kw) + (kt val) + (lp args))) + ((_ _ . args) + (lp args))))) + (define (kwarg-ref/const args kw kt kf) + (kwarg-ref args kw + (lambda (exp) + (match exp + (($ <const> _ val') (kt val')) + (_ (kf)))) + kf)) + (define (has-constant-initarg? args kw val) + (kwarg-ref/const args kw + (lambda (val') + (equal? val val')) + (lambda () #f))) + + ;; Collect declarative modules defined once in this compilation unit. + (define modules-with-inlinable-exports + (let lp ((defs modules) (not-inlinable '()) (inlinable '())) + (match defs + (() inlinable) + (((mod . args) . defs) + (cond ((member mod not-inlinable) + (lp defs not-inlinable inlinable)) + ((or (assoc mod defs) ;; doubly defined? + (not (has-constant-initarg? args #:declarative? #t))) + (lp defs (cons mod not-inlinable) inlinable)) + (else + (lp defs not-inlinable (cons mod inlinable)))))))) + + ;; Omit multiply-defined bindings, and definitions not in declarative + ;; modules. + (define non-declarative-definitions + (let lp ((bindings bindings) (non-declarative '())) + (match bindings + (() non-declarative) + ((((and mod+name (mod . name)) . val) . bindings) + (cond + ((member mod+name non-declarative) + (lp bindings non-declarative)) + ((or (assoc mod+name bindings) + (not (member mod modules-with-inlinable-exports))) + (lp bindings (cons mod+name non-declarative))) + (else + (lp bindings non-declarative))))))) + + (define exports + (map (lambda (module) + (define args (assoc-ref modules module)) + ;; Return list of (PRIVATE-NAME . PUBLIC-NAME) pairs. + (define (extract-exports kw) + (kwarg-ref/const args kw + (lambda (val) + (map (match-lambda + ((and pair (private . public)) pair) + (name (cons name name))) + val)) + (lambda () '()))) + (cons module + (append (extract-exports #:exports) + (extract-exports #:replacements)))) + modules-with-inlinable-exports)) + + ;; Compute ((PRIVATE-NAME . PUBLIC-NAME) . VALUE) pairs for each + ;; module with inlinable bindings, for exported bindings only. + (define inlinable-candidates + (map + (lambda (module) + (define name-pairs (assoc-ref exports module)) + (define (name-pair private-name) + (assq private-name name-pairs)) + (cons module + (filter-map + (match-lambda + (((and mod+name (mod . name)) . val) + (and (equal? module mod) + (not (member mod+name non-declarative-definitions)) + (and=> (name-pair name) + (lambda (pair) (cons pair val)))))) + bindings))) + modules-with-inlinable-exports)) + + (define inlinables + (filter-map + (match-lambda + ((mod . exports) + (let ((name-pairs (map car exports))) + (match (filter-map + (match-lambda + (((private . public) . val) + (match (inlinable-exp mod name-pairs lexicals + binding-lexicals val) + (#f #f) + (val (cons public val))))) + exports) + (() #f) + (exports (cons mod exports)))))) + inlinable-candidates)) + + inlinables) + +(define (put-uleb port val) + (let lp ((val val)) + (let ((next (ash val -7))) + (if (zero? next) + (put-u8 port val) + (begin + (put-u8 port (logior #x80 (logand val #x7f))) + (lp next)))))) + +(define (known-vtable vtable) + (define-syntax-rule (tree-il-case vt ...) + (cond + ((eq? vtable vt) (values '(language tree-il) 'vt)) + ... + (else (values #f #f)))) + (tree-il-case <void> + <const> + <primitive-ref> + <lexical-ref> + <lexical-set> + <module-ref> + <module-set> + <toplevel-ref> + <toplevel-set> + <toplevel-define> + <conditional> + <call> + <primcall> + <seq> + <lambda> + <lambda-case> + <let> + <letrec> + <fix> + <let-values> + <prompt> + <abort>)) + +(define-record-type <encoding> + (%make-encoding constants vtables pair-code vector-code symbol-code next-code) + encoding? + (constants constants) + (vtables vtables) + (pair-code pair-code set-pair-code!) + (vector-code vector-code set-vector-code!) + (symbol-code symbol-code set-symbol-code!) + (next-code next-code set-next-code!)) + +(define (make-encoding) + (%make-encoding (make-hash-table) (make-hash-table) #f #f #f 0)) + +(define (vtable-nfields vtable) + (define vtable-index-size 5) ; FIXME: pull from struct.h + (struct-ref/unboxed vtable vtable-index-size)) + +(define (build-encoding! term encoding) + (define (next-code!) + (let ((code (next-code encoding))) + (set-next-code! encoding (1+ code)) + code)) + + (define (intern-constant! x) + (unless (hash-ref (constants encoding) x) + (hash-set! (constants encoding) x (next-code!)))) + (define (intern-vtable! x) + (unless (hashq-ref (vtables encoding) x) + (hashq-set! (vtables encoding) x (next-code!)))) + (define (ensure-pair-code!) + (unless (pair-code encoding) + (set-pair-code! encoding (next-code!)))) + (define (ensure-vector-code!) + (unless (vector-code encoding) + (set-vector-code! encoding (next-code!)))) + (define (ensure-symbol-code!) + (unless (symbol-code encoding) + (set-symbol-code! encoding (next-code!)))) + + (let visit ((term term)) + (cond + ((pair? term) + (ensure-pair-code!) + (visit (car term)) + (visit (cdr term))) + ((vector? term) + (ensure-vector-code!) + (visit (vector-length term)) + (let lp ((i 0)) + (when (< i (vector-length term)) + (visit (vector-ref term i)) + (lp (1+ i))))) + ((symbol? term) + (ensure-symbol-code!) + (visit (symbol->string term))) + ((struct? term) + (let ((vtable (struct-vtable term))) + (unless (known-vtable vtable) + (error "struct of unknown type" term)) + (intern-vtable! vtable) + (let ((nfields (vtable-nfields vtable))) + (let lp ((i 0)) + (when (< i nfields) + (visit (struct-ref term i)) + (lp (1+ i))))))) + (else + (intern-constant! term))))) + +(define (compute-decoder encoding) + (define (pair-clause code) + `((eq? code ,code) + (let* ((car (lp)) + (cdr (lp))) + (cons car cdr)))) + (define (vector-clause code) + `((eq? code ,code) + (let* ((len (lp)) + (v (make-vector len))) + (let init ((i 0)) + (when (< i len) + (vector-set! v i (lp)) + (init (1+ i)))) + v))) + (define (symbol-clause code) + `((eq? code ,code) + (string->symbol (lp)))) + (define (vtable-clause vtable code) + (call-with-values (lambda () (known-vtable vtable)) + (lambda (mod name) + (let ((fields (map (lambda (i) (string->symbol (format #f "f~a" i))) + (iota (vtable-nfields vtable))))) + `((eq? code ,code) + (let* (,@(map (lambda (field) `(,field (lp))) fields)) + (make-struct/no-tail (@ ,mod ,name) ,@fields))))))) + (define (constant-clause constant code) + `((eq? code ,code) ',constant)) + + `(lambda (bv) + (define pos 0) + (define (next-u8!) + (let ((u8 (bytevector-u8-ref bv pos))) + (set! pos (1+ pos)) + u8)) + (define (next-uleb!) + ,(if (< (next-code encoding) #x80) + ;; No need for uleb decoding in this case. + '(next-u8!) + ;; FIXME: We have a maximum code length and probably we + ;; should just inline the corresponding decoder instead of + ;; looping. + '(let lp ((n 0) (shift 0)) + (let ((b (next-u8!))) + (if (zero? (logand b #x80)) + (logior (ash b shift) n) + (lp (logior (ash (logxor #x80 b) shift) n) + (+ shift 7))))))) + (let lp () + (let ((code (next-uleb!))) + (cond + ,@(if (pair-code encoding) + (list (pair-clause (pair-code encoding))) + '()) + ,@(if (vector-code encoding) + (list (vector-clause (vector-code encoding))) + '()) + ,@(if (symbol-code encoding) + (list (symbol-clause (symbol-code encoding))) + '()) + ,@(hash-map->list vtable-clause (vtables encoding)) + ,@(hash-map->list constant-clause (constants encoding)) + (else (error "bad code" code))))))) + +(define (encode term encoding) + (call-with-output-bytevector + (lambda (port) + (define (put x) (put-uleb port x)) + (let visit ((term term)) + (cond + ((pair? term) + (put (pair-code encoding)) + (visit (car term)) + (visit (cdr term))) + ((vector? term) + (put (vector-code encoding)) + (visit (vector-length term)) + (let lp ((i 0)) + (when (< i (vector-length term)) + (visit (vector-ref term i)) + (lp (1+ i))))) + ((symbol? term) + (put (symbol-code encoding)) + (visit (symbol->string term))) + ((struct? term) + (let* ((vtable (struct-vtable term)) + (nfields (vtable-nfields vtable))) + (put (hashq-ref (vtables encoding) vtable)) + (let lp ((i 0)) + (when (< i nfields) + (visit (struct-ref term i)) + (lp (1+ i)))))) + (else + (put (hash-ref (constants encoding) term)))))))) + +(define (compute-encoding bindings) + (let ((encoding (make-encoding))) + (for-each (match-lambda + ((name . expr) (build-encoding! expr encoding))) + bindings) + (let ((encoded (map (match-lambda + ((name . expr) (cons name (encode expr encoding)))) + bindings))) + `(lambda (name) + (define decode ,(compute-decoder encoding)) + (cond + ,@(map (match-lambda + ((name . bv) + `((eq? name ',name) (decode ,bv)))) + encoded) + (else #f)))))) + +(define encoding-module (current-module)) +(define (compile-inlinable-exports bindings) + (let ((exp (compute-encoding bindings))) + (fix-letrec + (expand-primitives + (resolve-primitives + (compile-tree-il exp encoding-module '()) + encoding-module))))) + +(define (attach-inlinables exp inlinables) + (post-order + (lambda (exp) + (match exp + (($ <call> src (and proc ($ <module-ref> _ '(guile) 'define-module* #f)) + ((and m ($ <const> _ mod)) . args)) + (cond + ((assoc-ref inlinables mod) + => (lambda (bindings) + (let ((inlinables (compile-inlinable-exports bindings))) + (make-call src proc + (cons* m + (make-const #f #:inlinable-exports) + inlinables + args))))) + (else exp))) + (exp exp))) + exp)) + +(define (inlinable-exports exp) + (attach-inlinables exp (compute-inlinable-bindings exp))) diff --git a/module/language/tree-il/letrectify.scm b/module/language/tree-il/letrectify.scm index c27e75e60..60d057ffd 100644 --- a/module/language/tree-il/letrectify.scm +++ b/module/language/tree-il/letrectify.scm @@ -1,6 +1,6 @@ ;;; transformation of top-level bindings into letrec* -;; Copyright (C) 2019-2020 Free Software Foundation, Inc. +;; Copyright (C) 2019-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 @@ -252,6 +252,24 @@ (add-statement src init (make-void src)))) mod-vars))))))) + (($ <let> src names vars vals body) + (let lp ((names names) (vars vars) (vals vals) (mod-vars mod-vars)) + (match (vector names vars vals) + (#(() () ()) + (values (visit-expr body) mod-vars)) + (#((name . names) (var . vars) (val . vals)) + (let* ((val (visit-expr val)) + (mod-vars + (match val + (($ <call> _ + ($ <module-ref> _ '(guile) 'define-module* #f) + (($ <const> _ mod) . args)) + (acons mod var mod-vars)) + (_ mod-vars)))) + (let-values (((exp mod-vars) (lp names vars vals mod-vars))) + (values (add-binding name var val exp) + mod-vars))))))) + (($ <seq> src head tail) (let*-values (((head mod-vars) (visit-top-level head mod-vars)) ((tail mod-vars) (visit-top-level tail mod-vars))) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index c080bbbc2..b1d8b8294 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -1,6 +1,6 @@ ;;; Tree-il optimizer -;; Copyright (C) 2009, 2010-2015, 2018-2020 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2010-2015, 2018-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 @@ -39,22 +39,27 @@ 'proc))))) (let ((verify (or (lookup #:verify-tree-il? debug verify-tree-il) (lambda (exp) exp))) + (modulify (lookup #:resolve-free-vars? resolve-free-vars)) (resolve (lookup #:resolve-primitives? primitives resolve-primitives)) (expand (lookup #:expand-primitives? primitives expand-primitives)) (letrectify (lookup #:letrectify? letrectify)) (seal? (assq-ref opts #:seal-private-bindings?)) + (xinline? (assq-ref opts #:cross-module-inlining?)) (peval (lookup #:partial-eval? peval)) - (eta-expand (lookup #:eta-expand? eta-expand))) + (eta-expand (lookup #:eta-expand? eta-expand)) + (inlinables (lookup #:inlinable-exports? inlinable-exports))) (define-syntax-rule (run-pass! (proc exp arg ...)) (when proc (set! exp (verify (proc exp arg ...))))) (lambda (exp env) (verify exp) + (run-pass! (modulify exp)) (run-pass! (resolve exp env)) (run-pass! (expand exp)) (run-pass! (letrectify exp #:seal-private-bindings? seal?)) (run-pass! (fix-letrec exp)) - (run-pass! (peval exp env)) + (run-pass! (peval exp env #:cross-module-inlining? xinline?)) (run-pass! (eta-expand exp)) + (run-pass! (inlinables exp)) exp))) (define (optimize x env opts) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 123b40384..d910088c9 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -368,7 +368,8 @@ (operand-size-limit 20) (value-size-limit 10) (effort-limit 500) - (recursive-effort-limit 100)) + (recursive-effort-limit 100) + (cross-module-inlining? #f)) "Partially evaluate EXP in compilation environment CENV, with top-level bindings from ENV and return the resulting expression." @@ -431,14 +432,54 @@ top-level bindings from ENV and return the resulting expression." (define (lexical-refcount sym) (var-refcount (lookup-var sym))) + (define (splice-expression exp) + (define vars (make-hash-table)) + (define (rename! old*) + (match old* + (() '()) + ((old . old*) + (cons (let ((new (gensym "t"))) + (hashq-set! vars old new) + new) + (rename! old*))))) + (define (new-name old) (hashq-ref vars old)) + (define renamed + (pre-order + (match-lambda + (($ <lexical-ref> src name gensym) + (make-lexical-ref src name (new-name gensym))) + (($ <lexical-set> src name gensym exp) + (make-lexical-set src name (new-name gensym) exp)) + (($ <lambda-case> src req opt rest kw init gensyms body alt) + (let ((gensyms (rename! gensyms))) + (make-lambda-case src req opt rest + (match kw + ((aok? (kw name sym) ...) + (cons aok? + (map (lambda (kw name sym) + (list kw name (new-name sym))) + kw name sym))) + (#f #f)) + init gensyms body alt))) + (($ <let> src names gensyms vals body) + (make-let src names (rename! gensyms) vals body)) + (($ <letrec>) + (error "unexpected letrec")) + (($ <fix> src names gensyms vals body) + (make-fix src names (rename! gensyms) vals body)) + (exp exp)) + exp)) + (set! store (build-var-table renamed store)) + renamed) + (define (with-temporaries src exps refcount can-copy? k) (let* ((pairs (map (match-lambda - ((and exp (? can-copy?)) - (cons #f exp)) - (exp - (let ((sym (gensym "tmp "))) - (record-new-temporary! 'tmp sym refcount) - (cons sym exp)))) + ((and exp (? can-copy?)) + (cons #f exp)) + (exp + (let ((sym (gensym "tmp "))) + (record-new-temporary! 'tmp sym refcount) + (cons sym exp)))) exps)) (tmps (filter car pairs))) (match tmps @@ -449,9 +490,9 @@ top-level bindings from ENV and return the resulting expression." (map car tmps) (map cdr tmps) (k (map (match-lambda - ((#f . val) val) - ((sym . _) - (make-lexical-ref #f 'tmp sym))) + ((#f . val) val) + ((sym . _) + (make-lexical-ref #f 'tmp sym))) pairs))))))) (define (make-begin0 src first second) @@ -506,14 +547,14 @@ top-level bindings from ENV and return the resulting expression." (define (apply-primitive name args) ;; todo: further optimize commutative primitives (catch #t - (lambda () - (call-with-values - (lambda () - (apply (module-ref the-scm-module name) args)) - (lambda results - (values #t results)))) - (lambda _ - (values #f '())))) + (lambda () + (call-with-values + (lambda () + (apply (module-ref the-scm-module name) args)) + (lambda results + (values #t results)))) + (lambda _ + (values #f '())))) (define (make-values src values) (match values ((single) single) ; 1 value @@ -1027,8 +1068,45 @@ top-level bindings from ENV and return the resulting expression." (make-primitive-ref src name) exp)) exp))) - (($ <module-ref>) - exp) + (($ <module-ref> src module name public?) + (cond + ((and cross-module-inlining? + public? + (and=> (resolve-interface module) + (lambda (module) + (and=> (module-inlinable-exports module) + (lambda (proc) (proc name)))))) + => (lambda (inlined) + ;; Similar logic to lexical-ref, but we can't enumerate + ;; uses, and don't know about aliases. + (log 'begin-xm-copy exp inlined) + (cond + ((eq? ctx 'effect) + (log 'xm-effect) + (make-void #f)) + ((eq? ctx 'call) + ;; Don't propagate copies if we are residualizing a call. + (log 'residualize-xm-call exp) + exp) + ((or (const? inlined) (void? inlined) (primitive-ref? inlined)) + ;; Always propagate simple values that cannot lead to + ;; code bloat. + (log 'copy-xm-const) + (for-tail inlined)) + ;; Inline in operator position if it's a lambda that's + ;; small enough. Normally the inlinable-exports pass + ;; will only make small lambdas available for inlining, + ;; but you never know. + ((and (eq? ctx 'operator) (lambda? inlined) + (small-expression? inlined operator-size-limit)) + (log 'copy-xm-operator exp inlined) + (splice-expression inlined)) + (else + (log 'xm-copy-failed) + ;; Could copy small lambdas in value context. Something + ;; to revisit. + exp)))) + (else exp))) (($ <module-set> src mod name public? exp) (make-module-set src mod name public? (for-value exp))) (($ <toplevel-define> src mod name exp) @@ -1146,55 +1224,55 @@ top-level bindings from ENV and return the resulting expression." (with-temporaries src (list w u) 2 constant-expression? (match-lambda - ((w u) - (make-seq - src + ((w u) (make-seq src - (make-conditional + (make-seq src - ;; fixme: introduce logic to fold thunk? - (make-primcall src 'thunk? (list u)) - (make-call src w '()) - (make-primcall - src 'throw - (list - (make-const #f 'wrong-type-arg) - (make-const #f "dynamic-wind") - (make-const #f "Wrong type (expecting thunk): ~S") - (make-primcall #f 'list (list u)) - (make-primcall #f 'list (list u))))) - (make-primcall src 'wind (list w u))) - (make-begin0 src - (make-call src thunk '()) - (make-seq src - (make-primcall src 'unwind '()) - (make-call src u '()))))))))) + (make-conditional + src + ;; fixme: introduce logic to fold thunk? + (make-primcall src 'thunk? (list u)) + (make-call src w '()) + (make-primcall + src 'throw + (list + (make-const #f 'wrong-type-arg) + (make-const #f "dynamic-wind") + (make-const #f "Wrong type (expecting thunk): ~S") + (make-primcall #f 'list (list u)) + (make-primcall #f 'list (list u))))) + (make-primcall src 'wind (list w u))) + (make-begin0 src + (make-call src thunk '()) + (make-seq src + (make-primcall src 'unwind '()) + (make-call src u '()))))))))) (($ <primcall> src 'with-fluid* (f v thunk)) (for-tail (with-temporaries src (list f v thunk) 1 constant-expression? (match-lambda - ((f v thunk) - (make-seq src - (make-primcall src 'push-fluid (list f v)) - (make-begin0 src - (make-call src thunk '()) - (make-primcall src 'pop-fluid '())))))))) + ((f v thunk) + (make-seq src + (make-primcall src 'push-fluid (list f v)) + (make-begin0 src + (make-call src thunk '()) + (make-primcall src 'pop-fluid '())))))))) (($ <primcall> src 'with-dynamic-state (state thunk)) (for-tail (with-temporaries src (list state thunk) 1 constant-expression? (match-lambda - ((state thunk) - (make-seq src - (make-primcall src 'push-dynamic-state (list state)) - (make-begin0 src - (make-call src thunk '()) - (make-primcall src 'pop-dynamic-state - '())))))))) + ((state thunk) + (make-seq src + (make-primcall src 'push-dynamic-state (list state)) + (make-begin0 src + (make-call src thunk '()) + (make-primcall src 'pop-dynamic-state + '())))))))) (($ <primcall> src 'values exps) (cond @@ -1379,7 +1457,7 @@ top-level bindings from ENV and return the resulting expression." (((? equality-primitive?) (and a ($ <const>)) b) (for-tail (make-primcall src name (list b a)))) (((? equality-primitive?) ($ <lexical-ref> _ _ sym) - ($ <lexical-ref> _ _ sym)) + ($ <lexical-ref> _ _ sym)) (for-tail (make-const src #t))) (('logbit? ($ <const> src2 @@ -1660,8 +1738,8 @@ top-level bindings from ENV and return the resulting expression." ($ <lambda-case> _ (_ . _) _ _ _ _ (k . _) body #f)) (not (tree-il-any (match-lambda - (($ <lexical-ref> _ _ (? (cut eq? <> k))) #t) - (_ #f)) + (($ <lexical-ref> _ _ (? (cut eq? <> k))) #t) + (_ #f)) body))) (else #f))) (if (and (not escape-only?) (escape-only-handler? handler)) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 1cc7907a8..7f3746b4f 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -48,6 +48,7 @@ memq memv = < > <= >= zero? positive? negative? + * - / 1- 1+ quotient remainder modulo exact->inexact + expt ash logand logior logxor lognot logtest logbit? sqrt abs floor ceiling sin cos tan asin acos atan not @@ -171,7 +172,7 @@ `(values eq? eqv? equal? = < > <= >= zero? positive? negative? - ash logand logior logxor lognot logtest logbit? + expt ash logand logior logxor lognot logtest logbit? + * - / 1- 1+ sqrt abs quotient remainder modulo exact->inexact floor ceiling sin cos tan asin acos atan not diff --git a/module/language/tree-il/resolve-free-vars.scm b/module/language/tree-il/resolve-free-vars.scm new file mode 100644 index 000000000..3d4eb2bb0 --- /dev/null +++ b/module/language/tree-il/resolve-free-vars.scm @@ -0,0 +1,282 @@ +;;; Resolving free top-level references to modules +;;; Copyright (C) 2021 +;;; Free Software Foundation, Inc. +;;; +;;; This library is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + + + +(define-module (language tree-il resolve-free-vars) + #:use-module (ice-9 match) + #:use-module (language tree-il) + #:use-module ((srfi srfi-1) #:select (filter-map)) + #:export (resolve-free-vars)) + +(define (compute-assigned-lexicals exp) + (define assigned-lexicals '()) + (define (add-assigned-lexical! var) + (set! assigned-lexicals (cons var assigned-lexicals))) + ((make-tree-il-folder) + exp + (lambda (exp) + (match exp + (($ <lexical-set> _ _ var _) + (add-assigned-lexical! var) + (values)) + (_ (values)))) + (lambda (exp) + (values))) + assigned-lexicals) + +(define (make-resolver mod local-definitions) + ;; Given that module A imports B and C, and X is free in A, + ;; unfortunately there are a few things preventing us from knowing + ;; whether the binding proceeds from B or C, just based on the text: + ;; + ;; - Renamers are evaluated at run-time. + ;; - Just using B doesn't let us know what definitions are in B. + ;; + ;; So instead of using the source program to determine where a binding + ;; comes from, we use the first-class module interface. + (define (imported-resolver iface) + (let ((public-iface (resolve-interface (module-name iface)))) + (if (eq? iface public-iface) + (lambda (name) + (and (module-variable iface name) + (cons (module-name iface) name))) + (let ((by-var (make-hash-table))) + (module-for-each (lambda (name var) + (hashq-set! by-var var name)) + public-iface) + (lambda (name) + (let ((var (module-variable iface name))) + (and var + (cons (module-name iface) + (hashq-ref by-var var))))))))) + + (define the-module (resolve-module mod)) + (define resolvers + (map imported-resolver (module-uses the-module))) + + (lambda (name) + (cond + ((or (module-local-variable the-module name) + (memq name local-definitions)) + 'local) + (else + (match (filter-map (lambda (resolve) (resolve name)) resolvers) + (() 'unknown) + (((mod . #f)) 'unknown) + (((mod . public-name)) (cons mod public-name)) + ((_ _ . _) 'duplicate)))))) + +;;; Record all bindings in a module, to know whether a toplevel-ref is +;;; an import or not. If toplevel-ref to imported variable, transform +;;; to module-ref or primitive-ref. New pass before peval. + +(define (compute-free-var-resolver exp) + (define assigned-lexicals (compute-assigned-lexicals exp)) + (define module-definitions '()) + (define module-lexicals '()) + (define bindings '()) + (define (add-module-definition! mod args) + (set! module-definitions (acons mod args module-definitions))) + (define (add-module-lexical! var mod) + (unless (memq var assigned-lexicals) + (set! module-lexicals (acons var mod module-lexicals)))) + (define (add-binding! mod name) + (set! bindings (acons mod name bindings))) + + (define (record-bindings! mod vars vals) + (for-each + (lambda (var val) + (match val + (($ <call> _ ($ <module-ref> _ '(guile) 'define-module* #f) + (($ <const> _ mod) . args)) + (add-module-definition! mod args) + (add-module-lexical! var mod)) + (($ <primcall> _ 'current-module ()) + (when mod + (add-module-lexical! var mod))) + (_ #f))) + vars vals)) + + ;; Thread a conservative idea of what the current module is through + ;; the visit. Visiting an expression returns the name of the current + ;; module when the expression completes, or #f if unknown. Record the + ;; define-module* forms, if any, and note any toplevel definitions. + (define (visit exp) (visit/mod exp #f)) + (define (visit* exps) + (unless (null? exps) + (visit (car exps)) + (visit* (cdr exps)))) + (define (visit+ exps mod) + (match exps + (() mod) + ((exp . exps) + (let lp ((mod' (visit/mod exp mod)) (exps exps)) + (match exps + (() mod') + ((exp . exps) + (lp (and (equal? mod' (visit/mod exp mod)) mod') + exps))))))) + (define (visit/mod exp mod) + (match exp + ((or ($ <void>) ($ <const>) ($ <primitive-ref>) ($ <lexical-ref>) + ($ <module-ref>) ($ <toplevel-ref>)) + mod) + + (($ <call> _ ($ <module-ref> _ '(guile) 'set-current-module #f) + (($ <lexical-ref> _ _ var))) + (assq-ref module-lexicals var)) + + (($ <call> _ proc args) + (visit proc) + (visit* args) + #f) + + (($ <primcall> _ _ args) + ;; There is no primcall that sets the current module. + (visit+ args mod)) + + (($ <conditional> src test consequent alternate) + (visit+ (list consequent alternate) (visit/mod test mod))) + + (($ <lexical-set> src name gensym exp) + (visit/mod exp mod)) + + (($ <toplevel-set> src mod name exp) + (visit/mod exp mod)) + + (($ <module-set> src mod name public? exp) + (visit/mod exp mod)) + + (($ <toplevel-define> src mod name exp) + (add-binding! mod name) + (visit/mod exp mod)) + + (($ <lambda> src meta body) + (when body (visit body)) + mod) + + (($ <lambda-case> src req opt rest kw inits gensyms body alternate) + (visit* inits) + (let* ((bodies (cons body inits)) + (bodies (if alternate (cons alternate bodies) bodies))) + (visit+ bodies mod))) + + (($ <seq> src head tail) + (visit/mod tail (visit/mod head mod))) + + (($ <let> src names gensyms vals body) + (record-bindings! mod gensyms vals) + (visit/mod body (visit+ vals mod))) + + (($ <letrec> src in-order? names gensyms vals body) + (record-bindings! mod gensyms vals) + (visit/mod body (visit+ vals mod))) + + (($ <fix> src names gensyms vals body) + (record-bindings! mod gensyms vals) + (visit/mod body (visit+ vals mod))) + + (($ <let-values> src exp body) + (visit/mod body (visit/mod exp mod))) + + (($ <prompt> src escape-only? tag body handler) + (visit+ (list body handler) (visit/mod tag mod))) + + (($ <abort> src tag args tail) + (visit tag) + (visit* args) + (visit tail) + #f))) + + (visit exp) + + (define (kwarg-ref args kw kt kf) + (let lp ((args args)) + (match args + (() (kf)) + ((($ <const> _ (? keyword? kw')) val . args) + (if (eq? kw' kw) + (kt val) + (lp args))) + ((_ _ . args) + (lp args))))) + (define (kwarg-ref/const args kw kt kf) + (kwarg-ref args kw + (lambda (exp) + (match exp + (($ <const> _ val') (kt val')) + (_ (kf)))) + kf)) + (define (has-constant-initarg? args kw val) + (kwarg-ref/const args kw + (lambda (val') + (equal? val val')) + (lambda () #f))) + + ;; Collect declarative modules defined once in this compilation unit. + (define declarative-modules + (let lp ((defs module-definitions) (not-declarative '()) (declarative '())) + (match defs + (() declarative) + (((mod . args) . defs) + (cond ((member mod not-declarative) + (lp defs not-declarative declarative)) + ((or (assoc mod defs) ;; doubly defined? + (not (has-constant-initarg? args #:declarative? #t))) + (lp defs (cons mod not-declarative) declarative)) + (else + (lp defs not-declarative (cons mod declarative)))))))) + + (define resolvers + (map (lambda (mod) + (define resolve + (make-resolver mod + (filter-map (match-lambda + ((mod' . name) + (and (equal? mod mod') name))) + bindings))) + (cons mod resolve)) + declarative-modules)) + + (lambda (mod name) + (cond + ((assoc-ref resolvers mod) + => (lambda (resolve) (resolve name))) + (else 'unknown)))) + +(define (resolve-free-vars exp) + "Traverse @var{exp}, extracting module-level definitions." + (define resolve + (compute-free-var-resolver exp)) + + (post-order + (lambda (exp) + (match exp + (($ <toplevel-ref> src mod name) + (match (resolve mod name) + ((or 'unknown 'duplicate 'local) exp) + ((mod . name) + (make-module-ref src mod name #t)))) + (($ <toplevel-set> src mod name val) + (match (resolve mod name) + ((or 'unknown 'duplicate 'local) exp) + ((mod . name) + (make-module-set src mod name #t val)))) + (exp exp))) + exp)) |