module/language/tree-il/primitives.scm

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