module/language/cps/specialize-primcalls.scm

   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 ;;; Some bytecode operations can encode an immediate as an operand.
  22 ;;; This pass tranforms generic primcalls to these specialized
  23 ;;; primcalls, if possible.
  24 ;;;
  25 ;;; Code:
  26
  27 (define-module (language cps specialize-primcalls)
  28   #:use-module (ice-9 match)
  29   #:use-module (language cps)
  30   #:use-module (language cps dfg)
  31   #:export (specialize-primcalls))
  32
  33 (define (specialize-primcalls fun)
  34   (with-fresh-name-state fun
  35     (let ((dfg (compute-dfg fun #:global? #t)))
  36       (define (immediate-u8? sym)
  37         (call-with-values (lambda () (find-constant-value sym dfg))
  38           (lambda (has-const? val)
  39             (and has-const? (integer? val) (exact? val) (<= 0 val 255)))))
  40       (define (visit-cont cont)
  41         (rewrite-cps-cont cont
  42           (($ $cont sym ($ $kargs names syms body))
  43            (sym ($kargs names syms ,(visit-term body))))
  44           (($ $cont sym ($ $kentry self tail clauses))
  45            (sym ($kentry self ,tail ,(map visit-cont clauses))))
  46           (($ $cont sym ($ $kclause arity body))
  47            (sym ($kclause ,arity ,(visit-cont body))))
  48           (($ $cont)
  49            ,cont)))
  50       (define (visit-term term)
  51         (rewrite-cps-term term
  52           (($ $letk conts body)
  53            ($letk ,(map visit-cont conts)
  54              ,(visit-term body)))
  55           (($ $letrec names syms funs body)
  56            ($letrec names syms (map visit-fun funs)
  57                     ,(visit-term body)))
  58           (($ $continue k src (and fun ($ $fun)))
  59            ($continue k src ,(visit-fun fun)))
  60           (($ $continue k src ($ $primcall name args))
  61            ,(visit-primcall k src name args))
  62           (($ $continue)
  63            ,term)))
  64       (define (visit-primcall k src name args)
  65         ;; If we introduce a VM op from a primcall without a VM op, we
  66         ;; will need to ensure that the return arity matches.  Rely on the
  67         ;; elide-values pass to clean up.
  68         (define-syntax-rule (adapt-void exp)
  69           (let-fresh (k* kvoid) (val)
  70             (build-cps-term
  71               ($letk ((k* ($kargs ('val) (val)
  72                             ($continue k src ($primcall 'values (val)))))
  73                       (kvoid ($kargs () ()
  74                                ($continue k* src ($void)))))
  75                 ($continue kvoid src exp)))))
  76         (define-syntax-rule (adapt-val exp)
  77           (let-fresh (k*) (val)
  78             (build-cps-term
  79               ($letk ((k* ($kargs ('val) (val)
  80                             ($continue k src ($primcall 'values (val))))))
  81                 ($continue k* src exp)))))
  82         (match (cons name args)
  83           (('make-vector (? immediate-u8? n) init)
  84            (adapt-val ($primcall 'make-vector/immediate (n init))))
  85           (('vector-ref v (? immediate-u8? n))
  86            (build-cps-term
  87              ($continue k src ($primcall 'vector-ref/immediate (v n)))))
  88           (('vector-set! v (? immediate-u8? n) x)
  89            (build-cps-term
  90              ($continue k src ($primcall 'vector-set!/immediate (v n x)))))
  91           (('allocate-struct v (? immediate-u8? n))
  92            (adapt-val ($primcall 'allocate-struct/immediate (v n))))
  93           (('struct-ref s (? immediate-u8? n))
  94            (adapt-val ($primcall 'struct-ref/immediate (s n))))
  95           (('struct-set! s (? immediate-u8? n) x)
  96            ;; Unhappily, and undocumentedly, struct-set! returns the value
  97            ;; that was set.  There is code that relies on this.  Hackety
  98            ;; hack...
  99            (let-fresh (k*) ()
 100              (build-cps-term
 101                ($letk ((k* ($kargs () ()
 102                              ($continue k src ($primcall 'values (x))))))
 103                  ($continue k* src ($primcall 'struct-set!/immediate (s n x)))))))
 104           (_
 105            (build-cps-term ($continue k src ($primcall name args))))))
 106
 107       (define (visit-fun fun)
 108         (rewrite-cps-exp fun
 109           (($ $fun src meta free body)
 110            ($fun src meta free ,(visit-cont body)))))
 111
 112       (visit-fun fun))))