module/language/tree-il/primitives.scm

   1 ;;; open-coding primitive procedures
   2
   3 ;; Copyright (C) 2009, 2010, 2011 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 bytevectors)
  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!
  30             effect-free-primitive? effect+exception-free-primitive?))
  31
  32 (define *interesting-primitive-names*
  33   '(apply @apply
  34     call-with-values @call-with-values
  35     call-with-current-continuation @call-with-current-continuation
  36     call/cc
  37     dynamic-wind
  38     @dynamic-wind
  39     values
  40     eq? eqv? equal?
  41     memq memv
  42     = < > <= >= zero?
  43     + * - / 1- 1+ quotient remainder modulo
  44     ash logand logior logxor
  45     not
  46     pair? null? list? symbol? vector? acons cons cons*
  47
  48     list vector
  49
  50     car cdr
  51     set-car! set-cdr!
  52
  53     caar cadr cdar cddr
  54
  55     caaar caadr cadar caddr cdaar cdadr cddar cdddr
  56
  57     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
  58     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
  59
  60     vector-ref vector-set!
  61     variable-ref variable-set!
  62     variable-bound?
  63
  64     fluid-ref fluid-set!
  65
  66     @prompt call-with-prompt @abort abort-to-prompt
  67     make-prompt-tag
  68
  69     struct? struct-vtable make-struct struct-ref struct-set!
  70
  71     bytevector-u8-ref bytevector-u8-set!
  72     bytevector-s8-ref bytevector-s8-set!
  73     u8vector-ref u8vector-set! s8vector-ref s8vector-set!
  74
  75     bytevector-u16-ref bytevector-u16-set!
  76     bytevector-u16-native-ref bytevector-u16-native-set!
  77     bytevector-s16-ref bytevector-s16-set!
  78     bytevector-s16-native-ref bytevector-s16-native-set!
  79     u16vector-ref u16vector-set! s16vector-ref s16vector-set!
  80
  81     bytevector-u32-ref bytevector-u32-set!
  82     bytevector-u32-native-ref bytevector-u32-native-set!
  83     bytevector-s32-ref bytevector-s32-set!
  84     bytevector-s32-native-ref bytevector-s32-native-set!
  85     u32vector-ref u32vector-set! s32vector-ref s32vector-set!
  86
  87     bytevector-u64-ref bytevector-u64-set!
  88     bytevector-u64-native-ref bytevector-u64-native-set!
  89     bytevector-s64-ref bytevector-s64-set!
  90     bytevector-s64-native-ref bytevector-s64-native-set!
  91     u64vector-ref u64vector-set! s64vector-ref s64vector-set!
  92
  93     bytevector-ieee-single-ref bytevector-ieee-single-set!
  94     bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
  95     bytevector-ieee-double-ref bytevector-ieee-double-set!
  96     bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
  97     f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
  98
  99 (define (add-interesting-primitive! name)
 100   (hashq-set! *interesting-primitive-vars*
 101               (or (module-variable (current-module) name)
 102                   (error "unbound interesting primitive" name))
 103               name))
 104
 105 (define *interesting-primitive-vars* (make-hash-table))
 106
 107 (for-each add-interesting-primitive! *interesting-primitive-names*)
 108
 109 (define *effect-free-primitives*
 110   '(values
 111     eq? eqv? equal?
 112     = < > <= >= zero?
 113     + * - / 1- 1+ quotient remainder modulo
 114     not
 115     pair? null? list? symbol? vector? acons cons cons*
 116     list vector
 117     car cdr
 118     caar cadr cdar cddr
 119     caaar caadr cadar caddr cdaar cdadr cddar cdddr
 120     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
 121     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
 122     vector-ref
 123     struct? struct-vtable make-struct make-struct/no-tail struct-ref
 124     bytevector-u8-ref bytevector-s8-ref
 125     bytevector-u16-ref bytevector-u16-native-ref
 126     bytevector-s16-ref bytevector-s16-native-ref
 127     bytevector-u32-ref bytevector-u32-native-ref
 128     bytevector-s32-ref bytevector-s32-native-ref
 129     bytevector-u64-ref bytevector-u64-native-ref
 130     bytevector-s64-ref bytevector-s64-native-ref
 131     bytevector-ieee-single-ref bytevector-ieee-single-native-ref
 132     bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
 133
 134 ;; Like *effect-free-primitives* above, but further restricted in that they
 135 ;; cannot raise exceptions.
 136 (define *effect+exception-free-primitives*
 137   '(values
 138     eq? eqv? equal?
 139     not
 140     pair? null? list? symbol? vector? acons cons cons*
 141     list vector
 142     struct?))
 143
 144 (define *effect-free-primitive-table* (make-hash-table))
 145 (define *effect+exceptions-free-primitive-table* (make-hash-table))
 146
 147 (for-each (lambda (x)
 148             (hashq-set! *effect-free-primitive-table* x #t))
 149           *effect-free-primitives*)
 150 (for-each (lambda (x)
 151             (hashq-set! *effect+exceptions-free-primitive-table* x #t))
 152           *effect+exception-free-primitives*)
 153
 154 (define (effect-free-primitive? prim)
 155   (hashq-ref *effect-free-primitive-table* prim))
 156 (define (effect+exception-free-primitive? prim)
 157   (hashq-ref *effect+exceptions-free-primitive-table* prim))
 158
 159 (define (resolve-primitives! x mod)
 160   (post-order!
 161    (lambda (x)
 162      (record-case x
 163        ((<toplevel-ref> src name)
 164         (and=> (hashq-ref *interesting-primitive-vars*
 165                           (module-variable mod name))
 166                (lambda (name) (make-primitive-ref src name))))
 167        ((<module-ref> src mod name public?)
 168         ;; for the moment, we're disabling primitive resolution for
 169         ;; public refs because resolve-interface can raise errors.
 170         (let ((m (and (not public?) (resolve-module mod))))
 171           (and m
 172                (and=> (hashq-ref *interesting-primitive-vars*
 173                                  (module-variable m name))
 174                       (lambda (name) (make-primitive-ref src name))))))
 175        ((<call> src proc args)
 176         (and (primitive-ref? proc)
 177              (make-primcall src (primitive-ref-name proc) args)))
 178        (else #f)))
 179    x))
 180
 181 \f
 182
 183 (define *primitive-expand-table* (make-hash-table))
 184
 185 (define (expand-primitives! x)
 186   (pre-order!
 187    (lambda (x)
 188      (record-case x
 189        ((<primcall> src name args)
 190         (let ((expand (hashq-ref *primitive-expand-table* name)))
 191           (and expand (apply expand src args))))
 192        (else #f)))
 193    x))
 194
 195 ;;; I actually did spend about 10 minutes trying to redo this with
 196 ;;; syntax-rules. Patches appreciated.
 197 ;;;
 198 (define-macro (define-primitive-expander sym . clauses)
 199   (define (inline-args args)
 200     (let lp ((in args) (out '()))
 201       (cond ((null? in) `(list ,@(reverse out)))
 202             ((symbol? in) `(cons* ,@(reverse out) ,in))
 203             ((pair? (car in))
 204              (lp (cdr in)
 205                  (cons (if (eq? (caar in) 'quote)
 206                            `(make-const src ,@(cdar in))
 207                            `(make-primcall src ',(caar in)
 208                                            ,(inline-args (cdar in))))
 209                        out)))
 210             ((symbol? (car in))
 211              ;; assume it's locally bound
 212              (lp (cdr in) (cons (car in) out)))
 213             ((self-evaluating? (car in))
 214              (lp (cdr in) (cons `(make-const src ,(car in)) out)))
 215             (else
 216              (error "what what" (car in))))))
 217   (define (consequent exp)
 218     (cond
 219      ((pair? exp)
 220       (pmatch exp
 221         ((if ,test ,then ,else)
 222          `(if ,test
 223               ,(consequent then)
 224               ,(consequent else)))
 225         (else
 226          `(make-primcall src ',(car exp)
 227                          ,(inline-args (cdr exp))))))
 228      ((symbol? exp)
 229       ;; assume locally bound
 230       exp)
 231      ((number? exp)
 232       `(make-const src ,exp))
 233      ((not exp)
 234       ;; failed match
 235       #f)
 236      (else (error "bad consequent yall" exp))))
 237   `(hashq-set! *primitive-expand-table*
 238                ',sym
 239                (case-lambda
 240                 ,@(let lp ((in clauses) (out '()))
 241                     (if (null? in)
 242                         (reverse (cons '(else #f) out))
 243                         (lp (cddr in)
 244                             (cons `((src . ,(car in))
 245                                     ,(consequent (cadr in))) out)))))))
 246
 247 (define-primitive-expander zero? (x)
 248   (= x 0))
 249
 250 (define-primitive-expander +
 251   () 0
 252   (x) x
 253   (x y) (if (and (const? y)
 254                  (let ((y (const-exp y)))
 255                    (and (number? y) (exact? y) (= y 1))))
 256             (1+ x)
 257             (if (and (const? y)
 258                      (let ((y (const-exp y)))
 259                        (and (number? y) (exact? y) (= y -1))))
 260                 (1- x)
 261                 (if (and (const? x)
 262                          (let ((x (const-exp x)))
 263                            (and (number? x) (exact? x) (= x 1))))
 264                     (1+ y)
 265                     (+ x y))))
 266   (x y z . rest) (+ x (+ y z . rest)))
 267
 268 (define-primitive-expander *
 269   () 1
 270   (x) x
 271   (x y z . rest) (* x (* y z . rest)))
 272
 273 (define-primitive-expander -
 274   (x) (- 0 x)
 275   (x y) (if (and (const? y)
 276                  (let ((y (const-exp y)))
 277                    (and (number? y) (exact? y) (= y 1))))
 278             (1- x)
 279             (- x y))
 280   (x y z . rest) (- x (+ y z . rest)))
 281
 282 (define-primitive-expander /
 283   (x) (/ 1 x)
 284   (x y z . rest) (/ x (* y z . rest)))
 285
 286 (define-primitive-expander caar (x) (car (car x)))
 287 (define-primitive-expander cadr (x) (car (cdr x)))
 288 (define-primitive-expander cdar (x) (cdr (car x)))
 289 (define-primitive-expander cddr (x) (cdr (cdr x)))
 290 (define-primitive-expander caaar (x) (car (car (car x))))
 291 (define-primitive-expander caadr (x) (car (car (cdr x))))
 292 (define-primitive-expander cadar (x) (car (cdr (car x))))
 293 (define-primitive-expander caddr (x) (car (cdr (cdr x))))
 294 (define-primitive-expander cdaar (x) (cdr (car (car x))))
 295 (define-primitive-expander cdadr (x) (cdr (car (cdr x))))
 296 (define-primitive-expander cddar (x) (cdr (cdr (car x))))
 297 (define-primitive-expander cdddr (x) (cdr (cdr (cdr x))))
 298 (define-primitive-expander caaaar (x) (car (car (car (car x)))))
 299 (define-primitive-expander caaadr (x) (car (car (car (cdr x)))))
 300 (define-primitive-expander caadar (x) (car (car (cdr (car x)))))
 301 (define-primitive-expander caaddr (x) (car (car (cdr (cdr x)))))
 302 (define-primitive-expander cadaar (x) (car (cdr (car (car x)))))
 303 (define-primitive-expander cadadr (x) (car (cdr (car (cdr x)))))
 304 (define-primitive-expander caddar (x) (car (cdr (cdr (car x)))))
 305 (define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x)))))
 306 (define-primitive-expander cdaaar (x) (cdr (car (car (car x)))))
 307 (define-primitive-expander cdaadr (x) (cdr (car (car (cdr x)))))
 308 (define-primitive-expander cdadar (x) (cdr (car (cdr (car x)))))
 309 (define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x)))))
 310 (define-primitive-expander cddaar (x) (cdr (cdr (car (car x)))))
 311 (define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x)))))
 312 (define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x)))))
 313 (define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
 314
 315 (define-primitive-expander cons*
 316   (x) x
 317   (x y) (cons x y)
 318   (x y . rest) (cons x (cons* y . rest)))
 319
 320 (define-primitive-expander acons (x y z)
 321   (cons (cons x y) z))
 322
 323 (define-primitive-expander apply (f a0 . args)
 324   (@apply f a0 . args))
 325
 326 (define-primitive-expander call-with-values (producer consumer)
 327   (@call-with-values producer consumer))
 328
 329 (define-primitive-expander call-with-current-continuation (proc)
 330   (@call-with-current-continuation proc))
 331
 332 (define-primitive-expander call/cc (proc)
 333   (@call-with-current-continuation proc))
 334
 335 (define-primitive-expander values (x) x)
 336
 337 (define-primitive-expander make-struct (vtable tail-size . args)
 338   (if (and (const? tail-size)
 339            (let ((n (const-exp tail-size)))
 340              (and (number? n) (exact? n) (zero? n))))
 341       (make-struct/no-tail vtable . args)
 342       #f))
 343
 344 (define-primitive-expander u8vector-ref (vec i)
 345   (bytevector-u8-ref vec i))
 346 (define-primitive-expander u8vector-set! (vec i x)
 347   (bytevector-u8-set! vec i x))
 348 (define-primitive-expander s8vector-ref (vec i)
 349   (bytevector-s8-ref vec i))
 350 (define-primitive-expander s8vector-set! (vec i x)
 351   (bytevector-s8-set! vec i x))
 352
 353 (define-primitive-expander u16vector-ref (vec i)
 354   (bytevector-u16-native-ref vec (* i 2)))
 355 (define-primitive-expander u16vector-set! (vec i x)
 356   (bytevector-u16-native-set! vec (* i 2) x))
 357 (define-primitive-expander s16vector-ref (vec i)
 358   (bytevector-s16-native-ref vec (* i 2)))
 359 (define-primitive-expander s16vector-set! (vec i x)
 360   (bytevector-s16-native-set! vec (* i 2) x))
 361
 362 (define-primitive-expander u32vector-ref (vec i)
 363   (bytevector-u32-native-ref vec (* i 4)))
 364 (define-primitive-expander u32vector-set! (vec i x)
 365   (bytevector-u32-native-set! vec (* i 4) x))
 366 (define-primitive-expander s32vector-ref (vec i)
 367   (bytevector-s32-native-ref vec (* i 4)))
 368 (define-primitive-expander s32vector-set! (vec i x)
 369   (bytevector-s32-native-set! vec (* i 4) x))
 370
 371 (define-primitive-expander u64vector-ref (vec i)
 372   (bytevector-u64-native-ref vec (* i 8)))
 373 (define-primitive-expander u64vector-set! (vec i x)
 374   (bytevector-u64-native-set! vec (* i 8) x))
 375 (define-primitive-expander s64vector-ref (vec i)
 376   (bytevector-s64-native-ref vec (* i 8)))
 377 (define-primitive-expander s64vector-set! (vec i x)
 378   (bytevector-s64-native-set! vec (* i 8) x))
 379
 380 (define-primitive-expander f32vector-ref (vec i)
 381   (bytevector-ieee-single-native-ref vec (* i 4)))
 382 (define-primitive-expander f32vector-set! (vec i x)
 383   (bytevector-ieee-single-native-set! vec (* i 4) x))
 384 (define-primitive-expander f32vector-ref (vec i)
 385   (bytevector-ieee-single-native-ref vec (* i 4)))
 386 (define-primitive-expander f32vector-set! (vec i x)
 387   (bytevector-ieee-single-native-set! vec (* i 4) x))
 388
 389 (define-primitive-expander f64vector-ref (vec i)
 390   (bytevector-ieee-double-native-ref vec (* i 8)))
 391 (define-primitive-expander f64vector-set! (vec i x)
 392   (bytevector-ieee-double-native-set! vec (* i 8) x))
 393 (define-primitive-expander f64vector-ref (vec i)
 394   (bytevector-ieee-double-native-ref vec (* i 8)))
 395 (define-primitive-expander f64vector-set! (vec i x)
 396   (bytevector-ieee-double-native-set! vec (* i 8) x))
 397
 398 (hashq-set! *primitive-expand-table*
 399             'dynamic-wind
 400             (case-lambda
 401               ((src pre thunk post)
 402                ;; Here we will make concessions to the fact that our inliner is
 403                ;; lame, and add a hack.
 404                (cond
 405                 ((lambda? thunk)
 406                  (let ((PRE (gensym " pre"))
 407                        (POST (gensym " post")))
 408                    (make-let
 409                     src
 410                     '(pre post)
 411                     (list PRE POST)
 412                     (list pre post)
 413                     (make-dynwind
 414                      src
 415                      (make-lexical-ref #f 'pre PRE)
 416                      (make-call #f thunk '())
 417                      (make-lexical-ref #f 'post POST)))))
 418                 (else
 419                  (let ((PRE (gensym " pre"))
 420                        (THUNK (gensym " thunk"))
 421                        (POST (gensym " post")))
 422                    (make-let
 423                     src
 424                     '(pre thunk post)
 425                     (list PRE THUNK POST)
 426                     (list pre thunk post)
 427                     (make-dynwind
 428                      src
 429                      (make-lexical-ref #f 'pre PRE)
 430                      (make-call #f (make-lexical-ref #f 'thunk THUNK) '())
 431                      (make-lexical-ref #f 'post POST)))))))
 432               (else #f)))
 433
 434 (hashq-set! *primitive-expand-table*
 435             '@dynamic-wind
 436             (case-lambda
 437               ((src pre expr post)
 438                (let ((PRE (gensym " pre"))
 439                      (POST (gensym " post")))
 440                  (make-let
 441                   src
 442                   '(pre post)
 443                   (list PRE POST)
 444                   (list pre post)
 445                   (make-dynwind
 446                    src
 447                    (make-lexical-ref #f 'pre PRE)
 448                    expr
 449                    (make-lexical-ref #f 'post POST)))))))
 450
 451 (hashq-set! *primitive-expand-table*
 452             'fluid-ref
 453             (case-lambda
 454               ((src fluid) (make-dynref src fluid))
 455               (else #f)))
 456
 457 (hashq-set! *primitive-expand-table*
 458             'fluid-set!
 459             (case-lambda
 460               ((src fluid exp) (make-dynset src fluid exp))
 461               (else #f)))
 462
 463 (hashq-set! *primitive-expand-table*
 464             '@prompt
 465             (case-lambda
 466               ((src tag exp handler)
 467                (let ((args-sym (gensym)))
 468                  (make-prompt
 469                   src tag exp
 470                   ;; If handler itself is a lambda, the inliner can do some
 471                   ;; trickery here.
 472                   (make-lambda-case
 473                    (tree-il-src handler) '() #f 'args #f '() (list args-sym)
 474                    (make-primcall #f 'apply
 475                                   (list handler
 476                                         (make-lexical-ref #f 'args args-sym)))
 477                    #f))))
 478               (else #f)))
 479
 480 (hashq-set! *primitive-expand-table*
 481             'call-with-prompt
 482             (case-lambda
 483               ((src tag thunk handler)
 484                ;; Sigh. Until the inliner does its job, manually inline
 485                ;; (let ((h (lambda ...))) (prompt k x h))
 486                (cond
 487                 ((lambda? handler)
 488                  (let ((args-sym (gensym)))
 489                    (make-prompt
 490                     src tag (make-call #f thunk '())
 491                     ;; If handler itself is a lambda, the inliner can do some
 492                     ;; trickery here.
 493                     (make-lambda-case
 494                      (tree-il-src handler) '() #f 'args #f '() (list args-sym)
 495                      (make-primcall #f 'apply
 496                                     (list handler
 497                                           (make-lexical-ref #f 'args args-sym)))
 498                      #f))))
 499                 (else #f)))
 500               (else #f)))
 501
 502 (hashq-set! *primitive-expand-table*
 503             '@abort
 504             (case-lambda
 505               ((src tag tail-args)
 506                (make-abort src tag '() tail-args))
 507               (else #f)))
 508 (hashq-set! *primitive-expand-table*
 509             'abort-to-prompt
 510             (case-lambda
 511               ((src tag . args)
 512                (make-abort src tag args (make-const #f '())))
 513               (else #f)))