module/language/tree-il/primitives.scm

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