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   (let ((dfg (compute-dfg fun #:global? #t)))
  35     (with-fresh-name-state-from-dfg dfg
  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 clause))
  45            (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))
  46           (($ $cont sym ($ $kclause arity body alternate))
  47            (sym ($kclause ,arity ,(visit-cont body)
  48                           ,(and alternate (visit-cont alternate)))))
  49           (($ $cont)
  50            ,cont)))
  51       (define (visit-term term)
  52         (rewrite-cps-term term
  53           (($ $letk conts body)
  54            ($letk ,(map visit-cont conts)
  55              ,(visit-term body)))
  56           (($ $letrec names syms funs body)
  57            ($letrec names syms (map visit-fun funs)
  58                     ,(visit-term body)))
  59           (($ $continue k src (and fun ($ $fun)))
  60            ($continue k src ,(visit-fun fun)))
  61           (($ $continue k src ($ $primcall name args))
  62            ,(visit-primcall k src name args))
  63           (($ $continue)
  64            ,term)))
  65       (define (visit-primcall k src name args)
  66         ;; If we introduce a VM op from a primcall without a VM op, we
  67         ;; will need to ensure that the return arity matches.  Rely on the
  68         ;; elide-values pass to clean up.
  69         (define-syntax-rule (adapt-void exp)
  70           (let-fresh (k* kvoid) (val)
  71             (build-cps-term
  72               ($letk ((k* ($kargs ('val) (val)
  73                             ($continue k src ($primcall 'values (val)))))
  74                       (kvoid ($kargs () ()
  75                                ($continue k* src ($void)))))
  76                 ($continue kvoid src exp)))))
  77         (define-syntax-rule (adapt-val exp)
  78           (let-fresh (k*) (val)
  79             (build-cps-term
  80               ($letk ((k* ($kargs ('val) (val)
  81                             ($continue k src ($primcall 'values (val))))))
  82                 ($continue k* src exp)))))
  83         (match (cons name args)
  84           (('make-vector (? immediate-u8? n) init)
  85            (adapt-val ($primcall 'make-vector/immediate (n init))))
  86           (('vector-ref v (? immediate-u8? n))
  87            (build-cps-term
  88              ($continue k src ($primcall 'vector-ref/immediate (v n)))))
  89           (('vector-set! v (? immediate-u8? n) x)
  90            (build-cps-term
  91              ($continue k src ($primcall 'vector-set!/immediate (v n x)))))
  92           (('allocate-struct v (? immediate-u8? n))
  93            (adapt-val ($primcall 'allocate-struct/immediate (v n))))
  94           (('struct-ref s (? immediate-u8? n))
  95            (adapt-val ($primcall 'struct-ref/immediate (s n))))
  96           (('struct-set! s (? immediate-u8? n) x)
  97            ;; Unhappily, and undocumentedly, struct-set! returns the value
  98            ;; that was set.  There is code that relies on this.  Hackety
  99            ;; hack...
 100            (let-fresh (k*) ()
 101              (build-cps-term
 102                ($letk ((k* ($kargs () ()
 103                              ($continue k src ($primcall 'values (x))))))
 104                  ($continue k* src ($primcall 'struct-set!/immediate (s n x)))))))
 105           (_
 106            (build-cps-term ($continue k src ($primcall name args))))))
 107
 108       (define (visit-fun fun)
 109         (rewrite-cps-exp fun
 110           (($ $fun src meta free body)
 111            ($fun src meta free ,(visit-cont body)))))
 112
 113       (visit-fun fun))))