module/language/tree-il/primitives.scm

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