module/language/tree-il/primitives.scm

   1 ;;; open-coding primitive procedures
   2
   3 ;; Copyright (C) 2009, 2010 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-4)
  27   #:use-module (srfi srfi-16)
  28   #:export (resolve-primitives! add-interesting-primitive!
  29             expand-primitives! effect-free-primitive?))
  30
  31 (define *interesting-primitive-names*
  32   '(apply @apply
  33     call-with-values @call-with-values
  34     call-with-current-continuation @call-with-current-continuation
  35     call/cc
  36     values
  37     eq? eqv? equal?
  38     memq memv
  39     = < > <= >= zero?
  40     + * - / 1- 1+ quotient remainder modulo
  41     ash logand logior logxor
  42     not
  43     pair? null? list? acons cons cons*
  44
  45     list vector
  46
  47     car cdr
  48     set-car! set-cdr!
  49
  50     caar cadr cdar cddr
  51
  52     caaar caadr cadar caddr cdaar cdadr cddar cdddr
  53
  54     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
  55     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
  56
  57     vector-ref vector-set!
  58     variable-ref variable-set!
  59     variable-bound?
  60     ;; args of variable-set are switched; it needs special help
  61
  62     struct? struct-vtable make-struct struct-ref struct-set!
  63
  64     bytevector-u8-ref bytevector-u8-set!
  65     bytevector-s8-ref bytevector-s8-set!
  66     u8vector-ref u8vector-set! s8vector-ref s8vector-set!
  67
  68     bytevector-u16-ref bytevector-u16-set!
  69     bytevector-u16-native-ref bytevector-u16-native-set!
  70     bytevector-s16-ref bytevector-s16-set!
  71     bytevector-s16-native-ref bytevector-s16-native-set!
  72     u16vector-ref u16vector-set! s16vector-ref s16vector-set!
  73
  74     bytevector-u32-ref bytevector-u32-set!
  75     bytevector-u32-native-ref bytevector-u32-native-set!
  76     bytevector-s32-ref bytevector-s32-set!
  77     bytevector-s32-native-ref bytevector-s32-native-set!
  78     u32vector-ref u32vector-set! s32vector-ref s32vector-set!
  79
  80     bytevector-u64-ref bytevector-u64-set!
  81     bytevector-u64-native-ref bytevector-u64-native-set!
  82     bytevector-s64-ref bytevector-s64-set!
  83     bytevector-s64-native-ref bytevector-s64-native-set!
  84     u64vector-ref u64vector-set! s64vector-ref s64vector-set!
  85
  86     bytevector-ieee-single-ref bytevector-ieee-single-set!
  87     bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
  88     bytevector-ieee-double-ref bytevector-ieee-double-set!
  89     bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
  90     f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
  91
  92 (define (add-interesting-primitive! name)
  93   (hashq-set! *interesting-primitive-vars*
  94               (or (module-variable (current-module) name)
  95                   (error "unbound interesting primitive" name))
  96               name))
  97
  98 (define *interesting-primitive-vars* (make-hash-table))
  99
 100 (for-each add-interesting-primitive! *interesting-primitive-names*)
 101
 102 (define *effect-free-primitives*
 103   '(values
 104     eq? eqv? equal?
 105     = < > <= >= zero?
 106     + * - / 1- 1+ quotient remainder modulo
 107     not
 108     pair? null? list? acons cons cons*
 109     list vector
 110     car cdr
 111     caar cadr cdar cddr
 112     caaar caadr cadar caddr cdaar cdadr cddar cdddr
 113     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
 114     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
 115     vector-ref
 116     struct? struct-vtable make-struct struct-ref
 117     bytevector-u8-ref bytevector-s8-ref
 118     bytevector-u16-ref bytevector-u16-native-ref
 119     bytevector-s16-ref bytevector-s16-native-ref
 120     bytevector-u32-ref bytevector-u32-native-ref
 121     bytevector-s32-ref bytevector-s32-native-ref
 122     bytevector-u64-ref bytevector-u64-native-ref
 123     bytevector-s64-ref bytevector-s64-native-ref
 124     bytevector-ieee-single-ref bytevector-ieee-single-native-ref
 125     bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
 126
 127
 128 (define *effect-free-primitive-table* (make-hash-table))
 129
 130 (for-each (lambda (x) (hashq-set! *effect-free-primitive-table* x #t))
 131           *effect-free-primitives*)
 132
 133 (define (effect-free-primitive? prim)
 134   (hashq-ref *effect-free-primitive-table* prim))
 135
 136 (define (resolve-primitives! x mod)
 137   (post-order!
 138    (lambda (x)
 139      (record-case x
 140        ((<toplevel-ref> src name)
 141         (and=> (hashq-ref *interesting-primitive-vars*
 142                           (module-variable mod name))
 143                (lambda (name) (make-primitive-ref src name))))
 144        ((<module-ref> src mod name public?)
 145         ;; for the moment, we're disabling primitive resolution for
 146         ;; public refs because resolve-interface can raise errors.
 147         (let ((m (and (not public?) (resolve-module mod))))
 148           (and m
 149                (and=> (hashq-ref *interesting-primitive-vars*
 150                                  (module-variable m name))
 151                       (lambda (name) (make-primitive-ref src name))))))
 152        (else #f)))
 153    x))
 154
 155 \f
 156
 157 (define *primitive-expand-table* (make-hash-table))
 158
 159 (define (expand-primitives! x)
 160   (pre-order!
 161    (lambda (x)
 162      (record-case x
 163        ((<application> src proc args)
 164         (and (primitive-ref? proc)
 165              (let ((expand (hashq-ref *primitive-expand-table*
 166                                       (primitive-ref-name proc))))
 167                (and expand (apply expand src args)))))
 168        (else #f)))
 169    x))
 170
 171 ;;; I actually did spend about 10 minutes trying to redo this with
 172 ;;; syntax-rules. Patches appreciated.
 173 ;;;
 174 (define-macro (define-primitive-expander sym . clauses)
 175   (define (inline-args args)
 176     (let lp ((in args) (out '()))
 177       (cond ((null? in) `(list ,@(reverse out)))
 178             ((symbol? in) `(cons* ,@(reverse out) ,in))
 179             ((pair? (car in))
 180              (lp (cdr in)
 181                  (cons `(make-application src (make-primitive-ref src ',(caar in))
 182                                           ,(inline-args (cdar in)))
 183                        out)))
 184             ((symbol? (car in))
 185              ;; assume it's locally bound
 186              (lp (cdr in) (cons (car in) out)))
 187             ((number? (car in))
 188              (lp (cdr in) (cons `(make-const src ,(car in)) out)))
 189             (else
 190              (error "what what" (car in))))))
 191   (define (consequent exp)
 192     (cond
 193      ((pair? exp)
 194       (pmatch exp
 195         ((if ,test ,then ,else)
 196          `(if ,test
 197               ,(consequent then)
 198               ,(consequent else)))
 199         (else
 200          `(make-application src (make-primitive-ref src ',(car exp))
 201                             ,(inline-args (cdr exp))))))
 202      ((symbol? exp)
 203       ;; assume locally bound
 204       exp)
 205      ((number? exp)
 206       `(make-const src ,exp))
 207      (else (error "bad consequent yall" exp))))
 208   `(hashq-set! *primitive-expand-table*
 209                ',sym
 210                (case-lambda
 211                 ,@(let lp ((in clauses) (out '()))
 212                     (if (null? in)
 213                         (reverse (cons '(else #f) out))
 214                         (lp (cddr in)
 215                             (cons `((src . ,(car in))
 216                                     ,(consequent (cadr in))) out)))))))
 217
 218 (define-primitive-expander zero? (x)
 219   (= x 0))
 220
 221 (define-primitive-expander +
 222   () 0
 223   (x) x
 224   (x y) (if (and (const? y)
 225                  (let ((y (const-exp y)))
 226                    (and (number? y) (exact? y) (= y 1))))
 227             (1+ x)
 228             (if (and (const? y)
 229                      (let ((y (const-exp y)))
 230                        (and (number? y) (exact? y) (= y -1))))
 231                 (1- x)
 232                 (if (and (const? x)
 233                          (let ((x (const-exp x)))
 234                            (and (number? x) (exact? x) (= x 1))))
 235                     (1+ y)
 236                     (+ x y))))
 237   (x y z . rest) (+ x (+ y z . rest)))
 238
 239 (define-primitive-expander *
 240   () 1
 241   (x) x
 242   (x y z . rest) (* x (* y z . rest)))
 243
 244 (define-primitive-expander -
 245   (x) (- 0 x)
 246   (x y) (if (and (const? y)
 247                  (let ((y (const-exp y)))
 248                    (and (number? y) (exact? y) (= y 1))))
 249             (1- x)
 250             (- x y))
 251   (x y z . rest) (- x (+ y z . rest)))
 252
 253 (define-primitive-expander /
 254   (x) (/ 1 x)
 255   (x y z . rest) (/ x (* y z . rest)))
 256
 257 (define-primitive-expander caar (x) (car (car x)))
 258 (define-primitive-expander cadr (x) (car (cdr x)))
 259 (define-primitive-expander cdar (x) (cdr (car x)))
 260 (define-primitive-expander cddr (x) (cdr (cdr x)))
 261 (define-primitive-expander caaar (x) (car (car (car x))))
 262 (define-primitive-expander caadr (x) (car (car (cdr x))))
 263 (define-primitive-expander cadar (x) (car (cdr (car x))))
 264 (define-primitive-expander caddr (x) (car (cdr (cdr x))))
 265 (define-primitive-expander cdaar (x) (cdr (car (car x))))
 266 (define-primitive-expander cdadr (x) (cdr (car (cdr x))))
 267 (define-primitive-expander cddar (x) (cdr (cdr (car x))))
 268 (define-primitive-expander cdddr (x) (cdr (cdr (cdr x))))
 269 (define-primitive-expander caaaar (x) (car (car (car (car x)))))
 270 (define-primitive-expander caaadr (x) (car (car (car (cdr x)))))
 271 (define-primitive-expander caadar (x) (car (car (cdr (car x)))))
 272 (define-primitive-expander caaddr (x) (car (car (cdr (cdr x)))))
 273 (define-primitive-expander cadaar (x) (car (cdr (car (car x)))))
 274 (define-primitive-expander cadadr (x) (car (cdr (car (cdr x)))))
 275 (define-primitive-expander caddar (x) (car (cdr (cdr (car x)))))
 276 (define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x)))))
 277 (define-primitive-expander cdaaar (x) (cdr (car (car (car x)))))
 278 (define-primitive-expander cdaadr (x) (cdr (car (car (cdr x)))))
 279 (define-primitive-expander cdadar (x) (cdr (car (cdr (car x)))))
 280 (define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x)))))
 281 (define-primitive-expander cddaar (x) (cdr (cdr (car (car x)))))
 282 (define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x)))))
 283 (define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x)))))
 284 (define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
 285
 286 (define-primitive-expander cons*
 287   (x) x
 288   (x y) (cons x y)
 289   (x y . rest) (cons x (cons* y . rest)))
 290
 291 (define-primitive-expander acons (x y z)
 292   (cons (cons x y) z))
 293
 294 (define-primitive-expander apply (f a0 . args)
 295   (@apply f a0 . args))
 296
 297 (define-primitive-expander call-with-values (producer consumer)
 298   (@call-with-values producer consumer))
 299
 300 (define-primitive-expander call-with-current-continuation (proc)
 301   (@call-with-current-continuation proc))
 302
 303 (define-primitive-expander call/cc (proc)
 304   (@call-with-current-continuation proc))
 305
 306 (define-primitive-expander values (x) x)
 307
 308 ;; swap args
 309 (define-primitive-expander variable-set! (var val)
 310   (variable-set val var))
 311
 312 (define-primitive-expander u8vector-ref (vec i)
 313   (bytevector-u8-ref vec i))
 314 (define-primitive-expander u8vector-set! (vec i x)
 315   (bytevector-u8-set! vec i x))
 316 (define-primitive-expander s8vector-ref (vec i)
 317   (bytevector-s8-ref vec i))
 318 (define-primitive-expander s8vector-set! (vec i x)
 319   (bytevector-s8-set! vec i x))
 320
 321 (define-primitive-expander u16vector-ref (vec i)
 322   (bytevector-u16-native-ref vec (* i 2)))
 323 (define-primitive-expander u16vector-set! (vec i x)
 324   (bytevector-u16-native-set! vec (* i 2) x))
 325 (define-primitive-expander s16vector-ref (vec i)
 326   (bytevector-s16-native-ref vec (* i 2)))
 327 (define-primitive-expander s16vector-set! (vec i x)
 328   (bytevector-s16-native-set! vec (* i 2) x))
 329
 330 (define-primitive-expander u32vector-ref (vec i)
 331   (bytevector-u32-native-ref vec (* i 4)))
 332 (define-primitive-expander u32vector-set! (vec i x)
 333   (bytevector-u32-native-set! vec (* i 4) x))
 334 (define-primitive-expander s32vector-ref (vec i)
 335   (bytevector-s32-native-ref vec (* i 4)))
 336 (define-primitive-expander s32vector-set! (vec i x)
 337   (bytevector-s32-native-set! vec (* i 4) x))
 338
 339 (define-primitive-expander u64vector-ref (vec i)
 340   (bytevector-u64-native-ref vec (* i 8)))
 341 (define-primitive-expander u64vector-set! (vec i x)
 342   (bytevector-u64-native-set! vec (* i 8) x))
 343 (define-primitive-expander s64vector-ref (vec i)
 344   (bytevector-s64-native-ref vec (* i 8)))
 345 (define-primitive-expander s64vector-set! (vec i x)
 346   (bytevector-s64-native-set! vec (* i 8) x))
 347
 348 (define-primitive-expander f32vector-ref (vec i)
 349   (bytevector-ieee-single-native-ref vec (* i 4)))
 350 (define-primitive-expander f32vector-set! (vec i x)
 351   (bytevector-ieee-single-native-set! vec (* i 4) x))
 352 (define-primitive-expander f32vector-ref (vec i)
 353   (bytevector-ieee-single-native-ref vec (* i 4)))
 354 (define-primitive-expander f32vector-set! (vec i x)
 355   (bytevector-ieee-single-native-set! vec (* i 4) x))
 356
 357 (define-primitive-expander f64vector-ref (vec i)
 358   (bytevector-ieee-double-native-ref vec (* i 8)))
 359 (define-primitive-expander f64vector-set! (vec i x)
 360   (bytevector-ieee-double-native-set! vec (* i 8) x))
 361 (define-primitive-expander f64vector-ref (vec i)
 362   (bytevector-ieee-double-native-ref vec (* i 8)))
 363 (define-primitive-expander f64vector-set! (vec i x)
 364   (bytevector-ieee-double-native-set! vec (* i 8) x))