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