;;; open-coding primitive procedures
-;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
#:use-module (language tree-il)
#:use-module (srfi srfi-4)
#:use-module (srfi srfi-16)
- #:export (resolve-primitives! add-interesting-primitive!
- expand-primitives!
+ #:export (resolve-primitives add-interesting-primitive!
+ expand-primitives
effect-free-primitive? effect+exception-free-primitive?
constructor-primitive? accessor-primitive?
- singly-valued-primitive? equality-primitive?))
+ singly-valued-primitive? equality-primitive?
+ bailout-primitive?
+ negate-primitive))
+;; When adding to this, be sure to update *multiply-valued-primitives*
+;; if appropriate.
(define *interesting-primitive-names*
'(apply @apply
call-with-values @call-with-values
memq memv
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
- ash logand logior logxor
+ ash logand logior logxor lognot
not
- pair? null? list? symbol? vector? string? struct?
- nil?
+ pair? null? list? symbol? vector? string? struct? number? char? nil?
+
+ complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+
+ char<? char<=? char>=? char>?
+
+ integer->char char->integer number->string string->number
+
acons cons cons*
list vector
fluid-ref fluid-set!
- @prompt call-with-prompt @abort abort-to-prompt
+ @prompt call-with-prompt
+ abort-to-prompt* abort-to-prompt
make-prompt-tag
+ throw error scm-error
+
string-length string-ref string-set!
struct-vtable make-struct struct-ref struct-set!
'(vector-ref
car cdr
memq memv
- struct-vtable struct-ref
+ struct-ref
string-ref
bytevector-u8-ref bytevector-s8-ref
bytevector-u16-ref bytevector-u16-native-ref
`(values
eq? eqv? equal?
= < > <= >= zero?
+ ash logand logior logxor lognot
+ * - / 1- 1+ quotient remainder modulo
not
- pair? null? list? symbol? vector? struct? string?
- nil?
+ pair? null? list? symbol? vector? struct? string? number? char? nil
+ complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+ char<? char<=? char>=? char>?
+ integer->char char->integer number->string string->number
+ struct-vtable
string-length vector-length
- ;; These all should get expanded out by expand-primitives!.
+ ;; These all should get expanded out by expand-primitives.
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
'(values
eq? eqv? equal?
not
- pair? null? list? symbol? vector? struct? string?
+ pair? null? list? symbol? vector? struct? string? number? char?
acons cons cons* list vector))
-;; Primitives that only return one value.
-(define *singly-valued-primitives*
- '(eq? eqv? equal?
- memq memv
- = < > <= >= zero?
- + * - / 1- 1+ quotient remainder modulo
- ash logand logior logxor
- not
- pair? null? list? symbol? vector? acons cons cons*
- nil?
- list vector
- car cdr
- set-car! set-cdr!
- caar cadr cdar cddr
- caaar caadr cadar caddr cdaar cdadr cddar cdddr
- caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
- cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- vector-ref vector-set!
- variable-ref variable-set!
- variable-bound?
- fluid-ref fluid-set!
- make-prompt-tag
- struct? struct-vtable make-struct struct-ref struct-set!
- string-length string-ref string-set!
- bytevector-u8-ref bytevector-u8-set!
- bytevector-s8-ref bytevector-s8-set!
- u8vector-ref u8vector-set! s8vector-ref s8vector-set!
- bytevector-u16-ref bytevector-u16-set!
- bytevector-u16-native-ref bytevector-u16-native-set!
- bytevector-s16-ref bytevector-s16-set!
- bytevector-s16-native-ref bytevector-s16-native-set!
- u16vector-ref u16vector-set! s16vector-ref s16vector-set!
- bytevector-u32-ref bytevector-u32-set!
- bytevector-u32-native-ref bytevector-u32-native-set!
- bytevector-s32-ref bytevector-s32-set!
- bytevector-s32-native-ref bytevector-s32-native-set!
- u32vector-ref u32vector-set! s32vector-ref s32vector-set!
- bytevector-u64-ref bytevector-u64-set!
- bytevector-u64-native-ref bytevector-u64-native-set!
- bytevector-s64-ref bytevector-s64-set!
- bytevector-s64-native-ref bytevector-s64-native-set!
- u64vector-ref u64vector-set! s64vector-ref s64vector-set!
- bytevector-ieee-single-ref bytevector-ieee-single-set!
- bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
- bytevector-ieee-double-ref bytevector-ieee-double-set!
- bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
- f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
+;; Primitives that don't always return one value.
+(define *multiply-valued-primitives*
+ '(apply @apply
+ call-with-values @call-with-values
+ call-with-current-continuation @call-with-current-continuation
+ call/cc
+ dynamic-wind
+ @dynamic-wind
+ values
+ @prompt call-with-prompt
+ @abort abort-to-prompt))
+
+;; Procedures that cause a nonlocal, non-resumable abort.
+(define *bailout-primitives*
+ '(throw error scm-error))
+
+;; Negatable predicates.
+(define *negatable-primitives*
+ '((even? . odd?)
+ (exact? . inexact?)
+ (< . >=)
+ (> . <=)
+ (char<? . char>=?)
+ (char>? . char<=?)))
(define *equality-primitives*
'(eq? eqv? equal?))
(define *effect-free-primitive-table* (make-hash-table))
(define *effect+exceptions-free-primitive-table* (make-hash-table))
-(define *singly-valued-primitive-table* (make-hash-table))
(define *equality-primitive-table* (make-hash-table))
+(define *multiply-valued-primitive-table* (make-hash-table))
+(define *bailout-primitive-table* (make-hash-table))
+(define *negatable-primitive-table* (make-hash-table))
(for-each (lambda (x)
(hashq-set! *effect-free-primitive-table* x #t))
(for-each (lambda (x)
(hashq-set! *effect+exceptions-free-primitive-table* x #t))
*effect+exception-free-primitives*)
-(for-each (lambda (x)
- (hashq-set! *singly-valued-primitive-table* x #t))
- *singly-valued-primitives*)
(for-each (lambda (x)
(hashq-set! *equality-primitive-table* x #t))
*equality-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *multiply-valued-primitive-table* x #t))
+ *multiply-valued-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *bailout-primitive-table* x #t))
+ *bailout-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *negatable-primitive-table* (car x) (cdr x))
+ (hashq-set! *negatable-primitive-table* (cdr x) (car x)))
+ *negatable-primitives*)
(define (constructor-primitive? prim)
(memq prim *primitive-constructors*))
(hashq-ref *effect-free-primitive-table* prim))
(define (effect+exception-free-primitive? prim)
(hashq-ref *effect+exceptions-free-primitive-table* prim))
-(define (singly-valued-primitive? prim)
- (hashq-ref *singly-valued-primitive-table* prim))
(define (equality-primitive? prim)
(hashq-ref *equality-primitive-table* prim))
+(define (singly-valued-primitive? prim)
+ (not (hashq-ref *multiply-valued-primitive-table* prim)))
+(define (bailout-primitive? prim)
+ (hashq-ref *bailout-primitive-table* prim))
+(define (negate-primitive prim)
+ (hashq-ref *negatable-primitive-table* prim))
-(define (resolve-primitives! x mod)
+(define (resolve-primitives x mod)
(define local-definitions
(make-hash-table))
(collect-local-definitions tail))
(else #f)))
- (post-order!
+ (post-order
(lambda (x)
- (record-case x
- ((<toplevel-ref> src name)
- (and=> (and (not (hashq-ref local-definitions name))
- (hashq-ref *interesting-primitive-vars*
- (module-variable mod name)))
- (lambda (name) (make-primitive-ref src name))))
- ((<module-ref> src mod name public?)
- ;; for the moment, we're disabling primitive resolution for
- ;; public refs because resolve-interface can raise errors.
- (let ((m (and (not public?) (resolve-module mod))))
- (and m
- (and=> (hashq-ref *interesting-primitive-vars*
- (module-variable m name))
- (lambda (name) (make-primitive-ref src name))))))
- ((<call> src proc args)
- (and (primitive-ref? proc)
- (make-primcall src (primitive-ref-name proc) args)))
- (else #f)))
+ (or
+ (record-case x
+ ((<toplevel-ref> src name)
+ (and=> (and (not (hashq-ref local-definitions name))
+ (hashq-ref *interesting-primitive-vars*
+ (module-variable mod name)))
+ (lambda (name) (make-primitive-ref src name))))
+ ((<module-ref> src mod name public?)
+ ;; for the moment, we're disabling primitive resolution for
+ ;; public refs because resolve-interface can raise errors.
+ (and=> (and=> (resolve-module mod)
+ (if public?
+ module-public-interface
+ identity))
+ (lambda (m)
+ (and=> (hashq-ref *interesting-primitive-vars*
+ (module-variable m name))
+ (lambda (name)
+ (make-primitive-ref src name))))))
+ ((<call> src proc args)
+ (and (primitive-ref? proc)
+ (make-primcall src (primitive-ref-name proc) args)))
+ (else #f))
+ x))
x))
\f
(define *primitive-expand-table* (make-hash-table))
-(define (expand-primitives! x)
- (pre-order!
+(define (expand-primitives x)
+ (pre-order
(lambda (x)
(record-case x
((<primcall> src name args)
(let ((expand (hashq-ref *primitive-expand-table* name)))
- (and expand (apply expand src args))))
- (else #f)))
+ (or (and expand (apply expand src args))
+ x)))
+ (else x)))
x))
;;; I actually did spend about 10 minutes trying to redo this with
(x) (/ 1 x)
(x y z . rest) (/ x (* y z . rest)))
+(define-primitive-expander logior
+ () 0
+ (x) (logior x 0)
+ (x y) (logior x y)
+ (x y z . rest) (logior x (logior y z . rest)))
+
+(define-primitive-expander logand
+ () -1
+ (x) (logand x -1)
+ (x y) (logand x y)
+ (x y z . rest) (logand x (logand y z . rest)))
+
(define-primitive-expander caar (x) (car (car x)))
(define-primitive-expander cadr (x) (car (cdr x)))
(define-primitive-expander cdar (x) (cdr (car x)))
(define-primitive-expander f64vector-set! (vec i x)
(bytevector-ieee-double-native-set! vec (* i 8) x))
+;; Appropriate for use with either 'eqv?' or 'equal?'.
+(define maybe-simplify-to-eq
+ (case-lambda
+ ((src a b)
+ ;; Simplify cases where either A or B is constant.
+ (define (maybe-simplify a b)
+ (and (const? a)
+ (let ((v (const-exp a)))
+ (and (or (memq v '(#f #t () #nil))
+ (symbol? v)
+ (and (integer? v)
+ (exact? v)
+ (<= v most-positive-fixnum)
+ (>= v most-negative-fixnum)))
+ (make-primcall src 'eq? (list a b))))))
+ (or (maybe-simplify a b) (maybe-simplify b a)))
+ (else #f)))
+
+(hashq-set! *primitive-expand-table* 'eqv? maybe-simplify-to-eq)
+(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
+
(hashq-set! *primitive-expand-table*
'@dynamic-wind
(case-lambda
((src pre expr post)
- (let ((PRE (gensym "pre-"))
- (POST (gensym "post-")))
- (make-let
- src
- '(pre post)
- (list PRE POST)
- (list pre post)
- (make-dynwind
- src
- (make-lexical-ref #f 'pre PRE)
- (make-call #f (make-lexical-ref #f 'pre PRE) '())
- expr
- (make-call #f (make-lexical-ref #f 'post POST) '())
- (make-lexical-ref #f 'post POST)))))))
+ (let* ((PRE (gensym "pre-"))
+ (POST (gensym "post-"))
+ (winder (make-lexical-ref #f 'winder PRE))
+ (unwinder (make-lexical-ref #f 'unwinder POST)))
+ (define (make-begin0 src first second)
+ (make-let-values
+ src
+ first
+ (let ((vals (gensym "vals ")))
+ (make-lambda-case
+ #f
+ '() #f 'vals #f '() (list vals)
+ (make-seq
+ src
+ second
+ (make-primcall #f 'apply
+ (list
+ (make-primitive-ref #f 'values)
+ (make-lexical-ref #f 'vals vals))))
+ #f))))
+ (make-let src '(pre post) (list PRE POST) (list pre post)
+ (make-seq src
+ (make-call src winder '())
+ (make-begin0
+ src
+ (make-dynwind src winder expr unwinder)
+ (make-call src unwinder '()))))))))
(hashq-set! *primitive-expand-table*
'fluid-ref
(else #f)))
(hashq-set! *primitive-expand-table*
- '@abort
+ 'abort-to-prompt*
(case-lambda
((src tag tail-args)
(make-abort src tag '() tail-args))
HCoop / bpt / guile.git / blobdiff