module/language/cps/specialize-primcalls.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013, 2014, 2015 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 ($ $kfun src meta self tail clause))
  45            (sym ($kfun src meta self ,tail
  46                   ,(and clause (visit-cont clause)))))
  47           (($ $cont sym ($ $kclause arity body alternate))
  48            (sym ($kclause ,arity ,(visit-cont body)
  49                           ,(and alternate (visit-cont alternate)))))
  50           (($ $cont)
  51            ,cont)))
  52       (define (visit-term term)
  53         (rewrite-cps-term term
  54           (($ $letk conts body)
  55            ($letk ,(map visit-cont conts)
  56              ,(visit-term body)))
  57           (($ $letrec names syms funs body)
  58            ($letrec names syms (map visit-fun funs)
  59                     ,(visit-term body)))
  60           (($ $continue k src (and fun ($ $fun)))
  61            ($continue k src ,(visit-fun fun)))
  62           (($ $continue k src ($ $primcall name args))
  63            ,(visit-primcall k src name args))
  64           (($ $continue)
  65            ,term)))
  66       (define (visit-primcall k src name args)
  67         ;; If we introduce a VM op from a primcall without a VM op, we
  68         ;; will need to ensure that the return arity matches.  Rely on the
  69         ;; elide-values pass to clean up.
  70         (define-syntax-rule (adapt-void exp)
  71           (let-fresh (k* kvoid) (val)
  72             (build-cps-term
  73               ($letk ((k* ($kargs ('val) (val)
  74                             ($continue k src ($primcall 'values (val)))))
  75                       (kvoid ($kargs () ()
  76                                ($continue k* src ($const *unspecified*)))))
  77                 ($continue kvoid src exp)))))
  78         (define-syntax-rule (adapt-val exp)
  79           (let-fresh (k*) (val)
  80             (build-cps-term
  81               ($letk ((k* ($kargs ('val) (val)
  82                             ($continue k src ($primcall 'values (val))))))
  83                 ($continue k* src exp)))))
  84         (match (cons name args)
  85           (('make-vector (? immediate-u8? n) init)
  86            (adapt-val ($primcall 'make-vector/immediate (n init))))
  87           (('vector-ref v (? immediate-u8? n))
  88            (build-cps-term
  89              ($continue k src ($primcall 'vector-ref/immediate (v n)))))
  90           (('vector-set! v (? immediate-u8? n) x)
  91            (build-cps-term
  92              ($continue k src ($primcall 'vector-set!/immediate (v n x)))))
  93           (('allocate-struct v (? immediate-u8? n))
  94            (adapt-val ($primcall 'allocate-struct/immediate (v n))))
  95           (('struct-ref s (? immediate-u8? n))
  96            (adapt-val ($primcall 'struct-ref/immediate (s n))))
  97           (('struct-set! s (? immediate-u8? n) x)
  98            (build-cps-term
  99              ($continue k src ($primcall 'struct-set!/immediate (s n x)))))
 100           (_
 101            (build-cps-term ($continue k src ($primcall name args))))))
 102
 103       (define (visit-fun fun)
 104         (rewrite-cps-exp fun
 105           (($ $fun free body)
 106            ($fun free ,(visit-cont body)))))
 107
 108       (visit-cont fun))))