mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
8bf77f7192
* libguile/frames.c (enum stack_item_representation): (scm_to_stack_item_representation): (scm_frame_local_ref, scm_frame_local_set_x): Support for S64 representations. * libguile/frames.h (union scm_vm_stack_element): Add signed 64-bit integer field. * libguile/vm-engine.c (scm->s64, s64->scm, load-s64): New instructions. * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/cse.scm (compute-equivalent-subexpressions): * module/language/cps/effects-analysis.scm: * module/language/cps/slot-allocation.scm (compute-var-representations) (compute-needs-slot, allocate-slots): * module/language/cps/utils.scm (compute-constant-values): * module/language/cps/specialize-primcalls.scm (specialize-primcalls): Add support for new primcalls. * module/language/cps/types.scm (&s64): New type. (&s64-min, &s64-max, &u64-max): New convenience definitions. (&range-min, &range-max): Use &s64-min and &u64-max names. (scm->s64, load-s64, s64->scm): Add support for new primcalls. * module/system/vm/assembler.scm (emit-scm->s64, emit-s64->scm) (emit-load-s64): New exports. * module/system/vm/assembler.scm (write-arities): Support for s64 slots. * module/system/vm/debug.scm (arity-definitions): Support for s64 slots.
457 lines
19 KiB
Scheme
457 lines
19 KiB
Scheme
;;; Continuation-passing style (CPS) intermediate language (IL)
|
|
|
|
;; Copyright (C) 2013, 2014, 2015 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:
|
|
;;;
|
|
;;; Common subexpression elimination for CPS.
|
|
;;;
|
|
;;; Code:
|
|
|
|
(define-module (language cps cse)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-11)
|
|
#:use-module (language cps)
|
|
#:use-module (language cps utils)
|
|
#:use-module (language cps effects-analysis)
|
|
#:use-module (language cps intmap)
|
|
#:use-module (language cps intset)
|
|
#:export (eliminate-common-subexpressions))
|
|
|
|
(define (intset-pop set)
|
|
(match (intset-next set)
|
|
(#f (values set #f))
|
|
(i (values (intset-remove set i) i))))
|
|
|
|
(define-syntax-rule (make-worklist-folder* seed ...)
|
|
(lambda (f worklist seed ...)
|
|
(let lp ((worklist worklist) (seed seed) ...)
|
|
(call-with-values (lambda () (intset-pop worklist))
|
|
(lambda (worklist i)
|
|
(if i
|
|
(call-with-values (lambda () (f i seed ...))
|
|
(lambda (i* seed ...)
|
|
(let add ((i* i*) (worklist worklist))
|
|
(match i*
|
|
(() (lp worklist seed ...))
|
|
((i . i*) (add i* (intset-add worklist i)))))))
|
|
(values seed ...)))))))
|
|
|
|
(define worklist-fold*
|
|
(case-lambda
|
|
((f worklist seed)
|
|
((make-worklist-folder* seed) f worklist seed))))
|
|
|
|
(define (compute-available-expressions conts kfun effects)
|
|
"Compute and return a map of LABEL->ANCESTOR..., where ANCESTOR... is
|
|
an intset containing ancestor labels whose value is available at LABEL."
|
|
(define (propagate avail succ out)
|
|
(let* ((in (intmap-ref avail succ (lambda (_) #f)))
|
|
(in* (if in (intset-intersect in out) out)))
|
|
(if (eq? in in*)
|
|
(values '() avail)
|
|
(values (list succ)
|
|
(intmap-add avail succ in* (lambda (old new) new))))))
|
|
|
|
(define (clobber label in)
|
|
(let ((fx (intmap-ref effects label)))
|
|
(cond
|
|
((not (causes-effect? fx &write))
|
|
;; Fast-path if this expression clobbers nothing.
|
|
in)
|
|
(else
|
|
;; Kill clobbered expressions. FIXME: there is no need to check
|
|
;; on any label before than the last dominating label that
|
|
;; clobbered everything. Another way to speed things up would
|
|
;; be to compute a clobber set per-effect, which we could
|
|
;; subtract from "in".
|
|
(let lp ((label 0) (in in))
|
|
(cond
|
|
((intset-next in label)
|
|
=> (lambda (label)
|
|
(if (effect-clobbers? fx (intmap-ref effects label))
|
|
(lp (1+ label) (intset-remove in label))
|
|
(lp (1+ label) in))))
|
|
(else in)))))))
|
|
|
|
(define (visit-cont label avail)
|
|
(let* ((in (intmap-ref avail label))
|
|
(out (intset-add (clobber label in) label)))
|
|
(define (propagate0)
|
|
(values '() avail))
|
|
(define (propagate1 succ)
|
|
(propagate avail succ out))
|
|
(define (propagate2 succ0 succ1)
|
|
(let*-values (((changed0 avail) (propagate avail succ0 out))
|
|
((changed1 avail) (propagate avail succ1 out)))
|
|
(values (append changed0 changed1) avail)))
|
|
|
|
(match (intmap-ref conts label)
|
|
(($ $kargs names vars ($ $continue k src exp))
|
|
(match exp
|
|
(($ $branch kt) (propagate2 k kt))
|
|
(($ $prompt escape? tag handler) (propagate2 k handler))
|
|
(_ (propagate1 k))))
|
|
(($ $kreceive arity k)
|
|
(propagate1 k))
|
|
(($ $kfun src meta self tail clause)
|
|
(if clause
|
|
(propagate1 clause)
|
|
(propagate0)))
|
|
(($ $kclause arity kbody kalt)
|
|
(if kalt
|
|
(propagate2 kbody kalt)
|
|
(propagate1 kbody)))
|
|
(($ $ktail) (propagate0)))))
|
|
|
|
(worklist-fold* visit-cont
|
|
(intset kfun)
|
|
(intmap-add empty-intmap kfun empty-intset)))
|
|
|
|
(define (compute-truthy-expressions conts kfun)
|
|
"Compute a \"truth map\", indicating which expressions can be shown to
|
|
be true and/or false at each label in the function starting at KFUN..
|
|
Returns an intmap of intsets. The even elements of the intset indicate
|
|
labels that may be true, and the odd ones indicate those that may be
|
|
false. It could be that both true and false proofs are available."
|
|
(define (true-idx label) (ash label 1))
|
|
(define (false-idx label) (1+ (ash label 1)))
|
|
|
|
(define (propagate boolv succ out)
|
|
(let* ((in (intmap-ref boolv succ (lambda (_) #f)))
|
|
(in* (if in (intset-intersect in out) out)))
|
|
(if (eq? in in*)
|
|
(values '() boolv)
|
|
(values (list succ)
|
|
(intmap-add boolv succ in* (lambda (old new) new))))))
|
|
|
|
(define (visit-cont label boolv)
|
|
(let ((in (intmap-ref boolv label)))
|
|
(define (propagate0)
|
|
(values '() boolv))
|
|
(define (propagate1 succ)
|
|
(propagate boolv succ in))
|
|
(define (propagate2 succ0 succ1)
|
|
(let*-values (((changed0 boolv) (propagate boolv succ0 in))
|
|
((changed1 boolv) (propagate boolv succ1 in)))
|
|
(values (append changed0 changed1) boolv)))
|
|
(define (propagate-branch succ0 succ1)
|
|
(let*-values (((changed0 boolv)
|
|
(propagate boolv succ0
|
|
(intset-add in (false-idx label))))
|
|
((changed1 boolv)
|
|
(propagate boolv succ1
|
|
(intset-add in (true-idx label)))))
|
|
(values (append changed0 changed1) boolv)))
|
|
|
|
(match (intmap-ref conts label)
|
|
(($ $kargs names vars ($ $continue k src exp))
|
|
(match exp
|
|
(($ $branch kt) (propagate-branch k kt))
|
|
(($ $prompt escape? tag handler) (propagate2 k handler))
|
|
(_ (propagate1 k))))
|
|
(($ $kreceive arity k)
|
|
(propagate1 k))
|
|
(($ $kfun src meta self tail clause)
|
|
(if clause
|
|
(propagate1 clause)
|
|
(propagate0)))
|
|
(($ $kclause arity kbody kalt)
|
|
(if kalt
|
|
(propagate2 kbody kalt)
|
|
(propagate1 kbody)))
|
|
(($ $ktail) (propagate0)))))
|
|
|
|
(intset-fold
|
|
(lambda (kfun boolv)
|
|
(worklist-fold* visit-cont
|
|
(intset kfun)
|
|
(intmap-add boolv kfun empty-intset)))
|
|
(intmap-keys (compute-reachable-functions conts kfun))
|
|
empty-intmap))
|
|
|
|
(define (intset-map f set)
|
|
(persistent-intmap
|
|
(intset-fold (lambda (i out) (intmap-add! out i (f i)))
|
|
set
|
|
empty-intmap)))
|
|
|
|
;; Returns a map of label-idx -> (var-idx ...) indicating the variables
|
|
;; defined by a given labelled expression.
|
|
(define (compute-defs conts kfun)
|
|
(intset-map (lambda (label)
|
|
(match (intmap-ref conts label)
|
|
(($ $kfun src meta self tail clause)
|
|
(list self))
|
|
(($ $kclause arity body alt)
|
|
(match (intmap-ref conts body)
|
|
(($ $kargs names vars) vars)))
|
|
(($ $kreceive arity kargs)
|
|
(match (intmap-ref conts kargs)
|
|
(($ $kargs names vars) vars)))
|
|
(($ $ktail)
|
|
'())
|
|
(($ $kargs names vars ($ $continue k))
|
|
(match (intmap-ref conts k)
|
|
(($ $kargs names vars) vars)
|
|
(_ #f)))))
|
|
(compute-function-body conts kfun)))
|
|
|
|
(define (compute-singly-referenced succs)
|
|
(define (visit label succs single multiple)
|
|
(intset-fold (lambda (label single multiple)
|
|
(if (intset-ref single label)
|
|
(values single (intset-add! multiple label))
|
|
(values (intset-add! single label) multiple)))
|
|
succs single multiple))
|
|
(call-with-values (lambda ()
|
|
(intmap-fold visit succs empty-intset empty-intset))
|
|
(lambda (single multiple)
|
|
(intset-subtract (persistent-intset single)
|
|
(persistent-intset multiple)))))
|
|
|
|
(define (compute-equivalent-subexpressions conts kfun effects)
|
|
(define (visit-fun kfun equiv-labels var-substs)
|
|
(let* ((succs (compute-successors conts kfun))
|
|
(singly-referenced (compute-singly-referenced succs))
|
|
(avail (compute-available-expressions conts kfun effects))
|
|
(defs (compute-defs conts kfun))
|
|
(equiv-set (make-hash-table)))
|
|
(define (subst-var var-substs var)
|
|
(intmap-ref var-substs var (lambda (var) var)))
|
|
(define (subst-vars var-substs vars)
|
|
(let lp ((vars vars))
|
|
(match vars
|
|
(() '())
|
|
((var . vars) (cons (subst-var var-substs var) (lp vars))))))
|
|
|
|
(define (compute-exp-key var-substs exp)
|
|
(match exp
|
|
(($ $const val) (cons 'const val))
|
|
(($ $prim name) (cons 'prim name))
|
|
(($ $fun body) #f)
|
|
(($ $rec names syms funs) #f)
|
|
(($ $closure label nfree) #f)
|
|
(($ $call proc args) #f)
|
|
(($ $callk k proc args) #f)
|
|
(($ $primcall name args)
|
|
(cons* 'primcall name (subst-vars var-substs args)))
|
|
(($ $branch _ ($ $primcall name args))
|
|
(cons* 'primcall name (subst-vars var-substs args)))
|
|
(($ $branch) #f)
|
|
(($ $values args) #f)
|
|
(($ $prompt escape? tag handler) #f)))
|
|
|
|
(define (add-auxiliary-definitions! label var-substs exp-key)
|
|
(define (subst var)
|
|
(subst-var var-substs var))
|
|
(let ((defs (intmap-ref defs label)))
|
|
(define (add-def! aux-key var)
|
|
(let ((equiv (hash-ref equiv-set aux-key '())))
|
|
(hash-set! equiv-set aux-key
|
|
(acons label (list var) equiv))))
|
|
(match exp-key
|
|
(('primcall 'box val)
|
|
(match defs
|
|
((box)
|
|
(add-def! `(primcall box-ref ,(subst box)) val))))
|
|
(('primcall 'box-set! box val)
|
|
(add-def! `(primcall box-ref ,box) val))
|
|
(('primcall 'cons car cdr)
|
|
(match defs
|
|
((pair)
|
|
(add-def! `(primcall car ,(subst pair)) car)
|
|
(add-def! `(primcall cdr ,(subst pair)) cdr))))
|
|
(('primcall 'set-car! pair car)
|
|
(add-def! `(primcall car ,pair) car))
|
|
(('primcall 'set-cdr! pair cdr)
|
|
(add-def! `(primcall cdr ,pair) cdr))
|
|
(('primcall (or 'make-vector 'make-vector/immediate) len fill)
|
|
(match defs
|
|
((vec)
|
|
(add-def! `(primcall vector-length ,(subst vec)) len))))
|
|
(('primcall 'vector-set! vec idx val)
|
|
(add-def! `(primcall vector-ref ,vec ,idx) val))
|
|
(('primcall 'vector-set!/immediate vec idx val)
|
|
(add-def! `(primcall vector-ref/immediate ,vec ,idx) val))
|
|
(('primcall (or 'allocate-struct 'allocate-struct/immediate)
|
|
vtable size)
|
|
(match defs
|
|
((struct)
|
|
(add-def! `(primcall struct-vtable ,(subst struct))
|
|
vtable))))
|
|
(('primcall 'struct-set! struct n val)
|
|
(add-def! `(primcall struct-ref ,struct ,n) val))
|
|
(('primcall 'struct-set!/immediate struct n val)
|
|
(add-def! `(primcall struct-ref/immediate ,struct ,n) val))
|
|
(('primcall 'scm->f64 scm)
|
|
(match defs
|
|
((f64)
|
|
(add-def! `(primcall f64->scm ,f64) scm))))
|
|
(('primcall 'f64->scm f64)
|
|
(match defs
|
|
((scm)
|
|
(add-def! `(primcall scm->f64 ,scm) f64))))
|
|
(('primcall 'scm->u64 scm)
|
|
(match defs
|
|
((u64)
|
|
(add-def! `(primcall u64->scm ,u64) scm))))
|
|
(('primcall 'u64->scm u64)
|
|
(match defs
|
|
((scm)
|
|
(add-def! `(primcall scm->u64 ,scm) u64))))
|
|
(('primcall 'scm->s64 scm)
|
|
(match defs
|
|
((s64)
|
|
(add-def! `(primcall s64->scm ,s64) scm))))
|
|
(('primcall 's64->scm s64)
|
|
(match defs
|
|
((scm)
|
|
(add-def! `(primcall scm->s64 ,scm) s64))))
|
|
(_ #t))))
|
|
|
|
(define (visit-label label equiv-labels var-substs)
|
|
(match (intmap-ref conts label)
|
|
(($ $kargs names vars ($ $continue k src exp))
|
|
(let* ((exp-key (compute-exp-key var-substs exp))
|
|
(equiv (hash-ref equiv-set exp-key '()))
|
|
(fx (intmap-ref effects label))
|
|
(avail (intmap-ref avail label)))
|
|
(define (finish equiv-labels var-substs)
|
|
;; If this expression defines auxiliary definitions,
|
|
;; as `cons' does for the results of `car' and `cdr',
|
|
;; define those. Do so after finding equivalent
|
|
;; expressions, so that we can take advantage of
|
|
;; subst'd output vars.
|
|
(add-auxiliary-definitions! label var-substs exp-key)
|
|
(values equiv-labels var-substs))
|
|
(let lp ((candidates equiv))
|
|
(match candidates
|
|
(()
|
|
;; No matching expressions. Add our expression
|
|
;; to the equivalence set, if appropriate. Note
|
|
;; that expressions that allocate a fresh object
|
|
;; or change the current fluid environment can't
|
|
;; be eliminated by CSE (though DCE might do it
|
|
;; if the value proves to be unused, in the
|
|
;; allocation case).
|
|
(when (and exp-key
|
|
(not (causes-effect? fx &allocation))
|
|
(not (effect-clobbers? fx (&read-object &fluid))))
|
|
(let ((defs (and (intset-ref singly-referenced k)
|
|
(intmap-ref defs label))))
|
|
(when defs
|
|
(hash-set! equiv-set exp-key
|
|
(acons label defs equiv)))))
|
|
(finish equiv-labels var-substs))
|
|
(((and head (candidate . vars)) . candidates)
|
|
(cond
|
|
((not (intset-ref avail candidate))
|
|
;; This expression isn't available here; try
|
|
;; the next one.
|
|
(lp candidates))
|
|
(else
|
|
;; Yay, a match. Mark expression as equivalent. If
|
|
;; we provide the definitions for the successor, mark
|
|
;; the vars for substitution.
|
|
(finish (intmap-add equiv-labels label head)
|
|
(let ((defs (and (intset-ref singly-referenced k)
|
|
(intmap-ref defs label))))
|
|
(if defs
|
|
(fold (lambda (def var var-substs)
|
|
(intmap-add var-substs def var))
|
|
var-substs defs vars)
|
|
var-substs))))))))))
|
|
(_ (values equiv-labels var-substs))))
|
|
|
|
;; Traverse the labels in fun in reverse post-order, which will
|
|
;; visit definitions before uses first.
|
|
(fold2 visit-label
|
|
(compute-reverse-post-order succs kfun)
|
|
equiv-labels
|
|
var-substs)))
|
|
|
|
(intset-fold visit-fun
|
|
(intmap-keys (compute-reachable-functions conts kfun))
|
|
empty-intmap
|
|
empty-intmap))
|
|
|
|
(define (apply-cse conts equiv-labels var-substs truthy-labels)
|
|
(define (true-idx idx) (ash idx 1))
|
|
(define (false-idx idx) (1+ (ash idx 1)))
|
|
|
|
(define (subst-var var)
|
|
(intmap-ref var-substs var (lambda (var) var)))
|
|
|
|
(define (visit-exp exp)
|
|
(rewrite-exp exp
|
|
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) ,exp)
|
|
(($ $call proc args)
|
|
($call (subst-var proc) ,(map subst-var args)))
|
|
(($ $callk k proc args)
|
|
($callk k (subst-var proc) ,(map subst-var args)))
|
|
(($ $primcall name args)
|
|
($primcall name ,(map subst-var args)))
|
|
(($ $branch k exp)
|
|
($branch k ,(visit-exp exp)))
|
|
(($ $values args)
|
|
($values ,(map subst-var args)))
|
|
(($ $prompt escape? tag handler)
|
|
($prompt escape? (subst-var tag) handler))))
|
|
|
|
(intmap-map
|
|
(lambda (label cont)
|
|
(match cont
|
|
(($ $kargs names vars ($ $continue k src exp))
|
|
(build-cont
|
|
($kargs names vars
|
|
,(match (intmap-ref equiv-labels label (lambda (_) #f))
|
|
((equiv . vars)
|
|
(match exp
|
|
(($ $branch kt exp)
|
|
(let* ((bool (intmap-ref truthy-labels label))
|
|
(t (intset-ref bool (true-idx equiv)))
|
|
(f (intset-ref bool (false-idx equiv))))
|
|
(if (eqv? t f)
|
|
(build-term
|
|
($continue k src
|
|
($branch kt ,(visit-exp exp))))
|
|
(build-term
|
|
($continue (if t kt k) src ($values ()))))))
|
|
(_
|
|
;; For better or for worse, we only replace primcalls
|
|
;; if they have an associated VM op, which allows
|
|
;; them to continue to $kargs and thus we know their
|
|
;; defs and can use a $values expression instead of a
|
|
;; values primcall.
|
|
(build-term
|
|
($continue k src ($values vars))))))
|
|
(#f
|
|
(build-term
|
|
($continue k src ,(visit-exp exp))))))))
|
|
(_ cont)))
|
|
conts))
|
|
|
|
(define (eliminate-common-subexpressions conts)
|
|
(call-with-values
|
|
(lambda ()
|
|
(let ((effects (synthesize-definition-effects (compute-effects conts))))
|
|
(compute-equivalent-subexpressions conts 0 effects)))
|
|
(lambda (equiv-labels var-substs)
|
|
(let ((truthy-labels (compute-truthy-expressions conts 0)))
|
|
(apply-cse conts equiv-labels var-substs truthy-labels)))))
|