summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
Diffstat (limited to 'module/language')
-rw-r--r--module/language/cps/cse.scm8
-rw-r--r--module/language/cps/dump.scm317
-rw-r--r--module/language/cps/effects-analysis.scm81
-rw-r--r--module/language/cps/graphs.scm88
-rw-r--r--module/language/cps/slot-allocation.scm214
-rw-r--r--module/language/cps/types.scm2
-rw-r--r--module/language/cps/utils.scm174
-rw-r--r--module/language/tree-il/compile-bytecode.scm6
-rw-r--r--module/language/tree-il/compile-cps.scm11
-rw-r--r--module/language/tree-il/inlinable-exports.scm869
-rw-r--r--module/language/tree-il/letrectify.scm20
-rw-r--r--module/language/tree-il/optimize.scm11
-rw-r--r--module/language/tree-il/peval.scm192
-rw-r--r--module/language/tree-il/primitives.scm3
-rw-r--r--module/language/tree-il/resolve-free-vars.scm282
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))