X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/cd36c69619e406082100efb1e62998fc67bbc2a6..a9ec16f9c5574d80f66c173b495285579f5894b4:/module/language/cps/arities.scm diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm index 1cd87040b..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, 2014 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,37 +32,43 @@ #: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))))) (($ $kreceive arity kargs) ,(match arity (($ $arity () () rest () #f) (if rest - (let-gensyms (knil) + (let-fresh (knil) () (build-cps-term ($letk ((knil ($kargs () () ($continue kargs src ($const '()))))) @@ -70,30 +76,31 @@ (build-cps-term ($continue kargs src ,exp)))) (_ - (let-gensyms (kvoid kvalues void) + (let-fresh (kvoid kvalues) (void) (build-cps-term ($letk* ((kvalues ($kargs ('void) (void) ($continue k src ($primcall 'values (void))))) (kvoid ($kargs () () ($continue kvalues src - ($void))))) + ($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 @@ -103,7 +110,7 @@ ,(match arity (($ $arity (_) () rest () #f) (if rest - (let-gensyms (kval val nil) + (let-fresh (kval) (val nil) (build-cps-term ($letk ((kval ($kargs ('val) (val) ($letconst (('nil nil '())) @@ -112,14 +119,14 @@ ($continue kval src ,exp)))) (build-cps-term ($continue kargs src ,exp)))) (_ - (let-gensyms (kvalues value) + (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 ()))))) @@ -129,19 +136,22 @@ (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))) + (($ $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 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)) @@ -158,7 +168,7 @@ (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))))) @@ -174,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))))