[bpt/guile.git] / module / language / cps / prune-bailouts.scm

;;; Continuation-passing style (CPS) intermediate language (IL)

;; Copyright (C) 2013, 2014 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:
;;;
;;; A pass that prunes successors of expressions that bail out.
;;;
;;; Code:

(define-module (language cps prune-bailouts)
  #:use-module (ice-9 match)
  #:use-module (language cps)
  #:export (prune-bailouts))

(define (module-box src module name public? bound? val-proc)
  (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
    (build-cps-term
      ($letconst (('module module-sym module)
                  ('name name-sym name)
                  ('public? public?-sym public?)
                  ('bound? bound?-sym bound?))
        ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
          ($continue kbox src
            ($primcall 'cached-module-box
                       (module-sym name-sym public?-sym bound?-sym))))))))

(define (primitive-ref name k src)
  (module-box #f '(guile) name #f #t
              (lambda (box)
                (build-cps-term
                  ($continue k src ($primcall 'box-ref (box)))))))

(define (prune-bailouts* fun)
  (define (visit-cont cont ktail)
    (rewrite-cps-cont cont
      (($ $cont label ($ $kargs names vars body))
       (label ($kargs names vars ,(visit-term body ktail))))
      (($ $cont label ($ $kfun src meta self tail clause))
       (label ($kfun src meta self ,tail
                ,(and clause (visit-cont clause ktail)))))
      (($ $cont label ($ $kclause arity body alternate))
       (label ($kclause ,arity ,(visit-cont body ktail)
                        ,(and alternate (visit-cont alternate ktail)))))
      (_ ,cont)))

  (define (visit-term term ktail)
    (rewrite-cps-term term
      (($ $letrec names vars funs body)
       ($letrec names vars (map visit-fun funs)
                ,(visit-term body ktail)))
      (($ $letk conts body)
       ($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts)
         ,(visit-term body ktail)))
      (($ $continue k src exp)
       ,(visit-exp k src exp ktail))))

  (define (visit-exp k src exp ktail)
    (rewrite-cps-term exp
      (($ $fun) ($continue k src ,(visit-fun exp)))
      (($ $primcall (and name (or 'error 'scm-error 'throw)) args)
       ,(if (eq? k ktail)
            (build-cps-term ($continue k src ,exp))
            (let-fresh (kprim kresult kreceive) (prim rest)
              (build-cps-term
                ($letk ((kresult ($kargs ('rest) (rest)
                                   ($continue ktail src ($values ()))))
                        (kreceive ($kreceive '() 'rest kresult))
                        (kprim ($kargs ('prim) (prim)
                                 ($continue kreceive src
                                   ($call prim args)))))
                  ,(primitive-ref name kprim src))))))
      (_ ($continue k src ,exp))))

  (define (visit-fun fun)
    (rewrite-cps-exp fun
      (($ $fun free body)
       ($fun free ,(prune-bailouts* body)))))

  (rewrite-cps-cont fun
    (($ $cont kfun
        ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
     (kfun ($kfun src meta self (ktail ($ktail))
             ,(and clause (visit-cont clause ktail)))))))

(define (prune-bailouts fun)
  (with-fresh-name-state fun
    (prune-bailouts* fun)))
Commit	Line	Data
63463880 AW	1	;;; Continuation-passing style (CPS) intermediate language (IL)
	2
	3	;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
	4
	5	;;;; This library is free software; you can redistribute it and/or
	6	;;;; modify it under the terms of the GNU Lesser General Public
	7	;;;; License as published by the Free Software Foundation; either
	8	;;;; version 3 of the License, or (at your option) any later version.
	9	;;;;
	10	;;;; This library is distributed in the hope that it will be useful,
	11	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	;;;; Lesser General Public License for more details.
	14	;;;;
	15	;;;; You should have received a copy of the GNU Lesser General Public
	16	;;;; License along with this library; if not, write to the Free Software
	17	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
	18
	19	;;; Commentary:
	20	;;;
	21	;;; A pass that prunes successors of expressions that bail out.
	22	;;;
	23	;;; Code:
	24
	25	(define-module (language cps prune-bailouts)
	26	#:use-module (ice-9 match)
	27	#:use-module (language cps)
	28	#:export (prune-bailouts))
	29
	30	(define (module-box src module name public? bound? val-proc)
	31	(let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
	32	(build-cps-term
	33	($letconst (('module module-sym module)
	34	('name name-sym name)
	35	('public? public?-sym public?)
	36	('bound? bound?-sym bound?))
	37	($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
	38	($continue kbox src
	39	($primcall 'cached-module-box
	40	(module-sym name-sym public?-sym bound?-sym))))))))
	41
	42	(define (primitive-ref name k src)
	43	(module-box #f '(guile) name #f #t
	44	(lambda (box)
	45	(build-cps-term
	46	($continue k src ($primcall 'box-ref (box)))))))
	47
	48	(define (prune-bailouts* fun)
	49	(define (visit-cont cont ktail)
	50	(rewrite-cps-cont cont
	51	(($ $cont label ($ $kargs names vars body))
	52	(label ($kargs names vars ,(visit-term body ktail))))
8320f504 AW	53	(($ $cont label ($ $kfun src meta self tail clause))
8320f504 AW	54	(label ($kfun src meta self ,tail
63463880 AW	55	,(and clause (visit-cont clause ktail)))))
	56	(($ $cont label ($ $kclause arity body alternate))
	57	(label ($kclause ,arity ,(visit-cont body ktail)
	58	,(and alternate (visit-cont alternate ktail)))))
	59	(_ ,cont)))
	60
	61	(define (visit-term term ktail)
	62	(rewrite-cps-term term
	63	(($ $letrec names vars funs body)
a0329d01	64	($letrec names vars (map visit-fun funs)
63463880 AW	65	,(visit-term body ktail)))
	66	(($ $letk conts body)
	67	($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts)
	68	,(visit-term body ktail)))
	69	(($ $continue k src exp)
	70	,(visit-exp k src exp ktail))))
	71
	72	(define (visit-exp k src exp ktail)
	73	(rewrite-cps-term exp
a0329d01	74	(($ $fun) ($continue k src ,(visit-fun exp)))
63463880 AW	75	(($ $primcall (and name (or 'error 'scm-error 'throw)) args)
	76	,(if (eq? k ktail)
	77	(build-cps-term ($continue k src ,exp))
	78	(let-fresh (kprim kresult kreceive) (prim rest)
	79	(build-cps-term
	80	($letk ((kresult ($kargs ('rest) (rest)
	81	($continue ktail src ($values ()))))
	82	(kreceive ($kreceive '() 'rest kresult))
	83	(kprim ($kargs ('prim) (prim)
	84	($continue kreceive src
	85	($call prim args)))))
	86	,(primitive-ref name kprim src))))))
	87	(_ ($continue k src ,exp))))
	88
a0329d01 AW	89	(define (visit-fun fun)
	90	(rewrite-cps-exp fun
	91	(($ $fun free body)
	92	($fun free ,(prune-bailouts* body)))))
	93
	94	(rewrite-cps-cont fun
	95	(($ $cont kfun
	96	($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
	97	(kfun ($kfun src meta self (ktail ($ktail))
	98	,(and clause (visit-cont clause ktail)))))))
63463880 AW	99
63463880 AW	100	(define (prune-bailouts fun)
a0329d01 AW	101	(with-fresh-name-state fun
a0329d01 AW	102	(prune-bailouts* fun)))