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