X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/091dd0cc58ea54c71bdef2e5804cf21095b342d5..a9ec16f9c5574d80f66c173b495285579f5894b4:/module/language/cps/arities.scm diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm index 10056831c..479d56dcb 100644 --- a/module/language/cps/arities.scm +++ b/module/language/cps/arities.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013 Free Software Foundation, Inc. +;; 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 @@ -32,79 +32,101 @@ #:use-module (language cps primitives) #:export (fix-arities)) -(define (fix-clause-arities clause) - (let ((conts (build-local-cont-table clause)) - (ktail (match clause - (($ $cont _ ($ $kentry _ ($ $cont ktail) _)) ktail)))) +(define (fix-arities* clause dfg) + (let ((ktail (match clause + (($ $cont _ + ($ $kfun src meta _ ($ $cont ktail) _)) ktail)))) (define (visit-term term) (rewrite-cps-term term (($ $letk conts body) ($letk ,(map visit-cont conts) ,(visit-term body))) (($ $letrec names syms funs body) - ($letrec names syms (map fix-arities funs) ,(visit-term body))) + ($letrec names syms (map (lambda (fun) + (rewrite-cps-exp fun + (($ $fun free body) + ($fun free ,(fix-arities* body dfg))))) + funs) + ,(visit-term body))) (($ $continue k src exp) ,(visit-exp k src exp)))) (define (adapt-exp nvals k src exp) (match nvals (0 - (rewrite-cps-term (lookup-cont k conts) + (rewrite-cps-term (lookup-cont k dfg) (($ $ktail) - ,(let-gensyms (kvoid kunspec unspec) + ,(let-fresh (kvoid kunspec) (unspec) (build-cps-term ($letk* ((kunspec ($kargs (unspec) (unspec) ($continue k src ($primcall 'return (unspec))))) (kvoid ($kargs () () - ($continue kunspec src ($void))))) + ($continue kunspec src + ($const *unspecified*))))) ($continue kvoid src ,exp))))) - (($ $ktrunc arity kargs) - ,(rewrite-cps-term arity - (($ $arity () () #f () #f) - ($continue kargs src ,exp)) + (($ $kreceive arity kargs) + ,(match arity + (($ $arity () () rest () #f) + (if rest + (let-fresh (knil) () + (build-cps-term + ($letk ((knil ($kargs () () + ($continue kargs src ($const '()))))) + ($continue knil src ,exp)))) + (build-cps-term + ($continue kargs src ,exp)))) (_ - ,(let-gensyms (kvoid kvalues void) - (build-cps-term - ($letk* ((kvalues ($kargs ('void) (void) - ($continue k src - ($primcall 'values (void))))) - (kvoid ($kargs () () - ($continue kvalues src - ($void))))) - ($continue kvoid src ,exp))))))) + (let-fresh (kvoid kvalues) (void) + (build-cps-term + ($letk* ((kvalues ($kargs ('void) (void) + ($continue k src + ($primcall 'values (void))))) + (kvoid ($kargs () () + ($continue kvalues src + ($const *unspecified*))))) + ($continue kvoid src ,exp))))))) (($ $kargs () () _) ($continue k src ,exp)) (_ - ,(let-gensyms (k*) + ,(let-fresh (k*) () (build-cps-term - ($letk ((k* ($kargs () () ($continue k src ($void))))) + ($letk ((k* ($kargs () () ($continue k src + ($const *unspecified*))))) ($continue k* src ,exp))))))) (1 - (rewrite-cps-term (lookup-cont k conts) + (rewrite-cps-term (lookup-cont k dfg) (($ $ktail) ,(rewrite-cps-term exp - (($values (sym)) + (($ $values (sym)) ($continue ktail src ($primcall 'return (sym)))) (_ - ,(let-gensyms (k* v) + ,(let-fresh (k*) (v) (build-cps-term ($letk ((k* ($kargs (v) (v) ($continue k src ($primcall 'return (v)))))) ($continue k* src ,exp))))))) - (($ $ktrunc arity kargs) - ,(rewrite-cps-term arity - (($ $arity (_) () #f () #f) - ($continue kargs src ,exp)) + (($ $kreceive arity kargs) + ,(match arity + (($ $arity (_) () rest () #f) + (if rest + (let-fresh (kval) (val nil) + (build-cps-term + ($letk ((kval ($kargs ('val) (val) + ($letconst (('nil nil '())) + ($continue kargs src + ($values (val nil))))))) + ($continue kval src ,exp)))) + (build-cps-term ($continue kargs src ,exp)))) (_ - ,(let-gensyms (kvalues value) - (build-cps-term - ($letk ((kvalues ($kargs ('value) (value) - ($continue k src - ($primcall 'values (value)))))) - ($continue kvalues src ,exp))))))) + (let-fresh (kvalues) (value) + (build-cps-term + ($letk ((kvalues ($kargs ('value) (value) + ($continue k src + ($primcall 'values (value)))))) + ($continue kvalues src ,exp))))))) (($ $kargs () () _) - ,(let-gensyms (k* drop) + ,(let-fresh (k*) (drop) (build-cps-term ($letk ((k* ($kargs ('drop) (drop) ($continue k src ($values ()))))) @@ -114,24 +136,27 @@ (define (visit-exp k src exp) (rewrite-cps-term exp - ((or ($ $void) - ($ $const) + ((or ($ $const) ($ $prim) ($ $values (_))) ,(adapt-exp 1 k src exp)) - (($ $fun) - ,(adapt-exp 1 k src (fix-arities exp))) - (($ $call) + (($ $fun free body) + ,(adapt-exp 1 k src (build-cps-exp + ($fun free ,(fix-arities* body dfg))))) + ((or ($ $call) ($ $callk)) ;; In general, calls have unknown return arity. For that - ;; reason every non-tail call has an implicit adaptor - ;; continuation to adapt the return to the target - ;; continuation, and we don't need to do any adapting here. + ;; reason every non-tail call has a $kreceive continuation to + ;; adapt the return to the target continuation, and we don't + ;; need to do any adapting here. + ($continue k src ,exp)) + (($ $branch) + ;; Assume branching primcalls have the correct arity. ($continue k src ,exp)) (($ $primcall 'return (arg)) ;; Primcalls to return are in tail position. ($continue ktail src ,exp)) (($ $primcall (? (lambda (name) - (and (not (prim-rtl-instruction name)) + (and (not (prim-instruction name)) (not (branching-primitive? name)))))) ($continue k src ,exp)) (($ $primcall name args) @@ -139,11 +164,11 @@ ((out . in) (if (= in (length args)) (adapt-exp out k src - (let ((inst (prim-rtl-instruction name))) + (let ((inst (prim-instruction name))) (if (and inst (not (eq? inst name))) (build-cps-exp ($primcall inst args)) exp))) - (let-gensyms (k* p*) + (let-fresh (k*) (p*) (build-cps-term ($letk ((k* ($kargs ('prim) (p*) ($continue k src ($call p* args))))) @@ -159,16 +184,17 @@ (rewrite-cps-cont cont (($ $cont sym ($ $kargs names syms body)) (sym ($kargs names syms ,(visit-term body)))) - (($ $cont sym ($ $kclause arity body)) - (sym ($kclause ,arity ,(visit-cont body)))) + (($ $cont sym ($ $kclause arity body alternate)) + (sym ($kclause ,arity ,(visit-cont body) + ,(and alternate (visit-cont alternate))))) (($ $cont) ,cont))) (rewrite-cps-cont clause - (($ $cont sym ($ $kentry self tail clauses)) - (sym ($kentry self ,tail ,(map visit-cont clauses))))))) + (($ $cont sym ($ $kfun src meta self tail clause)) + (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))))) (define (fix-arities fun) - (rewrite-cps-exp fun - (($ $fun src meta free body) - ($fun src meta free ,(fix-clause-arities body))))) + (let ((dfg (compute-dfg fun))) + (with-fresh-name-state-from-dfg dfg + (fix-arities* fun dfg))))