module/language/tree-il/primitives.scm

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