;;; open-coding primitive procedures
-;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 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
(define-module (language tree-il primitives)
#:use-module (system base pmatch)
+ #:use-module (ice-9 match)
#:use-module (rnrs bytevectors)
#:use-module (system base syntax)
#:use-module (language tree-il)
#:export (resolve-primitives add-interesting-primitive!
expand-primitives
effect-free-primitive? effect+exception-free-primitive?
- constructor-primitive? accessor-primitive?
+ constructor-primitive?
singly-valued-primitive? equality-primitive?
bailout-primitive?
negate-primitive))
values
eq? eqv? equal?
memq memv
- = < > <= >= zero?
+ = < > <= >= zero? positive? negative?
+ * - / 1- 1+ quotient remainder modulo
ash logand logior logxor lognot
not
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- vector-length vector-ref vector-set!
- variable-ref variable-set!
+ length
+
+ make-vector vector-length vector-ref vector-set!
+ variable? variable-ref variable-set!
variable-bound?
+ current-module define!
+
fluid-ref fluid-set! with-fluid*
call-with-prompt
string-length string-ref string-set!
- struct-vtable make-struct struct-ref struct-set!
+ allocate-struct struct-vtable make-struct struct-ref struct-set!
bytevector-u8-ref bytevector-u8-set!
bytevector-s8-ref bytevector-s8-set!
(define *primitive-constructors*
;; Primitives that return a fresh object.
- '(acons cons cons* list vector make-struct make-struct/no-tail
+ '(acons cons cons* list vector make-vector
+ allocate-struct make-struct make-struct/no-tail
make-prompt-tag))
(define *primitive-accessors*
;; Primitives that are pure, but whose result depends on the mutable
;; memory pointed to by their operands.
+ ;;
+ ;; Note: if you add an accessor here, be sure to add a corresponding
+ ;; case in (language tree-il effects)!
'(vector-ref
car cdr
memq memv
(define *effect-free-primitives*
`(values
eq? eqv? equal?
- = < > <= >= zero?
+ = < > <= >= zero? positive? negative?
ash logand logior logxor lognot
+ * - / 1- 1+ quotient remainder modulo
not
- pair? null? list? symbol? vector? struct? string? number? char? nil
+ pair? null? nil? list?
+ symbol? variable? vector? struct? string? number? char?
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
+ length string-length vector-length
;; These all should get expanded out by expand-primitives.
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
'(values
eq? eqv? equal?
not
- pair? null? list? symbol? vector? struct? string? number? char?
+ pair? null? nil? list?
+ symbol? variable? vector? struct? string? number? char?
procedure? thunk?
acons cons cons* list vector))
(define *negatable-primitives*
'((even? . odd?)
(exact? . inexact?)
- (< . >=)
- (> . <=)
+ ;; (< <= > >=) are not negatable because of NaNs.
(char<? . char>=?)
(char>? . char<=?)))
(define (constructor-primitive? prim)
(memq prim *primitive-constructors*))
-(define (accessor-primitive? prim)
- (memq prim *primitive-accessors*))
(define (effect-free-primitive? prim)
(hashq-ref *effect-free-primitive-table* prim))
(define (effect+exception-free-primitive? prim)
(define local-definitions
(make-hash-table))
- (let collect-local-definitions ((x x))
- (record-case x
- ((<toplevel-define> name)
- (hashq-set! local-definitions name #t))
- ((<seq> head tail)
- (collect-local-definitions head)
- (collect-local-definitions tail))
- (else #f)))
+ ;; Assume that any definitions with primitive names in the root module
+ ;; have the same semantics as the primitives.
+ (unless (eq? mod the-root-module)
+ (let collect-local-definitions ((x x))
+ (record-case x
+ ((<toplevel-define> name)
+ (hashq-set! local-definitions name #t))
+ ((<seq> head tail)
+ (collect-local-definitions head)
+ (collect-local-definitions tail))
+ (else #f))))
(post-order
(lambda (x)
(else (error "bad consequent yall" exp))))
`(hashq-set! *primitive-expand-table*
',sym
- (case-lambda
+ (match-lambda*
,@(let lp ((in clauses) (out '()))
(if (null? in)
- (reverse (cons '(else #f) out))
+ (reverse (cons '(_ #f) out))
(lp (cddr in)
(cons `((src . ,(car in))
- ,(consequent (cadr in))) out)))))))
+ ,(consequent (cadr in)))
+ out)))))))
(define-primitive-expander zero? (x)
(= x 0))
+(define-primitive-expander positive? (x)
+ (> x 0))
+
+(define-primitive-expander negative? (x)
+ (< x 0))
+
;; FIXME: All the code that uses `const?' is redundant with `peval'.
(define-primitive-expander +
() 0
(x) (values x)
- (x y) (if (and (const? y)
- (let ((y (const-exp y)))
- (and (number? y) (exact? y) (= y 1))))
+ (x y) (if (and (const? y) (eqv? (const-exp y) 1))
(1+ x)
- (if (and (const? y)
- (let ((y (const-exp y)))
- (and (number? y) (exact? y) (= y -1))))
+ (if (and (const? y) (eqv? (const-exp y) -1))
(1- x)
- (if (and (const? x)
- (let ((x (const-exp x)))
- (and (number? x) (exact? x) (= x 1))))
+ (if (and (const? x) (eqv? (const-exp x) 1))
(1+ y)
- (+ x y))))
- (x y z . rest) (+ x (+ y z . rest)))
-
+ (if (and (const? x) (eqv? (const-exp x) -1))
+ (1- y)
+ (+ x y)))))
+ (x y z ... last) (+ (+ x y . z) last))
+
(define-primitive-expander *
() 1
(x) (values x)
- (x y z . rest) (* x (* y z . rest)))
+ (x y z ... last) (* (* x y . z) last))
(define-primitive-expander -
(x) (- 0 x)
- (x y) (if (and (const? y)
- (let ((y (const-exp y)))
- (and (number? y) (exact? y) (= y 1))))
+ (x y) (if (and (const? y) (eqv? (const-exp y) 1))
(1- x)
(- x y))
- (x y z . rest) (- x (+ y z . rest)))
+ (x y z ... last) (- (- x y . z) last))
(define-primitive-expander /
(x) (/ 1 x)
- (x y z . rest) (/ x (* y z . rest)))
+ (x y z ... last) (/ (/ x y . z) last))
(define-primitive-expander logior
() 0
(x) (logior x 0)
(x y) (logior x y)
- (x y z . rest) (logior x (logior y z . rest)))
+ (x y z ... last) (logior (logior x y . z) last))
(define-primitive-expander logand
() -1
(x) (logand x -1)
(x y) (logand x y)
- (x y z . rest) (logand x (logand y z . rest)))
+ (x y z ... last) (logand (logand x y . z) last))
(define-primitive-expander caar (x) (car (car x)))
(define-primitive-expander cadr (x) (car (cdr x)))
(define-primitive-expander f64vector-set! (vec i x)
(bytevector-ieee-double-native-set! vec (* i 8) x))
+(define (chained-comparison-expander prim-name)
+ (case-lambda
+ ((src) (make-const src #t))
+ ((src a) #f)
+ ((src a b) #f)
+ ((src a b . rest)
+ (let* ((b-sym (gensym "b"))
+ (b* (make-lexical-ref src 'b b-sym)))
+ (make-let src
+ '(b)
+ (list b-sym)
+ (list b)
+ (make-conditional src
+ (make-primcall src prim-name (list a b*))
+ (make-primcall src prim-name (cons b* rest))
+ (make-const src #f)))))))
+
+(for-each (lambda (prim-name)
+ (hashq-set! *primitive-expand-table* prim-name
+ (chained-comparison-expander prim-name)))
+ '(< > <= >= =))
+
;; Appropriate for use with either 'eqv?' or 'equal?'.
-(define maybe-simplify-to-eq
+(define (maybe-simplify-to-eq prim)
(case-lambda
+ ((src) (make-const src #t))
+ ((src a) (make-const src #t))
((src a b)
;; Simplify cases where either A or B is constant.
(define (maybe-simplify a b)
(>= v most-negative-fixnum)))
(make-primcall src 'eq? (list a b))))))
(or (maybe-simplify a b) (maybe-simplify b a)))
+ ((src a b . rest)
+ (make-conditional src (make-primcall src prim (list a b))
+ (make-primcall src prim (cons b rest))
+ (make-const src #f)))
+ (else #f)))
+
+(hashq-set! *primitive-expand-table* 'eqv? (maybe-simplify-to-eq 'eqv?))
+(hashq-set! *primitive-expand-table* 'equal? (maybe-simplify-to-eq 'equal?))
+
+(define (expand-chained-comparisons prim)
+ (case-lambda
+ ((src) (make-const src #t))
+ ((src a) (make-const src #t))
+ ((src a b) #f)
+ ((src a b . rest)
+ (make-conditional src (make-primcall src prim (list a b))
+ (make-primcall src prim (cons b rest))
+ (make-const src #f)))
(else #f)))
-(hashq-set! *primitive-expand-table* 'eqv? maybe-simplify-to-eq)
-(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
+(for-each (lambda (prim)
+ (hashq-set! *primitive-expand-table* prim
+ (expand-chained-comparisons prim)))
+ '(< <= = >= > eq?))
(hashq-set! *primitive-expand-table*
'call-with-prompt
(case-lambda
((src tag thunk handler)
- (let ((handler-sym (gensym))
- (args-sym (gensym)))
- (make-let
- src '(handler) (list handler-sym) (list handler)
- (make-prompt
- src tag (make-call #f thunk '())
- ;; If handler itself is a lambda, the inliner can do some
- ;; trickery here.
- (make-lambda-case
- (tree-il-src handler) '() #f 'args #f '() (list args-sym)
- (make-primcall
- #f 'apply
- (list (make-lexical-ref #f 'handler handler-sym)
- (make-lexical-ref #f 'args args-sym)))
- #f)))))
+ (make-prompt src #f tag thunk handler))
(else #f)))
(hashq-set! *primitive-expand-table*
HCoop / bpt / guile.git / blobdiff