module/language/cps/primitives.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013 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 ;;; Information about named primitives, as they appear in $prim and $primcall.
  22 ;;;
  23 ;;; Code:
  24
  25 (define-module (language cps primitives)
  26   #:use-module (ice-9 match)
  27   #:use-module ((srfi srfi-1) #:select (fold))
  28   #:use-module (srfi srfi-26)
  29   #:use-module (language rtl)
  30   #:export (prim-rtl-instruction
  31             branching-primitive?
  32             prim-arity
  33             ))
  34
  35 (define *rtl-instruction-aliases*
  36   '((+ . add) (1+ . add1)
  37     (- . sub) (1- . sub1)
  38     (* . mul) (/ . div)
  39     (quotient . quo) (remainder . rem)
  40     (modulo . mod)
  41     (variable-ref . box-ref)
  42     (variable-set! . box-set!)
  43     (bytevector-u8-native-ref . bv-u8-ref)
  44     (bytevector-u16-native-ref . bv-u16-ref)
  45     (bytevector-u32-native-ref . bv-u32-ref)
  46     (bytevector-u64-native-ref . bv-u64-ref)
  47     (bytevector-s8-native-ref . bv-s8-ref)
  48     (bytevector-s16-native-ref . bv-s16-ref)
  49     (bytevector-s32-native-ref . bv-s32-ref)
  50     (bytevector-s64-native-ref . bv-s64-ref)
  51     (bytevector-f32-native-ref . bv-f32-ref)
  52     (bytevector-f64-native-ref . bv-f64-ref)
  53     (bytevector-u8-native-set! . bv-u8-set!)
  54     (bytevector-u16-native-set! . bv-u16-set!)
  55     (bytevector-u32-native-set! . bv-u32-set!)
  56     (bytevector-u64-native-set! . bv-u64-set!)
  57     (bytevector-s8-native-set! . bv-s8-set!)
  58     (bytevector-s16-native-set! . bv-s16-set!)
  59     (bytevector-s32-native-set! . bv-s32-set!)
  60     (bytevector-s64-native-set! . bv-s64-set!)
  61     (bytevector-f32-native-set! . bv-f32-set!)
  62     (bytevector-f64-native-set! . bv-f64-set!)))
  63
  64 (define *macro-instruction-arities*
  65   '((cache-current-module! . (0 . 2))
  66     (cached-toplevel-box . (1 . 3))
  67     (cached-module-box . (1 . 4))))
  68
  69 (define *branching-primcall-arities*
  70   '((null? . (1 . 1))
  71     (nil? . (1 . 1))
  72     (pair? . (1 . 1))
  73     (struct? . (1 . 1))
  74     (string? . (1 . 1))
  75     (vector? . (1 . 1))
  76     (symbol? . (1 . 1))
  77     (variable? . (1 . 1))
  78     (bitvector? . (1 . 1))
  79     (bytevector? . (1 . 1))
  80     (char? . (1 . 1))
  81     (eq? . (1 . 2))
  82     (eqv? . (1 . 2))
  83     (equal? . (1 . 2))
  84     (= . (1 . 2))
  85     (< . (1 . 2))
  86     (> . (1 . 2))
  87     (<= . (1 . 2))
  88     (>= . (1 . 2))))
  89
  90 (define (compute-prim-rtl-instructions)
  91   (let ((table (make-hash-table)))
  92     (for-each
  93      (match-lambda ((inst . _) (hashq-set! table inst inst)))
  94      (instruction-list))
  95     (for-each
  96      (match-lambda ((prim . inst) (hashq-set! table prim inst)))
  97      *rtl-instruction-aliases*)
  98     (for-each
  99      (match-lambda ((inst . arity) (hashq-set! table inst inst)))
 100      *macro-instruction-arities*)
 101     table))
 102
 103 (define *prim-rtl-instructions* (delay (compute-prim-rtl-instructions)))
 104
 105 ;; prim -> rtl-instruction | #f
 106 (define (prim-rtl-instruction name)
 107   (hashq-ref (force *prim-rtl-instructions*) name))
 108
 109 (define (branching-primitive? name)
 110   (and (assq name *branching-primcall-arities*) #t))
 111
 112 (define *prim-arities* (make-hash-table))
 113
 114 (define (prim-arity name)
 115   (or (hashq-ref *prim-arities* name)
 116       (let ((arity (cond
 117                     ((prim-rtl-instruction name) => rtl-instruction-arity)
 118                     ((assq name *branching-primcall-arities*) => cdr)
 119                     (else
 120                      (error "Primitive of unknown arity" name)))))
 121         (hashq-set! *prim-arities* name arity)
 122         arity)))