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