;;; 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? bailout-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
+ * - / 1- 1+ quotient remainder modulo
ash logand logior logxor lognot
not
- pair? null? list? symbol? vector? string? struct? number? char?
+ pair? null? list? symbol? vector? string? struct? number? char? nil?
+
+ procedure? thunk?
complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- vector-ref vector-set!
+ vector-length vector-ref vector-set!
variable-ref variable-set!
variable-bound?
- fluid-ref fluid-set!
+ fluid-ref fluid-set! with-fluid*
- @prompt call-with-prompt @abort abort-to-prompt
+ call-with-prompt
+ abort-to-prompt* abort-to-prompt
make-prompt-tag
throw error scm-error
ash logand logior logxor lognot
+ * - / 1- 1+ quotient remainder modulo
not
- pair? null? list? symbol? vector? struct? string? number? char?
+ 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
- ;; These all should get expanded out by expand-primitives!.
+ 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
eq? eqv? equal?
not
pair? null? list? symbol? 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*
(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 *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+exceptions-free-primitive-table* x #t))
*effect+exception-free-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*)
(hashq-ref *effect-free-primitive-table* prim))
(define (effect+exception-free-primitive? prim)
(hashq-ref *effect+exceptions-free-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)
(define (negate-primitive prim)
(hashq-ref *negatable-primitive-table* prim))
-(define (resolve-primitives! x mod)
- (post-order!
+(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)))
+
+ (post-order
(lambda (x)
- (record-case x
- ((<toplevel-ref> src name)
- (and=> (hashq-ref *interesting-primitive-vars*
- (module-variable mod name))
- (lambda (name) (make-primitive-ref src name))))
- ((<module-ref> src mod name public?)
- (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))))))
- (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
- ((<application> src proc args)
- (and (primitive-ref? proc)
- (let ((expand (hashq-ref *primitive-expand-table*
- (primitive-ref-name proc))))
- (and expand (apply expand src args)))))
- (else #f)))
+ ((<primcall> src name args)
+ (let ((expand (hashq-ref *primitive-expand-table* name)))
+ (or (and expand (apply expand src args))
+ x)))
+ (else x)))
x))
;;; I actually did spend about 10 minutes trying to redo this with
(lp (cdr in)
(cons (if (eq? (caar in) 'quote)
`(make-const src ,@(cdar in))
- `(make-application src (make-primitive-ref src ',(caar in))
- ,(inline-args (cdar in))))
+ `(make-primcall src ',(caar in)
+ ,(inline-args (cdar in))))
out)))
((symbol? (car in))
;; assume it's locally bound
,(consequent then)
,(consequent else)))
(else
- `(make-application src (make-primitive-ref src ',(car exp))
- ,(inline-args (cdr exp))))))
+ `(make-primcall src ',(car exp)
+ ,(inline-args (cdr exp))))))
((symbol? exp)
;; assume locally bound
exp)
(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)
(symbol? v)
(and (integer? v)
(exact? v)
- (<= most-negative-fixnum v most-positive-fixnum)))
- (make-application src (make-primitive-ref #f 'eq?)
- (list a b))))))
+ (<= 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 thunk post)
- (let ((PRE (gensym "pre-"))
- (THUNK (gensym "thunk-"))
- (POST (gensym "post-")))
- (make-let
- src
- '(pre thunk post)
- (list PRE THUNK POST)
- (list pre thunk post)
- (make-dynwind
- src
- (make-lexical-ref #f 'pre PRE)
- (make-application #f (make-lexical-ref #f 'thunk THUNK) '())
- (make-lexical-ref #f 'post POST)))))
- (else #f)))
-
-(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)
- expr
- (make-lexical-ref #f 'post POST)))))))
-
-(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)))
-
-(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-application #f (make-primitive-ref #f 'apply)
- (list handler
- (make-lexical-ref #f 'args args-sym)))
- #f))))
- (else #f)))
-
(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-application #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-application
- #f (make-primitive-ref #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