module/language/tree-il/primitives.scm

   1 ;;; open-coding primitive procedures
   2
   3 ;; Copyright (C) 2009 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 ;;; Code:
  20
  21 (define-module (language tree-il primitives)
  22   #:use-module (system base pmatch)
  23   #:use-module (rnrs bytevector)
  24   #:use-module (system base syntax)
  25   #:use-module (language tree-il)
  26   #:use-module (srfi srfi-16)
  27   #:export (resolve-primitives! add-interesting-primitive!
  28             expand-primitives!))
  29
  30 (define *interesting-primitive-names*
  31   '(apply @apply
  32     call-with-values @call-with-values
  33     call-with-current-continuation @call-with-current-continuation
  34     call/cc
  35     values
  36     eq? eqv? equal?
  37     = < > <= >= zero?
  38     + * - / 1- 1+ quotient remainder modulo
  39     not
  40     pair? null? list? acons cons cons*
  41
  42     list vector
  43
  44     car cdr
  45     set-car! set-cdr!
  46
  47     caar cadr cdar cddr
  48
  49     caaar caadr cadar caddr cdaar cdadr cddar cdddr
  50
  51     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
  52     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
  53
  54     vector-ref vector-set!
  55
  56     bytevector-u8-ref bytevector-u8-set!
  57     bytevector-s8-ref bytevector-s8-set!
  58
  59     bytevector-u16-ref bytevector-u16-set!
  60     bytevector-u16-native-ref bytevector-u16-native-set!
  61     bytevector-s16-ref bytevector-s16-set!
  62     bytevector-s16-native-ref bytevector-s16-native-set!
  63
  64     bytevector-u32-ref bytevector-u32-set!
  65     bytevector-u32-native-ref bytevector-u32-native-set!
  66     bytevector-s32-ref bytevector-s32-set!
  67     bytevector-s32-native-ref bytevector-s32-native-set!
  68
  69     bytevector-u64-ref bytevector-u64-set!
  70     bytevector-u64-native-ref bytevector-u64-native-set!
  71     bytevector-s64-ref bytevector-s64-set!
  72     bytevector-s64-native-ref bytevector-s64-native-set!
  73
  74     bytevector-ieee-single-ref bytevector-ieee-single-set!
  75     bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
  76     bytevector-ieee-double-ref bytevector-ieee-double-set!
  77     bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!))
  78
  79 (define (add-interesting-primitive! name)
  80   (hashq-set! *interesting-primitive-vars*
  81               (module-variable (current-module) name)
  82               name))
  83
  84 (define *interesting-primitive-vars* (make-hash-table))
  85
  86 (for-each add-interesting-primitive! *interesting-primitive-names*)
  87
  88 (define (resolve-primitives! x mod)
  89   (post-order!
  90    (lambda (x)
  91      (record-case x
  92        ((<toplevel-ref> src name)
  93         (and=> (hashq-ref *interesting-primitive-vars*
  94                           (module-variable mod name))
  95                (lambda (name) (make-primitive-ref src name))))
  96        ((<module-ref> src mod name public?)
  97         ;; for the moment, we're disabling primitive resolution for
  98         ;; public refs because resolve-interface can raise errors.
  99         (let ((m (and (not public?) (resolve-module mod))))
 100           (and m
 101                (and=> (hashq-ref *interesting-primitive-vars*
 102                                  (module-variable m name))
 103                       (lambda (name) (make-primitive-ref src name))))))
 104        (else #f)))
 105    x))
 106
 107 \f
 108
 109 (define *primitive-expand-table* (make-hash-table))
 110
 111 (define (expand-primitives! x)
 112   (pre-order!
 113    (lambda (x)
 114      (record-case x
 115        ((<application> src proc args)
 116         (and (primitive-ref? proc)
 117              (let ((expand (hashq-ref *primitive-expand-table*
 118                                       (primitive-ref-name proc))))
 119                (and expand (apply expand src args)))))
 120        (else #f)))
 121    x))
 122
 123 ;;; I actually did spend about 10 minutes trying to redo this with
 124 ;;; syntax-rules. Patches appreciated.
 125 ;;;
 126 (define-macro (define-primitive-expander sym . clauses)
 127   (define (inline-args args)
 128     (let lp ((in args) (out '()))
 129       (cond ((null? in) `(list ,@(reverse out)))
 130             ((symbol? in) `(cons* ,@(reverse out) ,in))
 131             ((pair? (car in))
 132              (lp (cdr in)
 133                  (cons `(make-application src (make-primitive-ref src ',(caar in))
 134                                           ,(inline-args (cdar in)))
 135                        out)))
 136             ((symbol? (car in))
 137              ;; assume it's locally bound
 138              (lp (cdr in) (cons (car in) out)))
 139             ((number? (car in))
 140              (lp (cdr in) (cons `(make-const src ,(car in)) out)))
 141             (else
 142              (error "what what" (car in))))))
 143   (define (consequent exp)
 144     (cond
 145      ((pair? exp)
 146       (pmatch exp
 147         ((if ,test ,then ,else)
 148          `(if ,test
 149               ,(consequent then)
 150               ,(consequent else)))
 151         (else
 152          `(make-application src (make-primitive-ref src ',(car exp))
 153                             ,(inline-args (cdr exp))))))
 154      ((symbol? exp)
 155       ;; assume locally bound
 156       exp)
 157      ((number? exp)
 158       `(make-const src ,exp))
 159      (else (error "bad consequent yall" exp))))
 160   `(hashq-set! *primitive-expand-table*
 161                ',sym
 162                (case-lambda
 163                 ,@(let lp ((in clauses) (out '()))
 164                     (if (null? in)
 165                         (reverse (cons '(else #f) out))
 166                         (lp (cddr in)
 167                             (cons `((src . ,(car in))
 168                                     ,(consequent (cadr in))) out)))))))
 169
 170 (define-primitive-expander +
 171   () 0
 172   (x) x
 173   (x y) (if (and (const? y)
 174                  (let ((y (const-exp y)))
 175                    (and (exact? y) (= y 1))))
 176             (1+ x)
 177             (if (and (const? x)
 178                      (let ((x (const-exp x)))
 179                        (and (exact? x) (= x 1))))
 180                 (1+ y)
 181                 (+ x y)))
 182   (x y z . rest) (+ x (+ y z . rest)))
 183
 184 (define-primitive-expander *
 185   () 1
 186   (x) x
 187   (x y z . rest) (* x (* y z . rest)))
 188
 189 (define-primitive-expander -
 190   (x) (- 0 x)
 191   (x y) (if (and (const? y)
 192                  (let ((y (const-exp y)))
 193                    (and (exact? y) (= y 1))))
 194             (1- x)
 195             (- x y))
 196   (x y z . rest) (- x (+ y z . rest)))
 197
 198 (define-primitive-expander /
 199   (x) (/ 1 x)
 200   (x y z . rest) (/ x (* y z . rest)))
 201
 202 (define-primitive-expander caar (x) (car (car x)))
 203 (define-primitive-expander cadr (x) (car (cdr x)))
 204 (define-primitive-expander cdar (x) (cdr (car x)))
 205 (define-primitive-expander cddr (x) (cdr (cdr x)))
 206 (define-primitive-expander caaar (x) (car (car (car x))))
 207 (define-primitive-expander caadr (x) (car (car (cdr x))))
 208 (define-primitive-expander cadar (x) (car (cdr (car x))))
 209 (define-primitive-expander caddr (x) (car (cdr (cdr x))))
 210 (define-primitive-expander cdaar (x) (cdr (car (car x))))
 211 (define-primitive-expander cdadr (x) (cdr (car (cdr x))))
 212 (define-primitive-expander cddar (x) (cdr (cdr (car x))))
 213 (define-primitive-expander cdddr (x) (cdr (cdr (cdr x))))
 214 (define-primitive-expander caaaar (x) (car (car (car (car x)))))
 215 (define-primitive-expander caaadr (x) (car (car (car (cdr x)))))
 216 (define-primitive-expander caadar (x) (car (car (cdr (car x)))))
 217 (define-primitive-expander caaddr (x) (car (car (cdr (cdr x)))))
 218 (define-primitive-expander cadaar (x) (car (cdr (car (car x)))))
 219 (define-primitive-expander cadadr (x) (car (cdr (car (cdr x)))))
 220 (define-primitive-expander caddar (x) (car (cdr (cdr (car x)))))
 221 (define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x)))))
 222 (define-primitive-expander cdaaar (x) (cdr (car (car (car x)))))
 223 (define-primitive-expander cdaadr (x) (cdr (car (car (cdr x)))))
 224 (define-primitive-expander cdadar (x) (cdr (car (cdr (car x)))))
 225 (define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x)))))
 226 (define-primitive-expander cddaar (x) (cdr (cdr (car (car x)))))
 227 (define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x)))))
 228 (define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x)))))
 229 (define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
 230
 231 (define-primitive-expander cons*
 232   (x) x
 233   (x y) (cons x y)
 234   (x y . rest) (cons x (cons* y . rest)))
 235
 236 (define-primitive-expander acons (x y z)
 237   (cons (cons x y) z))
 238
 239 (define-primitive-expander apply (f . args)
 240   (@apply f . args))
 241
 242 (define-primitive-expander call-with-values (producer consumer)
 243   (@call-with-values producer consumer))
 244
 245 (define-primitive-expander call-with-current-continuation (proc)
 246   (@call-with-current-continuation proc))
 247
 248 (define-primitive-expander call/cc (proc)
 249   (@call-with-current-continuation proc))
 250
 251 (define-primitive-expander values (x) x)