mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-17 17:20:29 +02:00
move lang-specific modules, e.g. (system il compile) to (language ghil compile-glil)
* configure.in: Remove module/system/il directory. * module/language/ghil/Makefile.am (SOURCES): * module/language/ghil/compile-glil.scm (system): * module/language/ghil/def.scm (language): * module/language/ghil/spec.scm (language, ghil): * module/language/glil/Makefile.am (SOURCES): * module/language/glil/compile-objcode.scm (language): * module/language/glil/def.scm (language): * module/language/glil/spec.scm (language, compile): * module/language/scheme/Makefile.am (SOURCES): * module/language/scheme/inline.scm (system, define-inline): * module/language/scheme/translate.scm (language): Move files, renaming the modules. * module/oop/goops.scm (load-toplevel): Unfortunately the GHIL name leaked here. Patch it up. * module/system/vm/Makefile.am (SOURCES): Remove assemble.scm.
This commit is contained in:
Andy Wingo
parent
6515a66638
commit
d9042285ba
16 changed files with 33 additions and 36 deletions
|
|
@ -1,3 +1,3 @@
|
|||
SOURCES = spec.scm
|
||||
SOURCES = spec.scm def.scm compile-glil.scm
|
||||
modpath = language/ghil
|
||||
include $(top_srcdir)/am/guilec
|
||||
|
|
|
|||
441
module/language/ghil/compile-glil.scm
Normal file
441
module/language/ghil/compile-glil.scm
Normal file
|
|
@ -0,0 +1,441 @@
|
|||
;;; GHIL -> GLIL compiler
|
||||
|
||||
;; Copyright (C) 2001 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
|
||||
;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;; any later version.
|
||||
;;
|
||||
;; This program 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 General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; see the file COPYING. If not, write to
|
||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (language ghil compile-glil)
|
||||
#:use-syntax (system base syntax)
|
||||
#:use-module (language glil def)
|
||||
#:use-module (language ghil def)
|
||||
#:use-module (ice-9 common-list)
|
||||
#:export (compile-glil))
|
||||
|
||||
(define (compile-glil x e opts)
|
||||
(if (memq #:O opts) (set! x (optimize x)))
|
||||
(values (codegen x)
|
||||
(and e (cons (car e) (cddr e)))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Stage 2: Optimization
|
||||
;;;
|
||||
|
||||
(define (lift-variables! env)
|
||||
(let ((parent-env (ghil-env-parent env)))
|
||||
(for-each (lambda (v)
|
||||
(case (ghil-var-kind v)
|
||||
((argument) (set! (ghil-var-kind v) 'local)))
|
||||
(set! (ghil-var-env v) parent-env)
|
||||
(ghil-env-add! parent-env v))
|
||||
(ghil-env-variables env))))
|
||||
|
||||
(define (optimize x)
|
||||
(record-case x
|
||||
((<ghil-set> env loc var val)
|
||||
(make-ghil-set env var (optimize val)))
|
||||
|
||||
((<ghil-define> env loc var val)
|
||||
(make-ghil-define env var (optimize val)))
|
||||
|
||||
((<ghil-if> env loc test then else)
|
||||
(make-ghil-if env loc (optimize test) (optimize then) (optimize else)))
|
||||
|
||||
((<ghil-and> env loc exps)
|
||||
(make-ghil-and env loc (map optimize exps)))
|
||||
|
||||
((<ghil-or> env loc exps)
|
||||
(make-ghil-or env loc (map optimize exps)))
|
||||
|
||||
((<ghil-begin> env loc exps)
|
||||
(make-ghil-begin env loc (map optimize exps)))
|
||||
|
||||
((<ghil-bind> env loc vars vals body)
|
||||
(make-ghil-bind env loc vars (map optimize vals) (optimize body)))
|
||||
|
||||
((<ghil-lambda> env loc vars rest meta body)
|
||||
(make-ghil-lambda env loc vars rest meta (optimize body)))
|
||||
|
||||
((<ghil-inline> env loc instruction args)
|
||||
(make-ghil-inline env loc instruction (map optimize args)))
|
||||
|
||||
((<ghil-call> env loc proc args)
|
||||
(let ((parent-env env))
|
||||
(record-case proc
|
||||
;; ((@lambda (VAR...) BODY...) ARG...) =>
|
||||
;; (@let ((VAR ARG) ...) BODY...)
|
||||
((<ghil-lambda> env loc vars rest meta body)
|
||||
(cond
|
||||
((not rest)
|
||||
(lift-variables! env)
|
||||
(make-ghil-bind parent-env loc (map optimize args)))
|
||||
(else
|
||||
(make-ghil-call parent-env loc (optimize proc) (map optimize args)))))
|
||||
(else
|
||||
(make-ghil-call parent-env loc (optimize proc) (map optimize args))))))
|
||||
|
||||
((<ghil-mv-call> env loc producer consumer)
|
||||
(record-case consumer
|
||||
;; (mv-call PRODUCER (lambda ARGS BODY...)) =>
|
||||
;; (mv-let PRODUCER ARGS BODY...)
|
||||
((<ghil-lambda> env loc vars rest meta body)
|
||||
(lift-variables! env)
|
||||
(make-ghil-mv-bind producer vars rest body))
|
||||
(else
|
||||
(make-ghil-mv-call env loc (optimize producer) (optimize consumer)))))
|
||||
|
||||
(else x)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Stage 3: Code generation
|
||||
;;;
|
||||
|
||||
(define *ia-void* (make-glil-void))
|
||||
(define *ia-drop* (make-glil-call 'drop 0))
|
||||
(define *ia-return* (make-glil-call 'return 0))
|
||||
|
||||
(define (make-label) (gensym ":L"))
|
||||
|
||||
(define (make-glil-var op env var)
|
||||
(case (ghil-var-kind var)
|
||||
((argument)
|
||||
(make-glil-argument op (ghil-var-index var)))
|
||||
((local)
|
||||
(make-glil-local op (ghil-var-index var)))
|
||||
((external)
|
||||
(do ((depth 0 (1+ depth))
|
||||
(e env (ghil-env-parent e)))
|
||||
((eq? e (ghil-var-env var))
|
||||
(make-glil-external op depth (ghil-var-index var)))))
|
||||
((toplevel)
|
||||
(make-glil-toplevel op (ghil-var-name var)))
|
||||
((public private)
|
||||
(make-glil-module op (ghil-var-env var) (ghil-var-name var)
|
||||
(eq? (ghil-var-kind var) 'public)))
|
||||
(else (error "Unknown kind of variable:" var))))
|
||||
|
||||
(define (constant? x)
|
||||
(cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t)
|
||||
((pair? x) (and (constant? (car x))
|
||||
(constant? (cdr x))))
|
||||
((vector? x) (let lp ((i (vector-length x)))
|
||||
(or (zero? i)
|
||||
(and (constant? (vector-ref x (1- i)))
|
||||
(lp (1- i))))))))
|
||||
|
||||
(define (codegen ghil)
|
||||
(let ((stack '()))
|
||||
(define (push-code! loc code)
|
||||
(set! stack (cons code stack))
|
||||
(if loc (set! stack (cons (make-glil-source loc) stack))))
|
||||
(define (var->binding var)
|
||||
(list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var)))
|
||||
(define (push-bindings! loc vars)
|
||||
(if (not (null? vars))
|
||||
(push-code! loc (make-glil-bind (map var->binding vars)))))
|
||||
(define (comp tree tail drop)
|
||||
(define (push-label! label)
|
||||
(push-code! #f (make-glil-label label)))
|
||||
(define (push-branch! loc inst label)
|
||||
(push-code! loc (make-glil-branch inst label)))
|
||||
(define (push-call! loc inst args)
|
||||
(for-each comp-push args)
|
||||
(push-code! loc (make-glil-call inst (length args))))
|
||||
;; possible tail position
|
||||
(define (comp-tail tree) (comp tree tail drop))
|
||||
;; push the result
|
||||
(define (comp-push tree) (comp tree #f #f))
|
||||
;; drop the result
|
||||
(define (comp-drop tree) (comp tree #f #t))
|
||||
;; drop the result if unnecessary
|
||||
(define (maybe-drop)
|
||||
(if drop (push-code! #f *ia-drop*)))
|
||||
;; return here if necessary
|
||||
(define (maybe-return)
|
||||
(if tail (push-code! #f *ia-return*)))
|
||||
;; return this code if necessary
|
||||
(define (return-code! loc code)
|
||||
(if (not drop) (push-code! loc code))
|
||||
(maybe-return))
|
||||
;; return void if necessary
|
||||
(define (return-void!)
|
||||
(return-code! #f *ia-void*))
|
||||
;; return object if necessary
|
||||
(define (return-object! loc obj)
|
||||
(return-code! loc (make-glil-const #:obj obj)))
|
||||
;;
|
||||
;; dispatch
|
||||
(record-case tree
|
||||
((<ghil-void>)
|
||||
(return-void!))
|
||||
|
||||
((<ghil-quote> env loc obj)
|
||||
(return-object! loc obj))
|
||||
|
||||
((<ghil-quasiquote> env loc exp)
|
||||
(let loop ((x exp) (in-car? #f))
|
||||
(cond
|
||||
((list? x)
|
||||
(push-call! #f 'mark '())
|
||||
(for-each (lambda (x) (loop x #t)) x)
|
||||
(push-call! #f 'list-mark '()))
|
||||
((pair? x)
|
||||
(push-call! #f 'mark '())
|
||||
(loop (car x) #t)
|
||||
(loop (cdr x) #f)
|
||||
(push-call! #f 'cons-mark '()))
|
||||
((record? x)
|
||||
(record-case x
|
||||
((<ghil-unquote> env loc exp)
|
||||
(comp-push exp))
|
||||
((<ghil-unquote-splicing> env loc exp)
|
||||
(if (not in-car?)
|
||||
(error "unquote-splicing in the cdr of a pair" exp))
|
||||
(comp-push exp)
|
||||
(push-call! #f 'list-break '()))))
|
||||
((constant? x)
|
||||
(push-code! #f (make-glil-const #:obj x)))
|
||||
(else
|
||||
(error "element of quasiquote can't be compiled" x))))
|
||||
(maybe-drop)
|
||||
(maybe-return))
|
||||
|
||||
((<ghil-ref> env loc var)
|
||||
(return-code! loc (make-glil-var 'ref env var)))
|
||||
|
||||
((<ghil-set> env loc var val)
|
||||
(comp-push val)
|
||||
(push-code! loc (make-glil-var 'set env var))
|
||||
(return-void!))
|
||||
|
||||
((<ghil-define> env loc var val)
|
||||
(comp-push val)
|
||||
(push-code! loc (make-glil-var 'define env var))
|
||||
(return-void!))
|
||||
|
||||
((<ghil-if> env loc test then else)
|
||||
;; TEST
|
||||
;; (br-if-not L1)
|
||||
;; THEN
|
||||
;; (br L2)
|
||||
;; L1: ELSE
|
||||
;; L2:
|
||||
(let ((L1 (make-label)) (L2 (make-label)))
|
||||
(comp-push test)
|
||||
(push-branch! loc 'br-if-not L1)
|
||||
(comp-tail then)
|
||||
(if (not tail) (push-branch! #f 'br L2))
|
||||
(push-label! L1)
|
||||
(comp-tail else)
|
||||
(if (not tail) (push-label! L2))))
|
||||
|
||||
((<ghil-and> env loc exps)
|
||||
;; EXP
|
||||
;; (br-if-not L1)
|
||||
;; ...
|
||||
;; TAIL
|
||||
;; (br L2)
|
||||
;; L1: (const #f)
|
||||
;; L2:
|
||||
(cond ((null? exps) (return-object! loc #t))
|
||||
((null? (cdr exps)) (comp-tail (car exps)))
|
||||
(else
|
||||
(let ((L1 (make-label)) (L2 (make-label)))
|
||||
(let lp ((exps exps))
|
||||
(cond ((null? (cdr exps))
|
||||
(comp-tail (car exps))
|
||||
(push-branch! #f 'br L2)
|
||||
(push-label! L1)
|
||||
(return-object! #f #f)
|
||||
(push-label! L2)
|
||||
(maybe-return))
|
||||
(else
|
||||
(comp-push (car exps))
|
||||
(push-branch! #f 'br-if-not L1)
|
||||
(lp (cdr exps)))))))))
|
||||
|
||||
((<ghil-or> env loc exps)
|
||||
;; EXP
|
||||
;; (dup)
|
||||
;; (br-if L1)
|
||||
;; (drop)
|
||||
;; ...
|
||||
;; TAIL
|
||||
;; L1:
|
||||
(cond ((null? exps) (return-object! loc #f))
|
||||
((null? (cdr exps)) (comp-tail (car exps)))
|
||||
(else
|
||||
(let ((L1 (make-label)))
|
||||
(let lp ((exps exps))
|
||||
(cond ((null? (cdr exps))
|
||||
(comp-tail (car exps))
|
||||
(push-label! L1)
|
||||
(maybe-return))
|
||||
(else
|
||||
(comp-push (car exps))
|
||||
(if (not drop)
|
||||
(push-call! #f 'dup '()))
|
||||
(push-branch! #f 'br-if L1)
|
||||
(if (not drop)
|
||||
(push-call! #f 'drop '()))
|
||||
(lp (cdr exps)))))))))
|
||||
|
||||
((<ghil-begin> env loc exps)
|
||||
;; EXPS...
|
||||
;; TAIL
|
||||
(if (null? exps)
|
||||
(return-void!)
|
||||
(do ((exps exps (cdr exps)))
|
||||
((null? (cdr exps))
|
||||
(comp-tail (car exps)))
|
||||
(comp-drop (car exps)))))
|
||||
|
||||
((<ghil-bind> env loc vars vals body)
|
||||
;; VALS...
|
||||
;; (set VARS)...
|
||||
;; BODY
|
||||
(for-each comp-push vals)
|
||||
(push-bindings! loc vars)
|
||||
(for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
|
||||
(reverse vars))
|
||||
(comp-tail body)
|
||||
(push-code! #f (make-glil-unbind)))
|
||||
|
||||
((<ghil-mv-bind> env loc producer vars rest body)
|
||||
;; VALS...
|
||||
;; (set VARS)...
|
||||
;; BODY
|
||||
(let ((MV (make-label)))
|
||||
(comp-push producer)
|
||||
(push-code! loc (make-glil-mv-call 0 MV))
|
||||
(push-code! #f (make-glil-const #:obj 1))
|
||||
(push-label! MV)
|
||||
(push-code! #f (make-glil-mv-bind (map var->binding vars) rest))
|
||||
(for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
|
||||
(reverse vars)))
|
||||
(comp-tail body)
|
||||
(push-code! #f (make-glil-unbind)))
|
||||
|
||||
((<ghil-lambda> env loc vars rest meta body)
|
||||
(return-code! loc (codegen tree)))
|
||||
|
||||
((<ghil-inline> env loc inline args)
|
||||
;; ARGS...
|
||||
;; (INST NARGS)
|
||||
(let ((tail-table '((call . goto/args)
|
||||
(apply . goto/apply)
|
||||
(call/cc . goto/cc))))
|
||||
(cond ((and tail (assq-ref tail-table inline))
|
||||
=> (lambda (tail-inst)
|
||||
(push-call! loc tail-inst args)))
|
||||
(else
|
||||
(push-call! loc inline args)
|
||||
(maybe-drop)
|
||||
(maybe-return)))))
|
||||
|
||||
((<ghil-values> env loc values)
|
||||
(cond (tail ;; (lambda () (values 1 2))
|
||||
(push-call! loc 'return/values values))
|
||||
(drop ;; (lambda () (values 1 2) 3)
|
||||
(for-each comp-drop values))
|
||||
(else ;; (lambda () (list (values 10 12) 1))
|
||||
(push-code! #f (make-glil-const #:obj 'values))
|
||||
(push-code! #f (make-glil-call #:inst 'link-now #:nargs 1))
|
||||
(push-code! #f (make-glil-call #:inst 'variable-ref #:nargs 0))
|
||||
(push-call! loc 'call values))))
|
||||
|
||||
((<ghil-values*> env loc values)
|
||||
(cond (tail ;; (lambda () (apply values '(1 2)))
|
||||
(push-call! loc 'return/values* values))
|
||||
(drop ;; (lambda () (apply values '(1 2)) 3)
|
||||
(for-each comp-drop values))
|
||||
(else ;; (lambda () (list (apply values '(10 12)) 1))
|
||||
(push-code! #f (make-glil-const #:obj 'values))
|
||||
(push-code! #f (make-glil-call #:inst 'link-now #:nargs 1))
|
||||
(push-code! #f (make-glil-call #:inst 'variable-ref #:nargs 0))
|
||||
(push-call! loc 'apply values))))
|
||||
|
||||
((<ghil-call> env loc proc args)
|
||||
;; PROC
|
||||
;; ARGS...
|
||||
;; ([tail-]call NARGS)
|
||||
(comp-push proc)
|
||||
(push-call! loc (if tail 'goto/args 'call) args)
|
||||
(maybe-drop))
|
||||
|
||||
((<ghil-mv-call> env loc producer consumer)
|
||||
;; CONSUMER
|
||||
;; PRODUCER
|
||||
;; (mv-call MV)
|
||||
;; ([tail]-call 1)
|
||||
;; goto POST
|
||||
;; MV: [tail-]call/nargs
|
||||
;; POST: (maybe-drop)
|
||||
(let ((MV (make-label)) (POST (make-label)))
|
||||
(comp-push consumer)
|
||||
(comp-push producer)
|
||||
(push-code! loc (make-glil-mv-call 0 MV))
|
||||
(push-code! loc (make-glil-call (if tail 'goto/args 'call) 1))
|
||||
(cond ((not tail)
|
||||
(push-branch! #f 'br POST)))
|
||||
(push-label! MV)
|
||||
(push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0))
|
||||
(cond ((not tail)
|
||||
(push-label! POST)
|
||||
(maybe-drop)))))
|
||||
|
||||
((<ghil-reified-env> env loc)
|
||||
(return-object! loc (ghil-env-reify env)))))
|
||||
|
||||
;;
|
||||
;; main
|
||||
(record-case ghil
|
||||
((<ghil-lambda> env loc vars rest meta body)
|
||||
(let* ((evars (ghil-env-variables env))
|
||||
(locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
|
||||
(exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)))
|
||||
;; initialize variable indexes
|
||||
(finalize-index! vars)
|
||||
(finalize-index! locs)
|
||||
(finalize-index! exts)
|
||||
;; meta bindings
|
||||
(push-bindings! #f vars)
|
||||
;; export arguments
|
||||
(do ((n 0 (1+ n))
|
||||
(l vars (cdr l)))
|
||||
((null? l))
|
||||
(let ((v (car l)))
|
||||
(case (ghil-var-kind v)
|
||||
((external)
|
||||
(push-code! #f (make-glil-argument 'ref n))
|
||||
(push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
|
||||
;; compile body
|
||||
(comp body #t #f)
|
||||
;; create GLIL
|
||||
(let ((vars (make-glil-vars #:nargs (length vars)
|
||||
#:nrest (if rest 1 0)
|
||||
#:nlocs (length locs)
|
||||
#:nexts (length exts))))
|
||||
(make-glil-asm vars meta (reverse! stack))))))))
|
||||
|
||||
(define (finalize-index! list)
|
||||
(do ((n 0 (1+ n))
|
||||
(l list (cdr l)))
|
||||
((null? l))
|
||||
(let ((v (car l))) (set! (ghil-var-index v) n))))
|
||||
478
module/language/ghil/def.scm
Normal file
478
module/language/ghil/def.scm
Normal file
|
|
@ -0,0 +1,478 @@
|
|||
;;; Guile High Intermediate Language
|
||||
|
||||
;; Copyright (C) 2001 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
|
||||
;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;; any later version.
|
||||
;;
|
||||
;; This program 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 General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; see the file COPYING. If not, write to
|
||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (language ghil def)
|
||||
#:use-module (system base syntax)
|
||||
#:use-module (system base pmatch)
|
||||
#:use-module (ice-9 regex)
|
||||
#:export
|
||||
(<ghil-void> make-ghil-void ghil-void?
|
||||
ghil-void-env ghil-void-loc
|
||||
|
||||
<ghil-quote> make-ghil-quote ghil-quote?
|
||||
ghil-quote-env ghil-quote-loc ghil-quote-obj
|
||||
|
||||
<ghil-quasiquote> make-ghil-quasiquote ghil-quasiquote?
|
||||
ghil-quasiquote-env ghil-quasiquote-loc ghil-quasiquote-exp
|
||||
|
||||
<ghil-unquote> make-ghil-unquote ghil-unquote?
|
||||
ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
|
||||
|
||||
<ghil-unquote-splicing> make-ghil-unquote-splicing ghil-unquote-splicing?
|
||||
ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
|
||||
|
||||
<ghil-ref> make-ghil-ref ghil-ref?
|
||||
ghil-ref-env ghil-ref-loc ghil-ref-var
|
||||
|
||||
<ghil-set> make-ghil-set ghil-set?
|
||||
ghil-set-env ghil-set-loc ghil-set-var ghil-set-val
|
||||
|
||||
<ghil-define> make-ghil-define ghil-define?
|
||||
ghil-define-env ghil-define-loc ghil-define-var ghil-define-val
|
||||
|
||||
<ghil-if> make-ghil-if ghil-if?
|
||||
ghil-if-env ghil-if-loc ghil-if-test ghil-if-then ghil-if-else
|
||||
|
||||
<ghil-and> make-ghil-and ghil-and?
|
||||
ghil-and-env ghil-and-loc ghil-and-exps
|
||||
|
||||
<ghil-or> make-ghil-or ghil-or?
|
||||
ghil-or-env ghil-or-loc ghil-or-exps
|
||||
|
||||
<ghil-begin> make-ghil-begin ghil-begin?
|
||||
ghil-begin-env ghil-begin-loc ghil-begin-exps
|
||||
|
||||
<ghil-bind> make-ghil-bind ghil-bind?
|
||||
ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
|
||||
|
||||
<ghil-mv-bind> make-ghil-mv-bind ghil-mv-bind?
|
||||
ghil-mv-bind-env ghil-mv-bind-loc ghil-mv-bind-producer ghil-mv-bind-vars ghil-mv-bind-rest ghil-mv-bind-body
|
||||
|
||||
<ghil-lambda> make-ghil-lambda ghil-lambda?
|
||||
ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest
|
||||
ghil-lambda-meta ghil-lambda-body
|
||||
|
||||
<ghil-inline> make-ghil-inline ghil-inline?
|
||||
ghil-inline-env ghil-inline-loc ghil-inline-inline ghil-inline-args
|
||||
|
||||
<ghil-call> make-ghil-call ghil-call?
|
||||
ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args
|
||||
|
||||
<ghil-mv-call> make-ghil-mv-call ghil-mv-call?
|
||||
ghil-mv-call-env ghil-mv-call-loc ghil-mv-call-producer ghil-mv-call-consumer
|
||||
|
||||
<ghil-values> make-ghil-values ghil-values?
|
||||
ghil-values-env ghil-values-loc ghil-values-values
|
||||
|
||||
<ghil-values*> make-ghil-values* ghil-values*?
|
||||
ghil-values*-env ghil-values*-loc ghil-values*-values
|
||||
|
||||
<ghil-var> make-ghil-var ghil-var?
|
||||
ghil-var-env ghil-var-name ghil-var-kind ghil-var-index
|
||||
|
||||
<ghil-toplevel-env> make-ghil-toplevel-env ghil-toplevel-env?
|
||||
ghil-toplevel-env-table
|
||||
|
||||
<ghil-env> make-ghil-env ghil-env?
|
||||
ghil-env-parent ghil-env-table ghil-env-variables
|
||||
|
||||
<ghil-reified-env> make-ghil-reified-env ghil-reified-env?
|
||||
ghil-reified-env-env ghil-reified-env-loc
|
||||
|
||||
ghil-env-add!
|
||||
ghil-env-reify ghil-env-dereify
|
||||
ghil-var-is-bound? ghil-var-for-ref! ghil-var-for-set! ghil-var-define!
|
||||
ghil-var-at-module!
|
||||
call-with-ghil-environment call-with-ghil-bindings
|
||||
|
||||
parse-ghil unparse-ghil))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Parse tree
|
||||
;;;
|
||||
|
||||
(define (print-ghil x port)
|
||||
(format port "#<ghil ~s>" (unparse-ghil x)))
|
||||
|
||||
(define-type (<ghil> #:printer print-ghil)
|
||||
;; Objects
|
||||
(<ghil-void> env loc)
|
||||
(<ghil-quote> env loc obj)
|
||||
(<ghil-quasiquote> env loc exp)
|
||||
(<ghil-unquote> env loc exp)
|
||||
(<ghil-unquote-splicing> env loc exp)
|
||||
;; Variables
|
||||
(<ghil-ref> env loc var)
|
||||
(<ghil-set> env loc var val)
|
||||
(<ghil-define> env loc var val)
|
||||
;; Controls
|
||||
(<ghil-if> env loc test then else)
|
||||
(<ghil-and> env loc exps)
|
||||
(<ghil-or> env loc exps)
|
||||
(<ghil-begin> env loc exps)
|
||||
(<ghil-bind> env loc vars vals body)
|
||||
(<ghil-mv-bind> env loc producer vars rest body)
|
||||
(<ghil-lambda> env loc vars rest meta body)
|
||||
(<ghil-call> env loc proc args)
|
||||
(<ghil-mv-call> env loc producer consumer)
|
||||
(<ghil-inline> env loc inline args)
|
||||
(<ghil-values> env loc values)
|
||||
(<ghil-values*> env loc values)
|
||||
(<ghil-reified-env> env loc))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; Variables
|
||||
;;;
|
||||
|
||||
(define-record <ghil-var> env name kind (index #f))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Modules
|
||||
;;;
|
||||
|
||||
|
||||
;;;
|
||||
;;; Environments
|
||||
;;;
|
||||
|
||||
(define-record <ghil-env> parent (table '()) (variables '()))
|
||||
(define-record <ghil-toplevel-env> (table '()))
|
||||
|
||||
(define (ghil-env-ref env sym)
|
||||
(assq-ref (ghil-env-table env) sym))
|
||||
|
||||
(define-macro (push! item loc)
|
||||
`(set! ,loc (cons ,item ,loc)))
|
||||
(define-macro (apush! k v loc)
|
||||
`(set! ,loc (acons ,k ,v ,loc)))
|
||||
(define-macro (apopq! k loc)
|
||||
`(set! ,loc (assq-remove! ,loc ,k)))
|
||||
|
||||
(define (ghil-env-add! env var)
|
||||
(apush! (ghil-var-name var) var (ghil-env-table env))
|
||||
(push! var (ghil-env-variables env)))
|
||||
|
||||
(define (ghil-env-remove! env var)
|
||||
(apopq! (ghil-var-name var) (ghil-env-table env)))
|
||||
|
||||
(define (force-heap-allocation! var)
|
||||
(set! (ghil-var-kind var) 'external))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; Public interface
|
||||
;;;
|
||||
|
||||
;; The following four functions used to be one, in ghil-lookup. Now they
|
||||
;; are four, to reflect the different intents. A bit of duplication, but
|
||||
;; that's OK. The common current is to find out where a variable will be
|
||||
;; stored at runtime.
|
||||
;;
|
||||
;; These functions first search the lexical environments. If the
|
||||
;; variable is not in the innermost environment, make sure the variable
|
||||
;; is marked as being "external" so that it goes on the heap. If the
|
||||
;; variable is being modified (via a set!), also make sure it's on the
|
||||
;; heap, so that other continuations see the changes to the var.
|
||||
;;
|
||||
;; If the variable is not found lexically, it is a toplevel variable,
|
||||
;; which will be looked up at runtime with respect to the module that
|
||||
;; was current when the lambda was bound, at runtime. The variable will
|
||||
;; be resolved when it is first used.
|
||||
(define (ghil-var-is-bound? env sym)
|
||||
(let loop ((e env))
|
||||
(record-case e
|
||||
((<ghil-toplevel-env> table)
|
||||
(let ((key (cons (module-name (current-module)) sym)))
|
||||
(assoc-ref table key)))
|
||||
((<ghil-env> parent table variables)
|
||||
(and (not (assq-ref table sym))
|
||||
(loop parent))))))
|
||||
|
||||
(define (ghil-var-for-ref! env sym)
|
||||
(let loop ((e env))
|
||||
(record-case e
|
||||
((<ghil-toplevel-env> table)
|
||||
(let ((key (cons (module-name (current-module)) sym)))
|
||||
(or (assoc-ref table key)
|
||||
(let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
|
||||
(apush! key var (ghil-toplevel-env-table e))
|
||||
var))))
|
||||
((<ghil-env> parent table variables)
|
||||
(cond
|
||||
((assq-ref table sym)
|
||||
=> (lambda (var)
|
||||
(or (eq? e env)
|
||||
(force-heap-allocation! var))
|
||||
var))
|
||||
(else
|
||||
(loop parent)))))))
|
||||
|
||||
(define (ghil-var-for-set! env sym)
|
||||
(let loop ((e env))
|
||||
(record-case e
|
||||
((<ghil-toplevel-env> table)
|
||||
(let ((key (cons (module-name (current-module)) sym)))
|
||||
(or (assoc-ref table key)
|
||||
(let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
|
||||
(apush! key var (ghil-toplevel-env-table e))
|
||||
var))))
|
||||
((<ghil-env> parent table variables)
|
||||
(cond
|
||||
((assq-ref table sym)
|
||||
=> (lambda (var)
|
||||
(force-heap-allocation! var)
|
||||
var))
|
||||
(else
|
||||
(loop parent)))))))
|
||||
|
||||
(define (ghil-var-at-module! env modname sym interface?)
|
||||
(let loop ((e env))
|
||||
(record-case e
|
||||
((<ghil-toplevel-env> table)
|
||||
(let ((key (list modname sym interface?)))
|
||||
(or (assoc-ref table key)
|
||||
(let ((var (make-ghil-var modname sym
|
||||
(if interface? 'public 'private))))
|
||||
(apush! key var (ghil-toplevel-env-table e))
|
||||
var))))
|
||||
((<ghil-env> parent table variables)
|
||||
(loop parent)))))
|
||||
|
||||
(define (ghil-var-define! toplevel sym)
|
||||
(let ((key (cons (module-name (current-module)) sym)))
|
||||
(or (assoc-ref (ghil-toplevel-env-table toplevel) key)
|
||||
(let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
|
||||
(apush! key var (ghil-toplevel-env-table toplevel))
|
||||
var))))
|
||||
|
||||
(define (call-with-ghil-environment e syms func)
|
||||
(let* ((e (make-ghil-env e))
|
||||
(vars (map (lambda (s)
|
||||
(let ((v (make-ghil-var e s 'argument)))
|
||||
(ghil-env-add! e v) v))
|
||||
syms)))
|
||||
(func e vars)))
|
||||
|
||||
(define (call-with-ghil-bindings e syms func)
|
||||
(let* ((vars (map (lambda (s)
|
||||
(let ((v (make-ghil-var e s 'local)))
|
||||
(ghil-env-add! e v) v))
|
||||
syms))
|
||||
(ret (func vars)))
|
||||
(for-each (lambda (v) (ghil-env-remove! e v)) vars)
|
||||
ret))
|
||||
|
||||
(define (ghil-env-reify env)
|
||||
(let loop ((e env) (out '()))
|
||||
(record-case e
|
||||
((<ghil-toplevel-env> table)
|
||||
(map (lambda (v)
|
||||
(cons (ghil-var-name v)
|
||||
(or (ghil-var-index v)
|
||||
(error "reify called before indices finalized"))))
|
||||
out))
|
||||
((<ghil-env> parent table variables)
|
||||
(loop parent
|
||||
(append out
|
||||
(filter (lambda (v) (eq? (ghil-var-kind v) 'external))
|
||||
variables)))))))
|
||||
|
||||
(define (ghil-env-dereify name-index-alist)
|
||||
(let* ((e (make-ghil-env (make-ghil-toplevel-env)))
|
||||
(vars (map (lambda (pair)
|
||||
(make-ghil-var e (car pair) 'external (cdr pair)))
|
||||
name-index-alist)))
|
||||
(set! (ghil-env-table e)
|
||||
(map (lambda (v) (cons (ghil-var-name v) v)) vars))
|
||||
(set! (ghil-env-variables e) vars)
|
||||
e))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Parser
|
||||
;;;
|
||||
|
||||
(define (location x)
|
||||
(and (pair? x)
|
||||
(let ((props (source-properties x)))
|
||||
(and (not (null? props))
|
||||
(vector (assq-ref props 'line)
|
||||
(assq-ref props 'column)
|
||||
(assq-ref props 'filename))))))
|
||||
|
||||
(define (parse-quasiquote e x level)
|
||||
(cond ((not (pair? x)) x)
|
||||
((memq (car x) '(unquote unquote-splicing))
|
||||
(let ((l (location x)))
|
||||
(pmatch (cdr x)
|
||||
((,obj)
|
||||
(cond
|
||||
((zero? level)
|
||||
(if (eq? (car x) 'unquote)
|
||||
(make-ghil-unquote e l (parse-ghil e obj))
|
||||
(make-ghil-unquote-splicing e l (parse-ghil e obj))))
|
||||
(else
|
||||
(list (car x) (parse-quasiquote e obj (1- level))))))
|
||||
(else (syntax-error l (format #f "bad ~A" (car x)) x)))))
|
||||
((eq? (car x) 'quasiquote)
|
||||
(let ((l (location x)))
|
||||
(pmatch (cdr x)
|
||||
((,obj) (list 'quasiquote (parse-quasiquote e obj (1+ level))))
|
||||
(else (syntax-error l (format #f "bad ~A" (car x)) x)))))
|
||||
(else (cons (parse-quasiquote e (car x) level)
|
||||
(parse-quasiquote e (cdr x) level)))))
|
||||
|
||||
(define (parse-ghil env exp)
|
||||
(let ((loc (location exp))
|
||||
(retrans (lambda (x) (parse-ghil env x))))
|
||||
(pmatch exp
|
||||
(,exp (guard (symbol? exp))
|
||||
(make-ghil-ref env #f (ghil-var-for-ref! env exp)))
|
||||
|
||||
(,exp (guard (not (pair? exp)))
|
||||
(make-ghil-quote #:env env #:loc #f #:obj exp))
|
||||
|
||||
(('quote ,exp) (make-ghil-quote #:env env #:loc loc #:obj exp))
|
||||
|
||||
((void) (make-ghil-void env loc))
|
||||
|
||||
((lambda ,syms ,rest ,meta . ,body)
|
||||
(call-with-ghil-environment env syms
|
||||
(lambda (env vars)
|
||||
(make-ghil-lambda env loc vars rest meta
|
||||
(parse-ghil env `(begin ,@body))))))
|
||||
|
||||
((begin . ,body)
|
||||
(make-ghil-begin env loc (map retrans body)))
|
||||
|
||||
((bind ,syms ,exprs . ,body)
|
||||
(let ((vals (map retrans exprs)))
|
||||
(call-with-ghil-bindings env syms
|
||||
(lambda (vars)
|
||||
(make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
|
||||
|
||||
((bindrec ,syms ,exprs . ,body)
|
||||
(call-with-ghil-bindings env syms
|
||||
(lambda (vars)
|
||||
(let ((vals (map (lambda (exp) (parse-ghil env exp)) exprs)))
|
||||
(make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
|
||||
|
||||
((set! ,sym ,val)
|
||||
(make-ghil-set env loc (ghil-var-for-set! env sym) (retrans val)))
|
||||
|
||||
((define ,sym ,val)
|
||||
(make-ghil-define env loc (ghil-var-define! env sym) (retrans val)))
|
||||
|
||||
((if ,test ,then ,else)
|
||||
(make-ghil-if env loc (retrans test) (retrans then) (retrans else)))
|
||||
|
||||
((and . ,exps)
|
||||
(make-ghil-and env loc (map retrans exps)))
|
||||
|
||||
((or . ,exps)
|
||||
(make-ghil-or env loc (map retrans exps)))
|
||||
|
||||
((mv-bind ,syms ,rest ,producer . ,body)
|
||||
(call-with-ghil-bindings env syms
|
||||
(lambda (vars)
|
||||
(make-ghil-mv-bind env loc (retrans producer) vars rest
|
||||
(map retrans body)))))
|
||||
|
||||
((call ,proc . ,args)
|
||||
(make-ghil-call env loc (retrans proc) (map retrans args)))
|
||||
|
||||
((mv-call ,producer . ,consumer)
|
||||
(make-ghil-mv-call env loc (retrans producer) (retrans consumer)))
|
||||
|
||||
((inline ,op . ,args)
|
||||
(make-ghil-inline env loc op (map retrans args)))
|
||||
|
||||
((values . ,values)
|
||||
(make-ghil-values env loc (map retrans values)))
|
||||
|
||||
((values* . ,values)
|
||||
(make-ghil-values* env loc (map retrans values)))
|
||||
|
||||
((compile-time-environment)
|
||||
(make-ghil-reified-env env loc))
|
||||
|
||||
((quasiquote ,exp)
|
||||
(make-ghil-quasiquote env loc #:exp (parse-quasiquote env exp 0)))
|
||||
|
||||
(else
|
||||
(error "unrecognized GHIL" exp)))))
|
||||
|
||||
(define (unparse-ghil ghil)
|
||||
(record-case ghil
|
||||
((<ghil-void> env loc)
|
||||
'(void))
|
||||
((<ghil-quote> env loc obj)
|
||||
(if (symbol? obj)
|
||||
`(,'quote ,obj)
|
||||
obj))
|
||||
((<ghil-quasiquote> env loc exp)
|
||||
`(,'quasiquote ,(map unparse-ghil exp)))
|
||||
((<ghil-unquote> env loc exp)
|
||||
`(,'unquote ,(unparse-ghil exp)))
|
||||
((<ghil-unquote-splicing> env loc exp)
|
||||
`(,'unquote-splicing ,(unparse-ghil exp)))
|
||||
;; Variables
|
||||
((<ghil-ref> env loc var)
|
||||
(ghil-var-name var))
|
||||
((<ghil-set> env loc var val)
|
||||
`(set! ,(ghil-var-name var) ,(unparse-ghil val)))
|
||||
((<ghil-define> env loc var val)
|
||||
`(define ,(ghil-var-name var) ,(unparse-ghil val)))
|
||||
;; Controls
|
||||
((<ghil-if> env loc test then else)
|
||||
`(if ,(unparse-ghil test) ,(unparse-ghil then) ,(unparse-ghil else)))
|
||||
((<ghil-and> env loc exps)
|
||||
`(and ,@(map unparse-ghil exps)))
|
||||
((<ghil-or> env loc exps)
|
||||
`(or ,@(map unparse-ghil exps)))
|
||||
((<ghil-begin> env loc exps)
|
||||
`(begin ,@(map unparse-ghil exps)))
|
||||
((<ghil-bind> env loc vars vals body)
|
||||
`(bind ,(map ghil-var-name vars) ,(map unparse-ghil vals)
|
||||
,@(map unparse-ghil body)))
|
||||
((<ghil-mv-bind> env loc producer vars rest body)
|
||||
`(mv-bind ,(map ghil-var-name vars) ,rest
|
||||
,(unparse-ghil producer) ,@(map unparse-ghil body)))
|
||||
((<ghil-lambda> env loc vars rest meta body)
|
||||
`(lambda ,(map ghil-var-name vars) ,rest ,meta
|
||||
,(unparse-ghil body)))
|
||||
((<ghil-call> env loc proc args)
|
||||
`(call ,(unparse-ghil proc) ,@(map unparse-ghil args)))
|
||||
((<ghil-mv-call> env loc producer consumer)
|
||||
`(mv-call ,(unparse-ghil producer) ,(unparse-ghil consumer)))
|
||||
((<ghil-inline> env loc inline args)
|
||||
`(inline ,inline ,@(map unparse-ghil args)))
|
||||
((<ghil-values> env loc values)
|
||||
`(values ,@(map unparse-ghil values)))
|
||||
((<ghil-values*> env loc values)
|
||||
`(values* ,@(map unparse-ghil values)))
|
||||
((<ghil-reified-env> env loc)
|
||||
`(compile-time-environment))))
|
||||
|
|
@ -22,8 +22,9 @@
|
|||
(define-module (language ghil spec)
|
||||
#:use-module (system base language)
|
||||
#:use-module (language glil spec)
|
||||
#:use-module (system il ghil)
|
||||
#:use-module ((system il compile) #:select ((compile . compile-il)))
|
||||
#:use-module (language glil def)
|
||||
#:use-module (language ghil def)
|
||||
#:use-module (language ghil compile-glil)
|
||||
#:export (ghil))
|
||||
|
||||
(define (write-ghil exp . port)
|
||||
|
|
@ -40,5 +41,5 @@
|
|||
#:reader read
|
||||
#:printer write-ghil
|
||||
#:parser parse
|
||||
#:compilers `((,glil . ,compile-il))
|
||||
#:compilers `((,glil . ,compile-glil))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
SOURCES = spec.scm
|
||||
SOURCES = spec.scm def.scm compile-objcode.scm
|
||||
modpath = language/glil
|
||||
include $(top_srcdir)/am/guilec
|
||||
|
|
|
|||
412
module/language/glil/compile-objcode.scm
Normal file
412
module/language/glil/compile-objcode.scm
Normal file
|
|
@ -0,0 +1,412 @@
|
|||
;;; Guile VM assembler
|
||||
|
||||
;; Copyright (C) 2001 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
|
||||
;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;; any later version.
|
||||
;;
|
||||
;; This program 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 General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; see the file COPYING. If not, write to
|
||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (language glil compile-objcode)
|
||||
#:use-syntax (system base syntax)
|
||||
#:use-module (language glil def)
|
||||
#:use-module (system vm instruction)
|
||||
#:use-module (system vm objcode)
|
||||
#:use-module ((system vm program) #:select (make-binding))
|
||||
#:use-module (system vm conv)
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (ice-9 common-list)
|
||||
#:use-module (srfi srfi-4)
|
||||
#:use-module ((srfi srfi-1) #:select (append-map))
|
||||
#:export (preprocess codegen compile-objcode))
|
||||
|
||||
(define (compile-objcode glil env . opts)
|
||||
(codegen (preprocess glil #f) #t))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Types
|
||||
;;;
|
||||
|
||||
(define-record <vm-asm> venv glil body)
|
||||
(define-record <venv> parent nexts closure?)
|
||||
;; key is either a symbol or the list (MODNAME SYM PUBLIC?)
|
||||
(define-record <vlink-now> key)
|
||||
(define-record <vlink-later> key)
|
||||
(define-record <vdefine> name)
|
||||
(define-record <bytespec> vars bytes meta objs closure?)
|
||||
|
||||
|
||||
;;;
|
||||
;;; Stage 1: Preprocess
|
||||
;;;
|
||||
|
||||
(define (preprocess x e)
|
||||
(record-case x
|
||||
((<glil-asm> vars meta body)
|
||||
(let* ((venv (make-venv #:parent e #:nexts (glil-vars-nexts vars) #:closure? #f))
|
||||
(body (map (lambda (x) (preprocess x venv)) body)))
|
||||
(make-vm-asm #:venv venv #:glil x #:body body)))
|
||||
((<glil-external> op depth index)
|
||||
(do ((d depth (- d 1))
|
||||
(e e (venv-parent e)))
|
||||
((= d 0))
|
||||
(set! (venv-closure? e) #t))
|
||||
x)
|
||||
(else x)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Stage 2: Bytecode generation
|
||||
;;;
|
||||
|
||||
(define-macro (push x loc)
|
||||
`(set! ,loc (cons ,x ,loc)))
|
||||
(define-macro (pop loc)
|
||||
`(let ((_x (car ,loc))) (set! ,loc (cdr ,loc)) _x))
|
||||
|
||||
;; this is to avoid glil-const's desire to put constants in the object
|
||||
;; array -- instead we explicitly want them in the code, because meta
|
||||
;; info is infrequently used. to load it up always would make garbage,
|
||||
;; needlessly. so hide it behind a lambda.
|
||||
(define (make-meta bindings sources tail)
|
||||
(if (and (null? bindings) (null? sources) (null? tail))
|
||||
#f
|
||||
(let ((stack '()))
|
||||
(define (push-code! code)
|
||||
(push (code->bytes code) stack))
|
||||
(dump-object! push-code! `(,bindings ,sources ,@tail))
|
||||
(push-code! '(return))
|
||||
(make-bytespec #:vars (make-glil-vars 0 0 0 0)
|
||||
#:bytes (stack->bytes (reverse! stack) '())
|
||||
#:meta #f #:objs #f #:closure? #f))))
|
||||
|
||||
(define (byte-length x)
|
||||
(cond ((u8vector? x) (u8vector-length x))
|
||||
((>= (instruction-length (car x)) 0)
|
||||
;; one byte for the instruction itself
|
||||
(1+ (instruction-length (car x))))
|
||||
(else (error "variable-length instruction?" x))))
|
||||
|
||||
;; a binding that doesn't yet know its extents
|
||||
(define (make-temp-binding name ext? index)
|
||||
(list name ext? index))
|
||||
(define btemp:name car)
|
||||
(define btemp:extp cadr)
|
||||
(define btemp:index caddr)
|
||||
|
||||
(define (codegen glil toplevel)
|
||||
(record-case glil
|
||||
((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars meta) ; body?
|
||||
(let ((stack '())
|
||||
(open-bindings '())
|
||||
(closed-bindings '())
|
||||
(source-alist '())
|
||||
(label-alist '())
|
||||
(object-alist '()))
|
||||
(define (push-code! code)
|
||||
; (format #t "push-code! ~a~%" code)
|
||||
(push (code->bytes code) stack))
|
||||
(define (push-object! x)
|
||||
(cond ((object->code x) => push-code!)
|
||||
(toplevel
|
||||
(dump-object! push-code! x))
|
||||
(else
|
||||
(let ((i (cond ((object-assoc x object-alist) => cdr)
|
||||
(else
|
||||
(let ((i (length object-alist)))
|
||||
(set! object-alist (acons x i object-alist))
|
||||
i)))))
|
||||
(push-code! `(object-ref ,i))))))
|
||||
(define (munge-bindings bindings nargs)
|
||||
(map
|
||||
(lambda (v)
|
||||
(let ((name (car v)) (type (cadr v)) (i (caddr v)))
|
||||
(case type
|
||||
((argument) (make-temp-binding name #f i))
|
||||
((local) (make-temp-binding name #f (+ nargs i)))
|
||||
((external) (make-temp-binding name #t i))
|
||||
(else (error "unknown binding type" name type)))))
|
||||
bindings))
|
||||
(define (push-bindings! bindings)
|
||||
(push (cons (current-address) bindings) open-bindings))
|
||||
(define (close-binding!)
|
||||
(let* ((bindings (pop open-bindings))
|
||||
(start (car bindings))
|
||||
(end (current-address)))
|
||||
(for-each
|
||||
(lambda (open)
|
||||
;; the cons is for dsu sort
|
||||
(push (cons start
|
||||
(make-binding (btemp:name open) (btemp:extp open)
|
||||
(btemp:index open) start end))
|
||||
closed-bindings))
|
||||
(cdr bindings))))
|
||||
(define (finish-bindings!)
|
||||
(while (not (null? open-bindings)) (close-binding!))
|
||||
(set! closed-bindings
|
||||
(stable-sort! (reverse! closed-bindings)
|
||||
(lambda (x y) (< (car x) (car y)))))
|
||||
(set! closed-bindings (map cdr closed-bindings)))
|
||||
(define (current-address)
|
||||
(apply + (map byte-length stack)))
|
||||
(define (generate-code x)
|
||||
(record-case x
|
||||
((<vm-asm> venv)
|
||||
(push-object! (codegen x #f))
|
||||
(if (venv-closure? venv) (push-code! `(make-closure))))
|
||||
|
||||
((<glil-bind> (binds vars))
|
||||
(push-bindings! (munge-bindings binds (glil-vars-nargs vars))))
|
||||
|
||||
((<glil-mv-bind> (binds vars) rest)
|
||||
(push-bindings! (munge-bindings binds (glil-vars-nargs vars)))
|
||||
(push-code! `(truncate-values ,(length binds) ,(if rest 1 0))))
|
||||
|
||||
((<glil-unbind>)
|
||||
(close-binding!))
|
||||
|
||||
((<glil-source> loc)
|
||||
(set! source-alist (acons (current-address) loc source-alist)))
|
||||
|
||||
((<glil-void>)
|
||||
(push-code! '(void)))
|
||||
|
||||
((<glil-const> obj)
|
||||
(push-object! obj))
|
||||
|
||||
((<glil-argument> op index)
|
||||
(if (eq? op 'ref)
|
||||
(push-code! `(local-ref ,index))
|
||||
(push-code! `(local-set ,index))))
|
||||
|
||||
((<glil-local> op index)
|
||||
(if (eq? op 'ref)
|
||||
(push-code! `(local-ref ,(+ (glil-vars-nargs vars) index)))
|
||||
(push-code! `(local-set ,(+ (glil-vars-nargs vars) index)))))
|
||||
|
||||
((<glil-external> op depth index)
|
||||
(do ((e venv (venv-parent e))
|
||||
(d depth (1- d))
|
||||
(n 0 (+ n (venv-nexts e))))
|
||||
((= d 0)
|
||||
(if (eq? op 'ref)
|
||||
(push-code! `(external-ref ,(+ n index)))
|
||||
(push-code! `(external-set ,(+ n index)))))))
|
||||
|
||||
((<glil-toplevel> op name)
|
||||
(case op
|
||||
((ref set)
|
||||
(cond
|
||||
(toplevel
|
||||
(push-object! (make-vlink-now #:key name))
|
||||
(push-code! (case op
|
||||
((ref) '(variable-ref))
|
||||
((set) '(variable-set)))))
|
||||
(else
|
||||
(let* ((var (make-vlink-later #:key name))
|
||||
(i (cond ((object-assoc var object-alist) => cdr)
|
||||
(else
|
||||
(let ((i (length object-alist)))
|
||||
(set! object-alist (acons var i object-alist))
|
||||
i)))))
|
||||
(push-code! (case op
|
||||
((ref) `(toplevel-ref ,i))
|
||||
((set) `(toplevel-set ,i))))))))
|
||||
((define)
|
||||
(push-object! (make-vdefine #:name name))
|
||||
(push-code! '(variable-set)))
|
||||
(else
|
||||
(error "unknown toplevel var kind" op name))))
|
||||
|
||||
((<glil-module> op mod name public?)
|
||||
(let ((key (list mod name public?)))
|
||||
(case op
|
||||
((ref set)
|
||||
(cond
|
||||
(toplevel
|
||||
(push-object! (make-vlink-now #:key key))
|
||||
(push-code! (case op
|
||||
((ref) '(variable-ref))
|
||||
((set) '(variable-set)))))
|
||||
(else
|
||||
(let* ((var (make-vlink-later #:key key))
|
||||
(i (cond ((object-assoc var object-alist) => cdr)
|
||||
(else
|
||||
(let ((i (length object-alist)))
|
||||
(set! object-alist (acons var i object-alist))
|
||||
i)))))
|
||||
(push-code! (case op
|
||||
((ref) `(toplevel-ref ,i))
|
||||
((set) `(toplevel-set ,i))))))))
|
||||
(else
|
||||
(error "unknown module var kind" op key)))))
|
||||
|
||||
((<glil-label> label)
|
||||
(set! label-alist (assq-set! label-alist label (current-address))))
|
||||
|
||||
((<glil-branch> inst label)
|
||||
(push (list inst label) stack))
|
||||
|
||||
((<glil-call> inst nargs)
|
||||
(if (instruction? inst)
|
||||
(let ((pops (instruction-pops inst)))
|
||||
(cond ((< pops 0)
|
||||
(push-code! (list inst nargs)))
|
||||
((= pops nargs)
|
||||
(push-code! (list inst)))
|
||||
(else
|
||||
(error "Wrong number of arguments:" inst nargs))))
|
||||
(error "Unknown instruction:" inst)))
|
||||
|
||||
((<glil-mv-call> nargs ra)
|
||||
(push (list 'mv-call nargs ra) stack))))
|
||||
|
||||
;;
|
||||
;; main
|
||||
(for-each generate-code body)
|
||||
(finish-bindings!)
|
||||
; (format #t "codegen: stack = ~a~%" (reverse stack))
|
||||
(let ((bytes (stack->bytes (reverse! stack) label-alist)))
|
||||
(if toplevel
|
||||
(bytecode->objcode bytes (glil-vars-nlocs vars) (glil-vars-nexts vars))
|
||||
(make-bytespec #:vars vars #:bytes bytes
|
||||
#:meta (make-meta closed-bindings
|
||||
(reverse! source-alist)
|
||||
meta)
|
||||
#:objs (let ((objs (map car (reverse! object-alist))))
|
||||
(if (null? objs) #f (list->vector objs)))
|
||||
#:closure? (venv-closure? venv))))))))))
|
||||
|
||||
(define (object-assoc x alist)
|
||||
(record-case x
|
||||
((<vlink-now>) (assoc x alist))
|
||||
((<vlink-later>) (assoc x alist))
|
||||
(else (assq x alist))))
|
||||
|
||||
(define (check-length len u8v)
|
||||
(or (= len (u8vector-length u8v))
|
||||
(error "the badness!" len u8v))
|
||||
u8v)
|
||||
|
||||
(define (stack->bytes stack label-alist)
|
||||
(let loop ((result '()) (stack stack) (addr 0))
|
||||
(if (null? stack)
|
||||
(check-length
|
||||
addr
|
||||
(list->u8vector
|
||||
(append-map u8vector->list (reverse! result))))
|
||||
(let ((elt (car stack)))
|
||||
(cond
|
||||
((u8vector? elt)
|
||||
(loop (cons elt result)
|
||||
(cdr stack)
|
||||
(+ addr (byte-length elt))))
|
||||
((symbol? (car (last-pair elt)))
|
||||
;; not yet code because labels needed to be resolved
|
||||
(let* ((head (list-head elt (1- (length elt))))
|
||||
(label-addr (assq-ref label-alist (car (last-pair elt))))
|
||||
(offset (- label-addr (+ addr (byte-length elt))))
|
||||
(n (if (< offset 0) (+ offset 65536) offset)))
|
||||
(loop (cons (code->bytes
|
||||
(append head (list (quotient n 256) (modulo n 256))))
|
||||
result)
|
||||
(cdr stack)
|
||||
(+ addr (byte-length elt)))))
|
||||
(else (error "bad code" elt)))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Object dump
|
||||
;;;
|
||||
|
||||
;; NOTE: undumpped in vm_system.c
|
||||
|
||||
(define (dump-object! push-code! x)
|
||||
(define (too-long x)
|
||||
(error (string-append x " too long")))
|
||||
|
||||
(let dump! ((x x))
|
||||
(cond
|
||||
((object->code x) => push-code!)
|
||||
((record? x)
|
||||
(record-case x
|
||||
((<bytespec> vars bytes meta objs closure?)
|
||||
;; dump parameters
|
||||
(let ((nargs (glil-vars-nargs vars)) (nrest (glil-vars-nrest vars))
|
||||
(nlocs (glil-vars-nlocs vars)) (nexts (glil-vars-nexts vars)))
|
||||
(cond
|
||||
((and (< nargs 16) (< nlocs 128) (< nexts 16))
|
||||
;; 16-bit representation
|
||||
(let ((x (logior
|
||||
(ash nargs 12) (ash nrest 11) (ash nlocs 4) nexts)))
|
||||
(push-code! `(make-int16 ,(ash x -8) ,(logand x (1- (ash 1 8)))))))
|
||||
(else
|
||||
;; Other cases
|
||||
(if (> (+ nargs nlocs) 255)
|
||||
(error "too many locals" nargs nlocs))
|
||||
;; really it should be a flag..
|
||||
(if (> nrest 1) (error "nrest should be 0 or 1" nrest))
|
||||
(if (> nexts 255) (error "too many externals" nexts))
|
||||
(push-code! (object->code nargs))
|
||||
(push-code! (object->code nrest))
|
||||
(push-code! (object->code nlocs))
|
||||
(push-code! (object->code nexts))
|
||||
(push-code! (object->code #f)))))
|
||||
;; dump object table
|
||||
(if objs (dump! objs))
|
||||
;; dump meta data
|
||||
(if meta (dump! meta))
|
||||
;; dump bytecode
|
||||
(push-code! `(load-program ,bytes)))
|
||||
((<vlink-later> key)
|
||||
(dump! key))
|
||||
((<vlink-now> key)
|
||||
(dump! key)
|
||||
(push-code! '(link-now)))
|
||||
((<vdefine> name)
|
||||
(push-code! `(define ,(symbol->string name))))
|
||||
(else
|
||||
(error "assemble: unknown record type" (record-type-descriptor x)))))
|
||||
((and (integer? x) (exact? x))
|
||||
(let ((str (do ((n x (quotient n 256))
|
||||
(l '() (cons (modulo n 256) l)))
|
||||
((= n 0)
|
||||
(apply u8vector l)))))
|
||||
(push-code! `(load-integer ,str))))
|
||||
((number? x)
|
||||
(push-code! `(load-number ,(number->string x))))
|
||||
((string? x)
|
||||
(push-code! `(load-string ,x)))
|
||||
((symbol? x)
|
||||
(push-code! `(load-symbol ,(symbol->string x))))
|
||||
((keyword? x)
|
||||
(push-code! `(load-keyword ,(symbol->string (keyword->symbol x)))))
|
||||
((list? x)
|
||||
(for-each dump! x)
|
||||
(let ((len (length x)))
|
||||
(if (>= len 65536) (too-long 'list))
|
||||
(push-code! `(list ,(quotient len 256) ,(modulo len 256)))))
|
||||
((pair? x)
|
||||
(dump! (car x))
|
||||
(dump! (cdr x))
|
||||
(push-code! `(cons)))
|
||||
((vector? x)
|
||||
(for-each dump! (vector->list x))
|
||||
(let ((len (vector-length x)))
|
||||
(if (>= len 65536) (too-long 'vector))
|
||||
(push-code! `(vector ,(quotient len 256) ,(modulo len 256)))))
|
||||
(else
|
||||
(error "assemble: unrecognized object" x)))))
|
||||
158
module/language/glil/def.scm
Normal file
158
module/language/glil/def.scm
Normal file
|
|
@ -0,0 +1,158 @@
|
|||
;;; Guile Low Intermediate Language
|
||||
|
||||
;; Copyright (C) 2001 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
|
||||
;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;; any later version.
|
||||
;;
|
||||
;; This program 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 General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; see the file COPYING. If not, write to
|
||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (language glil def)
|
||||
#:use-module (system base syntax)
|
||||
#:use-module (system base pmatch)
|
||||
#:export
|
||||
(<glil-vars> make-glil-vars
|
||||
glil-vars-nargs glil-vars-nrest glil-vars-nlocs glil-vars-nexts
|
||||
|
||||
<glil-asm> make-glil-asm glil-asm?
|
||||
glil-asm-vars glil-asm-meta glil-asm-body
|
||||
|
||||
<glil-bind> make-glil-bind glil-bind?
|
||||
glil-bind-vars
|
||||
|
||||
<glil-mv-bind> make-glil-mv-bind glil-mv-bind?
|
||||
glil-mv-bind-vars glil-mv-bind-rest
|
||||
|
||||
<glil-unbind> make-glil-unbind glil-unbind?
|
||||
|
||||
<glil-source> make-glil-source glil-source?
|
||||
glil-source-loc
|
||||
|
||||
<glil-void> make-glil-void glil-void?
|
||||
|
||||
<glil-const> make-glil-const glil-const?
|
||||
glil-const-obj
|
||||
|
||||
<glil-argument> make-glil-argument glil-argument?
|
||||
glil-argument-op glil-argument-index
|
||||
|
||||
<glil-local> make-glil-local glil-local?
|
||||
glil-local-op glil-local-index
|
||||
|
||||
<glil-external> make-glil-external glil-external?
|
||||
glil-external-op glil-external-depth glil-external-index
|
||||
|
||||
<glil-toplevel> make-glil-toplevel glil-toplevel?
|
||||
glil-toplevel-op glil-toplevel-name
|
||||
|
||||
<glil-module> make-glil-module glil-module?
|
||||
glil-module-op glil-module-mod glil-module-name glil-module-public?
|
||||
|
||||
<glil-label> make-glil-label glil-label?
|
||||
glil-label-label
|
||||
|
||||
<glil-branch> make-glil-branch glil-branch?
|
||||
glil-branch-inst glil-branch-label
|
||||
|
||||
<glil-call> make-glil-call glil-call?
|
||||
glil-call-inst glil-call-nargs
|
||||
|
||||
<glil-mv-call> make-glil-mv-call glil-mv-call?
|
||||
glil-mv-call-nargs glil-mv-call-ra
|
||||
|
||||
parse-glil unparse-glil))
|
||||
|
||||
(define-record <glil-vars> nargs nrest nlocs nexts)
|
||||
|
||||
(define (print-glil x port)
|
||||
(format port "#<glil ~s>" (unparse-glil x)))
|
||||
|
||||
(define-type (<glil> #:printer print-glil)
|
||||
;; Meta operations
|
||||
(<glil-asm> vars meta body)
|
||||
(<glil-bind> vars)
|
||||
(<glil-mv-bind> vars rest)
|
||||
(<glil-unbind>)
|
||||
(<glil-source> loc)
|
||||
;; Objects
|
||||
(<glil-void>)
|
||||
(<glil-const> obj)
|
||||
;; Variables
|
||||
(<glil-argument> op index)
|
||||
(<glil-local> op index)
|
||||
(<glil-external> op depth index)
|
||||
(<glil-toplevel> op name)
|
||||
(<glil-module> op mod name public?)
|
||||
;; Controls
|
||||
(<glil-label> label)
|
||||
(<glil-branch> inst label)
|
||||
(<glil-call> inst nargs)
|
||||
(<glil-mv-call> nargs ra))
|
||||
|
||||
|
||||
(define (parse-glil x)
|
||||
(pmatch x
|
||||
((asm (,nargs ,nrest ,nlocs ,next) ,meta . ,body)
|
||||
(make-glil-asm (make-glil-vars nargs nrest nlocs next)
|
||||
meta (map parse-glil body)))
|
||||
((bind . ,vars) (make-glil-bind vars))
|
||||
((mv-bind ,vars . ,rest) (make-glil-mv-bind vars (map parse-glil rest)))
|
||||
((unbind) (make-glil-unbind))
|
||||
((source ,loc) (make-glil-source loc))
|
||||
((void) (make-glil-void))
|
||||
((const ,obj) (make-glil-const obj))
|
||||
((argument ,op ,index) (make-glil-argument op index))
|
||||
((local ,op ,index) (make-glil-local op index))
|
||||
((external ,op ,depth ,index) (make-glil-external op depth index))
|
||||
((toplevel ,op ,name) (make-glil-toplevel op name))
|
||||
((module public ,op ,mod ,name) (make-glil-module op mod name #t))
|
||||
((module private ,op ,mod ,name) (make-glil-module op mod name #f))
|
||||
((label ,label) (make-label ,label))
|
||||
((branch ,inst ,label) (make-glil-branch inst label))
|
||||
((call ,inst ,nargs) (make-glil-call inst nargs))
|
||||
((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
|
||||
(else (error "invalid glil" x))))
|
||||
|
||||
(define (unparse-glil glil)
|
||||
(record-case glil
|
||||
;; meta
|
||||
((<glil-asm> vars meta body)
|
||||
`(asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars)
|
||||
,(glil-vars-nlocs vars) ,(glil-vars-nexts vars))
|
||||
,meta
|
||||
,@(map unparse-glil body)))
|
||||
((<glil-bind> vars) `(bind ,@vars))
|
||||
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,@rest))
|
||||
((<glil-unbind>) `(unbind))
|
||||
((<glil-source> loc) `(source ,loc))
|
||||
;; constants
|
||||
((<glil-void>) `(void))
|
||||
((<glil-const> obj) `(const ,obj))
|
||||
;; variables
|
||||
((<glil-argument> op index)
|
||||
`(argument ,op ,index))
|
||||
((<glil-local> op index)
|
||||
`(local ,op ,index))
|
||||
((<glil-external> op depth index)
|
||||
`(external ,op ,depth ,index))
|
||||
((<glil-toplevel> op name)
|
||||
`(toplevel ,op ,name))
|
||||
((<glil-module> op mod name public?)
|
||||
`(module ,(if public? 'public 'private) ,op ,mod ,name))
|
||||
;; controls
|
||||
((<glil-label> label) (label ,label))
|
||||
((<glil-branch> inst label) `(branch ,inst ,label))
|
||||
((<glil-call> inst nargs) `(call ,inst ,nargs))
|
||||
((<glil-mv-call> nargs ra) `(mv-call ,nargs ,(unparse-glil ra)))))
|
||||
|
|
@ -22,8 +22,8 @@
|
|||
(define-module (language glil spec)
|
||||
#:use-module (system base language)
|
||||
#:use-module (language objcode spec)
|
||||
#:use-module (system il glil)
|
||||
#:use-module (system vm assemble)
|
||||
#:use-module (language glil def)
|
||||
#:use-module (language glil compile-objcode)
|
||||
#:export (glil))
|
||||
|
||||
(define (write-glil exp . port)
|
||||
|
|
@ -36,7 +36,7 @@
|
|||
(parse-glil x))
|
||||
|
||||
(define (compile x e opts)
|
||||
(values (assemble x e) e))
|
||||
(values (compile-objcode x e) e))
|
||||
|
||||
(define-language glil
|
||||
#:title "Guile Lowlevel Intermediate Language (GLIL)"
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
SOURCES = translate.scm spec.scm
|
||||
SOURCES = translate.scm spec.scm inline.scm
|
||||
modpath = language/scheme
|
||||
include $(top_srcdir)/am/guilec
|
||||
|
|
|
|||
203
module/language/scheme/inline.scm
Normal file
203
module/language/scheme/inline.scm
Normal file
|
|
@ -0,0 +1,203 @@
|
|||
;;; GHIL macros
|
||||
|
||||
;; Copyright (C) 2001 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
|
||||
;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;; any later version.
|
||||
;;
|
||||
;; This program 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 General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; see the file COPYING. If not, write to
|
||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (language scheme inline)
|
||||
#:use-module (system base syntax)
|
||||
#:use-module (language ghil def)
|
||||
#:use-module (srfi srfi-16)
|
||||
#:export (*inline-table* define-inline try-inline try-inline-with-env))
|
||||
|
||||
(define *inline-table* '())
|
||||
|
||||
(define-macro (define-inline sym . clauses)
|
||||
(define (inline-args args)
|
||||
(let lp ((in args) (out '()))
|
||||
(cond ((null? in) `(list ,@(reverse out)))
|
||||
((symbol? in) `(cons* ,@(reverse out) ,in))
|
||||
((pair? (car in))
|
||||
(lp (cdr in)
|
||||
(cons `(or (try-inline ,(caar in) ,(inline-args (cdar in)))
|
||||
(error "what" ',(car in)))
|
||||
out)))
|
||||
((symbol? (car in))
|
||||
;; assume it's locally bound
|
||||
(lp (cdr in) (cons (car in) out)))
|
||||
((number? (car in))
|
||||
(lp (cdr in) (cons `(make-ghil-quote #f #f ,(car in)) out)))
|
||||
(else
|
||||
(error "what what" (car in))))))
|
||||
(define (consequent exp)
|
||||
(cond
|
||||
((pair? exp)
|
||||
`(make-ghil-inline #f #f ',(car exp) ,(inline-args (cdr exp))))
|
||||
((symbol? exp)
|
||||
;; assume locally bound
|
||||
exp)
|
||||
((number? exp)
|
||||
`(make-ghil-quote #f #f ,exp))
|
||||
(else (error "bad consequent yall" exp))))
|
||||
`(set! (@ (language scheme inline) *inline-table*)
|
||||
(assq-set! (@ (language scheme inline) *inline-table*)
|
||||
,sym
|
||||
(let ((make-ghil-inline (@ (language ghil def) make-ghil-inline))
|
||||
(make-ghil-quote (@ (language ghil def) make-ghil-quote))
|
||||
(try-inline (@ (language scheme inline) try-inline)))
|
||||
(case-lambda
|
||||
,@(let lp ((in clauses) (out '()))
|
||||
(if (null? in)
|
||||
(reverse (cons '(else #f) out))
|
||||
(lp (cddr in)
|
||||
(cons `(,(car in)
|
||||
,(consequent (cadr in))) out)))))))))
|
||||
|
||||
(define (try-inline head-value args)
|
||||
(and=> (assq-ref *inline-table* head-value)
|
||||
(lambda (proc) (apply proc args))))
|
||||
|
||||
|
||||
(define (try-inline-with-env env loc exp)
|
||||
(let ((sym (car exp)))
|
||||
(let loop ((e env))
|
||||
(record-case e
|
||||
((<ghil-toplevel-env> table)
|
||||
(let ((mod (current-module)))
|
||||
(and (not (assoc-ref table (cons (module-name mod) sym)))
|
||||
(module-bound? mod sym)
|
||||
(try-inline (module-ref mod sym) (cdr exp)))))
|
||||
((<ghil-env> parent table variables)
|
||||
(and (not (assq-ref table sym))
|
||||
(loop parent)))))))
|
||||
|
||||
(define-inline eq? (x y)
|
||||
(eq? x y))
|
||||
|
||||
(define-inline eqv? (x y)
|
||||
(eqv? x y))
|
||||
|
||||
(define-inline equal? (x y)
|
||||
(equal? x y))
|
||||
|
||||
(define-inline = (x y)
|
||||
(ee? x y))
|
||||
|
||||
(define-inline < (x y)
|
||||
(lt? x y))
|
||||
|
||||
(define-inline > (x y)
|
||||
(gt? x y))
|
||||
|
||||
(define-inline <= (x y)
|
||||
(le? x y))
|
||||
|
||||
(define-inline >= (x y)
|
||||
(ge? x y))
|
||||
|
||||
(define-inline zero? (x)
|
||||
(ee? x 0))
|
||||
|
||||
(define-inline +
|
||||
() 0
|
||||
(x) x
|
||||
(x y) (add x y)
|
||||
(x y . rest) (add x (+ y . rest)))
|
||||
|
||||
(define-inline *
|
||||
() 1
|
||||
(x) x
|
||||
(x y) (mul x y)
|
||||
(x y . rest) (mul x (* y . rest)))
|
||||
|
||||
(define-inline -
|
||||
(x) (sub 0 x)
|
||||
(x y) (sub x y)
|
||||
(x y . rest) (sub x (+ y . rest)))
|
||||
|
||||
(define-inline 1-
|
||||
(x) (sub x 1))
|
||||
|
||||
(define-inline /
|
||||
(x) (div 1 x)
|
||||
(x y) (div x y)
|
||||
(x y . rest) (div x (* y . rest)))
|
||||
|
||||
(define-inline quotient (x y)
|
||||
(quo x y))
|
||||
|
||||
(define-inline remainder (x y)
|
||||
(rem x y))
|
||||
|
||||
(define-inline modulo (x y)
|
||||
(mod x y))
|
||||
|
||||
(define-inline not (x)
|
||||
(not x))
|
||||
|
||||
(define-inline pair? (x)
|
||||
(pair? x))
|
||||
|
||||
(define-inline cons (x y)
|
||||
(cons x y))
|
||||
|
||||
(define-inline car (x) (car x))
|
||||
(define-inline cdr (x) (cdr x))
|
||||
|
||||
(define-inline set-car! (x y) (set-car! x y))
|
||||
(define-inline set-cdr! (x y) (set-cdr! x y))
|
||||
|
||||
(define-inline caar (x) (car (car x)))
|
||||
(define-inline cadr (x) (car (cdr x)))
|
||||
(define-inline cdar (x) (cdr (car x)))
|
||||
(define-inline cddr (x) (cdr (cdr x)))
|
||||
(define-inline caaar (x) (car (car (car x))))
|
||||
(define-inline caadr (x) (car (car (cdr x))))
|
||||
(define-inline cadar (x) (car (cdr (car x))))
|
||||
(define-inline caddr (x) (car (cdr (cdr x))))
|
||||
(define-inline cdaar (x) (cdr (car (car x))))
|
||||
(define-inline cdadr (x) (cdr (car (cdr x))))
|
||||
(define-inline cddar (x) (cdr (cdr (car x))))
|
||||
(define-inline cdddr (x) (cdr (cdr (cdr x))))
|
||||
(define-inline caaaar (x) (car (car (car (car x)))))
|
||||
(define-inline caaadr (x) (car (car (car (cdr x)))))
|
||||
(define-inline caadar (x) (car (car (cdr (car x)))))
|
||||
(define-inline caaddr (x) (car (car (cdr (cdr x)))))
|
||||
(define-inline cadaar (x) (car (cdr (car (car x)))))
|
||||
(define-inline cadadr (x) (car (cdr (car (cdr x)))))
|
||||
(define-inline caddar (x) (car (cdr (cdr (car x)))))
|
||||
(define-inline cadddr (x) (car (cdr (cdr (cdr x)))))
|
||||
(define-inline cdaaar (x) (cdr (car (car (car x)))))
|
||||
(define-inline cdaadr (x) (cdr (car (car (cdr x)))))
|
||||
(define-inline cdadar (x) (cdr (car (cdr (car x)))))
|
||||
(define-inline cdaddr (x) (cdr (car (cdr (cdr x)))))
|
||||
(define-inline cddaar (x) (cdr (cdr (car (car x)))))
|
||||
(define-inline cddadr (x) (cdr (cdr (car (cdr x)))))
|
||||
(define-inline cdddar (x) (cdr (cdr (cdr (car x)))))
|
||||
(define-inline cddddr (x) (cdr (cdr (cdr (cdr x)))))
|
||||
|
||||
(define-inline null? (x)
|
||||
(null? x))
|
||||
|
||||
(define-inline list? (x)
|
||||
(list? x))
|
||||
|
||||
(define-inline cons*
|
||||
(x) x
|
||||
(x y) (cons x y)
|
||||
(x y . rest) (cons x (cons* y . rest)))
|
||||
|
|
@ -22,8 +22,8 @@
|
|||
(define-module (language scheme translate)
|
||||
#:use-module (system base pmatch)
|
||||
#:use-module (system base language)
|
||||
#:use-module (system il ghil)
|
||||
#:use-module (system il inline)
|
||||
#:use-module (language ghil def)
|
||||
#:use-module (language scheme inline)
|
||||
#:use-module (system vm objcode)
|
||||
#:use-module (ice-9 receive)
|
||||
#:use-module (ice-9 optargs)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue