diff options
Diffstat (limited to 'module/language')
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" |