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! effect-free-primitive?))
  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 *effect-free-primitives*
  89   '(values
  90     eq? eqv? equal?
  91     = < > <= >= zero?
  92     + * - / 1- 1+ quotient remainder modulo
  93     not
  94     pair? null? list? acons cons cons*
  95     list vector
  96     car cdr
  97     caar cadr cdar cddr
  98     caaar caadr cadar caddr cdaar cdadr cddar cdddr
  99     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
 100     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
 101     vector-ref
 102     bytevector-u8-ref bytevector-s8-ref
 103     bytevector-u16-ref bytevector-u16-native-ref
 104     bytevector-s16-ref bytevector-s16-native-ref
 105     bytevector-u32-ref bytevector-u32-native-ref
 106     bytevector-s32-ref bytevector-s32-native-ref
 107     bytevector-u64-ref bytevector-u64-native-ref
 108     bytevector-s64-ref bytevector-s64-native-ref
 109     bytevector-ieee-single-ref bytevector-ieee-single-native-ref
 110     bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
 111
 112
 113 (define *effect-free-primitive-table* (make-hash-table))
 114
 115 (for-each (lambda (x) (hashq-set! *effect-free-primitive-table* x #t))
 116           *effect-free-primitives*)
 117
 118 (define (effect-free-primitive? prim)
 119   (hashq-ref *effect-free-primitive-table* prim))
 120
 121 (define (resolve-primitives! x mod)
 122   (post-order!
 123    (lambda (x)
 124      (record-case x
 125        ((<toplevel-ref> src name)
 126         (and=> (hashq-ref *interesting-primitive-vars*
 127                           (module-variable mod name))
 128                (lambda (name) (make-primitive-ref src name))))
 129        ((<module-ref> src mod name public?)
 130         ;; for the moment, we're disabling primitive resolution for
 131         ;; public refs because resolve-interface can raise errors.
 132         (let ((m (and (not public?) (resolve-module mod))))
 133           (and m
 134                (and=> (hashq-ref *interesting-primitive-vars*
 135                                  (module-variable m name))
 136                       (lambda (name) (make-primitive-ref src name))))))
 137        (else #f)))
 138    x))
 139
 140 \f
 141
 142 (define *primitive-expand-table* (make-hash-table))
 143
 144 (define (expand-primitives! x)
 145   (pre-order!
 146    (lambda (x)
 147      (record-case x
 148        ((<application> src proc args)
 149         (and (primitive-ref? proc)
 150              (let ((expand (hashq-ref *primitive-expand-table*
 151                                       (primitive-ref-name proc))))
 152                (and expand (apply expand src args)))))
 153        (else #f)))
 154    x))
 155
 156 ;;; I actually did spend about 10 minutes trying to redo this with
 157 ;;; syntax-rules. Patches appreciated.
 158 ;;;
 159 (define-macro (define-primitive-expander sym . clauses)
 160   (define (inline-args args)
 161     (let lp ((in args) (out '()))
 162       (cond ((null? in) `(list ,@(reverse out)))
 163             ((symbol? in) `(cons* ,@(reverse out) ,in))
 164             ((pair? (car in))
 165              (lp (cdr in)
 166                  (cons `(make-application src (make-primitive-ref src ',(caar in))
 167                                           ,(inline-args (cdar in)))
 168                        out)))
 169             ((symbol? (car in))
 170              ;; assume it's locally bound
 171              (lp (cdr in) (cons (car in) out)))
 172             ((number? (car in))
 173              (lp (cdr in) (cons `(make-const src ,(car in)) out)))
 174             (else
 175              (error "what what" (car in))))))
 176   (define (consequent exp)
 177     (cond
 178      ((pair? exp)
 179       (pmatch exp
 180         ((if ,test ,then ,else)
 181          `(if ,test
 182               ,(consequent then)
 183               ,(consequent else)))
 184         (else
 185          `(make-application src (make-primitive-ref src ',(car exp))
 186                             ,(inline-args (cdr exp))))))
 187      ((symbol? exp)
 188       ;; assume locally bound
 189       exp)
 190      ((number? exp)
 191       `(make-const src ,exp))
 192      (else (error "bad consequent yall" exp))))
 193   `(hashq-set! *primitive-expand-table*
 194                ',sym
 195                (case-lambda
 196                 ,@(let lp ((in clauses) (out '()))
 197                     (if (null? in)
 198                         (reverse (cons '(else #f) out))
 199                         (lp (cddr in)
 200                             (cons `((src . ,(car in))
 201                                     ,(consequent (cadr in))) out)))))))
 202
 203 (define-primitive-expander zero? (x)
 204   (= x 0))
 205
 206 (define-primitive-expander +
 207   () 0
 208   (x) x
 209   (x y) (if (and (const? y)
 210                  (let ((y (const-exp y)))
 211                    (and (number? y) (exact? y) (= y 1))))
 212             (1+ x)
 213             (if (and (const? y)
 214                  (let ((y (const-exp y)))
 215                    (and (number? y) (exact? y) (= y -1))))
 216                 (1- x)
 217                 (if (and (const? x)
 218                          (let ((x (const-exp x)))
 219                            (and (number? y) (exact? x) (= x 1))))
 220                     (1+ y)
 221                     (+ x y))))
 222   (x y z . rest) (+ x (+ y z . rest)))
 223
 224 (define-primitive-expander *
 225   () 1
 226   (x) x
 227   (x y z . rest) (* x (* y z . rest)))
 228
 229 (define-primitive-expander -
 230   (x) (- 0 x)
 231   (x y) (if (and (const? y)
 232                  (let ((y (const-exp y)))
 233                    (and (number? y) (exact? y) (= y 1))))
 234             (1- x)
 235             (- x y))
 236   (x y z . rest) (- x (+ y z . rest)))
 237
 238 (define-primitive-expander /
 239   (x) (/ 1 x)
 240   (x y z . rest) (/ x (* y z . rest)))
 241
 242 (define-primitive-expander caar (x) (car (car x)))
 243 (define-primitive-expander cadr (x) (car (cdr x)))
 244 (define-primitive-expander cdar (x) (cdr (car x)))
 245 (define-primitive-expander cddr (x) (cdr (cdr x)))
 246 (define-primitive-expander caaar (x) (car (car (car x))))
 247 (define-primitive-expander caadr (x) (car (car (cdr x))))
 248 (define-primitive-expander cadar (x) (car (cdr (car x))))
 249 (define-primitive-expander caddr (x) (car (cdr (cdr x))))
 250 (define-primitive-expander cdaar (x) (cdr (car (car x))))
 251 (define-primitive-expander cdadr (x) (cdr (car (cdr x))))
 252 (define-primitive-expander cddar (x) (cdr (cdr (car x))))
 253 (define-primitive-expander cdddr (x) (cdr (cdr (cdr x))))
 254 (define-primitive-expander caaaar (x) (car (car (car (car x)))))
 255 (define-primitive-expander caaadr (x) (car (car (car (cdr x)))))
 256 (define-primitive-expander caadar (x) (car (car (cdr (car x)))))
 257 (define-primitive-expander caaddr (x) (car (car (cdr (cdr x)))))
 258 (define-primitive-expander cadaar (x) (car (cdr (car (car x)))))
 259 (define-primitive-expander cadadr (x) (car (cdr (car (cdr x)))))
 260 (define-primitive-expander caddar (x) (car (cdr (cdr (car x)))))
 261 (define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x)))))
 262 (define-primitive-expander cdaaar (x) (cdr (car (car (car x)))))
 263 (define-primitive-expander cdaadr (x) (cdr (car (car (cdr x)))))
 264 (define-primitive-expander cdadar (x) (cdr (car (cdr (car x)))))
 265 (define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x)))))
 266 (define-primitive-expander cddaar (x) (cdr (cdr (car (car x)))))
 267 (define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x)))))
 268 (define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x)))))
 269 (define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
 270
 271 (define-primitive-expander cons*
 272   (x) x
 273   (x y) (cons x y)
 274   (x y . rest) (cons x (cons* y . rest)))
 275
 276 (define-primitive-expander acons (x y z)
 277   (cons (cons x y) z))
 278
 279 (define-primitive-expander apply (f . args)
 280   (@apply f . args))
 281
 282 (define-primitive-expander call-with-values (producer consumer)
 283   (@call-with-values producer consumer))
 284
 285 (define-primitive-expander call-with-current-continuation (proc)
 286   (@call-with-current-continuation proc))
 287
 288 (define-primitive-expander call/cc (proc)
 289   (@call-with-current-continuation proc))
 290
 291 (define-primitive-expander values (x) x)