;;; open-coding primitive procedures
-;; Copyright (C) 2009, 2010, 2011, 2012 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)
#: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?
+ constructor-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
- call-with-current-continuation @call-with-current-continuation
+ '(apply
+ call-with-values
+ call-with-current-continuation
call/cc
dynamic-wind
- @dynamic-wind
values
eq? eqv? equal?
memq memv
- = < > <= >= zero?
+ = < > <= >= zero? positive? negative?
+ * - / 1- 1+ quotient remainder modulo
ash logand logior logxor lognot
not
pair? null? list? symbol? vector? string? struct? number? char? nil?
+ procedure? thunk?
+
complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
char<? char<=? char>=? char>?
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?
- fluid-ref fluid-set!
+ current-module define!
- @prompt call-with-prompt @abort abort-to-prompt
+ fluid-ref fluid-set! with-fluid*
+
+ 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!
+ 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
- ;; These all should get expanded out by expand-primitives!.
+ 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
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
'(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))
;; 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
+ '(apply
+ call-with-values
+ call-with-current-continuation
call/cc
dynamic-wind
- @dynamic-wind
values
- @prompt call-with-prompt @abort abort-to-prompt))
+ call-with-prompt
+ @abort abort-to-prompt))
;; Procedures that cause a nonlocal, non-resumable abort.
(define *bailout-primitives*
(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 (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))
- (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!
+ (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.
- (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)))
+ (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
(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 acons (x y z)
(cons (cons x y) z))
-(define-primitive-expander apply (f a0 . args)
- (@apply f a0 . args))
-
-(define-primitive-expander call-with-values (producer consumer)
- (@call-with-values producer consumer))
-
-(define-primitive-expander call-with-current-continuation (proc)
- (@call-with-current-continuation proc))
-
(define-primitive-expander call/cc (proc)
- (@call-with-current-continuation proc))
+ (call-with-current-continuation proc))
(define-primitive-expander make-struct (vtable tail-size . args)
(if (and (const? tail-size)
(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)
-(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)))))))
+(hashq-set! *primitive-expand-table* 'eqv? (maybe-simplify-to-eq 'eqv?))
+(hashq-set! *primitive-expand-table* 'equal? (maybe-simplify-to-eq 'equal?))
-(hashq-set! *primitive-expand-table*
- 'fluid-ref
- (case-lambda
- ((src fluid) (make-dynref src fluid))
- (else #f)))
-
-(hashq-set! *primitive-expand-table*
- 'fluid-set!
- (case-lambda
- ((src fluid exp) (make-dynset src fluid exp))
- (else #f)))
+(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*
- '@prompt
- (case-lambda
- ((src tag exp handler)
- (let ((args-sym (gensym)))
- (make-prompt
- src tag exp
- ;; 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 handler
- (make-lexical-ref #f 'args args-sym)))
- #f))))
- (else #f)))
+(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*
- '@abort
+ 'abort-to-prompt*
(case-lambda
((src tag tail-args)
(make-abort src tag '() tail-args))
HCoop / bpt / guile.git / blobdiff