summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
Diffstat (limited to 'module/language')
-rw-r--r--module/language/assembly/compile-bytecode.scm2
-rw-r--r--module/language/assembly/disassemble.scm4
-rw-r--r--module/language/brainfuck/compile-tree-il.scm54
-rw-r--r--module/language/bytecode/spec.scm7
-rw-r--r--module/language/ecmascript/compile-tree-il.scm170
-rw-r--r--module/language/elisp/bindings.scm80
-rw-r--r--module/language/elisp/boot.el617
-rw-r--r--module/language/elisp/compile-tree-il.scm1046
-rw-r--r--module/language/elisp/falias.scm27
-rw-r--r--module/language/elisp/lexer.scm33
-rw-r--r--module/language/elisp/parser.scm2
-rw-r--r--module/language/elisp/runtime.scm143
-rw-r--r--module/language/elisp/runtime/function-slot.scm119
-rw-r--r--module/language/elisp/runtime/macros.scm208
-rw-r--r--module/language/elisp/runtime/subrs.scm383
-rw-r--r--module/language/elisp/runtime/value-slot.scm3
-rw-r--r--module/language/elisp/spec.scm4
-rw-r--r--module/language/objcode/elf.scm94
-rw-r--r--module/language/objcode/spec.scm1
-rw-r--r--module/language/scheme/decompile-tree-il.scm18
-rw-r--r--module/language/tree-il.scm143
-rw-r--r--module/language/tree-il/analyze.scm74
-rw-r--r--module/language/tree-il/canonicalize.scm18
-rw-r--r--module/language/tree-il/compile-glil.scm469
-rw-r--r--module/language/tree-il/cse.scm77
-rw-r--r--module/language/tree-il/debug.scm23
-rw-r--r--module/language/tree-il/effects.scm61
-rw-r--r--module/language/tree-il/fix-letrec.scm51
-rw-r--r--module/language/tree-il/peval.scm492
-rw-r--r--module/language/tree-il/primitives.scm97
-rw-r--r--module/language/tree-il/spec.scm6
31 files changed, 2229 insertions, 2297 deletions
diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
index 181fb06ab..d54186e16 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -133,6 +133,8 @@
((br-if-not-eq ,l) (write-break l))
((br-if-null ,l) (write-break l))
((br-if-not-null ,l) (write-break l))
+ ((br-if-nil ,l) (write-break l))
+ ((br-if-not-nil ,l) (write-break l))
((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm
index 5d30be391..dcdd78073 100644
--- a/module/language/assembly/disassemble.scm
+++ b/module/language/assembly/disassemble.scm
@@ -125,7 +125,9 @@
(case inst
((list vector)
(list "~a element~:p" (apply make-int16 args)))
- ((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null)
+ ((br
+ br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null
+ br-if-nil br-if-not-nil)
(list "-> ~A" (assq-ref labels (car args))))
((br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt)
(list "-> ~A" (assq-ref labels (caddr args))))
diff --git a/module/language/brainfuck/compile-tree-il.scm b/module/language/brainfuck/compile-tree-il.scm
index 33d563490..f9dd036e8 100644
--- a/module/language/brainfuck/compile-tree-il.scm
+++ b/module/language/brainfuck/compile-tree-il.scm
@@ -1,6 +1,6 @@
;;; Brainfuck for GNU Guile
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2011 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
@@ -94,7 +94,7 @@
(parse-tree-il
`(let (pointer tape) (pointer tape)
((const 0)
- (apply (primitive make-vector) (const ,tape-size) (const 0)))
+ (call (primitive make-vector) (const ,tape-size) (const 0)))
,(compile-body exp)))
env
env))
@@ -109,11 +109,11 @@
(cond
((null? in)
;; No more input, build our output.
- (cond
- ((null? out) '(void)) ; no output
- ((null? (cdr out)) (car out)) ; single expression
- (else `(begin ,@(reverse out)))) ; sequence
- )
+ (cond
+ ((null? out) '(void)) ; no output
+ ((null? (cdr out)) (car out)) ; single expression
+ (else `(begin ,@(reverse out)))) ; sequence
+ )
(else
(pmatch (car in)
@@ -121,34 +121,34 @@
;; (set! pointer (+ pointer +-1))
((<bf-move> ,dir)
(emit `(set! (lexical pointer)
- (apply (primitive +) (lexical pointer) (const ,dir)))))
+ (call (primitive +) (lexical pointer) (const ,dir)))))
;; Cell increment +- is done as:
;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
((<bf-increment> ,inc)
- (emit `(apply (primitive vector-set!) (lexical tape) (lexical pointer)
- (apply (primitive +)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))
- (const ,inc)))))
+ (emit `(call (primitive vector-set!) (lexical tape) (lexical pointer)
+ (call (primitive +)
+ (call (primitive vector-ref)
+ (lexical tape) (lexical pointer))
+ (const ,inc)))))
;; Output . is done by converting the cell's integer value to a
;; character first and then printing out this character:
;; (write-char (integer->char (vector-ref tape pointer)))
((<bf-print>)
- (emit `(apply (primitive write-char)
- (apply (primitive integer->char)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))))))
+ (emit `(call (primitive write-char)
+ (call (primitive integer->char)
+ (call (primitive vector-ref)
+ (lexical tape) (lexical pointer))))))
;; Input , is done similarly, read in a character, get its ASCII
;; code and store it into the current cell:
;; (vector-set! tape pointer (char->integer (read-char)))
((<bf-read>)
- (emit `(apply (primitive vector-set!)
- (lexical tape) (lexical pointer)
- (apply (primitive char->integer)
- (apply (primitive read-char))))))
+ (emit `(call (primitive vector-set!)
+ (lexical tape) (lexical pointer)
+ (call (primitive char->integer)
+ (call (primitive read-char))))))
;; For loops [...] we use a letrec construction to execute the body until
;; the current cell gets zero. The body is compiled via a recursive call
@@ -171,14 +171,14 @@
((lambda ()
(lambda-case
((() #f #f #f () ())
- (if (apply (primitive =)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))
- (const 0))
+ (if (call (primitive =)
+ (call (primitive vector-ref)
+ (lexical tape) (lexical pointer))
+ (const 0))
(void)
(begin ,(compile-body body)
- (apply (lexical ,iterate)))))
+ (call (lexical ,iterate)))))
#f)))
- (apply (lexical ,iterate))))))
+ (call (lexical ,iterate))))))
(else (error "unknown brainfuck instruction" (car in))))))))
diff --git a/module/language/bytecode/spec.scm b/module/language/bytecode/spec.scm
index 1d7e79b57..ca703c33c 100644
--- a/module/language/bytecode/spec.scm
+++ b/module/language/bytecode/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Lowlevel Intermediate Language
-;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 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
@@ -20,14 +20,15 @@
(define-module (language bytecode spec)
#:use-module (system base language)
+ #:use-module (system base target)
#:use-module (system vm objcode)
#:export (bytecode))
(define (compile-objcode x e opts)
- (values (bytecode->objcode x) e e))
+ (values (bytecode->objcode x (target-endianness)) e e))
(define (decompile-objcode x e opts)
- (values (objcode->bytecode x) e))
+ (values (objcode->bytecode x (target-endianness)) e))
(define-language bytecode
#:title "Guile Bytecode Vectors"
diff --git a/module/language/ecmascript/compile-tree-il.scm b/module/language/ecmascript/compile-tree-il.scm
index b5f0a3528..2fe0d924e 100644
--- a/module/language/ecmascript/compile-tree-il.scm
+++ b/module/language/ecmascript/compile-tree-il.scm
@@ -32,7 +32,7 @@
(-> (@ '(language ecmascript impl) 'sym)))
(define-syntax-rule (@impl sym arg ...)
- (-> (apply (@implv sym) arg ...)))
+ (-> (call (@implv sym) arg ...)))
(define (empty-lexical-environment)
'())
@@ -82,7 +82,7 @@
(parameterize ((current-return-tag
(-> (lexical 'return tag))))
(-> (let '(return) (list tag)
- (list (-> (apply (-> (primitive 'make-prompt-tag)))))
+ (list (-> (primcall 'make-prompt-tag)))
(-> (prompt (current-return-tag)
(body-thunk)
(let ((val (gensym "val")))
@@ -115,23 +115,23 @@
(this
(@impl get-this))
((+ ,a)
- (-> (apply (-> (primitive '+))
- (@impl ->number (comp a e))
- (-> (const 0)))))
+ (-> (call (-> (primitive '+))
+ (@impl ->number (comp a e))
+ (-> (const 0)))))
((- ,a)
- (-> (apply (-> (primitive '-)) (-> (const 0)) (comp a e))))
+ (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e))))
((~ ,a)
(@impl bitwise-not (comp a e)))
((! ,a)
(@impl logical-not (comp a e)))
((+ ,a ,b)
- (-> (apply (-> (primitive '+)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '+)) (comp a e) (comp b e))))
((- ,a ,b)
- (-> (apply (-> (primitive '-)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '-)) (comp a e) (comp b e))))
((/ ,a ,b)
- (-> (apply (-> (primitive '/)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '/)) (comp a e) (comp b e))))
((* ,a ,b)
- (-> (apply (-> (primitive '*)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '*)) (comp a e) (comp b e))))
((% ,a ,b)
(@impl mod (comp a e) (comp b e)))
((<< ,a ,b)
@@ -139,27 +139,27 @@
((>> ,a ,b)
(@impl shift (comp a e) (comp `(- ,b) e)))
((< ,a ,b)
- (-> (apply (-> (primitive '<)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '<)) (comp a e) (comp b e))))
((<= ,a ,b)
- (-> (apply (-> (primitive '<=)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '<=)) (comp a e) (comp b e))))
((> ,a ,b)
- (-> (apply (-> (primitive '>)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '>)) (comp a e) (comp b e))))
((>= ,a ,b)
- (-> (apply (-> (primitive '>=)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '>=)) (comp a e) (comp b e))))
((in ,a ,b)
(@impl has-property? (comp a e) (comp b e)))
((== ,a ,b)
- (-> (apply (-> (primitive 'equal?)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e))))
((!= ,a ,b)
- (-> (apply (-> (primitive 'not))
- (-> (apply (-> (primitive 'equal?))
- (comp a e) (comp b e))))))
+ (-> (call (-> (primitive 'not))
+ (-> (call (-> (primitive 'equal?))
+ (comp a e) (comp b e))))))
((=== ,a ,b)
- (-> (apply (-> (primitive 'eqv?)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e))))
((!== ,a ,b)
- (-> (apply (-> (primitive 'not))
- (-> (apply (-> (primitive 'eqv?))
- (comp a e) (comp b e))))))
+ (-> (call (-> (primitive 'not))
+ (-> (call (-> (primitive 'eqv?))
+ (comp a e) (comp b e))))))
((& ,a ,b)
(@impl band (comp a e) (comp b e)))
((^ ,a ,b)
@@ -188,9 +188,9 @@
(begin1 (comp `(ref ,foo) e)
(lambda (var)
(-> (set! (lookup foo e)
- (-> (apply (-> (primitive '+))
- (-> (lexical var var))
- (-> (const 1)))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
((postinc (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
@@ -201,9 +201,9 @@
(@impl pput
(-> (lexical objvar objvar))
(-> (const prop))
- (-> (apply (-> (primitive '+))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
((postinc (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
@@ -216,16 +216,16 @@
(@impl pput
(-> (lexical objvar objvar))
(-> (lexical propvar propvar))
- (-> (apply (-> (primitive '+))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))))
((postdec (ref ,foo))
(begin1 (comp `(ref ,foo) e)
(lambda (var)
(-> (set (lookup foo e)
- (-> (apply (-> (primitive '-))
- (-> (lexical var var))
- (-> (const 1)))))))))
+ (-> (call (-> (primitive '-))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
((postdec (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
@@ -236,9 +236,9 @@
(@impl pput
(-> (lexical objvar objvar))
(-> (const prop))
- (-> (apply (-> (primitive '-))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))
+ (-> (call (-> (primitive '-))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
((postdec (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
@@ -258,18 +258,18 @@
(let ((v (lookup foo e)))
(-> (begin
(-> (set! v
- (-> (apply (-> (primitive '+))
- v
- (-> (const 1))))))
+ (-> (call (-> (primitive '+))
+ v
+ (-> (const 1))))))
v))))
((preinc (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
- (begin1 (-> (apply (-> (primitive '+))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (const prop)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput (-> (lexical objvar objvar))
(-> (const prop))
@@ -279,11 +279,11 @@
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
- (begin1 (-> (apply (-> (primitive '+))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
@@ -293,18 +293,18 @@
(let ((v (lookup foo e)))
(-> (begin
(-> (set! v
- (-> (apply (-> (primitive '-))
+ (-> (call (-> (primitive '-))
v
(-> (const 1))))))
v))))
((predec (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
- (begin1 (-> (apply (-> (primitive '-))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (const prop)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
@@ -315,11 +315,11 @@
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
- (begin1 (-> (apply (-> (primitive '-))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
@@ -359,7 +359,7 @@
(-> (lambda '()
`(lambda-case
((() #f #f #f () ())
- (apply ,(@impl pget obj prop) ,@args)))))))
+ (call ,(@impl pget obj prop) ,@args)))))))
((call (pref ,obj ,prop) ,args)
(comp `(call/this ,(comp obj e)
,(-> (const prop))
@@ -371,24 +371,24 @@
,@(map (lambda (x) (comp x e)) args))
e))
((call ,proc ,args)
- `(apply ,(comp proc e)
- ,@(map (lambda (x) (comp x e)) args)))
+ `(call ,(comp proc e)
+ ,@(map (lambda (x) (comp x e)) args)))
((return ,expr)
(return (comp expr e)))
((array . ,args)
- `(apply ,(@implv new-array)
- ,@(map (lambda (x) (comp x e)) args)))
+ `(call ,(@implv new-array)
+ ,@(map (lambda (x) (comp x e)) args)))
((object . ,args)
- `(apply ,(@implv new-object)
- ,@(map (lambda (x)
- (pmatch x
- ((,prop ,val)
- (-> (apply (-> (primitive 'cons))
- (-> (const prop))
- (comp val e))))
- (else
- (error "bad prop-val pair" x))))
- args)))
+ `(call ,(@implv new-object)
+ ,@(map (lambda (x)
+ (pmatch x
+ ((,prop ,val)
+ (-> (call (-> (primitive 'cons))
+ (-> (const prop))
+ (comp val e))))
+ (else
+ (error "bad prop-val pair" x))))
+ args)))
((pref ,obj ,prop)
(@impl pget
(comp obj e)
@@ -463,14 +463,14 @@
`((() #f #f #f () ())
,(-> (begin
(comp statement e)
- (-> (apply (-> (lexical '%continue %continue)))))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))))
(-> (lambda '()
(-> (lambda-case
`((() #f #f #f () ())
,(-> (if (@impl ->boolean (comp test e))
- (-> (apply (-> (lexical '%loop %loop))))
+ (-> (call (-> (lexical '%loop %loop))))
(@implv *undefined*)))))))))
- (-> (apply (-> (lexical '%loop %loop)))))))))
+ (-> (call (-> (lexical '%loop %loop)))))))))
((while ,test ,statement)
(let ((%continue (gensym "%continue ")))
(let ((e (econs '%continue %continue e)))
@@ -480,9 +480,9 @@
`((() #f #f #f () ())
,(-> (if (@impl ->boolean (comp test e))
(-> (begin (comp statement e)
- (-> (apply (-> (lexical '%continue %continue))))))
+ (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*)))))))))
- (-> (apply (-> (lexical '%continue %continue)))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))
((for ,init ,test ,inc ,statement)
(let ((%continue (gensym "%continue ")))
@@ -496,10 +496,10 @@
(comp 'true e))
(-> (begin (comp statement e)
(comp (or inc '(begin)) e)
- (-> (apply (-> (lexical '%continue %continue))))))
+ (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*)))))))))
(-> (begin (comp (or init '(begin)) e)
- (-> (apply (-> (lexical '%continue %continue)))))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))))
((for-in ,var ,object ,statement)
(let ((%enum (gensym "%enum "))
@@ -519,9 +519,9 @@
,(-> (const 'pop))))
e)
(comp statement e)
- (-> (apply (-> (lexical '%continue %continue))))))
+ (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*)))))))))
- (-> (apply (-> (lexical '%continue %continue)))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))
((block ,x)
(comp x e))
diff --git a/module/language/elisp/bindings.scm b/module/language/elisp/bindings.scm
index 6ff56fdcd..9fabddfc4 100644
--- a/module/language/elisp/bindings.scm
+++ b/module/language/elisp/bindings.scm
@@ -19,21 +19,22 @@
;;; Code:
(define-module (language elisp bindings)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
#:export (make-bindings
- mark-global-needed!
- map-globals-needed
with-lexical-bindings
with-dynamic-bindings
- get-lexical-binding))
+ with-function-bindings
+ get-lexical-binding
+ get-function-binding))
;;; This module defines routines to handle analysis of symbol bindings
;;; used during elisp compilation. This data allows to collect the
;;; symbols, for which globals need to be created, or mark certain
;;; symbols as lexically bound.
;;;
-;;; Needed globals are stored in an association-list that stores a list
-;;; of symbols for each module they are needed in.
-;;;
;;; The lexical bindings of symbols are stored in a hash-table that
;;; associates symbols to fluids; those fluids are used in the
;;; with-lexical-binding and with-dynamic-binding routines to associate
@@ -41,64 +42,32 @@
;;; Record type used to hold the data necessary.
-(define bindings-type
- (make-record-type 'bindings '(needed-globals lexical-bindings)))
+(define-record-type bindings
+ (%make-bindings lexical-bindings function-bindings)
+ bindings?
+ (lexical-bindings lexical-bindings)
+ (function-bindings function-bindings))
;;; Construct an 'empty' instance of the bindings data structure to be
;;; used at the start of a fresh compilation.
(define (make-bindings)
- ((record-constructor bindings-type) '() (make-hash-table)))
-
-;;; Mark that a given symbol is needed as global in the specified
-;;; slot-module.
-
-(define (mark-global-needed! bindings sym module)
- (let* ((old-needed ((record-accessor bindings-type 'needed-globals)
- bindings))
- (old-in-module (or (assoc-ref old-needed module) '()))
- (new-in-module (if (memq sym old-in-module)
- old-in-module
- (cons sym old-in-module)))
- (new-needed (assoc-set! old-needed module new-in-module)))
- ((record-modifier bindings-type 'needed-globals)
- bindings
- new-needed)))
-
-;;; Cycle through all globals needed in order to generate the code for
-;;; their creation or some other analysis.
-
-(define (map-globals-needed bindings proc)
- (let ((needed ((record-accessor bindings-type 'needed-globals)
- bindings)))
- (let iterate-modules ((mod-tail needed)
- (mod-result '()))
- (if (null? mod-tail)
- mod-result
- (iterate-modules
- (cdr mod-tail)
- (let* ((aentry (car mod-tail))
- (module (car aentry))
- (symbols (cdr aentry)))
- (let iterate-symbols ((sym-tail symbols)
- (sym-result mod-result))
- (if (null? sym-tail)
- sym-result
- (iterate-symbols (cdr sym-tail)
- (cons (proc module (car sym-tail))
- sym-result))))))))))
+ (%make-bindings (make-hash-table) (make-hash-table)))
;;; Get the current lexical binding (gensym it should refer to in the
;;; current scope) for a symbol or #f if it is dynamically bound.
(define (get-lexical-binding bindings sym)
- (let* ((lex ((record-accessor bindings-type 'lexical-bindings)
- bindings))
+ (let* ((lex (lexical-bindings bindings))
(slot (hash-ref lex sym #f)))
(if slot
(fluid-ref slot)
#f)))
+(define (get-function-binding bindings symbol)
+ (and=> (hash-ref (function-bindings bindings) symbol)
+ fluid-ref))
+
;;; Establish a binding or mark a symbol as dynamically bound for the
;;; extent of calling proc.
@@ -106,8 +75,7 @@
(if (or (not (list? syms))
(not (and-map symbol? syms)))
(error "can't bind non-symbols" syms))
- (let ((lex ((record-accessor bindings-type 'lexical-bindings)
- bindings)))
+ (let ((lex (lexical-bindings bindings)))
(for-each (lambda (sym)
(if (not (hash-ref lex sym))
(hash-set! lex sym (make-fluid))))
@@ -127,3 +95,13 @@
syms
(map (lambda (el) #f) syms)
proc))
+
+(define (with-function-bindings bindings symbols gensyms thunk)
+ (let ((fb (function-bindings bindings)))
+ (for-each (lambda (symbol)
+ (if (not (hash-ref fb symbol))
+ (hash-set! fb symbol (make-fluid))))
+ symbols)
+ (with-fluids* (map (cut hash-ref fb <>) symbols)
+ gensyms
+ thunk)))
diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el
new file mode 100644
index 000000000..f55722a9a
--- /dev/null
+++ b/module/language/elisp/boot.el
@@ -0,0 +1,617 @@
+;;; Guile Emacs Lisp -*- lexical-binding: t -*-
+
+;;; Copyright (C) 2011 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 License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;;; 02110-1301 USA
+
+;;; Code:
+
+(defmacro @ (module symbol)
+ `(guile-ref ,module ,symbol))
+
+(defmacro eval-and-compile (&rest body)
+ `(progn
+ (eval-when-compile ,@body)
+ (progn ,@body)))
+
+(eval-and-compile
+ (defun null (object)
+ (if object nil t))
+ (defun consp (object)
+ (%funcall (@ (guile) pair?) object))
+ (defun listp (object)
+ (if object (consp object) t))
+ (defun car (list)
+ (if list (%funcall (@ (guile) car) list) nil))
+ (defun cdr (list)
+ (if list (%funcall (@ (guile) cdr) list) nil))
+ (defun make-symbol (name)
+ (%funcall (@ (guile) make-symbol) name))
+ (defun signal (error-symbol data)
+ (%funcall (@ (guile) throw) 'elisp-condition error-symbol data)))
+
+(defmacro lambda (&rest cdr)
+ `#'(lambda ,@cdr))
+
+(defmacro prog1 (first &rest body)
+ (let ((temp (make-symbol "prog1-temp")))
+ `(let ((,temp ,first))
+ (declare (lexical ,temp))
+ ,@body
+ ,temp)))
+
+(defmacro prog2 (form1 form2 &rest body)
+ `(progn ,form1 (prog1 ,form2 ,@body)))
+
+(defmacro cond (&rest clauses)
+ (if (null clauses)
+ nil
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (listp first)
+ (let ((condition (car first))
+ (body (cdr first)))
+ (if (null body)
+ (let ((temp (make-symbol "cond-temp")))
+ `(let ((,temp ,condition))
+ (declare (lexical ,temp))
+ (if ,temp
+ ,temp
+ (cond ,@rest))))
+ `(if ,condition
+ (progn ,@body)
+ (cond ,@rest))))
+ (signal 'wrong-type-argument `(listp ,first))))))
+
+(defmacro and (&rest conditions)
+ (cond ((null conditions) t)
+ ((null (cdr conditions)) (car conditions))
+ (t `(if ,(car conditions)
+ (and ,@(cdr conditions))
+ nil))))
+
+(defmacro or (&rest conditions)
+ (cond ((null conditions) nil)
+ ((null (cdr conditions)) (car conditions))
+ (t (let ((temp (make-symbol "or-temp")))
+ `(let ((,temp ,(car conditions)))
+ (declare (lexical ,temp))
+ (if ,temp
+ ,temp
+ (or ,@(cdr conditions))))))))
+
+(defmacro lexical-let (bindings &rest body)
+ (labels ((loop (list vars)
+ (if (null list)
+ `(let ,bindings
+ (declare (lexical ,@vars))
+ ,@body)
+ (loop (cdr list)
+ (if (consp (car list))
+ `(,(car (car list)) ,@vars)
+ `(,(car list) ,@vars))))))
+ (loop bindings '())))
+
+(defmacro lexical-let* (bindings &rest body)
+ (labels ((loop (list vars)
+ (if (null list)
+ `(let* ,bindings
+ (declare (lexical ,@vars))
+ ,@body)
+ (loop (cdr list)
+ (if (consp (car list))
+ (cons (car (car list)) vars)
+ (cons (car list) vars))))))
+ (loop bindings '())))
+
+(defmacro while (test &rest body)
+ (let ((loop (make-symbol "loop")))
+ `(labels ((,loop ()
+ (if ,test
+ (progn ,@body (,loop))
+ nil)))
+ (,loop))))
+
+(defmacro unwind-protect (bodyform &rest unwindforms)
+ `(funcall (@ (guile) dynamic-wind)
+ #'(lambda () nil)
+ #'(lambda () ,bodyform)
+ #'(lambda () ,@unwindforms)))
+
+(defmacro when (cond &rest body)
+ `(if ,cond
+ (progn ,@body)))
+
+(defmacro unless (cond &rest body)
+ `(when (not ,cond)
+ ,@body))
+
+(defun symbolp (object)
+ (%funcall (@ (guile) symbol?) object))
+
+(defun functionp (object)
+ (%funcall (@ (guile) procedure?) object))
+
+(defun symbol-function (symbol)
+ (let ((f (%funcall (@ (language elisp runtime) symbol-function)
+ symbol)))
+ (if (%funcall (@ (language elisp falias) falias?) f)
+ (%funcall (@ (language elisp falias) falias-object) f)
+ f)))
+
+(defun eval (form)
+ (%funcall (@ (system base compile) compile)
+ form
+ (%funcall (@ (guile) symbol->keyword) 'from)
+ 'elisp
+ (%funcall (@ (guile) symbol->keyword) 'to)
+ 'value))
+
+(defun %indirect-function (object)
+ (cond
+ ((functionp object)
+ object)
+ ((symbolp object) ;++ cycle detection
+ (%indirect-function (symbol-function object)))
+ ((listp object)
+ (eval `(function ,object)))
+ (t
+ (signal 'invalid-function `(,object)))))
+
+(defun apply (function &rest arguments)
+ (%funcall (@ (guile) apply)
+ (@ (guile) apply)
+ (%indirect-function function)
+ arguments))
+
+(defun funcall (function &rest arguments)
+ (%funcall (@ (guile) apply)
+ (%indirect-function function)
+ arguments))
+
+(defun fset (symbol definition)
+ (funcall (@ (language elisp runtime) set-symbol-function!)
+ symbol
+ (if (functionp definition)
+ definition
+ (funcall (@ (language elisp falias) make-falias)
+ #'(lambda (&rest args) (apply definition args))
+ definition)))
+ definition)
+
+(defun load (file)
+ (funcall (@ (system base compile) compile-file)
+ file
+ (funcall (@ (guile) symbol->keyword) 'from)
+ 'elisp
+ (funcall (@ (guile) symbol->keyword) 'to)
+ 'value)
+ t)
+
+;;; Equality predicates
+
+(defun eq (obj1 obj2)
+ (if obj1
+ (funcall (@ (guile) eq?) obj1 obj2)
+ (null obj2)))
+
+(defun eql (obj1 obj2)
+ (if obj1
+ (funcall (@ (guile) eqv?) obj1 obj2)
+ (null obj2)))
+
+(defun equal (obj1 obj2)
+ (if obj1
+ (funcall (@ (guile) equal?) obj1 obj2)
+ (null obj2)))
+
+;;; Symbols
+
+;;; `symbolp' and `symbol-function' are defined above.
+
+(fset 'symbol-name (@ (guile) symbol->string))
+(fset 'symbol-value (@ (language elisp runtime) symbol-value))
+(fset 'set (@ (language elisp runtime) set-symbol-value!))
+(fset 'makunbound (@ (language elisp runtime) makunbound!))
+(fset 'fmakunbound (@ (language elisp runtime) fmakunbound!))
+(fset 'boundp (@ (language elisp runtime) symbol-bound?))
+(fset 'fboundp (@ (language elisp runtime) symbol-fbound?))
+(fset 'intern (@ (guile) string->symbol))
+
+(defun defvaralias (new-alias base-variable &optional docstring)
+ (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid)
+ base-variable)))
+ (funcall (@ (language elisp runtime) set-symbol-fluid!)
+ new-alias
+ fluid)
+ base-variable))
+
+;;; Numerical type predicates
+
+(defun floatp (object)
+ (and (funcall (@ (guile) real?) object)
+ (or (funcall (@ (guile) inexact?) object)
+ (null (funcall (@ (guile) integer?) object)))))
+
+(defun integerp (object)
+ (and (funcall (@ (guile) integer?) object)
+ (funcall (@ (guile) exact?) object)))
+
+(defun numberp (object)
+ (funcall (@ (guile) real?) object))
+
+(defun wholenump (object)
+ (and (integerp object) (>= object 0)))
+
+(defun zerop (object)
+ (= object 0))
+
+;;; Numerical comparisons
+
+(fset '= (@ (guile) =))
+
+(defun /= (num1 num2)
+ (null (= num1 num2)))
+
+(fset '< (@ (guile) <))
+(fset '<= (@ (guile) <=))
+(fset '> (@ (guile) >))
+(fset '>= (@ (guile) >=))
+
+(defun max (&rest numbers)
+ (apply (@ (guile) max) numbers))
+
+(defun min (&rest numbers)
+ (apply (@ (guile) min) numbers))
+
+;;; Arithmetic functions
+
+(fset '1+ (@ (guile) 1+))
+(fset '1- (@ (guile) 1-))
+(fset '+ (@ (guile) +))
+(fset '- (@ (guile) -))
+(fset '* (@ (guile) *))
+(fset '% (@ (guile) modulo))
+(fset 'abs (@ (guile) abs))
+
+;;; Floating-point rounding
+
+(fset 'ffloor (@ (guile) floor))
+(fset 'fceiling (@ (guile) ceiling))
+(fset 'ftruncate (@ (guile) truncate))
+(fset 'fround (@ (guile) round))
+
+;;; Numeric conversion
+
+(defun float (arg)
+ (if (numberp arg)
+ (funcall (@ (guile) exact->inexact) arg)
+ (signal 'wrong-type-argument `(numberp ,arg))))
+
+;;; List predicates
+
+(fset 'not #'null)
+
+(defun atom (object)
+ (null (consp object)))
+
+(defun nlistp (object)
+ (null (listp object)))
+
+;;; Lists
+
+(fset 'cons (@ (guile) cons))
+(fset 'list (@ (guile) list))
+(fset 'make-list (@ (guile) make-list))
+(fset 'append (@ (guile) append))
+(fset 'reverse (@ (guile) reverse))
+(fset 'nreverse (@ (guile) reverse!))
+
+(defun car-safe (object)
+ (if (consp object)
+ (car object)
+ nil))
+
+(defun cdr-safe (object)
+ (if (consp object)
+ (cdr object)
+ nil))
+
+(defun setcar (cell newcar)
+ (if (consp cell)
+ (progn
+ (funcall (@ (guile) set-car!) cell newcar)
+ newcar)
+ (signal 'wrong-type-argument `(consp ,cell))))
+
+(defun setcdr (cell newcdr)
+ (if (consp cell)
+ (progn
+ (funcall (@ (guile) set-cdr!) cell newcdr)
+ newcdr)
+ (signal 'wrong-type-argument `(consp ,cell))))
+
+(defun nthcdr (n list)
+ (let ((i 0))
+ (while (< i n)
+ (setq list (cdr list)
+ i (+ i 1)))
+ list))
+
+(defun nth (n list)
+ (car (nthcdr n list)))
+
+(defun %member (elt list test)
+ (cond
+ ((null list) nil)
+ ((consp list)
+ (if (funcall test elt (car list))
+ list
+ (%member elt (cdr list) test)))
+ (t (signal 'wrong-type-argument `(listp ,list)))))
+
+(defun member (elt list)
+ (%member elt list #'equal))
+
+(defun memql (elt list)
+ (%member elt list #'eql))
+
+(defun memq (elt list)
+ (%member elt list #'eq))
+
+(defun assoc (key list)
+ (funcall (@ (srfi srfi-1) assoc) key list #'equal))
+
+(defun assq (key list)
+ (funcall (@ (srfi srfi-1) assoc) key list #'eq))
+
+(defun rplaca (cell newcar)
+ (funcall (@ (guile) set-car!) cell newcar)
+ newcar)
+
+(defun rplacd (cell newcdr)
+ (funcall (@ (guile) set-cdr!) cell newcdr)
+ newcdr)
+
+(defun caar (x)
+ (car (car x)))
+
+(defun cadr (x)
+ (car (cdr x)))
+
+(defun cdar (x)
+ (cdr (car x)))
+
+(defun cddr (x)
+ (cdr (cdr x)))
+
+(defmacro dolist (spec &rest body)
+ (apply #'(lambda (var list &optional result)
+ `(mapc #'(lambda (,var)
+ ,@body
+ ,result)
+ ,list))
+ spec))
+
+;;; Strings
+
+(defun string (&rest characters)
+ (funcall (@ (guile) list->string)
+ (mapcar (@ (guile) integer->char) characters)))
+
+(defun stringp (object)
+ (funcall (@ (guile) string?) object))
+
+(defun string-equal (s1 s2)
+ (let ((s1 (if (symbolp s1) (symbol-name s1) s1))
+ (s2 (if (symbolp s2) (symbol-name s2) s2)))
+ (funcall (@ (guile) string=?) s1 s2)))
+
+(fset 'string= 'string-equal)
+
+(defun substring (string from &optional to)
+ (apply (@ (guile) substring) string from (if to (list to) nil)))
+
+(defun upcase (obj)
+ (funcall (@ (guile) string-upcase) obj))
+
+(defun downcase (obj)
+ (funcall (@ (guile) string-downcase) obj))
+
+(defun string-match (regexp string &optional start)
+ (let ((m (funcall (@ (ice-9 regex) string-match)
+ regexp
+ string
+ (or start 0))))
+ (if m
+ (funcall (@ (ice-9 regex) match:start) m 0)
+ nil)))
+
+;; Vectors
+
+(defun make-vector (length init)
+ (funcall (@ (guile) make-vector) length init))
+
+;;; Sequences
+
+(defun length (sequence)
+ (funcall (if (listp sequence)
+ (@ (guile) length)
+ (@ (guile) generalized-vector-length))
+ sequence))
+
+(defun mapcar (function sequence)
+ (funcall (@ (guile) map) function sequence))
+
+(defun mapc (function sequence)
+ (funcall (@ (guile) for-each) function sequence)
+ sequence)
+
+(defun aref (array idx)
+ (funcall (@ (guile) generalized-vector-ref) array idx))
+
+(defun aset (array idx newelt)
+ (funcall (@ (guile) generalized-vector-set!) array idx newelt)
+ newelt)
+
+(defun concat (&rest sequences)
+ (apply (@ (guile) string-append) sequences))
+
+;;; Property lists
+
+(defun %plist-member (plist property test)
+ (cond
+ ((null plist) nil)
+ ((consp plist)
+ (if (funcall test (car plist) property)
+ (cdr plist)
+ (%plist-member (cdr (cdr plist)) property test)))
+ (t (signal 'wrong-type-argument `(listp ,plist)))))
+
+(defun %plist-get (plist property test)
+ (car (%plist-member plist property test)))
+
+(defun %plist-put (plist property value test)
+ (let ((x (%plist-member plist property test)))
+ (if x
+ (progn (setcar x value) plist)
+ (cons property (cons value plist)))))
+
+(defun plist-get (plist property)
+ (%plist-get plist property #'eq))
+
+(defun plist-put (plist property value)
+ (%plist-put plist property value #'eq))
+
+(defun plist-member (plist property)
+ (%plist-member plist property #'eq))
+
+(defun lax-plist-get (plist property)
+ (%plist-get plist property #'equal))
+
+(defun lax-plist-put (plist property value)
+ (%plist-put plist property value #'equal))
+
+(defvar plist-function (funcall (@ (guile) make-object-property)))
+
+(defun symbol-plist (symbol)
+ (funcall plist-function symbol))
+
+(defun setplist (symbol plist)
+ (funcall (funcall (@ (guile) setter) plist-function) symbol plist))
+
+(defun get (symbol propname)
+ (plist-get (symbol-plist symbol) propname))
+
+(defun put (symbol propname value)
+ (setplist symbol (plist-put (symbol-plist symbol) propname value)))
+
+;;; Nonlocal exits
+
+(defmacro condition-case (var bodyform &rest handlers)
+ (let ((key (make-symbol "key"))
+ (error-symbol (make-symbol "error-symbol"))
+ (data (make-symbol "data"))
+ (conditions (make-symbol "conditions")))
+ (flet ((handler->cond-clause (handler)
+ `((or ,@(mapcar #'(lambda (c) `(memq ',c ,conditions))
+ (if (consp (car handler))
+ (car handler)
+ (list (car handler)))))
+ ,@(cdr handler))))
+ `(funcall (@ (guile) catch)
+ 'elisp-condition
+ #'(lambda () ,bodyform)
+ #'(lambda (,key ,error-symbol ,data)
+ (declare (lexical ,key ,error-symbol ,data))
+ (let ((,conditions
+ (get ,error-symbol 'error-conditions))
+ ,@(if var
+ `((,var (cons ,error-symbol ,data)))
+ '()))
+ (declare (lexical ,conditions
+ ,@(if var `(,var) '())))
+ (cond ,@(mapcar #'handler->cond-clause handlers)
+ (t (signal ,error-symbol ,data)))))))))
+
+(put 'error 'error-conditions '(error))
+(put 'wrong-type-argument 'error-conditions '(wrong-type-argument error))
+(put 'invalid-function 'error-conditions '(invalid-function error))
+(put 'no-catch 'error-conditions '(no-catch error))
+(put 'throw 'error-conditions '(throw))
+
+(defvar %catch nil)
+
+(defmacro catch (tag &rest body)
+ (let ((tag-value (make-symbol "tag-value"))
+ (c (make-symbol "c"))
+ (data (make-symbol "data")))
+ `(let ((,tag-value ,tag))
+ (declare (lexical ,tag-value))
+ (condition-case ,c
+ (let ((%catch t))
+ ,@body)
+ (throw
+ (let ((,data (cdr ,c)))
+ (declare (lexical ,data))
+ (if (eq (car ,data) ,tag-value)
+ (car (cdr ,data))
+ (apply #'throw ,data))))))))
+
+(defun throw (tag value)
+ (signal (if %catch 'throw 'no-catch) (list tag value)))
+
+;;; I/O
+
+(defun princ (object)
+ (funcall (@ (guile) display) object))
+
+(defun print (object)
+ (funcall (@ (guile) write) object))
+
+(defun terpri ()
+ (funcall (@ (guile) newline)))
+
+(defun format* (stream string &rest args)
+ (apply (@ (guile) format) stream string args))
+
+(defun send-string-to-terminal (string)
+ (princ string))
+
+(defun read-from-minibuffer (prompt &rest ignore)
+ (princ prompt)
+ (let ((value (funcall (@ (ice-9 rdelim) read-line))))
+ (if (funcall (@ (guile) eof-object?) value)
+ ""
+ value)))
+
+(defun prin1-to-string (object)
+ (format* nil "~S" object))
+
+;; Random number generation
+
+(defvar %random-state (funcall (@ (guile) copy-random-state)
+ (@ (guile) *random-state*)))
+
+(defun random (&optional limit)
+ (if (eq limit t)
+ (setq %random-state
+ (funcall (@ (guile) random-state-from-platform))))
+ (funcall (@ (guile) random)
+ (if (wholenump limit)
+ limit
+ (@ (guile) most-positive-fixnum))
+ %random-state))
diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm
index 0df21c7e6..1a4d00faa 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -1,6 +1,6 @@
;;; Guile Emacs Lisp
-;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -31,26 +31,24 @@
#:use-module (srfi srfi-26)
#:export (compile-tree-il
compile-progn
+ compile-eval-when-compile
compile-if
compile-defconst
compile-defvar
compile-setq
compile-let
- compile-lexical-let
compile-flet
+ compile-labels
compile-let*
- compile-lexical-let*
- compile-flet*
- compile-without-void-checks
- compile-with-always-lexical
compile-guile-ref
compile-guile-primitive
- compile-while
compile-function
compile-defmacro
compile-defun
#{compile-`}#
- compile-quote))
+ compile-quote
+ compile-%funcall
+ compile-%set-lexical-binding-mode))
;;; Certain common parameters (like the bindings data structure or
;;; compiler options) are not always passed around but accessed using
@@ -61,14 +59,7 @@
(define bindings-data (make-fluid))
-;;; Store for which symbols (or all/none) void checks are disabled.
-
-(define disable-void-check (make-fluid))
-
-;;; Store which symbols (or all/none) should always be bound lexically,
-;;; even with ordinary let and as lambda arguments.
-
-(define always-lexical (make-fluid))
+(define lexical-binding (make-fluid))
;;; Find the source properties of some parsed expression if there are
;;; any associated with it.
@@ -109,7 +100,7 @@
;;; Build a call to a primitive procedure nicely.
(define (call-primitive loc sym . args)
- (make-application loc (make-primitive-ref loc sym) args))
+ (make-primcall loc sym args))
;;; Error reporting routine for syntax/compilation problems or build
;;; code for a runtime-error output.
@@ -117,422 +108,253 @@
(define (report-error loc . args)
(apply error args))
-(define (runtime-error loc msg . args)
- (make-application loc
- (make-primitive-ref loc 'error)
- (cons (make-const loc msg) args)))
-
-;;; Generate code to ensure a global symbol is there for further use of
-;;; a given symbol. In general during the compilation, those needed are
-;;; only tracked with the bindings data structure. Afterwards, however,
-;;; for all those needed symbols the globals are really generated with
-;;; this routine.
-
-(define (generate-ensure-global loc sym module)
- (make-application loc
- (make-module-ref loc runtime 'ensure-fluid! #t)
- (list (make-const loc module)
- (make-const loc sym))))
-
-(define (ensuring-globals loc bindings body)
- (make-sequence
- loc
- `(,@(map-globals-needed (fluid-ref bindings)
- (lambda (mod sym)
- (generate-ensure-global loc sym mod)))
- ,body)))
-
-;;; Build a construct that establishes dynamic bindings for certain
-;;; variables. We may want to choose between binding with fluids and
-;;; with-fluids* and using just ordinary module symbols and
-;;; setting/reverting their values with a dynamic-wind.
-
-(define (let-dynamic loc syms module vals body)
- (call-primitive
- loc
- 'with-fluids*
- (make-application loc
- (make-primitive-ref loc 'list)
- (map (lambda (sym)
- (make-module-ref loc module sym #t))
- syms))
- (make-application loc (make-primitive-ref loc 'list) vals)
- (make-lambda loc
- '()
- (make-lambda-case #f '() #f #f #f '() '() body #f))))
-
-;;; Handle access to a variable (reference/setting) correctly depending
-;;; on whether it is currently lexically or dynamically bound. lexical
-;;; access is done only for references to the value-slot module!
-
-(define (access-variable loc
- sym
- module
- handle-global
- handle-lexical
- handle-dynamic)
- (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
- (cond
- (lexical (handle-lexical lexical))
- ((equal? module function-slot) (handle-global))
- (else (handle-dynamic)))))
-
-;;; Generate code to reference a variable. For references in the
-;;; value-slot module, we may want to generate a lexical reference
-;;; instead if the variable has a lexical binding.
+(define (access-variable loc symbol handle-lexical handle-dynamic)
+ (cond
+ ((get-lexical-binding (fluid-ref bindings-data) symbol)
+ => handle-lexical)
+ (else
+ (handle-dynamic))))
-(define (reference-variable loc sym module)
+(define (reference-variable loc symbol)
(access-variable
loc
- sym
- module
- (lambda () (make-module-ref loc module sym #t))
- (lambda (lexical) (make-lexical-ref loc lexical lexical))
+ symbol
+ (lambda (lexical)
+ (make-lexical-ref loc lexical lexical))
(lambda ()
- (mark-global-needed! (fluid-ref bindings-data) sym module)
(call-primitive loc
'fluid-ref
- (make-module-ref loc module sym #t)))))
-
-;;; Generate code to set a variable. Just as with reference-variable, in
-;;; case of a reference to value-slot, we want to generate a lexical set
-;;; when the variable has a lexical binding.
-
-(define (set-variable! loc sym module value)
+ (make-module-ref loc value-slot symbol #t)))))
+
+(define (global? module symbol)
+ (module-variable module symbol))
+
+(define (ensure-globals! loc names body)
+ (if (and (every (cut global? (resolve-module value-slot) <>) names)
+ (every symbol-interned? names))
+ body
+ (list->seq
+ loc
+ `(,@(map
+ (lambda (name)
+ (ensure-fluid! value-slot name)
+ (make-call loc
+ (make-module-ref loc runtime 'ensure-fluid! #t)
+ (list (make-const loc value-slot)
+ (make-const loc name))))
+ names)
+ ,body))))
+
+(define (set-variable! loc symbol value)
(access-variable
loc
- sym
- module
+ symbol
+ (lambda (lexical)
+ (make-lexical-set loc lexical lexical value))
(lambda ()
- (make-application
+ (ensure-globals!
loc
- (make-module-ref loc runtime 'set-variable! #t)
- (list (make-const loc module) (make-const loc sym) value)))
- (lambda (lexical) (make-lexical-set loc lexical lexical value))
+ (list symbol)
+ (call-primitive loc
+ 'fluid-set!
+ (make-module-ref loc value-slot symbol #t)
+ value)))))
+
+(define (access-function loc symbol handle-lexical handle-global)
+ (cond
+ ((get-function-binding (fluid-ref bindings-data) symbol)
+ => handle-lexical)
+ (else
+ (handle-global))))
+
+(define (reference-function loc symbol)
+ (access-function
+ loc
+ symbol
+ (lambda (gensym) (make-lexical-ref loc symbol gensym))
+ (lambda () (make-module-ref loc function-slot symbol #t))))
+
+(define (set-function! loc symbol value)
+ (access-function
+ loc
+ symbol
+ (lambda (gensym) (make-lexical-set loc symbol gensym value))
(lambda ()
- (mark-global-needed! (fluid-ref bindings-data) sym module)
- (call-primitive loc
- 'fluid-set!
- (make-module-ref loc module sym #t)
- value))))
-
-;;; Process the bindings part of a let or let* expression; that is,
-;;; check for correctness and bring it to the form ((sym1 . val1) (sym2
-;;; . val2) ...).
-
-(define (process-let-bindings loc bindings)
- (map
- (lambda (b)
- (if (symbol? b)
- (cons b 'nil)
- (if (or (not (list? b))
- (not (= (length b) 2)))
- (report-error
- loc
- "expected symbol or list of 2 elements in let")
- (if (not (symbol? (car b)))
- (report-error loc "expected symbol in let")
- (cons (car b) (cadr b))))))
- bindings))
-
-;;; Split the let bindings into a list to be done lexically and one
-;;; dynamically. A symbol will be bound lexically if and only if: We're
-;;; processing a lexical-let (i.e. module is 'lexical), OR we're
-;;; processing a value-slot binding AND the symbol is already lexically
-;;; bound or is always lexical, OR we're processing a function-slot
-;;; binding.
-
-(define (bind-lexically? sym module)
- (or (eq? module 'lexical)
- (eq? module function-slot)
- (and (equal? module value-slot)
- (let ((always (fluid-ref always-lexical)))
- (or (eq? always 'all)
- (memq sym always)
- (get-lexical-binding (fluid-ref bindings-data) sym))))))
-
-(define (split-let-bindings bindings module)
- (let iterate ((tail bindings)
- (lexical '())
- (dynamic '()))
- (if (null? tail)
- (values (reverse lexical) (reverse dynamic))
- (if (bind-lexically? (caar tail) module)
- (iterate (cdr tail) (cons (car tail) lexical) dynamic)
- (iterate (cdr tail) lexical (cons (car tail) dynamic))))))
-
-;;; Compile let and let* expressions. The code here is used both for
-;;; let/let* and flet/flet*, just with a different bindings module.
-;;;
-;;; A special module value 'lexical means that we're doing a lexical-let
-;;; instead and the bindings should not be saved to globals at all but
-;;; be done with the lexical framework instead.
-
-;;; Let is done with a single call to let-dynamic binding them locally
-;;; to new values all "at once". If there is at least one variable to
-;;; bind lexically among the bindings, we first do a let for all of them
-;;; to evaluate all values before any bindings take place, and then call
-;;; let-dynamic for the variables to bind dynamically.
-
-(define (generate-let loc module bindings body)
- (let ((bind (process-let-bindings loc bindings)))
- (call-with-values
- (lambda () (split-let-bindings bind module))
- (lambda (lexical dynamic)
- (for-each (lambda (sym)
- (mark-global-needed! (fluid-ref bindings-data)
- sym
- module))
- (map car dynamic))
- (let ((make-values (lambda (for)
- (map (lambda (el) (compile-expr (cdr el)))
- for)))
- (make-body (lambda ()
- (make-sequence loc (map compile-expr body)))))
- (if (null? lexical)
- (let-dynamic loc (map car dynamic) module
- (make-values dynamic) (make-body))
- (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
- (dynamic-syms (map (lambda (el) (gensym)) dynamic))
- (all-syms (append lexical-syms dynamic-syms))
- (vals (append (make-values lexical)
- (make-values dynamic))))
- (make-let loc
- all-syms
- all-syms
- vals
- (with-lexical-bindings
- (fluid-ref bindings-data)
- (map car lexical) lexical-syms
- (lambda ()
- (if (null? dynamic)
- (make-body)
- (let-dynamic loc
- (map car dynamic)
- module
- (map
- (lambda (sym)
- (make-lexical-ref loc
- sym
- sym))
- dynamic-syms)
- (make-body)))))))))))))
-
-;;; Let* is compiled to a cascaded set of "small lets" for each binding
-;;; in turn so that each one already sees the preceding bindings.
-
-(define (generate-let* loc module bindings body)
- (let ((bind (process-let-bindings loc bindings)))
- (begin
- (for-each (lambda (sym)
- (if (not (bind-lexically? sym module))
- (mark-global-needed! (fluid-ref bindings-data)
- sym
- module)))
- (map car bind))
- (let iterate ((tail bind))
- (if (null? tail)
- (make-sequence loc (map compile-expr body))
- (let ((sym (caar tail))
- (value (compile-expr (cdar tail))))
- (if (bind-lexically? sym module)
- (let ((target (gensym)))
- (make-let loc
- `(,target)
- `(,target)
- `(,value)
- (with-lexical-bindings
- (fluid-ref bindings-data)
- `(,sym)
- `(,target)
- (lambda () (iterate (cdr tail))))))
- (let-dynamic loc
- `(,(caar tail))
- module
- `(,value)
- (iterate (cdr tail))))))))))
-
-;;; Split the argument list of a lambda expression into required,
-;;; optional and rest arguments and also check it is actually valid.
-;;; Additionally, we create a list of all "local variables" (that is,
-;;; required, optional and rest arguments together) and also this one
-;;; split into those to be bound lexically and dynamically. Returned is
-;;; as multiple values: required optional rest lexical dynamic
-
-(define (bind-arg-lexical? arg)
- (let ((always (fluid-ref always-lexical)))
- (or (eq? always 'all)
- (memq arg always))))
-
-(define (split-lambda-arguments loc args)
- (let iterate ((tail args)
- (mode 'required)
- (required '())
- (optional '())
- (lexical '())
- (dynamic '()))
- (cond
- ((null? tail)
- (let ((final-required (reverse required))
- (final-optional (reverse optional))
- (final-lexical (reverse lexical))
- (final-dynamic (reverse dynamic)))
- (values final-required
- final-optional
- #f
- final-lexical
- final-dynamic)))
- ((and (eq? mode 'required)
- (eq? (car tail) '&optional))
- (iterate (cdr tail) 'optional required optional lexical dynamic))
- ((eq? (car tail) '&rest)
- (if (or (null? (cdr tail))
- (not (null? (cddr tail))))
- (report-error loc "expected exactly one symbol after &rest")
- (let* ((rest (cadr tail))
- (rest-lexical (bind-arg-lexical? rest))
- (final-required (reverse required))
- (final-optional (reverse optional))
- (final-lexical (reverse (if rest-lexical
- (cons rest lexical)
- lexical)))
- (final-dynamic (reverse (if rest-lexical
- dynamic
- (cons rest dynamic)))))
- (values final-required
- final-optional
- rest
- final-lexical
- final-dynamic))))
- (else
- (if (not (symbol? (car tail)))
- (report-error loc
- "expected symbol in argument list, got"
- (car tail))
- (let* ((arg (car tail))
- (bind-lexical (bind-arg-lexical? arg))
- (new-lexical (if bind-lexical
- (cons arg lexical)
- lexical))
- (new-dynamic (if bind-lexical
- dynamic
- (cons arg dynamic))))
- (case mode
- ((required) (iterate (cdr tail) mode
- (cons arg required) optional
- new-lexical new-dynamic))
- ((optional) (iterate (cdr tail) mode
- required (cons arg optional)
- new-lexical new-dynamic))
- (else
- (error "invalid mode in split-lambda-arguments"
- mode)))))))))
-
-;;; Compile a lambda expression. One thing we have to be aware of is
-;;; that lambda arguments are usually dynamically bound, even when a
-;;; lexical binding is intact for a symbol. For symbols that are marked
-;;; as 'always lexical,' however, we lexically bind here as well, and
-;;; thus we get them out of the let-dynamic call and register a lexical
-;;; binding for them (the lexical target variable is already there,
-;;; namely the real lambda argument from TreeIL).
-
-(define (compile-lambda loc args body)
- (if (not (list? args))
- (report-error loc "expected list for argument-list" args))
- (if (null? body)
- (report-error loc "function body must not be empty"))
- (receive (required optional rest lexical dynamic)
- (split-lambda-arguments loc args)
- (define (process-args args)
- (define (find-pairs pairs filter)
- (lset-intersection (lambda (name+sym x)
- (eq? (car name+sym) x))
- pairs
- filter))
- (let* ((syms (map (lambda (x) (gensym)) args))
- (pairs (map cons args syms))
- (lexical-pairs (find-pairs pairs lexical))
- (dynamic-pairs (find-pairs pairs dynamic)))
- (values syms pairs lexical-pairs dynamic-pairs)))
- (let*-values (((required-syms
- required-pairs
- required-lex-pairs
- required-dyn-pairs)
- (process-args required))
- ((optional-syms
- optional-pairs
- optional-lex-pairs
- optional-dyn-pairs)
- (process-args optional))
- ((rest-syms rest-pairs rest-lex-pairs rest-dyn-pairs)
- (process-args (if rest (list rest) '())))
- ((the-rest-sym) (if rest (car rest-syms) #f))
- ((all-syms) (append required-syms
- optional-syms
- rest-syms))
- ((all-lex-pairs) (append required-lex-pairs
- optional-lex-pairs
- rest-lex-pairs))
- ((all-dyn-pairs) (append required-dyn-pairs
- optional-dyn-pairs
- rest-dyn-pairs)))
- (for-each (lambda (sym)
- (mark-global-needed! (fluid-ref bindings-data)
- sym
- value-slot))
- dynamic)
- (with-dynamic-bindings
- (fluid-ref bindings-data)
- dynamic
- (lambda ()
- (with-lexical-bindings
- (fluid-ref bindings-data)
- (map car all-lex-pairs)
- (map cdr all-lex-pairs)
- (lambda ()
- (make-lambda
- loc
- '()
- (make-lambda-case
- #f
- required
- optional
- rest
- #f
- (map (lambda (x) (nil-value loc)) optional)
- all-syms
- (let ((compiled-body
- (make-sequence loc (map compile-expr body))))
- (make-sequence
- loc
- (list
- (if rest
- (make-conditional
- loc
- (call-primitive loc
- 'null?
- (make-lexical-ref loc
- rest
- the-rest-sym))
- (make-lexical-set loc
- rest
- the-rest-sym
- (nil-value loc))
- (make-void loc))
- (make-void loc))
- (if (null? dynamic)
- compiled-body
- (let-dynamic loc
- dynamic
- value-slot
- (map (lambda (name-sym)
- (make-lexical-ref
- loc
- (car name-sym)
- (cdr name-sym)))
- all-dyn-pairs)
- compiled-body)))))
- #f)))))))))
+ (make-call
+ loc
+ (make-module-ref loc runtime 'set-symbol-function! #t)
+ (list (make-const loc symbol) value)))))
+
+(define (bind-lexically? sym module decls)
+ (or (eq? module function-slot)
+ (let ((decl (assq-ref decls sym)))
+ (and (equal? module value-slot)
+ (or
+ (eq? decl 'lexical)
+ (and
+ (fluid-ref lexical-binding)
+ (not (global? (resolve-module module) sym))))))))
+
+(define (parse-let-binding loc binding)
+ (pmatch binding
+ ((unquote var)
+ (guard (symbol? var))
+ (cons var #nil))
+ ((,var)
+ (guard (symbol? var))
+ (cons var #nil))
+ ((,var ,val)
+ (guard (symbol? var))
+ (cons var val))
+ (else
+ (report-error loc "malformed variable binding" binding))))
+
+(define (parse-flet-binding loc binding)
+ (pmatch binding
+ ((,var ,args . ,body)
+ (guard (symbol? var))
+ (cons var `(function (lambda ,args ,@body))))
+ (else
+ (report-error loc "malformed function binding" binding))))
+
+(define (parse-declaration expr)
+ (pmatch expr
+ ((lexical . ,vars)
+ (map (cut cons <> 'lexical) vars))
+ (else
+ '())))
+
+(define (parse-body-1 body lambda?)
+ (let loop ((lst body)
+ (decls '())
+ (intspec #f)
+ (doc #f))
+ (pmatch lst
+ (((declare . ,x) . ,tail)
+ (loop tail (append-reverse x decls) intspec doc))
+ (((interactive . ,x) . ,tail)
+ (guard lambda? (not intspec))
+ (loop tail decls x doc))
+ ((,x . ,tail)
+ (guard lambda? (string? x) (not doc) (not (null? tail)))
+ (loop tail decls intspec x))
+ (else
+ (values (append-map parse-declaration decls)
+ intspec
+ doc
+ lst)))))
+
+(define (parse-lambda-body body)
+ (parse-body-1 body #t))
+
+(define (parse-body body)
+ (receive (decls intspec doc body) (parse-body-1 body #f)
+ (values decls body)))
+
+;;; Partition the argument list of a lambda expression into required,
+;;; optional and rest arguments.
+
+(define (parse-lambda-list lst)
+ (define (%match lst null optional rest symbol)
+ (pmatch lst
+ (() (null))
+ ((&optional . ,tail) (optional tail))
+ ((&rest . ,tail) (rest tail))
+ ((,arg . ,tail) (guard (symbol? arg)) (symbol arg tail))
+ (else (fail))))
+ (define (return rreq ropt rest)
+ (values #t (reverse rreq) (reverse ropt) rest))
+ (define (fail)
+ (values #f #f #f #f))
+ (define (parse-req lst rreq)
+ (%match lst
+ (lambda () (return rreq '() #f))
+ (lambda (tail) (parse-opt tail rreq '()))
+ (lambda (tail) (parse-rest tail rreq '()))
+ (lambda (arg tail) (parse-req tail (cons arg rreq)))))
+ (define (parse-opt lst rreq ropt)
+ (%match lst
+ (lambda () (return rreq ropt #f))
+ (lambda (tail) (fail))
+ (lambda (tail) (parse-rest tail rreq ropt))
+ (lambda (arg tail) (parse-opt tail rreq (cons arg ropt)))))
+ (define (parse-rest lst rreq ropt)
+ (%match lst
+ (lambda () (fail))
+ (lambda (tail) (fail))
+ (lambda (tail) (fail))
+ (lambda (arg tail) (parse-post-rest tail rreq ropt arg))))
+ (define (parse-post-rest lst rreq ropt rest)
+ (%match lst
+ (lambda () (return rreq ropt rest))
+ (lambda () (fail))
+ (lambda () (fail))
+ (lambda (arg tail) (fail))))
+ (parse-req lst '()))
+
+(define (make-simple-lambda loc meta req opt init rest vars body)
+ (make-lambda loc
+ meta
+ (make-lambda-case #f req opt rest #f init vars body #f)))
+
+(define (compile-lambda loc meta args body)
+ (receive (valid? req-ids opt-ids rest-id)
+ (parse-lambda-list args)
+ (if valid?
+ (let* ((all-ids (append req-ids
+ opt-ids
+ (or (and=> rest-id list) '())))
+ (all-vars (map (lambda (ignore) (gensym)) all-ids)))
+ (let*-values (((decls intspec doc forms)
+ (parse-lambda-body body))
+ ((lexical dynamic)
+ (partition
+ (compose (cut bind-lexically? <> value-slot decls)
+ car)
+ (map list all-ids all-vars)))
+ ((lexical-ids lexical-vars) (unzip2 lexical))
+ ((dynamic-ids dynamic-vars) (unzip2 dynamic)))
+ (with-dynamic-bindings
+ (fluid-ref bindings-data)
+ dynamic-ids
+ (lambda ()
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ lexical-ids
+ lexical-vars
+ (lambda ()
+ (ensure-globals!
+ loc
+ dynamic-ids
+ (let* ((tree-il
+ (compile-expr
+ (if rest-id
+ `(let ((,rest-id (if ,rest-id
+ ,rest-id
+ nil)))
+ ,@forms)
+ `(progn ,@forms))))
+ (full-body
+ (if (null? dynamic)
+ tree-il
+ (make-dynlet
+ loc
+ (map (cut make-module-ref loc value-slot <> #t)
+ dynamic-ids)
+ (map (cut make-lexical-ref loc <> <>)
+ dynamic-ids
+ dynamic-vars)
+ tree-il))))
+ (make-simple-lambda loc
+ meta
+ req-ids
+ opt-ids
+ (map (const (nil-value loc))
+ opt-ids)
+ rest-id
+ all-vars
+ full-body)))))))))
+ (report-error "invalid function" `(lambda ,args ,@body)))))
;;; Handle the common part of defconst and defvar, that is, checking for
;;; a correct doc string and arguments as well as maybe in the future
@@ -550,12 +372,11 @@
;;; Handle macro and special operator bindings.
-(define (find-operator sym type)
+(define (find-operator name type)
(and
- (symbol? sym)
- (module-defined? (resolve-interface function-slot) sym)
- (let* ((op (module-ref (resolve-module function-slot) sym))
- (op (if (fluid? op) (fluid-ref op) op)))
+ (symbol? name)
+ (module-defined? (resolve-interface function-slot) name)
+ (let ((op (module-ref (resolve-module function-slot) name)))
(if (and (pair? op) (eq? (car op) type))
(cdr op)
#f))))
@@ -611,87 +432,67 @@
expr))
(make-const loc expr)))
-;;; Temporarily update a list of symbols that are handled specially
-;;; (disabled void check or always lexical) for compiling body. We need
-;;; to handle special cases for already all / set to all and the like.
-
-(define (with-added-symbols loc fluid syms body)
- (if (null? body)
- (report-error loc "symbol-list construct has empty body"))
- (if (not (or (eq? syms 'all)
- (and (list? syms) (and-map symbol? syms))))
- (report-error loc "invalid symbol list" syms))
- (let ((old (fluid-ref fluid))
- (make-body (lambda ()
- (make-sequence loc (map compile-expr body)))))
- (if (eq? old 'all)
- (make-body)
- (let ((new (if (eq? syms 'all)
- 'all
- (append syms old))))
- (with-fluids ((fluid new))
- (make-body))))))
-
;;; Special operators
(defspecial progn (loc args)
- (make-sequence loc (map compile-expr args)))
+ (list->seq loc
+ (if (null? args)
+ (list (nil-value loc))
+ (map compile-expr args))))
+
+(defspecial eval-when-compile (loc args)
+ (make-const loc (compile `(progn ,@args) #:from 'elisp #:to 'value)))
(defspecial if (loc args)
(pmatch args
((,cond ,then . ,else)
- (make-conditional loc
- (compile-expr cond)
- (compile-expr then)
- (if (null? else)
- (nil-value loc)
- (make-sequence loc
- (map compile-expr else)))))))
+ (make-conditional
+ loc
+ (call-primitive loc 'not
+ (call-primitive loc 'nil? (compile-expr cond)))
+ (compile-expr then)
+ (compile-expr `(progn ,@else))))))
(defspecial defconst (loc args)
(pmatch args
((,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
- (make-sequence loc
- (list (set-variable! loc
- sym
- value-slot
- (compile-expr value))
- (make-const loc sym)))))))
+ (make-seq loc
+ (set-variable! loc sym (compile-expr value))
+ (make-const loc sym))))))
(defspecial defvar (loc args)
(pmatch args
((,sym) (make-const loc sym))
((,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
- (make-sequence
+ (make-seq
loc
- (list
+ (make-conditional
+ loc
(make-conditional
loc
- (make-conditional
+ (call-primitive
loc
- (call-primitive
- loc
- 'module-bound?
- (call-primitive loc
- 'resolve-interface
- (make-const loc value-slot))
- (make-const loc sym))
+ 'module-bound?
(call-primitive loc
- 'fluid-bound?
- (make-module-ref loc value-slot sym #t))
- (make-const loc #f))
- (make-void loc)
- (set-variable! loc sym value-slot (compile-expr value)))
- (make-const loc sym)))))))
+ 'resolve-interface
+ (make-const loc value-slot))
+ (make-const loc sym))
+ (call-primitive loc
+ 'fluid-bound?
+ (make-module-ref loc value-slot sym #t))
+ (make-const loc #f))
+ (make-void loc)
+ (set-variable! loc sym (compile-expr value)))
+ (make-const loc sym))))))
(defspecial setq (loc args)
(define (car* x) (if (null? x) '() (car x)))
(define (cdr* x) (if (null? x) '() (cdr x)))
(define (cadr* x) (car* (cdr* x)))
(define (cddr* x) (cdr* (cdr* x)))
- (make-sequence
+ (list->seq
loc
(let loop ((args args) (last (nil-value loc)))
(if (null? args)
@@ -701,47 +502,141 @@
(if (not (symbol? sym))
(report-error loc "expected symbol in setq")
(cons
- (set-variable! loc sym value-slot val)
+ (set-variable! loc sym val)
(loop (cddr* args)
- (reference-variable loc sym value-slot)))))))))
+ (reference-variable loc sym)))))))))
(defspecial let (loc args)
(pmatch args
- ((,bindings . ,body)
- (generate-let loc value-slot bindings body))))
-
-(defspecial lexical-let (loc args)
- (pmatch args
- ((,bindings . ,body)
- (generate-let loc 'lexical bindings body))))
-
-(defspecial flet (loc args)
- (pmatch args
- ((,bindings . ,body)
- (generate-let loc function-slot bindings body))))
+ ((,varlist . ,body)
+ (let ((bindings (map (cut parse-let-binding loc <>) varlist)))
+ (receive (decls forms) (parse-body body)
+ (receive (lexical dynamic)
+ (partition
+ (compose (cut bind-lexically? <> value-slot decls)
+ car)
+ bindings)
+ (let ((make-values (lambda (for)
+ (map (lambda (el) (compile-expr (cdr el)))
+ for)))
+ (make-body (lambda () (compile-expr `(progn ,@forms)))))
+ (ensure-globals!
+ loc
+ (map car dynamic)
+ (if (null? lexical)
+ (make-dynlet loc
+ (map (compose (cut make-module-ref
+ loc
+ value-slot
+ <>
+ #t)
+ car)
+ dynamic)
+ (map (compose compile-expr cdr)
+ dynamic)
+ (make-body))
+ (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
+ (dynamic-syms (map (lambda (el) (gensym)) dynamic))
+ (all-syms (append lexical-syms dynamic-syms))
+ (vals (append (make-values lexical)
+ (make-values dynamic))))
+ (make-let loc
+ all-syms
+ all-syms
+ vals
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ (map car lexical)
+ lexical-syms
+ (lambda ()
+ (if (null? dynamic)
+ (make-body)
+ (make-dynlet loc
+ (map
+ (compose
+ (cut make-module-ref
+ loc
+ value-slot
+ <>
+ #t)
+ car)
+ dynamic)
+ (map
+ (lambda (sym)
+ (make-lexical-ref
+ loc
+ sym
+ sym))
+ dynamic-syms)
+ (make-body))))))))))))))))
(defspecial let* (loc args)
(pmatch args
- ((,bindings . ,body)
- (generate-let* loc value-slot bindings body))))
+ ((,varlist . ,body)
+ (let ((bindings (map (cut parse-let-binding loc <>) varlist)))
+ (receive (decls forms) (parse-body body)
+ (let iterate ((tail bindings))
+ (if (null? tail)
+ (compile-expr `(progn ,@forms))
+ (let ((sym (caar tail))
+ (value (compile-expr (cdar tail))))
+ (if (bind-lexically? sym value-slot decls)
+ (let ((target (gensym)))
+ (make-let loc
+ `(,target)
+ `(,target)
+ `(,value)
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ `(,sym)
+ `(,target)
+ (lambda () (iterate (cdr tail))))))
+ (ensure-globals!
+ loc
+ (list sym)
+ (make-dynlet loc
+ (list (make-module-ref loc value-slot sym #t))
+ (list value)
+ (iterate (cdr tail)))))))))))))
-(defspecial lexical-let* (loc args)
+(defspecial flet (loc args)
(pmatch args
((,bindings . ,body)
- (generate-let* loc 'lexical bindings body))))
-
-(defspecial flet* (loc args)
+ (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
+ (receive (decls forms) (parse-body body)
+ (let ((names (map car names+vals))
+ (vals (map cdr names+vals))
+ (gensyms (map (lambda (x) (gensym)) names+vals)))
+ (with-function-bindings
+ (fluid-ref bindings-data)
+ names
+ gensyms
+ (lambda ()
+ (make-let loc
+ names
+ gensyms
+ (map compile-expr vals)
+ (compile-expr `(progn ,@forms)))))))))))
+
+(defspecial labels (loc args)
(pmatch args
((,bindings . ,body)
- (generate-let* loc function-slot bindings body))))
-
-;;; Temporarily set symbols as always lexical only for the lexical scope
-;;; of a construct.
-
-(defspecial with-always-lexical (loc args)
- (pmatch args
- ((,syms . ,body)
- (with-added-symbols loc always-lexical syms body))))
+ (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
+ (receive (decls forms) (parse-body body)
+ (let ((names (map car names+vals))
+ (vals (map cdr names+vals))
+ (gensyms (map (lambda (x) (gensym)) names+vals)))
+ (with-function-bindings
+ (fluid-ref bindings-data)
+ names
+ gensyms
+ (lambda ()
+ (make-letrec #f
+ loc
+ names
+ gensyms
+ (map compile-expr vals)
+ (compile-expr `(progn ,@forms)))))))))))
;;; guile-ref allows building TreeIL's module references from within
;;; elisp as a way to access data within the Guile universe. The module
@@ -761,59 +656,12 @@
((,sym)
(make-primitive-ref loc sym))))
-;;; A while construct is transformed into a tail-recursive loop like
-;;; this:
-;;;
-;;; (letrec ((iterate (lambda ()
-;;; (if condition
-;;; (begin body
-;;; (iterate))
-;;; #nil))))
-;;; (iterate))
-;;;
-;;; As letrec is not directly accessible from elisp, while is
-;;; implemented here instead of with a macro.
-
-(defspecial while (loc args)
- (pmatch args
- ((,condition . ,body)
- (let* ((itersym (gensym))
- (compiled-body (map compile-expr body))
- (iter-call (make-application loc
- (make-lexical-ref loc
- 'iterate
- itersym)
- (list)))
- (full-body (make-sequence loc
- `(,@compiled-body ,iter-call)))
- (lambda-body (make-conditional loc
- (compile-expr condition)
- full-body
- (nil-value loc)))
- (iter-thunk (make-lambda loc
- '()
- (make-lambda-case #f
- '()
- #f
- #f
- #f
- '()
- '()
- lambda-body
- #f))))
- (make-letrec loc
- #f
- '(iterate)
- (list itersym)
- (list iter-thunk)
- iter-call)))))
-
(defspecial function (loc args)
(pmatch args
(((lambda ,args . ,body))
- (compile-lambda loc args body))
+ (compile-lambda loc '() args body))
((,sym) (guard (symbol? sym))
- (reference-variable loc sym function-slot))))
+ (reference-function loc sym))))
(defspecial defmacro (loc args)
(pmatch args
@@ -821,22 +669,21 @@
(if (not (symbol? name))
(report-error loc "expected symbol as macro name" name)
(let* ((tree-il
- (make-sequence
+ (make-seq
loc
- (list
- (set-variable!
+ (set-function!
+ loc
+ name
+ (make-call
loc
- name
- function-slot
- (make-application
- loc
- (make-module-ref loc '(guile) 'cons #t)
- (list (make-const loc 'macro)
- (compile-lambda loc args body))))
- (make-const loc name)))))
- (compile (ensuring-globals loc bindings-data tree-il)
- #:from 'tree-il
- #:to 'value)
+ (make-module-ref loc '(guile) 'cons #t)
+ (list (make-const loc 'macro)
+ (compile-lambda loc
+ `((name . ,name))
+ args
+ body))))
+ (make-const loc name))))
+ (compile tree-il #:from 'tree-il #:to 'value)
tree-il)))))
(defspecial defun (loc args)
@@ -844,14 +691,14 @@
((,name ,args . ,body)
(if (not (symbol? name))
(report-error loc "expected symbol as function name" name)
- (make-sequence loc
- (list (set-variable! loc
- name
- function-slot
- (compile-lambda loc
- args
- body))
- (make-const loc name)))))))
+ (make-seq loc
+ (set-function! loc
+ name
+ (compile-lambda loc
+ `((name . ,name))
+ args
+ body))
+ (make-const loc name))))))
(defspecial #{`}# (loc args)
(pmatch args
@@ -863,6 +710,19 @@
((,val)
(make-const loc val))))
+(defspecial %funcall (loc args)
+ (pmatch args
+ ((,function . ,arguments)
+ (make-call loc
+ (compile-expr function)
+ (map compile-expr arguments)))))
+
+(defspecial %set-lexical-binding-mode (loc args)
+ (pmatch args
+ ((,val)
+ (fluid-set! lexical-binding val)
+ (make-void loc))))
+
;;; Compile a compound expression to Tree-IL.
(define (compile-pair loc expr)
@@ -876,13 +736,7 @@
=> (lambda (macro-function)
(compile-expr (apply macro-function arguments))))
(else
- (make-application loc
- (if (symbol? operator)
- (reference-variable loc
- operator
- function-slot)
- (compile-expr operator))
- (map compile-expr arguments))))))
+ (compile-expr `(%funcall (function ,operator) ,@arguments))))))
;;; Compile a symbol expression. This is a variable reference or maybe
;;; some special value like nil.
@@ -891,7 +745,7 @@
(case sym
((nil) (nil-value loc))
((t) (t-value loc))
- (else (reference-variable loc sym value-slot))))
+ (else (reference-variable loc sym))))
;;; Compile a single expression to TreeIL.
@@ -921,28 +775,14 @@
(case key
((#:warnings) ; ignore
#f)
- ((#:always-lexical)
- (if (valid-symbol-list-arg? value)
- (fluid-set! always-lexical value)
- (report-error #f
- "Invalid value for #:always-lexical"
- value)))
(else (report-error #f
"Invalid compiler option"
key)))))))
-;;; Entry point for compilation to TreeIL. This creates the bindings
-;;; data structure, and after compiling the main expression we need to
-;;; make sure all globals for symbols used during the compilation are
-;;; created using the generate-ensure-global function.
-
(define (compile-tree-il expr env opts)
(values
- (with-fluids ((bindings-data (make-bindings))
- (disable-void-check '())
- (always-lexical '()))
+ (with-fluids ((bindings-data (make-bindings)))
(process-options! opts)
- (let ((compiled (compile-expr expr)))
- (ensuring-globals (location expr) bindings-data compiled)))
+ (compile-expr expr))
env
env))
diff --git a/module/language/elisp/falias.scm b/module/language/elisp/falias.scm
new file mode 100644
index 000000000..f043548fb
--- /dev/null
+++ b/module/language/elisp/falias.scm
@@ -0,0 +1,27 @@
+(define-module (language elisp falias)
+ #:export (falias?
+ make-falias
+ falias-function
+ falias-object))
+
+(define <falias-vtable>
+ (make-struct <applicable-struct-vtable>
+ 0
+ (make-struct-layout "pwpw")
+ (lambda (object port)
+ (format port "#<falias ~S>" (falias-object object)))))
+
+(set-struct-vtable-name! <falias-vtable> 'falias)
+
+(define (falias? object)
+ (and (struct? object)
+ (eq? (struct-vtable object) <falias-vtable>)))
+
+(define (make-falias f object)
+ (make-struct <falias-vtable> 0 f object))
+
+(define (falias-function object)
+ (struct-ref object 0))
+
+(define (falias-object object)
+ (struct-ref object 1))
diff --git a/module/language/elisp/lexer.scm b/module/language/elisp/lexer.scm
index af7e02add..1933ff34d 100644
--- a/module/language/elisp/lexer.scm
+++ b/module/language/elisp/lexer.scm
@@ -252,7 +252,15 @@
;;; Main lexer routine, which is given a port and does look for the next
;;; token.
+(define lexical-binding-regexp
+ (make-regexp
+ "-\\*-(|.*;)[ \t]*lexical-binding:[ \t]*([^;]*[^ \t;]).*-\\*-"))
+
(define (lex port)
+ (define (lexical-binding-value string)
+ (and=> (regexp-exec lexical-binding-regexp string)
+ (lambda (match)
+ (not (member (match:substring match 2) '("nil" "()"))))))
(let ((return (let ((file (if (file-port? port)
(port-filename port)
#f))
@@ -283,11 +291,19 @@
(case c
;; A line comment, skip until end-of-line is found.
((#\;)
- (let iterate ()
- (let ((cur (read-char port)))
- (if (or (eof-object? cur) (char=? cur #\newline))
- (lex port)
- (iterate)))))
+ (if (= (port-line port) 0)
+ (let iterate ((chars '()))
+ (let ((cur (read-char port)))
+ (if (or (eof-object? cur) (char=? cur #\newline))
+ (let ((string (list->string (reverse chars))))
+ (return 'set-lexical-binding-mode!
+ (lexical-binding-value string)))
+ (iterate (cons cur chars)))))
+ (let iterate ()
+ (let ((cur (read-char port)))
+ (if (or (eof-object? cur) (char=? cur #\newline))
+ (lex port)
+ (iterate))))))
;; A character literal.
((#\?)
(return 'character (get-character port #f)))
@@ -321,7 +337,12 @@
(let ((mark (get-circular-marker port)))
(return (car mark) (cdr mark))))
((#\')
- (return 'function #f)))))
+ (return 'function #f))
+ ((#\:)
+ (call-with-values
+ (lambda () (get-symbol-or-number port))
+ (lambda (type str)
+ (return 'symbol (make-symbol str))))))))
;; Parentheses and other special-meaning single characters.
((#\() (return 'paren-open #f))
((#\)) (return 'paren-close #f))
diff --git a/module/language/elisp/parser.scm b/module/language/elisp/parser.scm
index df825eb4e..e83f136bb 100644
--- a/module/language/elisp/parser.scm
+++ b/module/language/elisp/parser.scm
@@ -201,6 +201,8 @@
(setter expr)
(force-promises! expr)
expr))
+ ((set-lexical-binding-mode!)
+ (return `(%set-lexical-binding-mode ,(cdr token))))
(else
(parse-error token "expected expression, got" token)))))
diff --git a/module/language/elisp/runtime.scm b/module/language/elisp/runtime.scm
index 0c84d102b..6f6a22074 100644
--- a/module/language/elisp/runtime.scm
+++ b/module/language/elisp/runtime.scm
@@ -25,11 +25,17 @@
function-slot-module
elisp-bool
ensure-fluid!
- reference-variable
- set-variable!
- runtime-error
- macro-error)
- #:export-syntax (built-in-func built-in-macro defspecial prim))
+ symbol-fluid
+ set-symbol-fluid!
+ symbol-value
+ set-symbol-value!
+ symbol-function
+ set-symbol-function!
+ symbol-bound?
+ symbol-fbound?
+ makunbound!
+ fmakunbound!)
+ #:export-syntax (defspecial prim))
;;; This module provides runtime support for the Elisp front-end.
@@ -47,22 +53,6 @@
(define function-slot-module '(language elisp runtime function-slot))
-;;; Report an error during macro compilation, that means some special
-;;; compilation (syntax) error; or report a simple runtime-error from a
-;;; built-in function.
-
-(define (macro-error msg . args)
- (apply error msg args))
-
-(define runtime-error macro-error)
-
-;;; Convert a scheme boolean to Elisp.
-
-(define (elisp-bool b)
- (if b
- t-value
- nil-value))
-
;;; Routines for access to elisp dynamically bound symbols. This is
;;; used for runtime access using functions like symbol-value or set,
;;; where the symbol accessed might not be known at compile-time. These
@@ -77,39 +67,68 @@
(module-define! resolved sym fluid)
(module-export! resolved `(,sym))))))
-(define (reference-variable module sym)
- (let ((resolved (resolve-module module)))
- (cond
- ((equal? module function-slot-module)
- (module-ref resolved sym))
- (else
- (ensure-fluid! module sym)
- (fluid-ref (module-ref resolved sym))))))
+(define (symbol-fluid symbol)
+ (let ((module (resolve-module value-slot-module)))
+ (ensure-fluid! value-slot-module symbol) ;++ implicit special proclamation
+ (module-ref module symbol)))
-(define (set-variable! module sym value)
- (let ((intf (resolve-interface module))
- (resolved (resolve-module module)))
- (cond
- ((equal? module function-slot-module)
- (cond
- ((module-defined? intf sym)
- (module-set! resolved sym value))
- (else
- (module-define! resolved sym value)
- (module-export! resolved `(,sym)))))
- (else
- (ensure-fluid! module sym)
- (fluid-set! (module-ref resolved sym) value))))
+(define (set-symbol-fluid! symbol fluid)
+ (let ((module (resolve-module value-slot-module)))
+ (module-define! module symbol fluid)
+ (module-export! module (list symbol)))
+ fluid)
+
+(define (symbol-value symbol)
+ (fluid-ref (symbol-fluid symbol)))
+
+(define (set-symbol-value! symbol value)
+ (fluid-set! (symbol-fluid symbol) value)
value)
-;;; Define a predefined function or predefined macro for use in the
-;;; function-slot and macro-slot modules, respectively.
+(define (symbol-function symbol)
+ (let ((module (resolve-module function-slot-module)))
+ (module-ref module symbol)))
+
+(define (set-symbol-function! symbol value)
+ (let ((module (resolve-module function-slot-module)))
+ (module-define! module symbol value)
+ (module-export! module (list symbol)))
+ value)
-(define-syntax built-in-func
- (syntax-rules ()
- ((_ name value)
- (begin
- (define-public name value)))))
+(define (symbol-bound? symbol)
+ (and
+ (module-bound? (resolve-interface value-slot-module) symbol)
+ (let ((var (module-variable (resolve-module value-slot-module)
+ symbol)))
+ (and (variable-bound? var)
+ (if (fluid? (variable-ref var))
+ (fluid-bound? (variable-ref var))
+ #t)))))
+
+(define (symbol-fbound? symbol)
+ (and
+ (module-bound? (resolve-interface function-slot-module) symbol)
+ (variable-bound?
+ (module-variable (resolve-module function-slot-module)
+ symbol))))
+
+(define (makunbound! symbol)
+ (if (module-bound? (resolve-interface value-slot-module) symbol)
+ (let ((var (module-variable (resolve-module value-slot-module)
+ symbol)))
+ (if (and (variable-bound? var) (fluid? (variable-ref var)))
+ (fluid-unset! (variable-ref var))
+ (variable-unset! var))))
+ symbol)
+
+(define (fmakunbound! symbol)
+ (if (module-bound? (resolve-interface function-slot-module) symbol)
+ (variable-unset! (module-variable
+ (resolve-module function-slot-module)
+ symbol)))
+ symbol)
+
+;;; Define a predefined macro for use in the function-slot module.
(define (make-id template-id . data)
(let ((append-symbols
@@ -125,30 +144,10 @@
datum))
data)))))
-(define-syntax built-in-macro
- (lambda (x)
- (syntax-case x ()
- ((_ name value)
- (with-syntax ((scheme-name (make-id #'name 'macro- #'name)))
- #'(begin
- (define-public scheme-name
- (make-fluid (cons 'macro value)))))))))
-
(define-syntax defspecial
(lambda (x)
(syntax-case x ()
((_ name args body ...)
(with-syntax ((scheme-name (make-id #'name 'compile- #'name)))
- #'(begin
- (define scheme-name
- (make-fluid
- (cons 'special-operator
- (lambda args body ...))))))))))
-
-;;; Call a guile-primitive that may be rebound for elisp and thus needs
-;;; absolute addressing.
-
-(define-syntax prim
- (syntax-rules ()
- ((_ sym args ...)
- ((@ (guile) sym) args ...))))
+ #'(define scheme-name
+ (cons 'special-operator (lambda args body ...))))))))
diff --git a/module/language/elisp/runtime/function-slot.scm b/module/language/elisp/runtime/function-slot.scm
index 896e3cece..3b10205c1 100644
--- a/module/language/elisp/runtime/function-slot.scm
+++ b/module/language/elisp/runtime/function-slot.scm
@@ -17,142 +17,47 @@
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (language elisp runtime function-slot)
- #:use-module (language elisp runtime subrs)
- #:use-module ((language elisp runtime macros)
- #:select
- ((macro-lambda . lambda)
- (macro-prog1 . prog1)
- (macro-prog2 . prog2)
- (macro-when . when)
- (macro-unless . unless)
- (macro-cond . cond)
- (macro-and . and)
- (macro-or . or)
- (macro-dotimes . dotimes)
- (macro-dolist . dolist)
- (macro-catch . catch)
- (macro-unwind-protect . unwind-protect)
- (macro-pop . pop)
- (macro-push . push)))
#:use-module ((language elisp compile-tree-il)
#:select
((compile-progn . progn)
+ (compile-eval-when-compile . eval-when-compile)
(compile-if . if)
(compile-defconst . defconst)
(compile-defvar . defvar)
(compile-setq . setq)
(compile-let . let)
- (compile-lexical-let . lexical-let)
(compile-flet . flet)
+ (compile-labels . labels)
(compile-let* . let*)
- (compile-lexical-let* . lexical-let*)
- (compile-flet* . flet*)
- (compile-with-always-lexical . with-always-lexical)
(compile-guile-ref . guile-ref)
(compile-guile-primitive . guile-primitive)
- (compile-while . while)
(compile-function . function)
(compile-defun . defun)
(compile-defmacro . defmacro)
(#{compile-`}# . #{`}#)
- (compile-quote . quote)))
+ (compile-quote . quote)
+ (compile-%funcall . %funcall)
+ (compile-%set-lexical-binding-mode
+ . %set-lexical-binding-mode)))
#:duplicates (last)
;; special operators
#:re-export (progn
+ eval-when-compile
if
defconst
defvar
setq
let
- lexical-let
flet
+ labels
let*
- lexical-let*
- flet*
- with-always-lexical
guile-ref
guile-primitive
- while
function
defun
defmacro
#{`}#
- quote)
- ;; macros
- #:re-export (lambda
- prog1
- prog2
- when
- unless
- cond
- and
- or
- dotimes
- dolist
- catch
- unwind-protect
- pop
- push)
- ;; functions
- #:re-export (eq
- equal
- floatp
- integerp
- numberp
- wholenump
- zerop
- =
- /=
- <
- <=
- >
- >=
- max
- min
- abs
- float
- 1+
- 1-
- +
- -
- *
- %
- ffloor
- fceiling
- ftruncate
- fround
- consp
- atomp
- listp
- nlistp
- null
- car
- cdr
- car-safe
- cdr-safe
- nth
- nthcdr
- length
- cons
- list
- make-list
- append
- reverse
- copy-tree
- number-sequence
- setcar
- setcdr
- symbol-value
- symbol-function
- set
- fset
- makunbound
- fmakunbound
- boundp
- fboundp
- apply
- funcall
- throw
- not
- eval
- load))
+ quote
+ %funcall
+ %set-lexical-binding-mode)
+ #:pure)
diff --git a/module/language/elisp/runtime/macros.scm b/module/language/elisp/runtime/macros.scm
deleted file mode 100644
index b28706781..000000000
--- a/module/language/elisp/runtime/macros.scm
+++ /dev/null
@@ -1,208 +0,0 @@
-;;; Guile Emacs Lisp
-
-;;; Copyright (C) 2009, 2010 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
-;;; License as published by the Free Software Foundation; either
-;;; version 3 of the License, or (at your option) any later version.
-;;;
-;;; This library is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; Lesser General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with this library; if not, write to the Free Software
-;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-;;; Code:
-
-(define-module (language elisp runtime macros)
- #:use-module (language elisp runtime))
-
-;;; This module contains the macro definitions of elisp symbols. In
-;;; contrast to the other runtime modules, those are used directly
-;;; during compilation, of course, so not really in runtime. But I
-;;; think it fits well to the others here.
-
-(built-in-macro lambda
- (lambda cdr
- `(function (lambda ,@cdr))))
-
-;;; The prog1 and prog2 constructs can easily be defined as macros using
-;;; progn and some lexical-let's to save the intermediate value to
-;;; return at the end.
-
-(built-in-macro prog1
- (lambda (form1 . rest)
- (let ((temp (gensym)))
- `(lexical-let ((,temp ,form1))
- ,@rest
- ,temp))))
-
-(built-in-macro prog2
- (lambda (form1 form2 . rest)
- `(progn ,form1 (prog1 ,form2 ,@rest))))
-
-;;; Define the conditionals when and unless as macros.
-
-(built-in-macro when
- (lambda (condition . thens)
- `(if ,condition (progn ,@thens) nil)))
-
-(built-in-macro unless
- (lambda (condition . elses)
- `(if ,condition nil (progn ,@elses))))
-
-;;; Impement the cond form as nested if's. A special case is a
-;;; (condition) subform, in which case we need to return the condition
-;;; itself if it is true and thus save it in a local variable before
-;;; testing it.
-
-(built-in-macro cond
- (lambda (. clauses)
- (let iterate ((tail clauses))
- (if (null? tail)
- 'nil
- (let ((cur (car tail))
- (rest (iterate (cdr tail))))
- (prim cond
- ((prim or (not (list? cur)) (null? cur))
- (macro-error "invalid clause in cond" cur))
- ((null? (cdr cur))
- (let ((var (gensym)))
- `(lexical-let ((,var ,(car cur)))
- (if ,var
- ,var
- ,rest))))
- (else
- `(if ,(car cur)
- (progn ,@(cdr cur))
- ,rest))))))))
-
-;;; The `and' and `or' forms can also be easily defined with macros.
-
-(built-in-macro and
- (case-lambda
- (() 't)
- ((x) x)
- ((x . args)
- (let iterate ((x x) (tail args))
- (if (null? tail)
- x
- `(if ,x
- ,(iterate (car tail) (cdr tail))
- nil))))))
-
-(built-in-macro or
- (case-lambda
- (() 'nil)
- ((x) x)
- ((x . args)
- (let iterate ((x x) (tail args))
- (if (null? tail)
- x
- (let ((var (gensym)))
- `(lexical-let ((,var ,x))
- (if ,var
- ,var
- ,(iterate (car tail) (cdr tail))))))))))
-
-;;; Define the dotimes and dolist iteration macros.
-
-(built-in-macro dotimes
- (lambda (args . body)
- (if (prim or
- (not (list? args))
- (< (length args) 2)
- (> (length args) 3))
- (macro-error "invalid dotimes arguments" args)
- (let ((var (car args))
- (count (cadr args)))
- (if (not (symbol? var))
- (macro-error "expected symbol as dotimes variable"))
- `(let ((,var 0))
- (while ((guile-primitive <) ,var ,count)
- ,@body
- (setq ,var ((guile-primitive 1+) ,var)))
- ,@(if (= (length args) 3)
- (list (caddr args))
- '()))))))
-
-(built-in-macro dolist
- (lambda (args . body)
- (if (prim or
- (not (list? args))
- (< (length args) 2)
- (> (length args) 3))
- (macro-error "invalid dolist arguments" args)
- (let ((var (car args))
- (iter-list (cadr args))
- (tailvar (gensym)))
- (if (not (symbol? var))
- (macro-error "expected symbol as dolist variable")
- `(let (,var)
- (lexical-let ((,tailvar ,iter-list))
- (while ((guile-primitive not)
- ((guile-primitive null?) ,tailvar))
- (setq ,var ((guile-primitive car) ,tailvar))
- ,@body
- (setq ,tailvar ((guile-primitive cdr) ,tailvar)))
- ,@(if (= (length args) 3)
- (list (caddr args))
- '()))))))))
-
-;;; Exception handling. unwind-protect and catch are implemented as
-;;; macros (throw is a built-in function).
-
-;;; catch and throw can mainly be implemented directly using Guile's
-;;; primitives for exceptions, the only difficulty is that the keys used
-;;; within Guile must be symbols, while elisp allows any value and
-;;; checks for matches using eq (eq?). We handle this by using always #t
-;;; as key for the Guile primitives and check for matches inside the
-;;; handler; if the elisp keys are not eq?, we rethrow the exception.
-
-(built-in-macro catch
- (lambda (tag . body)
- (if (null? body)
- (macro-error "catch with empty body"))
- (let ((tagsym (gensym)))
- `(lexical-let ((,tagsym ,tag))
- ((guile-primitive catch)
- #t
- (lambda () ,@body)
- ,(let* ((dummy-key (gensym))
- (elisp-key (gensym))
- (value (gensym))
- (arglist `(,dummy-key ,elisp-key ,value)))
- `(with-always-lexical
- ,arglist
- (lambda ,arglist
- (if (eq ,elisp-key ,tagsym)
- ,value
- ((guile-primitive throw) ,dummy-key ,elisp-key
- ,value))))))))))
-
-;;; unwind-protect is just some weaker construct as dynamic-wind, so
-;;; straight-forward to implement.
-
-(built-in-macro unwind-protect
- (lambda (body . clean-ups)
- (if (null? clean-ups)
- (macro-error "unwind-protect without cleanup code"))
- `((guile-primitive dynamic-wind)
- (lambda () nil)
- (lambda () ,body)
- (lambda () ,@clean-ups))))
-
-;;; Pop off the first element from a list or push one to it.
-
-(built-in-macro pop
- (lambda (list-name)
- `(prog1 (car ,list-name)
- (setq ,list-name (cdr ,list-name)))))
-
-(built-in-macro push
- (lambda (new-el list-name)
- `(setq ,list-name (cons ,new-el ,list-name))))
diff --git a/module/language/elisp/runtime/subrs.scm b/module/language/elisp/runtime/subrs.scm
deleted file mode 100644
index b03a510a1..000000000
--- a/module/language/elisp/runtime/subrs.scm
+++ /dev/null
@@ -1,383 +0,0 @@
-;;; Guile Emacs Lisp
-
-;;; Copyright (C) 2009 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 License as
-;;; published by the Free Software Foundation; either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; This library is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; Lesser General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with this library; if not, write to the Free Software
-;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-;;; 02110-1301 USA
-
-;;; Code:
-
-(define-module (language elisp runtime subrs)
- #:use-module (language elisp runtime)
- #:use-module (system base compile))
-
-;;; This module contains the function-slots of elisp symbols. Elisp
-;;; built-in functions are implemented as predefined function bindings
-;;; here.
-
-;;; Equivalence and equalness predicates.
-
-(built-in-func eq
- (lambda (a b)
- (elisp-bool (eq? a b))))
-
-(built-in-func equal
- (lambda (a b)
- (elisp-bool (equal? a b))))
-
-;;; Number predicates.
-
-(built-in-func floatp
- (lambda (num)
- (elisp-bool (and (real? num)
- (or (inexact? num)
- (prim not (integer? num)))))))
-
-(built-in-func integerp
- (lambda (num)
- (elisp-bool (and (exact? num)
- (integer? num)))))
-
-(built-in-func numberp
- (lambda (num)
- (elisp-bool (real? num))))
-
-(built-in-func wholenump
- (lambda (num)
- (elisp-bool (and (exact? num)
- (integer? num)
- (prim >= num 0)))))
-
-(built-in-func zerop
- (lambda (num)
- (elisp-bool (prim = num 0))))
-
-;;; Number comparisons.
-
-(built-in-func =
- (lambda (num1 num2)
- (elisp-bool (prim = num1 num2))))
-
-(built-in-func /=
- (lambda (num1 num2)
- (elisp-bool (prim not (prim = num1 num2)))))
-
-(built-in-func <
- (lambda (num1 num2)
- (elisp-bool (prim < num1 num2))))
-
-(built-in-func <=
- (lambda (num1 num2)
- (elisp-bool (prim <= num1 num2))))
-
-(built-in-func >
- (lambda (num1 num2)
- (elisp-bool (prim > num1 num2))))
-
-(built-in-func >=
- (lambda (num1 num2)
- (elisp-bool (prim >= num1 num2))))
-
-(built-in-func max
- (lambda (. nums)
- (prim apply (@ (guile) max) nums)))
-
-(built-in-func min
- (lambda (. nums)
- (prim apply (@ (guile) min) nums)))
-
-(built-in-func abs
- (@ (guile) abs))
-
-;;; Number conversion.
-
-(built-in-func float
- (lambda (num)
- (if (exact? num)
- (exact->inexact num)
- num)))
-
-;;; TODO: truncate, floor, ceiling, round.
-
-;;; Arithmetic functions.
-
-(built-in-func 1+ (@ (guile) 1+))
-
-(built-in-func 1- (@ (guile) 1-))
-
-(built-in-func + (@ (guile) +))
-
-(built-in-func - (@ (guile) -))
-
-(built-in-func * (@ (guile) *))
-
-(built-in-func % (@ (guile) modulo))
-
-;;; TODO: / with correct integer/real behaviour, mod (for floating-piont
-;;; values).
-
-;;; Floating-point rounding operations.
-
-(built-in-func ffloor (@ (guile) floor))
-
-(built-in-func fceiling (@ (guile) ceiling))
-
-(built-in-func ftruncate (@ (guile) truncate))
-
-(built-in-func fround (@ (guile) round))
-
-;;; List predicates.
-
-(built-in-func consp
- (lambda (el)
- (elisp-bool (pair? el))))
-
-(built-in-func atomp
- (lambda (el)
- (elisp-bool (prim not (pair? el)))))
-
-(built-in-func listp
- (lambda (el)
- (elisp-bool (or (pair? el) (null? el)))))
-
-(built-in-func nlistp
- (lambda (el)
- (elisp-bool (and (prim not (pair? el))
- (prim not (null? el))))))
-
-(built-in-func null
- (lambda (el)
- (elisp-bool (null? el))))
-
-;;; Accessing list elements.
-
-(built-in-func car
- (lambda (el)
- (if (null? el)
- nil-value
- (prim car el))))
-
-(built-in-func cdr
- (lambda (el)
- (if (null? el)
- nil-value
- (prim cdr el))))
-
-(built-in-func car-safe
- (lambda (el)
- (if (pair? el)
- (prim car el)
- nil-value)))
-
-(built-in-func cdr-safe
- (lambda (el)
- (if (pair? el)
- (prim cdr el)
- nil-value)))
-
-(built-in-func nth
- (lambda (n lst)
- (if (negative? n)
- (prim car lst)
- (let iterate ((i n)
- (tail lst))
- (cond
- ((null? tail) nil-value)
- ((zero? i) (prim car tail))
- (else (iterate (prim 1- i) (prim cdr tail))))))))
-
-(built-in-func nthcdr
- (lambda (n lst)
- (if (negative? n)
- lst
- (let iterate ((i n)
- (tail lst))
- (cond
- ((null? tail) nil-value)
- ((zero? i) tail)
- (else (iterate (prim 1- i) (prim cdr tail))))))))
-
-(built-in-func length (@ (guile) length))
-
-;;; Building lists.
-
-(built-in-func cons (@ (guile) cons))
-
-(built-in-func list (@ (guile) list))
-
-(built-in-func make-list
- (lambda (len obj)
- (prim make-list len obj)))
-
-(built-in-func append (@ (guile) append))
-
-(built-in-func reverse (@ (guile) reverse))
-
-(built-in-func copy-tree (@ (guile) copy-tree))
-
-(built-in-func number-sequence
- (lambda (from . rest)
- (if (prim > (prim length rest) 2)
- (runtime-error "too many arguments for number-sequence"
- (prim cdddr rest))
- (if (null? rest)
- `(,from)
- (let ((to (prim car rest))
- (sep (if (or (null? (prim cdr rest))
- (eq? nil-value (prim cadr rest)))
- 1
- (prim cadr rest))))
- (cond
- ((or (eq? nil-value to) (prim = to from)) `(,from))
- ((and (zero? sep) (prim not (prim = from to)))
- (runtime-error "infinite list in number-sequence"))
- ((prim < (prim * to sep) (prim * from sep)) '())
- (else
- (let iterate ((i (prim +
- from
- (prim *
- sep
- (prim quotient
- (prim abs
- (prim -
- to
- from))
- (prim abs sep)))))
- (result '()))
- (if (prim = i from)
- (prim cons i result)
- (iterate (prim - i sep)
- (prim cons i result)))))))))))
-
-;;; Changing lists.
-
-(built-in-func setcar
- (lambda (cell val)
- (if (and (null? cell) (null? val))
- #nil
- (prim set-car! cell val))
- val))
-
-(built-in-func setcdr
- (lambda (cell val)
- (if (and (null? cell) (null? val))
- #nil
- (prim set-cdr! cell val))
- val))
-
-;;; Accessing symbol bindings for symbols known only at runtime.
-
-(built-in-func symbol-value
- (lambda (sym)
- (reference-variable value-slot-module sym)))
-
-(built-in-func symbol-function
- (lambda (sym)
- (reference-variable function-slot-module sym)))
-
-(built-in-func set
- (lambda (sym value)
- (set-variable! value-slot-module sym value)))
-
-(built-in-func fset
- (lambda (sym value)
- (set-variable! function-slot-module sym value)))
-
-(built-in-func makunbound
- (lambda (sym)
- (if (module-bound? (resolve-interface value-slot-module) sym)
- (let ((var (module-variable (resolve-module value-slot-module)
- sym)))
- (if (and (variable-bound? var) (fluid? (variable-ref var)))
- (fluid-unset! (variable-ref var))
- (variable-unset! var))))
- sym))
-
-(built-in-func fmakunbound
- (lambda (sym)
- (if (module-bound? (resolve-interface function-slot-module) sym)
- (let ((var (module-variable
- (resolve-module function-slot-module)
- sym)))
- (if (and (variable-bound? var) (fluid? (variable-ref var)))
- (fluid-unset! (variable-ref var))
- (variable-unset! var))))
- sym))
-
-(built-in-func boundp
- (lambda (sym)
- (elisp-bool
- (and
- (module-bound? (resolve-interface value-slot-module) sym)
- (let ((var (module-variable (resolve-module value-slot-module)
- sym)))
- (and (variable-bound? var)
- (if (fluid? (variable-ref var))
- (fluid-bound? (variable-ref var))
- #t)))))))
-
-(built-in-func fboundp
- (lambda (sym)
- (elisp-bool
- (and
- (module-bound? (resolve-interface function-slot-module) sym)
- (let* ((var (module-variable (resolve-module function-slot-module)
- sym)))
- (and (variable-bound? var)
- (if (fluid? (variable-ref var))
- (fluid-bound? (variable-ref var))
- #t)))))))
-
-;;; Function calls. These must take care of special cases, like using
-;;; symbols or raw lambda-lists as functions!
-
-(built-in-func apply
- (lambda (func . args)
- (let ((real-func (cond
- ((symbol? func)
- (reference-variable function-slot-module func))
- ((list? func)
- (if (and (prim not (null? func))
- (eq? (prim car func) 'lambda))
- (compile func #:from 'elisp #:to 'value)
- (runtime-error "list is not a function"
- func)))
- (else func))))
- (prim apply (@ (guile) apply) real-func args))))
-
-(built-in-func funcall
- (lambda (func . args)
- (apply func args)))
-
-;;; Throw can be implemented as built-in function.
-
-(built-in-func throw
- (lambda (tag value)
- (prim throw 'elisp-exception tag value)))
-
-;;; Miscellaneous.
-
-(built-in-func not
- (lambda (x)
- (if x nil-value t-value)))
-
-(built-in-func eval
- (lambda (form)
- (compile form #:from 'elisp #:to 'value)))
-
-(built-in-func load
- (lambda* (file)
- (compile-file file #:from 'elisp #:to 'value)
- #t))
diff --git a/module/language/elisp/runtime/value-slot.scm b/module/language/elisp/runtime/value-slot.scm
index c6cc3b46f..c2f3666cc 100644
--- a/module/language/elisp/runtime/value-slot.scm
+++ b/module/language/elisp/runtime/value-slot.scm
@@ -18,6 +18,7 @@
;;; Code:
-(define-module (language elisp runtime value-slot))
+(define-module (language elisp runtime value-slot)
+ #:pure)
;;; This module contains the value-slots of elisp symbols.
diff --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm
index 3da368093..38a32c2df 100644
--- a/module/language/elisp/spec.scm
+++ b/module/language/elisp/spec.scm
@@ -22,6 +22,7 @@
#:use-module (language elisp compile-tree-il)
#:use-module (language elisp parser)
#:use-module (system base language)
+ #:use-module (system base compile)
#:export (elisp))
(define-language elisp
@@ -29,3 +30,6 @@
#:reader (lambda (port env) (read-elisp port))
#:printer write
#:compilers `((tree-il . ,compile-tree-il)))
+
+(compile-and-load (%search-load-path "language/elisp/boot.el")
+ #:from 'elisp)
diff --git a/module/language/objcode/elf.scm b/module/language/objcode/elf.scm
new file mode 100644
index 000000000..9654c0861
--- /dev/null
+++ b/module/language/objcode/elf.scm
@@ -0,0 +1,94 @@
+;;; Embedding bytecode in ELF
+
+;; Copyright (C) 2012 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
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+;; The eval-when is because (language objcode elf) will not be loaded
+;; yet when we go to compile it, but later passes of the
+;; compiler need it. So we have to be sure that the module is present
+;; at compile time, with all of its definitions. The easiest way to do
+;; that is just to go ahead and resolve it now.
+;;
+(define-module (language objcode elf)
+ #:use-module (system vm objcode)
+ #:use-module (system base target)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (system vm elf)
+ #:export (write-objcode))
+
+(define (bytecode->elf bv)
+ (let ((string-table (make-elf-string-table)))
+ (define (intern-string! string)
+ (call-with-values
+ (lambda () (elf-string-table-intern string-table string))
+ (lambda (table idx)
+ (set! string-table table)
+ idx)))
+ (define (make-object name bv relocs . kwargs)
+ (let ((name-idx (intern-string! (symbol->string name))))
+ (make-elf-object (apply make-elf-section
+ #:name name-idx
+ #:size (bytevector-length bv)
+ kwargs)
+ bv relocs
+ (list (make-elf-symbol name 0)))))
+ (define (make-dynamic-section word-size endianness)
+ (define (make-dynamic-section/32)
+ (let ((bv (make-bytevector 24 0)))
+ (bytevector-u32-set! bv 0 DT_GUILE_RTL_VERSION endianness)
+ (bytevector-u32-set! bv 4 #x02000000 endianness)
+ (bytevector-u32-set! bv 8 DT_GUILE_ENTRY endianness)
+ (bytevector-u32-set! bv 12 0 endianness)
+ (bytevector-u32-set! bv 16 DT_NULL endianness)
+ (bytevector-u32-set! bv 20 0 endianness)
+ (values bv (make-elf-reloc 'abs32/1 12 0 '.rtl-text))))
+ (define (make-dynamic-section/64)
+ (let ((bv (make-bytevector 48 0)))
+ (bytevector-u64-set! bv 0 DT_GUILE_RTL_VERSION endianness)
+ (bytevector-u64-set! bv 8 #x02000000 endianness)
+ (bytevector-u64-set! bv 16 DT_GUILE_ENTRY endianness)
+ (bytevector-u64-set! bv 24 0 endianness)
+ (bytevector-u64-set! bv 32 DT_NULL endianness)
+ (bytevector-u64-set! bv 40 0 endianness)
+ (values bv (make-elf-reloc 'abs64/1 24 0 '.rtl-text))))
+ (call-with-values (lambda ()
+ (case word-size
+ ((4) (make-dynamic-section/32))
+ ((8) (make-dynamic-section/64))
+ (else (error "unexpected word size" word-size))))
+ (lambda (bv reloc)
+ (make-object '.dynamic bv (list reloc)
+ #:type SHT_DYNAMIC #:flags SHF_ALLOC))))
+ (define (link-string-table)
+ (intern-string! ".shstrtab")
+ (make-object '.shstrtab (link-elf-string-table string-table) '()
+ #:type SHT_STRTAB #:flags 0))
+ (let* ((word-size (target-word-size))
+ (endianness (target-endianness))
+ (text (make-object '.rtl-text bv '()))
+ (dt (make-dynamic-section word-size endianness))
+ ;; This needs to be linked last, because linking other
+ ;; sections adds entries to the string table.
+ (shstrtab (link-string-table)))
+ (link-elf (list text dt shstrtab)
+ #:endianness endianness #:word-size word-size))))
+
+(define (write-objcode objcode port)
+ (let ((bv (objcode->bytecode objcode (target-endianness))))
+ (put-bytevector port (bytecode->elf bv))))
diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm
index bf0649a54..16f52410a 100644
--- a/module/language/objcode/spec.scm
+++ b/module/language/objcode/spec.scm
@@ -22,6 +22,7 @@
#:use-module (system base language)
#:use-module (system vm objcode)
#:use-module (system vm program)
+ #:use-module (language objcode elf)
#:export (objcode))
(define (objcode->value x e opts)
diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm
index f94661da4..c065474b5 100644
--- a/module/language/scheme/decompile-tree-il.scm
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -219,10 +219,12 @@
exp
`(quote ,exp)))
- ((<sequence> exps)
- (build-begin (map recurse exps)))
+ ((<seq> head tail)
+ (build-begin (cons (recurse head)
+ (build-begin-body
+ (recurse tail)))))
- ((<application> proc args)
+ ((<call> proc args)
(match `(,(recurse proc) ,@(map recurse args))
((('lambda (formals ...) body ...) args ...)
(=> failure)
@@ -231,6 +233,9 @@
(failure)))
(e e)))
+ ((<primcall> name args)
+ `(,name ,@(map recurse args)))
+
((<primitive-ref> name)
name)
@@ -658,7 +663,7 @@
((<void>) (primitive 'if)) ; (if #f #f)
((<const>) (primitive 'quote))
- ((<application> proc args)
+ ((<call> proc args)
(if (lexical-ref? proc)
(let* ((gensym (lexical-ref-gensym proc))
(name (source-name gensym)))
@@ -673,6 +678,7 @@
(for-each recurse args))
((<primitive-ref> name) (primitive name))
+ ((<primcall> name args) (primitive name) (for-each recurse args))
((<lexical-ref> gensym) (lexical gensym))
((<lexical-set> gensym exp)
@@ -695,7 +701,9 @@
(primitive 'if)
(recurse test) (recurse consequent) (recurse alternate))
- ((<sequence> exps) (primitive 'begin) (for-each recurse exps))
+ ((<seq> head tail)
+ (primitive 'begin) (recurse head) (recurse tail))
+
((<lambda> body)
(if body (recurse body)))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index aa00b381e..ddcba9938 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -34,8 +34,9 @@
<toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp
<toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
<conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate
- <application> application? make-application application-src application-proc application-args
- <sequence> sequence? make-sequence sequence-src sequence-exps
+ <call> call? make-call call-src call-proc call-args
+ <primcall> primcall? make-primcall primcall-src primcall-name primcall-args
+ <seq> seq? make-seq seq-src seq-head seq-tail
<lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
<lambda-case> lambda-case? make-lambda-case lambda-case-src
lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
@@ -45,13 +46,15 @@
<letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
<let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
- <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
+ <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-pre dynwind-body dynwind-post dynwind-unwinder
<dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
<dynref> dynref? make-dynref dynref-src dynref-fluid
<dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
<prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
<abort> abort? make-abort abort-src abort-tag abort-args abort-tail
+ list->seq
+
parse-tree-il
unparse-tree-il
tree-il->scheme
@@ -121,8 +124,9 @@
;; (<toplevel-set> name exp)
;; (<toplevel-define> name exp)
;; (<conditional> test consequent alternate)
- ;; (<application> proc args)
- ;; (<sequence> exps)
+ ;; (<call> proc args)
+ ;; (<primcall> name args)
+ ;; (<seq> head tail)
;; (<lambda> meta body)
;; (<lambda-case> req opt rest kw inits gensyms body alternate)
;; (<let> names gensyms vals body)
@@ -132,7 +136,7 @@
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
(<fix> names gensyms vals body)
(<let-values> exp body)
- (<dynwind> winder body unwinder)
+ (<dynwind> winder pre body post unwinder)
(<dynref> fluid)
(<dynset> fluid exp)
(<prompt> tag body handler)
@@ -140,6 +144,14 @@
+;; A helper.
+(define (list->seq loc exps)
+ (if (null? (cdr exps))
+ (car exps)
+ (make-seq loc (car exps) (list->seq #f (cdr exps)))))
+
+
+
(define (location x)
(and (pair? x)
(let ((props (source-properties x)))
@@ -152,8 +164,11 @@
((void)
(make-void loc))
- ((apply ,proc . ,args)
- (make-application loc (retrans proc) (map retrans args)))
+ ((call ,proc . ,args)
+ (make-call loc (retrans proc) (map retrans args)))
+
+ ((primcall ,name . ,args)
+ (make-primcall loc name (map retrans args)))
((if ,test ,consequent ,alternate)
(make-conditional loc (retrans test) (retrans consequent) (retrans alternate)))
@@ -212,8 +227,12 @@
((const ,exp)
(make-const loc exp))
+ ((seq ,head ,tail)
+ (make-seq loc (retrans head) (retrans tail)))
+
+ ;; Convenience.
((begin . ,exps)
- (make-sequence loc (map retrans exps)))
+ (list->seq loc (map retrans exps)))
((let ,names ,gensyms ,vals ,body)
(make-let loc names gensyms (map retrans vals) (retrans body)))
@@ -230,8 +249,10 @@
((let-values ,exp ,body)
(make-let-values loc (retrans exp) (retrans body)))
- ((dynwind ,winder ,body ,unwinder)
- (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
+ ((dynwind ,winder ,pre ,body ,post ,unwinder)
+ (make-dynwind loc (retrans winder) (retrans pre)
+ (retrans body)
+ (retrans post) (retrans unwinder)))
((dynlet ,fluids ,vals ,body)
(make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
@@ -256,8 +277,11 @@
((<void>)
'(void))
- ((<application> proc args)
- `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
+ ((<call> proc args)
+ `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
+
+ ((<primcall> name args)
+ `(primcall ,name ,@(map unparse-tree-il args)))
((<conditional> test consequent alternate)
`(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))
@@ -299,9 +323,9 @@
((<const> exp)
`(const ,exp))
- ((<sequence> exps)
- `(begin ,@(map unparse-tree-il exps)))
-
+ ((<seq> head tail)
+ `(seq ,(unparse-tree-il head) ,(unparse-tree-il tail)))
+
((<let> names gensyms vals body)
`(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
@@ -315,9 +339,10 @@
((<let-values> exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
- ((<dynwind> winder body unwinder)
- `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il body)
- ,(unparse-tree-il unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il pre)
+ ,(unparse-tree-il body)
+ ,(unparse-tree-il post) ,(unparse-tree-il unwinder)))
((<dynlet> fluids vals body)
`(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
@@ -349,7 +374,7 @@ invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
and SEED is the current result, intially seeded with SEED.
This is an implementation of `foldts' as described by Andy Wingo in
-``Applications of fold to XML transformation''."
+``Calls of fold to XML transformation''."
(let loop ((tree tree)
(result seed))
(if (or (null? tree) (pair? tree))
@@ -367,10 +392,12 @@ This is an implementation of `foldts' as described by Andy Wingo in
(up tree (loop alternate
(loop consequent
(loop test (down tree result))))))
- ((<application> proc args)
+ ((<call> proc args)
(up tree (loop (cons proc args) (down tree result))))
- ((<sequence> exps)
- (up tree (loop exps (down tree result))))
+ ((<primcall> name args)
+ (up tree (loop args (down tree result))))
+ ((<seq> head tail)
+ (up tree (loop tail (loop head (down tree result)))))
((<lambda> body)
(let ((result (down tree result)))
(up tree
@@ -396,10 +423,13 @@ This is an implementation of `foldts' as described by Andy Wingo in
(down tree result)))))
((<let-values> exp body)
(up tree (loop body (loop exp (down tree result)))))
- ((<dynwind> body winder unwinder)
+ ((<dynwind> winder pre body post unwinder)
(up tree (loop unwinder
- (loop winder
- (loop body (down tree result))))))
+ (loop post
+ (loop body
+ (loop pre
+ (loop winder
+ (down tree result))))))))
((<dynlet> fluids vals body)
(up tree (loop body
(loop vals
@@ -442,11 +472,14 @@ This is an implementation of `foldts' as described by Andy Wingo in
(let*-values (((seed ...) (foldts test seed ...))
((seed ...) (foldts consequent seed ...)))
(foldts alternate seed ...)))
- ((<application> proc args)
+ ((<call> proc args)
(let-values (((seed ...) (foldts proc seed ...)))
(fold-values foldts args seed ...)))
- ((<sequence> exps)
- (fold-values foldts exps seed ...))
+ ((<primcall> name args)
+ (fold-values foldts args seed ...))
+ ((<seq> head tail)
+ (let-values (((seed ...) (foldts head seed ...)))
+ (foldts tail seed ...)))
((<lambda> body)
(if body
(foldts body seed ...)
@@ -469,9 +502,11 @@ This is an implementation of `foldts' as described by Andy Wingo in
((<let-values> exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
- ((<dynwind> body winder unwinder)
- (let*-values (((seed ...) (foldts body seed ...))
- ((seed ...) (foldts winder seed ...)))
+ ((<dynwind> winder pre body post unwinder)
+ (let*-values (((seed ...) (foldts winder seed ...))
+ ((seed ...) (foldts pre seed ...))
+ ((seed ...) (foldts body seed ...))
+ ((seed ...) (foldts post seed ...)))
(foldts unwinder seed ...)))
((<dynlet> fluids vals body)
(let*-values (((seed ...) (fold-values foldts fluids seed ...))
@@ -497,9 +532,12 @@ This is an implementation of `foldts' as described by Andy Wingo in
(define (post-order! f x)
(let lp ((x x))
(record-case x
- ((<application> proc args)
- (set! (application-proc x) (lp proc))
- (set! (application-args x) (map lp args)))
+ ((<call> proc args)
+ (set! (call-proc x) (lp proc))
+ (set! (call-args x) (map lp args)))
+
+ ((<primcall> name args)
+ (set! (primcall-args x) (map lp args)))
((<conditional> test consequent alternate)
(set! (conditional-test x) (lp test))
@@ -528,9 +566,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
(if alternate
(set! (lambda-case-alternate x) (lp alternate))))
- ((<sequence> exps)
- (set! (sequence-exps x) (map lp exps)))
-
+ ((<seq> head tail)
+ (set! (seq-head x) (lp head))
+ (set! (seq-tail x) (lp tail)))
+
((<let> gensyms vals body)
(set! (let-vals x) (map lp vals))
(set! (let-body x) (lp body)))
@@ -547,9 +586,11 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
- ((<dynwind> body winder unwinder)
- (set! (dynwind-body x) (lp body))
+ ((<dynwind> winder pre body post unwinder)
(set! (dynwind-winder x) (lp winder))
+ (set! (dynwind-pre x) (lp pre))
+ (set! (dynwind-body x) (lp body))
+ (set! (dynwind-post x) (lp post))
(set! (dynwind-unwinder x) (lp unwinder)))
((<dynlet> fluids vals body)
@@ -582,9 +623,12 @@ This is an implementation of `foldts' as described by Andy Wingo in
(let lp ((x x))
(let ((x (or (f x) x)))
(record-case x
- ((<application> proc args)
- (set! (application-proc x) (lp proc))
- (set! (application-args x) (map lp args)))
+ ((<call> proc args)
+ (set! (call-proc x) (lp proc))
+ (set! (call-args x) (map lp args)))
+
+ ((<primcall> name args)
+ (set! (primcall-args x) (map lp args)))
((<conditional> test consequent alternate)
(set! (conditional-test x) (lp test))
@@ -612,9 +656,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (lambda-case-body x) (lp body))
(if alternate (set! (lambda-case-alternate x) (lp alternate))))
- ((<sequence> exps)
- (set! (sequence-exps x) (map lp exps)))
-
+ ((<seq> head tail)
+ (set! (seq-head x) (lp head))
+ (set! (seq-tail x) (lp tail)))
+
((<let> vals body)
(set! (let-vals x) (map lp vals))
(set! (let-body x) (lp body)))
@@ -631,9 +676,11 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
- ((<dynwind> body winder unwinder)
- (set! (dynwind-body x) (lp body))
+ ((<dynwind> winder pre body post unwinder)
(set! (dynwind-winder x) (lp winder))
+ (set! (dynwind-pre x) (lp pre))
+ (set! (dynwind-body x) (lp body))
+ (set! (dynwind-post x) (lp post))
(set! (dynwind-unwinder x) (lp unwinder)))
((<dynlet> fluids vals body)
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index badce9f77..f5890b25a 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -180,10 +180,13 @@
(analyze! x new-proc (append labels labels-in-proc) #t #f))
(define (recur x new-proc) (analyze! x new-proc '() tail? #f))
(record-case x
- ((<application> proc args)
+ ((<call> proc args)
(apply lset-union eq? (step-tail-call proc args)
(map step args)))
+ ((<primcall> args)
+ (apply lset-union eq? (map step args)))
+
((<conditional> test consequent alternate)
(lset-union eq? (step test) (step-tail consequent) (step-tail alternate)))
@@ -222,13 +225,8 @@
((<toplevel-define> exp)
(step exp))
- ((<sequence> exps)
- (let lp ((exps exps) (ret '()))
- (cond ((null? exps) '())
- ((null? (cdr exps))
- (lset-union eq? ret (step-tail (car exps))))
- (else
- (lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
+ ((<seq> head tail)
+ (lset-union eq? (step head) (step-tail tail)))
((<lambda> body)
;; order is important here
@@ -339,8 +337,10 @@
((<let-values> exp body)
(lset-union eq? (step exp) (step body)))
- ((<dynwind> body winder unwinder)
- (lset-union eq? (step body) (step winder) (step unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ (lset-union eq? (step winder) (step pre)
+ (step body)
+ (step post) (step unwinder)))
((<dynlet> fluids vals body)
(apply lset-union eq? (step body) (map step (append fluids vals))))
@@ -367,9 +367,12 @@
(define (allocate! x proc n)
(define (recur y) (allocate! y proc n))
(record-case x
- ((<application> proc args)
+ ((<call> proc args)
(apply max (recur proc) (map recur args)))
+ ((<primcall> args)
+ (apply max n (map recur args)))
+
((<conditional> test consequent alternate)
(max (recur test) (recur consequent) (recur alternate)))
@@ -385,8 +388,9 @@
((<toplevel-define> exp)
(recur exp))
- ((<sequence> exps)
- (apply max (map recur exps)))
+ ((<seq> head tail)
+ (max (recur head)
+ (recur tail)))
((<lambda> body)
;; allocate closure vars in order
@@ -509,8 +513,10 @@
((<let-values> exp body)
(max (recur exp) (recur body)))
- ((<dynwind> body winder unwinder)
- (max (recur body) (recur winder) (recur unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ (max (recur winder) (recur pre)
+ (recur body)
+ (recur post) (recur unwinder)))
((<dynlet> fluids vals body)
(apply max (recur body) (map recur (append fluids vals))))
@@ -866,7 +872,7 @@ accurate information is missing from a given `tree-il' element."
(defs toplevel-info-defs)) ;; (VARIABLE-NAME ...)
(define (goops-toplevel-definition proc args env)
- ;; If application of PROC to ARGS is a GOOPS top-level definition, return
+ ;; If call of PROC to ARGS is a GOOPS top-level definition, return
;; the name of the variable being defined; otherwise return #f. This
;; assumes knowledge of the current implementation of `define-class' et al.
(define (toplevel-define-arg args)
@@ -927,7 +933,7 @@ accurate information is missing from a given `tree-il' element."
(make-toplevel-info (vhash-delq name refs)
(vhash-consq name #t defs)))
- ((<application> proc args)
+ ((<call> proc args)
;; Check for a dynamic top-level definition, as is
;; done by code expanded from GOOPS macros.
(let ((name (goops-toplevel-definition proc args
@@ -965,12 +971,12 @@ accurate information is missing from a given `tree-il' element."
(define-record-type <arity-info>
(make-arity-info toplevel-calls lexical-lambdas toplevel-lambdas)
arity-info?
- (toplevel-calls toplevel-procedure-calls) ;; ((NAME . APPLICATION) ...)
+ (toplevel-calls toplevel-procedure-calls) ;; ((NAME . CALL) ...)
(lexical-lambdas lexical-lambdas) ;; ((GENSYM . DEFINITION) ...)
(toplevel-lambdas toplevel-lambdas)) ;; ((NAME . DEFINITION) ...)
-(define (validate-arity proc application lexical?)
- ;; Validate the argument count of APPLICATION, a tree-il application of
+(define (validate-arity proc call lexical?)
+ ;; Validate the argument count of CALL, a tree-il call of
;; PROC, emitting a warning in case of argument count mismatch.
(define (filter-keyword-args keywords allow-other-keys? args)
@@ -1034,8 +1040,8 @@ accurate information is missing from a given `tree-il' element."
(else
(values #f #f))))))))
- (let ((args (application-args application))
- (src (tree-il-src application)))
+ (let ((args (call-args call))
+ (src (tree-il-src call)))
(call-with-values (lambda () (arities proc))
(lambda (name arities)
(define matches?
@@ -1122,7 +1128,7 @@ accurate information is missing from a given `tree-il' element."
((<fix> gensyms vals)
(fold extend info gensyms vals))
- ((<application> proc args src)
+ ((<call> proc args src)
(record-case proc
((<lambda> body)
(validate-arity proc x #t)
@@ -1182,9 +1188,9 @@ accurate information is missing from a given `tree-il' element."
(let ((toplevel-calls (toplevel-procedure-calls result))
(toplevel-lambdas (toplevel-lambdas result)))
(vlist-for-each
- (lambda (name+application)
- (let* ((name (car name+application))
- (application (cdr name+application))
+ (lambda (name+call)
+ (let* ((name (car name+call))
+ (call (cdr name+call))
(proc
(or (and=> (vhash-assq name toplevel-lambdas) cdr)
(and (module? env)
@@ -1199,9 +1205,9 @@ accurate information is missing from a given `tree-il' element."
(module-ref env name))))
proc)))
(cond ((lambda? proc*)
- (validate-arity proc* application #t))
+ (validate-arity proc* call #t))
((procedure? proc*)
- (validate-arity proc* application #f)))))
+ (validate-arity proc* call #f)))))
toplevel-calls)))
(make-arity-info vlist-null vlist-null vlist-null)))
@@ -1395,11 +1401,11 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME."
(match x
(($ <const> _ (? string? exp))
exp)
- (($ <application> _ (? (cut gettext? <> env))
+ (($ <call> _ (? (cut gettext? <> env))
(($ <const> _ (? string? fmt))))
;; Gettexted literals, like `(_ "foo")'.
fmt)
- (($ <application> _ (? (cut ngettext? <> env))
+ (($ <call> _ (? (cut ngettext? <> env))
(($ <const> _ (? string? fmt)) ($ <const> _ (? string?)) _ ..1))
;; Plural gettextized literals, like `(N_ "singular" "plural" n)'.
@@ -1490,17 +1496,17 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME."
(false-if-exception (module-ref env name))))
(match x
- (($ <application> src ($ <toplevel-ref> _ name) args)
+ (($ <call> src ($ <toplevel-ref> _ name) args)
(let ((proc (resolve-toplevel name)))
(if (or (and (eq? proc (@ (guile) simple-format))
(check-simple-format-args args
(or src (find pair? locs))))
(eq? proc (@ (ice-9 format) format)))
(check-format-args args (or src (find pair? locs))))))
- (($ <application> src ($ <module-ref> _ '(ice-9 format) 'format) args)
+ (($ <call> src ($ <module-ref> _ '(ice-9 format) 'format) args)
(check-format-args args (or src (find pair? locs))))
- (($ <application> src ($ <module-ref> _ '(guile)
- (or 'format 'simple-format))
+ (($ <call> src ($ <module-ref> _ '(guile)
+ (or 'format 'simple-format))
args)
(and (check-simple-format-args args
(or src (find pair? locs)))
diff --git a/module/language/tree-il/canonicalize.scm b/module/language/tree-il/canonicalize.scm
index 2fa8c2ec9..1db842022 100644
--- a/module/language/tree-il/canonicalize.scm
+++ b/module/language/tree-il/canonicalize.scm
@@ -36,16 +36,6 @@
(post-order!
(lambda (x)
(match x
- (($ <sequence> src (tail))
- tail)
- (($ <sequence> src exps)
- (and (any sequence? exps)
- (make-sequence src
- (append-map (lambda (x)
- (if (sequence? x)
- (sequence-exps x)
- (list x)))
- exps))))
(($ <let> src () () () body)
body)
(($ <letrec> src _ () () () body)
@@ -60,9 +50,9 @@
src meta
(make-lambda-case
#f '() #f #f #f '() '()
- (make-application
+ (make-primcall
#f
- (make-primitive-ref #f 'throw)
+ 'throw
(list (make-const #f 'wrong-number-of-args)
(make-const #f #f)
(make-const #f "Wrong number of arguments")
@@ -80,7 +70,7 @@
(else #f)))
(define (thunk-application? x)
(match x
- (($ <application> _
+ (($ <call> _
($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f))
()) #t)
(_ #f)))
@@ -88,7 +78,7 @@
(define thunk
(make-lambda #f '()
(make-lambda-case #f '() #f #f #f '() '() body #f)))
- (make-application #f thunk '()))
+ (make-call #f thunk '()))
;; This code has a nasty job to do: to ensure that either the
;; handler is escape-only, or the body is the application of a
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index e4df6e1bd..1b6fea69c 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -110,11 +110,15 @@
((list? . 1) . list?)
((symbol? . 1) . symbol?)
((vector? . 1) . vector?)
+ ((nil? . 1) . nil?)
(list . list)
(vector . vector)
((class-of . 1) . class-of)
((@slot-ref . 2) . slot-ref)
((@slot-set! . 3) . slot-set)
+ ((string-length . 1) . string-length)
+ ((string-ref . 2) . string-ref)
+ ((vector-length . 1) . vector-length)
((vector-ref . 2) . vector-ref)
((vector-set! . 3) . vector-set)
((variable-ref . 1) . variable-ref)
@@ -268,199 +272,12 @@
(emit-code src (make-glil-const exp))))
(maybe-emit-return))
- ;; FIXME: should represent sequence as exps tail
- ((<sequence> exps)
- (let lp ((exps exps))
- (if (null? (cdr exps))
- (comp-tail (car exps))
- (begin
- (comp-drop (car exps))
- (lp (cdr exps))))))
-
- ((<application> src proc args)
- ;; FIXME: need a better pattern-matcher here
+ ((<seq> head tail)
+ (comp-drop head)
+ (comp-tail tail))
+
+ ((<call> src proc args)
(cond
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@apply)
- (>= (length args) 1))
- (let ((proc (car args))
- (args (cdr args)))
- (cond
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
- (not (eq? context 'push)) (not (eq? context 'vals)))
- ;; tail: (lambda () (apply values '(1 2)))
- ;; drop: (lambda () (apply values '(1 2)) 3)
- ;; push: (lambda () (list (apply values '(10 12)) 1))
- (case context
- ((drop) (for-each comp-drop args) (maybe-emit-return))
- ((tail)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'return/values* (length args))))))
-
- (else
- (case context
- ((tail)
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
- ((push)
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'apply (1+ (length args))))
- (maybe-emit-return))
- ((vals)
- (comp-vals
- (make-application src (make-primitive-ref #f 'apply)
- (cons proc args))
- MVRA)
- (maybe-emit-return))
- ((drop)
- ;; Well, shit. The proc might return any number of
- ;; values (including 0), since it's in a drop context,
- ;; yet apply does not create a MV continuation. So we
- ;; mv-call out to our trampoline instead.
- (comp-drop
- (make-application src (make-primitive-ref #f 'apply)
- (cons proc args)))
- (maybe-emit-return)))))))
-
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values))
- ;; tail: (lambda () (values '(1 2)))
- ;; drop: (lambda () (values '(1 2)) 3)
- ;; push: (lambda () (list (values '(10 12)) 1))
- ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
- (case context
- ((drop) (for-each comp-drop args) (maybe-emit-return))
- ((push)
- (case (length args)
- ((0)
- ;; FIXME: This is surely an error. We need to add a
- ;; values-mismatch warning pass.
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push proc)
- (emit-code src (make-glil-call 'call 0))
- (maybe-emit-return))
- (else
- ;; Taking advantage of unspecified order of evaluation of
- ;; arguments.
- (for-each comp-drop (cdr args))
- (comp-push (car args))
- (maybe-emit-return))))
- ((vals)
- (for-each comp-push args)
- (emit-code #f (make-glil-const (length args)))
- (emit-branch src 'br MVRA))
- ((tail)
- (for-each comp-push args)
- (emit-code src (let ((len (length args)))
- (if (= len 1)
- (make-glil-call 'return 1)
- (make-glil-call 'return/values len)))))))
-
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-values)
- (= (length args) 2))
- ;; CONSUMER
- ;; PRODUCER
- ;; (mv-call MV)
- ;; ([tail]-call 1)
- ;; goto POST
- ;; MV: [tail-]call/nargs
- ;; POST: (maybe-drop)
- (case context
- ((vals)
- ;; Fall back.
- (comp-vals
- (make-application src (make-primitive-ref #f 'call-with-values)
- args)
- MVRA)
- (maybe-emit-return))
- (else
- (let ((MV (make-label)) (POST (make-label))
- (producer (car args)) (consumer (cadr args)))
- (if (not (eq? context 'tail))
- (emit-code src (make-glil-call 'new-frame 0)))
- (comp-push consumer)
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push producer)
- (emit-code src (make-glil-mv-call 0 MV))
- (case context
- ((tail) (emit-code src (make-glil-call 'tail-call 1)))
- (else (emit-code src (make-glil-call 'call 1))
- (emit-branch #f 'br POST)))
- (emit-label MV)
- (case context
- ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
- (else (emit-code src (make-glil-call 'call/nargs 0))
- (emit-label POST)
- (if (eq? context 'drop)
- (emit-code #f (make-glil-call 'drop 1)))
- (maybe-emit-return)))))))
-
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-current-continuation)
- (= (length args) 1))
- (case context
- ((tail)
- (comp-push (car args))
- (emit-code src (make-glil-call 'tail-call/cc 1)))
- ((vals)
- (comp-vals
- (make-application
- src (make-primitive-ref #f 'call-with-current-continuation)
- args)
- MVRA)
- (maybe-emit-return))
- ((push)
- (comp-push (car args))
- (emit-code src (make-glil-call 'call/cc 1))
- (maybe-emit-return))
- ((drop)
- ;; Crap. Just like `apply' in drop context.
- (comp-drop
- (make-application
- src (make-primitive-ref #f 'call-with-current-continuation)
- args))
- (maybe-emit-return))))
-
- ;; A hack for variable-set, the opcode for which takes its args
- ;; reversed, relative to the variable-set! function
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) 'variable-set!)
- (= (length args) 2))
- (comp-push (cadr args))
- (comp-push (car args))
- (emit-code src (make-glil-call 'variable-set 2))
- (case context
- ((tail push vals) (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ((and (primitive-ref? proc)
- (or (hash-ref *primcall-ops*
- (cons (primitive-ref-name proc) (length args)))
- (hash-ref *primcall-ops* (primitive-ref-name proc))))
- => (lambda (op)
- (for-each comp-push args)
- (emit-code src (make-glil-call op (length args)))
- (case (instruction-pushes op)
- ((0)
- (case context
- ((tail push vals) (emit-code #f (make-glil-void))))
- (maybe-emit-return))
- ((1)
- (case context
- ((drop) (emit-code #f (make-glil-call 'drop 1))))
- (maybe-emit-return))
- ((-1)
- ;; A control instruction, like return/values. Here we
- ;; just have to hope that the author of the tree-il
- ;; knew what they were doing.
- *unspecified*)
- (else
- (error "bad primitive op: too many pushes"
- op (instruction-pushes op))))))
-
;; call to the same lambda-case in tail position
((and (lexical-ref? proc)
self-label (eq? (lexical-ref-gensym proc) self-label)
@@ -553,6 +370,157 @@
(emit-branch #f 'br RA)
(emit-label POST)))))))))
+ ((<primcall> src name args)
+ (pmatch (cons name args)
+ ((@apply ,proc . ,args)
+ (cond
+ ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+ (not (eq? context 'push)) (not (eq? context 'vals)))
+ ;; tail: (lambda () (apply values '(1 2)))
+ ;; drop: (lambda () (apply values '(1 2)) 3)
+ ;; push: (lambda () (list (apply values '(10 12)) 1))
+ (case context
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'return/values* (length args))))))
+
+ (else
+ (case context
+ ((tail)
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
+ ((push)
+ (emit-code src (make-glil-call 'new-frame 0))
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'apply (1+ (length args))))
+ (maybe-emit-return))
+ (else
+ (comp-tail (make-primcall src 'apply (cons proc args))))))))
+
+ ((values . _)
+ ;; tail: (lambda () (values '(1 2)))
+ ;; drop: (lambda () (values '(1 2)) 3)
+ ;; push: (lambda () (list (values '(10 12)) 1))
+ ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
+ (case context
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
+ ((push)
+ (case (length args)
+ ((0)
+ ;; FIXME: This is surely an error. We need to add a
+ ;; values-mismatch warning pass.
+ (comp-push (make-call src (make-primitive-ref #f 'values)
+ '())))
+ (else
+ ;; Taking advantage of unspecified order of evaluation of
+ ;; arguments.
+ (for-each comp-drop (cdr args))
+ (comp-push (car args))
+ (maybe-emit-return))))
+ ((vals)
+ (for-each comp-push args)
+ (emit-code #f (make-glil-const (length args)))
+ (emit-branch src 'br MVRA))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (let ((len (length args)))
+ (if (= len 1)
+ (make-glil-call 'return 1)
+ (make-glil-call 'return/values len)))))))
+
+ ((@call-with-values ,producer ,consumer)
+ ;; CONSUMER
+ ;; PRODUCER
+ ;; (mv-call MV)
+ ;; ([tail]-call 1)
+ ;; goto POST
+ ;; MV: [tail-]call/nargs
+ ;; POST: (maybe-drop)
+ (case context
+ ((vals)
+ ;; Fall back.
+ (comp-tail (make-primcall src 'call-with-values args)))
+ (else
+ (let ((MV (make-label)) (POST (make-label)))
+ (if (not (eq? context 'tail))
+ (emit-code src (make-glil-call 'new-frame 0)))
+ (comp-push consumer)
+ (emit-code src (make-glil-call 'new-frame 0))
+ (comp-push producer)
+ (emit-code src (make-glil-mv-call 0 MV))
+ (case context
+ ((tail) (emit-code src (make-glil-call 'tail-call 1)))
+ (else (emit-code src (make-glil-call 'call 1))
+ (emit-branch #f 'br POST)))
+ (emit-label MV)
+ (case context
+ ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
+ (else (emit-code src (make-glil-call 'call/nargs 0))
+ (emit-label POST)
+ (if (eq? context 'drop)
+ (emit-code #f (make-glil-call 'drop 1)))
+ (maybe-emit-return)))))))
+
+ ((@call-with-current-continuation ,proc)
+ (case context
+ ((tail)
+ (comp-push proc)
+ (emit-code src (make-glil-call 'tail-call/cc 1)))
+ ((vals)
+ (comp-vals
+ (make-primcall src 'call-with-current-continuation args)
+ MVRA)
+ (maybe-emit-return))
+ ((push)
+ (comp-push proc)
+ (emit-code src (make-glil-call 'call/cc 1))
+ (maybe-emit-return))
+ ((drop)
+ ;; Fall back.
+ (comp-tail
+ (make-primcall src 'call-with-current-continuation args)))))
+
+ ;; A hack for variable-set, the opcode for which takes its args
+ ;; reversed, relative to the variable-set! function
+ ((variable-set! ,var ,val)
+ (comp-push val)
+ (comp-push var)
+ (emit-code src (make-glil-call 'variable-set 2))
+ (case context
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ (else
+ (cond
+ ((or (hash-ref *primcall-ops* (cons name (length args)))
+ (hash-ref *primcall-ops* name))
+ => (lambda (op)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call op (length args)))
+ (case (instruction-pushes op)
+ ((0)
+ (case context
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+ ((1)
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
+ ((-1)
+ ;; A control instruction, like return/values. Here we
+ ;; just have to hope that the author of the tree-il
+ ;; knew what they were doing.
+ *unspecified*)
+ (else
+ (error "bad primitive op: too many pushes"
+ op (instruction-pushes op))))))
+ (else
+ ;; Fall back to the normal compilation strategy.
+ (comp-tail (make-call src (make-primitive-ref #f name) args)))))))
+
((<conditional> src test consequent alternate)
;; TEST
;; (br-if-not L1)
@@ -561,54 +529,39 @@
;; L1: alternate
;; L2:
(let ((L1 (make-label)) (L2 (make-label)))
- ;; need a pattern matcher
(record-case test
- ((<application> proc args)
- (record-case proc
- ((<primitive-ref> name)
- (let ((len (length args)))
- (cond
-
- ((and (eq? name 'eq?) (= len 2))
- (comp-push (car args))
- (comp-push (cadr args))
- (emit-branch src 'br-if-not-eq L1))
-
- ((and (eq? name 'null?) (= len 1))
- (comp-push (car args))
- (emit-branch src 'br-if-not-null L1))
-
- ((and (eq? name 'not) (= len 1))
- (let ((app (car args)))
- (record-case app
- ((<application> proc args)
- (let ((len (length args)))
- (record-case proc
- ((<primitive-ref> name)
- (cond
-
- ((and (eq? name 'eq?) (= len 2))
- (comp-push (car args))
- (comp-push (cadr args))
- (emit-branch src 'br-if-eq L1))
-
- ((and (eq? name 'null?) (= len 1))
- (comp-push (car args))
- (emit-branch src 'br-if-null L1))
-
- (else
- (comp-push app)
- (emit-branch src 'br-if L1))))
- (else
- (comp-push app)
- (emit-branch src 'br-if L1)))))
- (else
- (comp-push app)
- (emit-branch src 'br-if L1)))))
-
- (else
- (comp-push test)
- (emit-branch src 'br-if-not L1)))))
+ ((<primcall> name args)
+ (pmatch (cons name args)
+ ((eq? ,a ,b)
+ (comp-push a)
+ (comp-push b)
+ (emit-branch src 'br-if-not-eq L1))
+ ((null? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-not-null L1))
+ ((nil? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-not-nil L1))
+ ((not ,x)
+ (record-case x
+ ((<primcall> name args)
+ (pmatch (cons name args)
+ ((eq? ,a ,b)
+ (comp-push a)
+ (comp-push b)
+ (emit-branch src 'br-if-eq L1))
+ ((null? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-null L1))
+ ((nil? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-nil L1))
+ (else
+ (comp-push x)
+ (emit-branch src 'br-if L1))))
+ (else
+ (comp-push x)
+ (emit-branch src 'br-if L1))))
(else
(comp-push test)
(emit-branch src 'br-if-not L1))))
@@ -985,10 +938,34 @@
;; to have body's return value(s) on the stack while the unwinder runs,
;; then proceed with returning or dropping or what-have-you, interacting
;; with RA and MVRA. What have you, I say.
- ((<dynwind> src body winder unwinder)
+ ((<dynwind> src winder pre body post unwinder)
+ (define (thunk? x)
+ (and (lambda? x)
+ (null? (lambda-case-gensyms (lambda-body x)))))
+ (define (make-wrong-type-arg x)
+ (make-primcall src 'scm-error
+ (list
+ (make-const #f 'wrong-type-arg)
+ (make-const #f "dynamic-wind")
+ (make-const #f "Wrong type (expecting thunk): ~S")
+ (make-primcall #f 'list (list x))
+ (make-primcall #f 'list (list x)))))
+ (define (emit-thunk-check x)
+ (comp-drop (make-conditional
+ src
+ (make-primcall src 'thunk? (list x))
+ (make-void #f)
+ (make-wrong-type-arg x))))
+
+ ;; We know at this point that `winder' and `unwinder' are
+ ;; constant expressions and can be duplicated.
+ (if (not (thunk? winder))
+ (emit-thunk-check winder))
(comp-push winder)
+ (if (not (thunk? unwinder))
+ (emit-thunk-check unwinder))
(comp-push unwinder)
- (comp-drop (make-application src winder '()))
+ (comp-drop pre)
(emit-code #f (make-glil-call 'wind 2))
(case context
@@ -997,14 +974,14 @@
(comp-vals body MV)
;; one value: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; ...and return the val
(emit-code #f (make-glil-call 'return 1))
(emit-label MV)
;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; and return the values.
(emit-code #f (make-glil-call 'return/nvalues 1))))
@@ -1013,7 +990,7 @@
(comp-push body)
;; and unwind, leaving the val on the stack
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '())))
+ (comp-drop post))
((vals)
(let ((MV (make-label)))
@@ -1024,7 +1001,7 @@
(emit-label MV)
;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; and goto the MVRA.
(emit-branch #f 'br MVRA)))
@@ -1032,7 +1009,7 @@
;; compile body, discarding values. then unwind...
(comp-drop body)
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; and fall through, or goto RA if there is one.
(if RA
(emit-branch #f 'br RA)))))
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index b025bcb08..f8df3ce55 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -149,8 +149,7 @@
(define (boolean-valued-expression? x ctx)
(match x
- (($ <application> _
- ($ <primitive-ref> _ (? boolean-valued-primitive?))) #t)
+ (($ <primcall> _ (? boolean-valued-primitive?)) #t)
(($ <const> _ (? boolean?)) #t)
(_ (eq? ctx 'test))))
@@ -163,9 +162,8 @@
(($ <primitive-ref>) #t)
(($ <module-ref>) #t)
(($ <toplevel-ref>) #t)
- (($ <application> _
- ($ <primitive-ref> _ (? singly-valued-primitive?))) #t)
- (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t)
+ (($ <primcall> _ (? singly-valued-primitive?)) #t)
+ (($ <primcall> _ 'values (val)) #t)
(($ <lambda>) #t)
(_ (eq? ctx 'value))))
@@ -188,17 +186,13 @@
(make-const src #f))
(($ <conditional> src test consequent alternate)
(make-conditional src test (negate consequent ctx) (negate alternate ctx)))
- (($ <application> _ ($ <primitive-ref> _ 'not)
+ (($ <primcall> _ 'not
((and x (? (cut boolean-valued-expression? <> ctx)))))
x)
- (($ <application> src
- ($ <primitive-ref> _ (and pred (? negate-primitive)))
- args)
- (make-application src
- (make-primitive-ref #f (negate-primitive pred))
- args))
+ (($ <primcall> src (and pred (? negate-primitive)) args)
+ (make-primcall src (negate-primitive pred) args))
(_
- (make-application #f (make-primitive-ref #f 'not) (list exp)))))
+ (make-primcall #f 'not (list exp)))))
(define (hasher n)
@@ -267,7 +261,7 @@
exp
(make-const src (not (not val)))))
;; For (not FOO), try to prove FOO, then negate the result.
- (($ <application> src ($ <primitive-ref> _ 'not) (exp*))
+ (($ <primcall> src 'not (exp*))
(match (find-dominating-test exp* effects db)
(($ <const> _ val)
(log 'inferring exp (not val))
@@ -450,12 +444,19 @@
((consumer db**) (visit consumer (concat db* db) env ctx)))
(return (make-let-values src producer consumer)
(concat db** db*))))
- (($ <dynwind> src winder body unwinder)
- (let*-values (((pre db*) (visit winder db env 'value))
- ((body db**) (visit body (concat db* db) env ctx))
- ((post db***) (visit unwinder db env 'value)))
- (return (make-dynwind src pre body post)
- (concat db* (concat db** db***)))))
+ (($ <dynwind> src winder pre body post unwinder)
+ (let*-values (((winder db*) (visit winder db env 'value))
+ ((db**) db*)
+ ((unwinder db*) (visit unwinder db env 'value))
+ ((db**) (concat db* db**))
+ ((pre db*) (visit pre (concat db** db) env 'effect))
+ ((db**) (concat db* db**))
+ ((body db*) (visit body (concat db** db) env ctx))
+ ((db**) (concat db* db**))
+ ((post db*) (visit post (concat db** db) env 'effect))
+ ((db**) (concat db* db**)))
+ (return (make-dynwind src winder pre body post unwinder)
+ db**)))
(($ <dynlet> src fluids vals body)
(let*-values (((fluids db*) (parallel-visit fluids db env 'value))
((vals db**) (parallel-visit vals db env 'value))
@@ -504,7 +505,7 @@
;; (if FOO A A) => (begin FOO A)
(($ <conditional> src _
($ <const> _ a) ($ <const> _ (? (cut equal? a <>))))
- (visit (make-sequence #f (list test (make-const #f a)))
+ (visit (make-seq #f test (make-const #f a))
db env ctx))
;; (if FOO #t #f) => FOO for boolean-valued FOO.
(($ <conditional> src
@@ -529,10 +530,13 @@
(c
(return c (intersection (concat db++ db+) (concat db-- db-)))))))
- (($ <application> src proc args)
+ (($ <primcall> src primitive args)
+ (let*-values (((args db*) (parallel-visit args db env 'value)))
+ (return (make-primcall src primitive args) db*)))
+ (($ <call> src proc args)
(let*-values (((proc db*) (visit proc db env 'value))
((args db**) (parallel-visit args db env 'value)))
- (return (make-application src proc args)
+ (return (make-call src proc args)
(concat db** db*))))
(($ <lambda> src meta body)
(let*-values (((body _) (if body
@@ -549,24 +553,15 @@
(values #f #f))))
(return (make-lambda-case src req opt rest kw inits gensyms body alt)
(if alt vlist-null db*))))
- (($ <sequence> src exps)
- (let lp ((in exps) (out '()) (db* vlist-null))
- (match in
- ((last)
- (let*-values (((last db**) (visit last (concat db* db) env ctx)))
- (if (null? out)
- (return last (concat db** db*))
- (return (make-sequence src (reverse (cons last out)))
- (concat db** db*)))))
- ((head . rest)
- (let*-values (((head db**) (visit head (concat db* db) env 'effect)))
- (cond
- ((sequence? head)
- (lp (append (sequence-exps head) rest) out db*))
- ((void? head)
- (lp rest out db*))
- (else
- (lp rest (cons head out) (concat db** db*)))))))))
+ (($ <seq> src head tail)
+ (let*-values (((head db*) (visit head db env 'effect)))
+ (cond
+ ((void? head)
+ (visit tail db env ctx))
+ (else
+ (let*-values (((tail db**) (visit tail (concat db* db) env ctx)))
+ (values (make-seq src head tail)
+ (concat db** db*)))))))
(($ <prompt> src tag body handler)
(let*-values (((tag db*) (visit tag db env 'value))
((body _) (visit body (concat db* db) env ctx))
diff --git a/module/language/tree-il/debug.scm b/module/language/tree-il/debug.scm
index 97737c29b..65fd58e3c 100644
--- a/module/language/tree-il/debug.scm
+++ b/module/language/tree-il/debug.scm
@@ -216,9 +216,11 @@
(for-each (cut visit <> env) fluids)
(for-each (cut visit <> env) vals)
(visit body env))))
- (($ <dynwind> src winder body unwinder)
+ (($ <dynwind> src winder pre body post unwinder)
(visit winder env)
+ (visit pre env)
(visit body env)
+ (visit post env)
(visit unwinder env))
(($ <dynref> src fluid)
(visit fluid env))
@@ -229,21 +231,24 @@
(visit condition env)
(visit subsequent env)
(visit alternate env))
- (($ <application> src proc args)
+ (($ <primcall> src name args)
(cond
+ ((not (symbol? name))
+ (error "expected symbolic operator" exp))
((not (list? args))
(error "expected list of args" args))
(else
- (visit proc env)
(for-each (cut visit <> env) args))))
- (($ <sequence> src exps)
+ (($ <call> src proc args)
(cond
- ((not (list? exps))
- (error "expected list of exps" exp))
- ((null? exps)
- (error "expected more than one exp" exp))
+ ((not (list? args))
+ (error "expected list of args" args))
(else
- (for-each (cut visit <> env) exps))))
+ (visit proc env)
+ (for-each (cut visit <> env) args))))
+ (($ <seq> src head tail)
+ (visit head env)
+ (visit tail env))
(($ <prompt> src tag body handler)
(visit tag env)
(visit body env)
diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm
index 1fe4aebb0..b5586e2b4 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -211,9 +211,11 @@ of an expression."
(logior (compute-effects producer)
(compute-effects consumer)
(cause &type-check)))
- (($ <dynwind> _ winder body unwinder)
+ (($ <dynwind> _ winder pre body post unwinder)
(logior (compute-effects winder)
+ (compute-effects pre)
(compute-effects body)
+ (compute-effects post)
(compute-effects unwinder)))
(($ <dynlet> _ fluids vals body)
(logior (accumulate-effects fluids)
@@ -259,43 +261,37 @@ of an expression."
&definite-bailout))))
;; Zero values.
- (($ <application> _ ($ <primitive-ref> _ 'values) ())
+ (($ <primcall> _ 'values ())
(cause &zero-values))
;; Effect-free primitives.
- (($ <application> _
- ($ <primitive-ref> _ (or 'values 'eq? 'eqv? 'equal?))
- args)
+ (($ <primcall> _ (or 'values 'eq? 'eqv? 'equal?) args)
(accumulate-effects args))
- (($ <application> _
- ($ <primitive-ref> _ (or 'not 'pair? 'null? 'list? 'symbol?
- 'vector? 'struct? 'string? 'number?
- 'char?))
+ (($ <primcall> _ (or 'not 'pair? 'null? 'list? 'symbol?
+ 'vector? 'struct? 'string? 'number?
+ 'char?)
(arg))
(compute-effects arg))
;; Primitives that allocate memory.
- (($ <application> _ ($ <primitive-ref> _ 'cons) (x y))
+ (($ <primcall> _ 'cons (x y))
(logior (compute-effects x) (compute-effects y)
&allocation))
- (($ <application> _ ($ <primitive-ref> _ (or 'list 'vector)) args)
+ (($ <primcall> _ (or 'list 'vector) args)
(logior (accumulate-effects args) &allocation))
- (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) ())
+ (($ <primcall> _ 'make-prompt-tag ())
&allocation)
- (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) (arg))
+ (($ <primcall> _ 'make-prompt-tag (arg))
(logior (compute-effects arg) &allocation))
;; Primitives that are normally effect-free, but which might
;; cause type checks, allocate memory, or access mutable
;; memory. FIXME: expand, to be more precise.
- (($ <application> _
- ($ <primitive-ref> _ (and name
- (? effect-free-primitive?)))
- args)
+ (($ <primcall> _ (and name (? effect-free-primitive?)) args)
(logior (accumulate-effects args)
(cause &type-check)
(if (constructor-primitive? name)
@@ -305,7 +301,7 @@ of an expression."
&no-effects))))
;; Lambda applications might throw wrong-number-of-args.
- (($ <application> _ ($ <lambda> _ _ body) args)
+ (($ <call> _ ($ <lambda> _ _ body) args)
(logior (accumulate-effects args)
(match body
(($ <lambda-case> _ req #f #f #f () syms body #f)
@@ -323,25 +319,27 @@ of an expression."
(cause &possible-bailout))))))
;; Bailout primitives.
- (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
- args)
+ (($ <primcall> _ (? bailout-primitive? name) args)
(logior (accumulate-effects args)
(cause &definite-bailout)
(cause &possible-bailout)))
;; A call to a lexically bound procedure, perhaps labels
;; allocated.
- (($ <application> _ (and proc ($ <lexical-ref> _ _ sym)) args)
+ (($ <call> _ (and proc ($ <lexical-ref> _ _ sym)) args)
(cond
((lookup sym)
=> (lambda (proc)
- (compute-effects (make-application #f proc args))))
+ (compute-effects (make-call #f proc args))))
(else
(logior &all-effects-but-bailout
(cause &all-effects-but-bailout)))))
;; A call to an unknown procedure can do anything.
- (($ <application> _ proc args)
+ (($ <primcall> _ name args)
+ (logior &all-effects-but-bailout
+ (cause &all-effects-but-bailout)))
+ (($ <call> _ proc args)
(logior &all-effects-but-bailout
(cause &all-effects-but-bailout)))
@@ -356,16 +354,13 @@ of an expression."
(compute-effects body)
(if alt (compute-effects alt) &no-effects)))
- (($ <sequence> _ exps)
- (let lp ((exps exps) (effects &no-effects))
- (match exps
- ((tail)
- (logior (compute-effects tail)
- ;; Returning zero values to a for-effect continuation is
- ;; not observable.
- (exclude-effects effects (cause &zero-values))))
- ((head . tail)
- (lp tail (logior (compute-effects head) effects))))))
+ (($ <seq> _ head tail)
+ (logior
+ ;; Returning zero values to a for-effect continuation is
+ ;; not observable.
+ (exclude-effects (compute-effects head)
+ (cause &zero-values))
+ (compute-effects tail)))
(($ <prompt> _ tag body handler)
(logior (compute-effects tag)
diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm
index 60c87e389..b5722fe09 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -41,12 +41,11 @@
(and (simple-expression? test bound-vars simple-primcall?)
(simple-expression? consequent bound-vars simple-primcall?)
(simple-expression? alternate bound-vars simple-primcall?)))
- ((<sequence> exps)
- (and-map (lambda (x) (simple-expression? x bound-vars simple-primcall?))
- exps))
- ((<application> proc args)
- (and (primitive-ref? proc)
- (simple-primcall? x)
+ ((<seq> head tail)
+ (and (simple-expression? head bound-vars simple-primcall?)
+ (simple-expression? tail bound-vars simple-primcall?)))
+ ((<primcall> name args)
+ (and (simple-primcall? x)
(and-map (lambda (x)
(simple-expression? x bound-vars simple-primcall?))
args)))
@@ -191,19 +190,25 @@
'())))
(values unref simple lambda* complex)))
-(define (make-sequence* src exps)
- (let lp ((in exps) (out '()))
- (if (null? (cdr in))
- (if (null? out)
- (car in)
- (make-sequence src (reverse (cons (car in) out))))
- (let ((head (car in)))
- (record-case head
- ((<lambda>) (lp (cdr in) out))
- ((<const>) (lp (cdr in) out))
- ((<lexical-ref>) (lp (cdr in) out))
- ((<void>) (lp (cdr in) out))
- (else (lp (cdr in) (cons head out))))))))
+(define (make-seq* src head tail)
+ (record-case head
+ ((<lambda>) tail)
+ ((<const>) tail)
+ ((<lexical-ref>) tail)
+ ((<void>) tail)
+ (else (make-seq src head tail))))
+
+(define (list->seq* loc exps)
+ (if (null? (cdr exps))
+ (car exps)
+ (let lp ((exps (cdr exps)) (effects (list (car exps))))
+ (if (null? (cdr exps))
+ (make-seq* loc
+ (fold (lambda (exp tail) (make-seq* #f exp tail))
+ (car effects)
+ (cdr effects))
+ (car exps))
+ (lp (cdr exps) (cons (car exps) effects))))))
(define (fix-letrec! x)
(let-values (((unref simple lambda* complex) (partition-vars x)))
@@ -215,7 +220,7 @@
;; expression, called for effect.
((<lexical-set> gensym exp)
(if (memq gensym unref)
- (make-sequence* #f (list exp (make-void #f)))
+ (make-seq* #f exp (make-void #f))
x))
((<letrec> src in-order? names gensyms vals body)
@@ -243,7 +248,7 @@
;; Bind lambdas using the fixpoint operator.
(make-fix
src (map cadr l) (map car l) (map caddr l)
- (make-sequence*
+ (list->seq*
src
(append
;; The right-hand-sides of the unreferenced
@@ -270,7 +275,7 @@
(let ((tmps (map (lambda (x) (gensym)) c)))
(make-let
#f (map cadr c) tmps (map caddr c)
- (make-sequence
+ (list->seq
#f
(map (lambda (x tmp)
(make-lexical-set
@@ -287,7 +292,7 @@
(let ((u (lookup unref))
(l (lookup lambda*))
(c (lookup complex)))
- (make-sequence*
+ (list->seq*
src
(append
;; unreferenced bindings, called for effect.
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index bf96179e0..fe637f0a5 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -109,9 +109,8 @@
(($ <primitive-ref>) #t)
(($ <module-ref>) #t)
(($ <toplevel-ref>) #t)
- (($ <application> _
- ($ <primitive-ref> _ (? singly-valued-primitive?))) #t)
- (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t)
+ (($ <primcall> _ (? singly-valued-primitive?)) #t)
+ (($ <primcall> _ 'values (val)) #t)
(($ <lambda>) #t)
(else #f)))
@@ -119,9 +118,7 @@
"Discard all but the first value of X."
(if (singly-valued-expression? x)
x
- (make-application (tree-il-src x)
- (make-primitive-ref #f 'values)
- (list x))))
+ (make-primcall (tree-il-src x) 'values (list x))))
;; Peval will do a one-pass analysis on the source program to determine
;; the set of assigned lexicals, and to identify unreferenced and
@@ -328,7 +325,7 @@
(%set-operand-residual-value!
op
(match val
- (($ <application> src ($ <primitive-ref> _ 'values) (first))
+ (($ <primcall> src 'values (first))
;; The continuation of a residualized binding does not need the
;; introduced `values' node, so undo the effects of truncation.
first)
@@ -401,18 +398,15 @@ top-level bindings from ENV and return the resulting expression."
(define local-toplevel-env
;; The top-level environment of the module being compiled.
- (match exp
- (($ <toplevel-define> _ name)
- (vhash-consq name #t env))
- (($ <sequence> _ exps)
- (fold (lambda (x r)
- (match x
- (($ <toplevel-define> _ name)
- (vhash-consq name #t r))
- (_ r)))
- env
- exps))
- (_ env)))
+ (let ()
+ (define (env-folder x env)
+ (match x
+ (($ <toplevel-define> _ name)
+ (vhash-consq name #t env))
+ (($ <seq> _ head tail)
+ (env-folder tail (env-folder head env)))
+ (_ env)))
+ (env-folder exp vlist-null)))
(define (local-toplevel? name)
(vhash-assq name local-toplevel-env))
@@ -492,15 +486,13 @@ top-level bindings from ENV and return the resulting expression."
(values #t results))))
(lambda _
(values #f '()))))
-
(define (make-values src values)
(match values
((single) single) ; 1 value
((_ ...) ; 0, or 2 or more values
- (make-application src (make-primitive-ref src 'values)
- values))))
+ (make-primcall src 'values values))))
(define (residualize-call)
- (make-application src (make-primitive-ref #f name) args))
+ (make-primcall src name args))
(cond
((every const? args)
(let-values (((success? values)
@@ -540,21 +532,21 @@ top-level bindings from ENV and return the resulting expression."
($ <toplevel-define>) ; the future
($ <module-set>) ;
($ <dynset>) ;
- ($ <application> src
- ($ <primitive-ref> _ (? singly-valued-primitive?))))
+ ($ <primcall> src (? singly-valued-primitive?)))
(and (<= nmin 1) (or (not nmax) (>= nmax 1))
- (make-application src (make-lambda #f '() consumer) (list exp))))
+ (make-call src (make-lambda #f '() consumer) (list exp))))
;; Statically-known number of values.
- (($ <application> src ($ <primitive-ref> _ 'values) vals)
+ (($ <primcall> src 'values vals)
(and (<= nmin (length vals)) (or (not nmax) (>= nmax (length vals)))
- (make-application src (make-lambda #f '() consumer) vals)))
+ (make-call src (make-lambda #f '() consumer) vals)))
;; Not going to copy code into both branches.
(($ <conditional>) #f)
;; Bail on other applications.
- (($ <application>) #f)
+ (($ <call>) #f)
+ (($ <primcall>) #f)
;; Bail on prompt and abort.
(($ <prompt>) #f)
@@ -580,20 +572,17 @@ top-level bindings from ENV and return the resulting expression."
(make-let-values src exp
(make-lambda-case src2 req opt rest kw
inits gensyms body #f)))))
- (($ <dynwind> src winder body unwinder)
+ (($ <dynwind> src winder pre body post unwinder)
(let ((body (loop body)))
(and body
- (make-dynwind src winder body unwinder))))
+ (make-dynwind src winder pre body post unwinder))))
(($ <dynlet> src fluids vals body)
(let ((body (loop body)))
(and body
(make-dynlet src fluids vals body))))
- (($ <sequence> src exps)
- (match exps
- ((head ... tail)
- (let ((tail (loop tail)))
- (and tail
- (make-sequence src (append head (list tail)))))))))))
+ (($ <seq> src head tail)
+ (let ((tail (loop tail)))
+ (and tail (make-seq src head tail)))))))
(define compute-effects
(make-effects-analyzer assigned-lexical?))
@@ -640,7 +629,7 @@ top-level bindings from ENV and return the resulting expression."
(if (null? effects)
body
(let ((effect-vals (map operand-residual-value effects)))
- (make-sequence #f (reverse (cons body effect-vals)))))))
+ (list->seq #f (reverse (cons body effect-vals)))))))
(if (null? values)
body
(let ((values (reverse values)))
@@ -875,16 +864,15 @@ top-level bindings from ENV and return the resulting expression."
(let ((exp (for-effect exp)))
(if (void? exp)
exp
- (make-sequence src (list exp (make-void #f)))))
+ (make-seq src exp (make-void #f))))
(begin
(record-operand-use op)
(make-lexical-set src name (operand-sym op) (for-value exp))))))
(($ <let> src
(names ... rest)
(gensyms ... rest-sym)
- (vals ... ($ <application> _ ($ <primitive-ref> _ 'list) rest-args))
- ($ <application> asrc
- ($ <primitive-ref> _ (or 'apply '@apply))
+ (vals ... ($ <primcall> _ 'list rest-args))
+ ($ <primcall> asrc (or 'apply '@apply)
(proc args ...
($ <lexical-ref> _
(? (cut eq? <> rest))
@@ -898,7 +886,7 @@ top-level bindings from ENV and return the resulting expression."
(append names tmps)
(append gensyms tmp-syms)
(append vals rest-args)
- (make-application
+ (make-call
asrc
proc
(append args
@@ -940,14 +928,14 @@ top-level bindings from ENV and return the resulting expression."
(body (loop body env counter ctx)))
(cond
((const? body)
- (for-tail (make-sequence src (append vals (list body)))))
+ (for-tail (list->seq src (append vals (list body)))))
((and (lexical-ref? body)
(memq (lexical-ref-gensym body) new))
(let ((sym (lexical-ref-gensym body))
(pairs (map cons new vals)))
;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
(for-tail
- (make-sequence
+ (list->seq
src
(append (map cdr (alist-delete sym pairs eq?))
(list (assq-ref pairs sym)))))))
@@ -1008,40 +996,10 @@ top-level bindings from ENV and return the resulting expression."
(else #f))))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
- (($ <dynwind> src winder body unwinder)
- (let ((pre (for-value winder))
- (body (for-tail body))
- (post (for-value unwinder)))
- (cond
- ((not (constant-expression? pre))
- (cond
- ((not (constant-expression? post))
- (let ((pre-sym (gensym "pre-")) (post-sym (gensym "post-")))
- (record-new-temporary! 'pre pre-sym 1)
- (record-new-temporary! 'post post-sym 1)
- (make-let src '(pre post) (list pre-sym post-sym) (list pre post)
- (make-dynwind src
- (make-lexical-ref #f 'pre pre-sym)
- body
- (make-lexical-ref #f 'post post-sym)))))
- (else
- (let ((pre-sym (gensym "pre-")))
- (record-new-temporary! 'pre pre-sym 1)
- (make-let src '(pre) (list pre-sym) (list pre)
- (make-dynwind src
- (make-lexical-ref #f 'pre pre-sym)
- body
- post))))))
- ((not (constant-expression? post))
- (let ((post-sym (gensym "post-")))
- (record-new-temporary! 'post post-sym 1)
- (make-let src '(post) (list post-sym) (list post)
- (make-dynwind src
- pre
- body
- (make-lexical-ref #f 'post post-sym)))))
- (else
- (make-dynwind src pre body post)))))
+ (($ <dynwind> src winder pre body post unwinder)
+ (make-dynwind src (for-value winder) (for-effect pre)
+ (for-tail body)
+ (for-effect post) (for-value unwinder)))
(($ <dynlet> src fluids vals body)
(make-dynlet src (map for-value fluids) (map for-value vals)
(for-tail body)))
@@ -1050,12 +1008,7 @@ top-level bindings from ENV and return the resulting expression."
(($ <dynset> src fluid exp)
(make-dynset src (for-value fluid) (for-value exp)))
(($ <toplevel-ref> src (? effect-free-primitive? name))
- (if (local-toplevel? name)
- exp
- (let ((exp (resolve-primitives! exp cenv)))
- (if (primitive-ref? exp)
- (for-tail exp)
- exp))))
+ exp)
(($ <toplevel-ref>)
;; todo: open private local bindings.
exp)
@@ -1084,7 +1037,8 @@ top-level bindings from ENV and return the resulting expression."
(($ <conditional> src condition subsequent alternate)
(define (call-with-failure-thunk exp proc)
(match exp
- (($ <application> _ _ ()) (proc exp))
+ (($ <call> _ _ ()) (proc exp))
+ (($ <primcall> _ _ ()) (proc exp))
(($ <const>) (proc exp))
(($ <void>) (proc exp))
(($ <lexical-ref>) (proc exp))
@@ -1097,13 +1051,12 @@ top-level bindings from ENV and return the resulting expression."
(make-lambda
#f '()
(make-lambda-case #f '() #f #f #f '() '() exp #f)))
- (proc (make-application #f (make-lexical-ref #f 'failure t)
- '())))))))
+ (proc (make-call #f (make-lexical-ref #f 'failure t)
+ '())))))))
(define (simplify-conditional c)
(match c
;; Swap the arms of (if (not FOO) A B), to simplify.
- (($ <conditional> src
- ($ <application> _ ($ <primitive-ref> _ 'not) (pred))
+ (($ <conditional> src ($ <primcall> _ 'not (pred))
subsequent alternate)
(simplify-conditional
(make-conditional src pred alternate subsequent)))
@@ -1155,17 +1108,59 @@ top-level bindings from ENV and return the resulting expression."
(simplify-conditional
(make-conditional src c (for-tail subsequent)
(for-tail alternate))))))
- (($ <application> src
- ($ <primitive-ref> _ '@call-with-values)
+ (($ <primcall> src '@call-with-values
(producer
($ <lambda> _ _
(and consumer
;; No optional or kwargs.
($ <lambda-case>
_ req #f rest #f () gensyms body #f)))))
- (for-tail (make-let-values src (make-application src producer '())
+ (for-tail (make-let-values src (make-call src producer '())
consumer)))
- (($ <application> src ($ <primitive-ref> _ 'values) exps)
+ (($ <primcall> src 'dynamic-wind (w thunk u))
+ (for-tail
+ (cond
+ ((not (constant-expression? w))
+ (cond
+ ((not (constant-expression? u))
+ (let ((w-sym (gensym "w ")) (u-sym (gensym "u ")))
+ (record-new-temporary! 'w w-sym 2)
+ (record-new-temporary! 'u u-sym 2)
+ (make-let src '(w u) (list w-sym u-sym) (list w u)
+ (make-dynwind
+ src
+ (make-lexical-ref #f 'w w-sym)
+ (make-call #f (make-lexical-ref #f 'w w-sym) '())
+ (make-call #f thunk '())
+ (make-call #f (make-lexical-ref #f 'u u-sym) '())
+ (make-lexical-ref #f 'u u-sym)))))
+ (else
+ (let ((w-sym (gensym "w ")))
+ (record-new-temporary! 'w w-sym 2)
+ (make-let src '(w) (list w-sym) (list w)
+ (make-dynwind
+ src
+ (make-lexical-ref #f 'w w-sym)
+ (make-call #f (make-lexical-ref #f 'w w-sym) '())
+ (make-call #f thunk '())
+ (make-call #f u '())
+ u))))))
+ ((not (constant-expression? u))
+ (let ((u-sym (gensym "u ")))
+ (record-new-temporary! 'u u-sym 2)
+ (make-let src '(u) (list u-sym) (list u)
+ (make-dynwind
+ src
+ w
+ (make-call #f w '())
+ (make-call #f thunk '())
+ (make-call #f (make-lexical-ref #f 'u u-sym) '())
+ (make-lexical-ref #f 'u u-sym)))))
+ (else
+ (make-dynwind src w (make-call #f w '()) (make-call #f thunk '())
+ (make-call #f u '()) u)))))
+
+ (($ <primcall> src 'values exps)
(cond
((null? exps)
(if (eq? ctx 'effect)
@@ -1177,10 +1172,10 @@ top-level bindings from ENV and return the resulting expression."
((value test effect) #t)
(else (null? (cdr vals))))
(every singly-valued-expression? vals))
- (for-tail (make-sequence src (append (cdr vals) (list (car vals)))))
- (make-application src (make-primitive-ref #f 'values) vals))))))
- (($ <application> src (and apply ($ <primitive-ref> _ (or 'apply '@apply)))
- (proc args ... tail))
+ (for-tail (list->seq src (append (cdr vals) (list (car vals)))))
+ (make-primcall src 'values vals))))))
+
+ (($ <primcall> src (or 'apply '@apply) (proc args ... tail))
(let lp ((tail* (find-definition tail 1)) (speculative? #t))
(define (copyable? x)
;; Inlining a result from find-definition effectively copies it,
@@ -1190,126 +1185,133 @@ top-level bindings from ENV and return the resulting expression."
(match tail*
(($ <const> _ (args* ...))
(let ((args* (map (cut make-const #f <>) args*)))
- (for-tail (make-application src proc (append args args*)))))
- (($ <application> _ ($ <primitive-ref> _ 'cons)
+ (for-tail (make-call src proc (append args args*)))))
+ (($ <primcall> _ 'cons
((and head (? copyable?)) (and tail (? copyable?))))
- (for-tail (make-application src apply
- (cons proc
- (append args (list head tail))))))
- (($ <application> _ ($ <primitive-ref> _ 'list)
+ (for-tail (make-primcall src '@apply
+ (cons proc
+ (append args (list head tail))))))
+ (($ <primcall> _ 'list
(and args* ((? copyable?) ...)))
- (for-tail (make-application src proc (append args args*))))
+ (for-tail (make-call src proc (append args args*))))
(tail*
(if speculative?
(lp (for-value tail) #f)
(let ((args (append (map for-value args) (list tail*))))
- (make-application src apply
- (cons (for-value proc) args))))))))
- (($ <application> src orig-proc orig-args)
+ (make-primcall src '@apply
+ (cons (for-value proc) args))))))))
+
+ (($ <primcall> src (? constructor-primitive? name) args)
+ (cond
+ ((and (memq ctx '(effect test))
+ (match (cons name args)
+ ((or ('cons _ _)
+ ('list . _)
+ ('vector . _)
+ ('make-prompt-tag)
+ ('make-prompt-tag ($ <const> _ (? string?))))
+ #t)
+ (_ #f)))
+ ;; Some expressions can be folded without visiting the
+ ;; arguments for value.
+ (let ((res (if (eq? ctx 'effect)
+ (make-void #f)
+ (make-const #f #t))))
+ (for-tail (list->seq src (append args (list res))))))
+ (else
+ (match (cons name (map for-value args))
+ (('cons x ($ <const> _ (? (cut eq? <> '()))))
+ (make-primcall src 'list (list x)))
+ (('cons x ($ <primcall> _ 'list elts))
+ (make-primcall src 'list (cons x elts)))
+ ((name . args)
+ (make-primcall src name args))))))
+
+ (($ <primcall> src (? accessor-primitive? name) args)
+ (match (cons name (map for-value args))
+ ;; FIXME: these for-tail recursions could take place outside
+ ;; an effort counter.
+ (('car ($ <primcall> src 'cons (head tail)))
+ (for-tail (make-seq src tail head)))
+ (('cdr ($ <primcall> src 'cons (head tail)))
+ (for-tail (make-seq src head tail)))
+ (('car ($ <primcall> src 'list (head . tail)))
+ (for-tail (list->seq src (append tail (list head)))))
+ (('cdr ($ <primcall> src 'list (head . tail)))
+ (for-tail (make-seq src head (make-primcall #f 'list tail))))
+
+ (('car ($ <const> src (head . tail)))
+ (for-tail (make-const src head)))
+ (('cdr ($ <const> src (head . tail)))
+ (for-tail (make-const src tail)))
+ (((or 'memq 'memv) k ($ <const> _ (elts ...)))
+ ;; FIXME: factor
+ (case ctx
+ ((effect)
+ (for-tail
+ (make-seq src k (make-void #f))))
+ ((test)
+ (cond
+ ((const? k)
+ ;; A shortcut. The `else' case would handle it, but
+ ;; this way is faster.
+ (let ((member (case name ((memq) memq) ((memv) memv))))
+ (make-const #f (and (member (const-exp k) elts) #t))))
+ ((null? elts)
+ (for-tail
+ (make-seq src k (make-const #f #f))))
+ (else
+ (let ((t (gensym "t "))
+ (eq (if (eq? name 'memq) 'eq? 'eqv?)))
+ (record-new-temporary! 't t (length elts))
+ (for-tail
+ (make-let
+ src (list 't) (list t) (list k)
+ (let lp ((elts elts))
+ (define test
+ (make-primcall #f eq
+ (list (make-lexical-ref #f 't t)
+ (make-const #f (car elts)))))
+ (if (null? (cdr elts))
+ test
+ (make-conditional src test
+ (make-const #f #t)
+ (lp (cdr elts)))))))))))
+ (else
+ (cond
+ ((const? k)
+ (let ((member (case name ((memq) memq) ((memv) memv))))
+ (make-const #f (member (const-exp k) elts))))
+ ((null? elts)
+ (for-tail (make-seq src k (make-const #f #f))))
+ (else
+ (make-primcall src name (list k (make-const #f elts))))))))
+ ((name . args)
+ (fold-constants src name args ctx))))
+
+ (($ <primcall> src (? equality-primitive? name) (a b))
+ (let ((val-a (for-value a))
+ (val-b (for-value b)))
+ (log 'equality-primitive name val-a val-b)
+ (cond ((and (lexical-ref? val-a) (lexical-ref? val-b)
+ (eq? (lexical-ref-gensym val-a)
+ (lexical-ref-gensym val-b)))
+ (for-tail (make-const #f #t)))
+ (else
+ (fold-constants src name (list val-a val-b) ctx)))))
+
+ (($ <primcall> src (? effect-free-primitive? name) args)
+ (fold-constants src name (map for-value args) ctx))
+
+ (($ <primcall> src name args)
+ (make-primcall src name (map for-value args)))
+
+ (($ <call> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
(let revisit-proc ((proc (visit orig-proc 'operator)))
(match proc
- (($ <primitive-ref> _ (? constructor-primitive? name))
- (cond
- ((and (memq ctx '(effect test))
- (match (cons name orig-args)
- ((or ('cons _ _)
- ('list . _)
- ('vector . _)
- ('make-prompt-tag)
- ('make-prompt-tag ($ <const> _ (? string?))))
- #t)
- (_ #f)))
- ;; Some expressions can be folded without visiting the
- ;; arguments for value.
- (let ((res (if (eq? ctx 'effect)
- (make-void #f)
- (make-const #f #t))))
- (for-tail (make-sequence src (append orig-args (list res))))))
- (else
- (match (cons name (map for-value orig-args))
- (('cons head tail)
- (match tail
- (($ <const> src (? (cut eq? <> '())))
- (make-application src (make-primitive-ref #f 'list)
- (list head)))
- (($ <application> src ($ <primitive-ref> _ 'list) elts)
- (make-application src (make-primitive-ref #f 'list)
- (cons head elts)))
- (_ (make-application src proc (list head tail)))))
- ((_ . args)
- (make-application src proc args))))))
- (($ <primitive-ref> _ (? accessor-primitive? name))
- (match (cons name (map for-value orig-args))
- ;; FIXME: these for-tail recursions could take place outside
- ;; an effort counter.
- (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
- (for-tail (make-sequence src (list tail head))))
- (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
- (for-tail (make-sequence src (list head tail))))
- (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
- (for-tail (make-sequence src (append tail (list head)))))
- (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
- (for-tail (make-sequence
- src
- (list head
- (make-application
- src (make-primitive-ref #f 'list) tail)))))
-
- (('car ($ <const> src (head . tail)))
- (for-tail (make-const src head)))
- (('cdr ($ <const> src (head . tail)))
- (for-tail (make-const src tail)))
- (((or 'memq 'memv) k ($ <const> _ (elts ...)))
- ;; FIXME: factor
- (case ctx
- ((effect)
- (for-tail
- (make-sequence src (list k (make-void #f)))))
- ((test)
- (cond
- ((const? k)
- ;; A shortcut. The `else' case would handle it, but
- ;; this way is faster.
- (let ((member (case name ((memq) memq) ((memv) memv))))
- (make-const #f (and (member (const-exp k) elts) #t))))
- ((null? elts)
- (for-tail
- (make-sequence src (list k (make-const #f #f)))))
- (else
- (let ((t (gensym "t-"))
- (eq (if (eq? name 'memq) 'eq? 'eqv?)))
- (record-new-temporary! 't t (length elts))
- (for-tail
- (make-let
- src (list 't) (list t) (list k)
- (let lp ((elts elts))
- (define test
- (make-application
- #f (make-primitive-ref #f eq)
- (list (make-lexical-ref #f 't t)
- (make-const #f (car elts)))))
- (if (null? (cdr elts))
- test
- (make-conditional src test
- (make-const #f #t)
- (lp (cdr elts)))))))))))
- (else
- (cond
- ((const? k)
- (let ((member (case name ((memq) memq) ((memv) memv))))
- (make-const #f (member (const-exp k) elts))))
- ((null? elts)
- (for-tail (make-sequence src (list k (make-const #f #f)))))
- (else
- (make-application src proc (list k (make-const #f elts))))))))
- ((_ . args)
- (or (fold-constants src name args ctx)
- (make-application src proc args)))))
- (($ <primitive-ref> _ (? effect-free-primitive? name))
- (let ((args (map for-value orig-args)))
- (or (fold-constants src name args ctx)
- (make-application src proc args))))
+ (($ <primitive-ref> _ name)
+ (for-tail (make-primcall src name orig-args)))
(($ <lambda> _ _
($ <lambda-case> _ req opt rest #f inits gensyms body #f))
;; Simple case: no keyword arguments.
@@ -1318,7 +1320,7 @@ top-level bindings from ENV and return the resulting expression."
(nreq (length req))
(nopt (if opt (length opt) 0))
(key (source-expression proc)))
- (define (inlined-application)
+ (define (inlined-call)
(make-let src
(append req
(or opt '())
@@ -1327,9 +1329,8 @@ top-level bindings from ENV and return the resulting expression."
(if (> nargs (+ nreq nopt))
(append (list-head orig-args (+ nreq nopt))
(list
- (make-application
- #f
- (make-primitive-ref #f 'list)
+ (make-primcall
+ #f 'list
(drop orig-args (+ nreq nopt)))))
(append orig-args
(drop inits (- nargs nreq))
@@ -1341,8 +1342,7 @@ top-level bindings from ENV and return the resulting expression."
(cond
((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
;; An error, or effecting arguments.
- (make-application src (for-call orig-proc)
- (map for-value orig-args)))
+ (make-call src (for-call orig-proc) (map for-value orig-args)))
((or (and=> (find-counter key counter) counter-recursive?)
(lambda? orig-proc))
;; A recursive call, or a lambda in the operator
@@ -1364,7 +1364,7 @@ top-level bindings from ENV and return the resulting expression."
(lp (counter-prev counter)))))))
(log 'inline-recurse key)
- (loop (inlined-application) env counter ctx))
+ (loop (inlined-call) env counter ctx))
(else
;; An integration at the top-level, the first
;; recursion of a recursive procedure, or a nested
@@ -1374,8 +1374,8 @@ top-level bindings from ENV and return the resulting expression."
(let/ec k
(define (abort)
(log 'inline-abort exp)
- (k (make-application src (for-call orig-proc)
- (map for-value orig-args))))
+ (k (make-call src (for-call orig-proc)
+ (map for-value orig-args))))
(define new-counter
(cond
;; These first two cases will transfer effort
@@ -1395,7 +1395,7 @@ top-level bindings from ENV and return the resulting expression."
(make-top-counter effort-limit operand-size-limit
abort key))))
(define result
- (loop (inlined-application) env new-counter ctx))
+ (loop (inlined-call) env new-counter ctx))
(if counter
;; The nested inlining attempt succeeded.
@@ -1420,7 +1420,7 @@ top-level bindings from ENV and return the resulting expression."
(log 'inline-let orig-proc)
(for-tail
(make-let lsrc names syms vals
- (make-application src body orig-args))))
+ (make-call src body orig-args))))
;; It's possible for a `let' to go away after the
;; visit due to the fact that visiting a procedure in
;; value context will prune unused bindings, whereas
@@ -1428,11 +1428,10 @@ top-level bindings from ENV and return the resulting expression."
;; traverse through lambdas. In that case re-visit
;; the procedure.
(proc (revisit-proc proc)))
- (make-application src (for-call orig-proc)
- (map for-value orig-args))))
+ (make-call src (for-call orig-proc)
+ (map for-value orig-args))))
(_
- (make-application src (for-call orig-proc)
- (map for-value orig-args))))))
+ (make-call src (for-call orig-proc) (map for-value orig-args))))))
(($ <lambda> src meta body)
(case ctx
((effect) (make-void #f))
@@ -1445,8 +1444,7 @@ top-level bindings from ENV and return the resulting expression."
(define (lift-applied-lambda body gensyms)
(and (not opt) rest (not kw)
(match body
- (($ <application> _
- ($ <primitive-ref> _ '@apply)
+ (($ <primcall> _ '@apply
(($ <lambda> _ _ (and lcase ($ <lambda-case>)))
($ <lexical-ref> _ _ sym)
...))
@@ -1473,29 +1471,21 @@ top-level bindings from ENV and return the resulting expression."
new
body
(and alt (for-tail alt))))))
- (($ <sequence> src exps)
- (let lp ((exps exps) (effects '()))
- (match exps
- ((last)
- (if (null? effects)
- (for-tail last)
- (make-sequence
- src
- (reverse (cons (for-tail last) effects)))))
- ((head . rest)
- (let ((head (for-effect head)))
- (cond
- ((sequence? head)
- (lp (append (sequence-exps head) rest) effects))
- ((void? head)
- (lp rest effects))
- (else
- (lp rest (cons head effects)))))))))
+ (($ <seq> src head tail)
+ (let ((head (for-effect head))
+ (tail (for-tail tail)))
+ (if (void? head)
+ tail
+ (make-seq src
+ (if (and (seq? head)
+ (void? (seq-tail head)))
+ (seq-head head)
+ head)
+ tail))))
(($ <prompt> src tag body handler)
(define (make-prompt-tag? x)
(match x
- (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
- (or () ((? constant-expression?))))
+ (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?))))
#t)
(_ #f)))
@@ -1527,11 +1517,11 @@ top-level bindings from ENV and return the resulting expression."
(for-tail
(make-let-values
src
- (make-application #f (make-primitive-ref #f 'apply)
- `(,(make-primitive-ref #f 'values)
- ,(make-primitive-ref #f 'values)
- ,@(abort-args body)
- ,(abort-tail body)))
+ (make-primcall #f 'apply
+ `(,(make-primitive-ref #f 'values)
+ ,(make-primitive-ref #f 'values)
+ ,@(abort-args body)
+ ,(abort-tail body)))
(for-value handler)))))
(else
(make-prompt src tag body (for-value handler))))))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index bac3136e3..e3f6a9071 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -29,7 +29,8 @@
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*
@@ -48,7 +49,7 @@
+ * - / 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?
complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
@@ -70,7 +71,7 @@
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?
@@ -153,12 +154,12 @@
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
+ 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
@@ -200,8 +201,12 @@
(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))
@@ -212,6 +217,9 @@
(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*)
@@ -231,6 +239,8 @@
(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)
@@ -239,14 +249,29 @@
(hashq-ref *negatable-primitive-table* prim))
(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))
+ (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
@@ -256,6 +281,9 @@
(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))
@@ -267,11 +295,9 @@
(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)))))
+ ((<primcall> src name args)
+ (let ((expand (hashq-ref *primitive-expand-table* name)))
+ (and expand (apply expand src args))))
(else #f)))
x))
@@ -287,8 +313,8 @@
(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
@@ -306,8 +332,8 @@
,(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)
@@ -502,9 +528,9 @@
(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)))
@@ -512,25 +538,6 @@
(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)
@@ -544,7 +551,9 @@
(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*
@@ -570,9 +579,9 @@
;; 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)))
+ (make-primcall #f 'apply
+ (list handler
+ (make-lexical-ref #f 'args args-sym)))
#f))))
(else #f)))
@@ -585,13 +594,13 @@
(make-let
src '(handler) (list handler-sym) (list handler)
(make-prompt
- src tag (make-application #f thunk '())
+ 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-application
- #f (make-primitive-ref #f 'apply)
+ (make-primcall
+ #f 'apply
(list (make-lexical-ref #f 'handler handler-sym)
(make-lexical-ref #f 'args args-sym)))
#f)))))
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index bb7a200b7..80c32fe29 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -1,6 +1,6 @@
;;; Tree Intermediate Language
-;; Copyright (C) 2009, 2010, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 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
@@ -33,7 +33,9 @@
(pmatch exps
(() (make-void #f))
((,x) x)
- (else (make-sequence #f exps))))
+ ((,x . ,rest)
+ (make-seq #f x (join rest env)))
+ (else (error "what!" exps env))))
(define-language tree-il
#:title "Tree Intermediate Language"