assembly-pack assembly-unpack
object->assembly assembly->object))
-;; nargs, nrest, nlocs, nexts, len, metalen
+;; nargs, nrest, nlocs, <unused>, len, metalen
(define *program-header-len* (+ 1 1 1 1 4 4))
;; lengths are encoded in 3 bytes
(+ 1 *len-len* (bytevector-length bv)))
((define ,str)
(+ 1 *len-len* (string-length str)))
- ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
+ ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
(+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
((,inst . _) (guard (>= (instruction-length inst) 0))
(+ 1 (instruction-length inst)))
(len (instruction-length inst)))
(write-byte opcode)
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,nexts
- ,labels ,length ,meta . ,code)
+ ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code)
(write-byte nargs)
(write-byte nrest)
(write-byte nlocs)
- (write-byte nexts)
+ (write-byte 0) ;; what used to be nexts
(write-uint32 length)
(write-uint32 (if meta (1- (byte-length meta)) 0))
(letrec ((i 0)
;;; Guile VM code converters
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 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
(- x (ash 1 16)))))
(define (decode-load-program pop)
- (let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (nexts (pop))
+ (let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (unused (pop))
(a (pop)) (b (pop)) (c (pop)) (d (pop))
(e (pop)) (f (pop)) (g (pop)) (h (pop))
(len (+ a (ash b 8) (ash c 16) (ash d 24)))
(cond ((> i len)
(error "error decoding program -- read too many bytes" out))
((= i len)
- `(load-program ,nargs ,nrest ,nlocs ,nexts
+ `(load-program ,nargs ,nrest ,nlocs
,(map (lambda (x) (cons (cdr x) (car x)))
(reverse labels))
,len
;;; Guile VM code converters
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 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
(define (disassemble-load-program asm env)
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
+ ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
(let ((objs (and env (assq-ref env 'objects)))
+ (free-vars (and env (assq-ref env 'free-vars)))
(meta (and env (assq-ref env 'meta)))
- (exts (and env (assq-ref env 'exts)))
(blocs (and env (assq-ref env 'blocs)))
- (bexts (and env (assq-ref env 'bexts)))
(srcs (and env (assq-ref env 'sources))))
(let lp ((pos 0) (code code) (programs '()))
(cond
(acons sym asm programs))))
(else
(print-info pos asm
- (code-annotation end asm objs nargs blocs bexts
+ (code-annotation end asm objs nargs blocs
labels)
(and=> (and srcs (assq end srcs)) source->string))
(lp (+ pos (byte-length asm)) (cdr code) programs)))))))
- (if (pair? exts)
- (disassemble-externals exts))
+ (if (pair? free-vars)
+ (disassemble-free-vars free-vars))
(if meta
(disassemble-meta meta))
((= n len) (newline))
(print-info n (vector-ref objs n) #f #f))))
-(define (disassemble-externals exts)
- (display "Externals:\n\n")
- (let ((len (length exts)))
- (do ((n 0 (1+ n))
- (l exts (cdr l)))
- ((null? l) (newline))
- (print-info n (car l) #f #f))))
+(define (disassemble-free-vars free-vars)
+ (display "Free variables:\n\n")
+ (let ((i 0))
+ (cond ((< i (vector-length free-vars))
+ (print-info i (vector-ref free-vars i) #f #f)
+ (lp (1+ i))))))
(define-macro (unless test . body)
`(if (not ,test) (begin ,@body)))
(define (make-int16 byte1 byte2)
(+ (* byte1 256) byte2))
-(define (code-annotation end-addr code objs nargs blocs bexts labels)
+(define (code-annotation end-addr code objs nargs blocs labels)
(let* ((code (assembly-unpack code))
(inst (car code))
(args (cdr code)))
(list "-> ~A" (assq-ref labels (car args))))
((object-ref)
(and objs (list "~s" (vector-ref objs (car args)))))
- ((local-ref local-set)
+ ((local-ref local-boxed-ref local-set local-boxed-set)
(and blocs
(let lp ((bindings (list-ref blocs (car args))))
(and (pair? bindings)
(list "`~a'~@[ (arg)~]"
(binding:name b) (< (binding:index b) nargs))
(lp (cdr bindings))))))))
- ((external-ref external-set)
- (and bexts
- (if (< (car args) (length bexts))
- (let ((b (list-ref bexts (car args))))
- (list "`~a'~@[ (arg)~]"
- (binding:name b) (< (binding:index b) nargs)))
- (list "(closure variable)"))))
+ ((free-ref free-boxed-ref free-boxed-set)
+ ;; FIXME: we can do better than this
+ (list "(closure variable)"))
((toplevel-ref toplevel-set)
(and objs
(let ((v (vector-ref objs (car args))))
#:use-module ((srfi srfi-1) #:select (fold))
#:export
(<glil-program> make-glil-program glil-program?
- glil-program-nargs glil-program-nrest glil-program-nlocs glil-program-nexts
- glil-program-meta glil-program-body glil-program-closure-level
-
+ glil-program-nargs glil-program-nrest glil-program-nlocs
+ glil-program-meta glil-program-body
+
<glil-bind> make-glil-bind glil-bind?
glil-bind-vars
<glil-const> make-glil-const glil-const?
glil-const-obj
- <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-lexical> make-glil-lexical glil-lexical?
glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index
(define-type (<glil> #:printer print-glil)
;; Meta operations
- (<glil-program> nargs nrest nlocs nexts meta body (closure-level #f))
+ (<glil-program> nargs nrest nlocs meta body)
(<glil-bind> vars)
(<glil-mv-bind> vars rest)
(<glil-unbind>)
(<glil-void>)
(<glil-const> obj)
;; Variables
- (<glil-local> op index)
- (<glil-external> op depth index)
(<glil-lexical> local? boxed? op index)
(<glil-toplevel> op name)
(<glil-module> op mod name public?)
(<glil-call> inst nargs)
(<glil-mv-call> nargs ra))
-(define (compute-closure-level body)
- (fold (lambda (x ret)
- (record-case x
- ((<glil-program> closure-level) (max ret closure-level))
- ((<glil-external> depth) (max ret depth))
- (else ret)))
- 0 body))
-
-(define %make-glil-program make-glil-program)
-(define (make-glil-program . args)
- (let ((prog (apply %make-glil-program args)))
- (if (not (glil-program-closure-level prog))
- (set! (glil-program-closure-level prog)
- (compute-closure-level (glil-program-body prog))))
- prog))
-
\f
+
(define (parse-glil x)
(pmatch x
- ((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body)
- (make-glil-program nargs nrest nlocs nexts meta (map parse-glil body)))
+ ((program ,nargs ,nrest ,nlocs ,meta . ,body)
+ (make-glil-program nargs nrest nlocs meta (map parse-glil body)))
((bind . ,vars) (make-glil-bind vars))
((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
((unbind) (make-glil-unbind))
((source ,props) (make-glil-source props))
((void) (make-glil-void))
((const ,obj) (make-glil-const obj))
- ((local ,op ,index) (make-glil-local op index))
- ((external ,op ,depth ,index) (make-glil-external op depth index))
((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index))
((toplevel ,op ,name) (make-glil-toplevel op name))
((module public ,op ,mod ,name) (make-glil-module op mod name #t))
(define (unparse-glil glil)
(record-case glil
;; meta
- ((<glil-program> nargs nrest nlocs nexts meta body)
- `(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
+ ((<glil-program> nargs nrest nlocs meta body)
+ `(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body)))
((<glil-bind> vars) `(bind ,@vars))
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
((<glil-unbind>) `(unbind))
((<glil-void>) `(void))
((<glil-const> obj) `(const ,obj))
;; variables
- ((<glil-external> op depth index)
- `(external ,op ,depth ,index))
((<glil-lexical> local? boxed? op index)
`(lexical ,local? ,boxed? ,op ,index))
((<glil-toplevel> op name)
(if (and (null? bindings) (null? sources) (null? tail))
#f
(compile-assembly
- (make-glil-program 0 0 0 0 '()
+ (make-glil-program 0 0 0 '()
(list
(make-glil-const `(,bindings ,sources ,@tail))
(make-glil-call 'return 1))))))
(define (compile-assembly glil)
(receive (code . _)
- (glil->assembly glil '() '(()) '() '() #f -1)
+ (glil->assembly glil #t '(()) '() '() #f -1)
(car code)))
(define (make-object-table objects)
(and (not (null? objects))
(list->vector (cons #f objects))))
-(define (glil->assembly glil nexts-stack bindings
+(define (glil->assembly glil toplevel? bindings
source-alist label-alist object-alist addr)
(define (emit-code x)
(values (map assembly-pack x) bindings source-alist label-alist object-alist))
(values (map assembly-pack x) bindings source-alist label-alist object-alist))
(record-case glil
- ((<glil-program> nargs nrest nlocs nexts meta body closure-level)
- (let ((toplevel? (null? nexts-stack)))
- (define (process-body)
- (let ((nexts-stack (cons nexts nexts-stack)))
- (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
- (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
+ ((<glil-program> nargs nrest nlocs meta body)
+ (define (process-body)
+ (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
+ (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
+ (cond
+ ((null? body)
+ (values (reverse code)
+ (close-all-bindings bindings addr)
+ (limn-sources (reverse! source-alist))
+ (reverse label-alist)
+ (and object-alist (map car (reverse object-alist)))
+ addr))
+ (else
+ (receive (subcode bindings source-alist label-alist object-alist)
+ (glil->assembly (car body) #f bindings
+ source-alist label-alist object-alist addr)
+ (lp (cdr body) (append (reverse subcode) code)
+ bindings source-alist label-alist object-alist
+ (addr+ addr subcode)))))))
+
+ (receive (code bindings sources labels objects len)
+ (process-body)
+ (let ((prog `(load-program ,nargs ,nrest ,nlocs ,labels
+ ,len
+ ,(make-meta bindings sources meta)
+ . ,code)))
+ (cond
+ (toplevel?
+ ;; toplevel bytecode isn't loaded by the vm, no way to do
+ ;; object table or closure capture (not in the bytecode,
+ ;; anyway)
+ (emit-code (align-program prog addr)))
+ (else
+ (let ((table (dump-object (make-object-table objects) addr)))
(cond
- ((null? body)
- (values (reverse code)
- (close-all-bindings bindings addr)
- (limn-sources (reverse! source-alist))
- (reverse label-alist)
- (and object-alist (map car (reverse object-alist)))
- addr))
+ (object-alist
+ ;; if we are being compiled from something with an object
+ ;; table, cache the program there
+ (receive (i object-alist)
+ (object-index-and-alist (make-subprogram table prog)
+ object-alist)
+ (emit-code/object `(,(if (< i 256)
+ `(object-ref ,i)
+ `(long-object-ref ,(quotient i 256)
+ ,(modulo i 256))))
+ object-alist)))
(else
- (receive (subcode bindings source-alist label-alist object-alist)
- (glil->assembly (car body) nexts-stack bindings
- source-alist label-alist object-alist addr)
- (lp (cdr body) (append (reverse subcode) code)
- bindings source-alist label-alist object-alist
- (addr+ addr subcode))))))))
-
- (receive (code bindings sources labels objects len)
- (process-body)
- (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
- ,len
- ,(make-meta bindings sources meta)
- . ,code)))
- (cond
- (toplevel?
- ;; toplevel bytecode isn't loaded by the vm, no way to do
- ;; object table or closure capture (not in the bytecode,
- ;; anyway)
- (emit-code (align-program prog addr)))
- (else
- (let ((table (dump-object (make-object-table objects) addr))
- (closure '()))
- (cond
- (object-alist
- ;; if we are being compiled from something with an object
- ;; table, cache the program there
- (receive (i object-alist)
- (object-index-and-alist (make-subprogram table prog)
- object-alist)
- (emit-code/object `(,(if (< i 256)
- `(object-ref ,i)
- `(long-object-ref ,(quotient i 256)
- ,(modulo i 256)))
- ,@closure)
- object-alist)))
- (else
- ;; otherwise emit a load directly
- (emit-code `(,@table ,@(align-program prog (addr+ addr table))
- ,@closure)))))))))))
+ ;; otherwise emit a load directly
+ (emit-code `(,@table ,@(align-program prog (addr+ addr table))))))))))))
+
((<glil-bind> vars)
(values '()
,(modulo i 256))))
object-alist)))))
- ((<glil-local> op index)
- (emit-code (if (eq? op 'ref)
- `((local-ref ,index))
- `((local-set ,index)))))
-
- ((<glil-external> op depth index)
- (emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
- (if (> d 0)
- (lp (1- d) (+ n (car stack)) (cdr stack))
- (if (eq? op 'ref)
- `((external-ref ,(+ n index)))
- `((external-set ,(+ n index))))))))
-
((<glil-lexical> local? boxed? op index)
(emit-code
`((,(if local?
;;; Guile VM code converters
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 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
(define (decompile-toplevel x)
(pmatch x
- ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,body)
- (decompile-load-program nargs nrest nlocs nexts
+ ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body)
+ (decompile-load-program nargs nrest nlocs
(decompile-meta meta)
body labels #f))
(else
((glil-program? (car in)) (lp (cdr in) (cons (car in) out)))
(else (lp (cdr in) (cons (make-glil-const (car l)) out))))))
-(define (decompile-load-program nargs nrest nlocs nexts meta body labels
+(define (decompile-load-program nargs nrest nlocs meta body labels
objects)
(let ((glil-labels (sort (map (lambda (x)
(cons (cdr x) (make-glil-label (car x))))
(cond
((null? in)
(or (null? stack) (error "leftover stack insts" stack body))
- (make-glil-program nargs nrest nlocs nexts props (reverse out) #f))
+ (make-glil-program nargs nrest nlocs props (reverse out) #f))
((pop-bindings! pos)
=> (lambda (bindings)
(lp in stack
- (cons (make-glil-bind
- (map (lambda (x)
- (let ((name (binding:name x))
- (i (binding:index x)))
- (cond
- ((binding:extp x) `(,name external ,i))
- ((< i nargs) `(,name argument ,i))
- (else `(,name local ,(- i nargs))))))
- bindings))
+ (cons (make-glil-bind bindings)
out)
pos)))
((pop-unbindings! pos)
((program? x)
(let ((objs (program-objects x))
(meta (program-meta x))
- (exts (program-external x))
+ (free-vars (program-free-variables x))
(binds (program-bindings x))
(srcs (program-sources x))
(nargs (arity:nargs (program-arity x))))
- (let ((blocs (and binds
- (collapse-locals
- (append (list-head binds nargs)
- (filter (lambda (x) (not (binding:extp x)))
- (list-tail binds nargs))))))
- (bexts (and binds
- (filter binding:extp binds))))
+ (let ((blocs (and binds (collapse-locals binds))))
(values (program-objcode x)
`((objects . ,objs)
(meta . ,(and meta (meta)))
- (exts . ,exts)
+ (free-vars . ,free-vars)
(blocs . ,blocs)
- (bexts . ,bexts)
(sources . ,srcs))))))
((objcode? x)
(values x #f))
(1+ n) 1))))
(let ((nlocs (car (hashq-ref allocation x))))
(make-glil-program
- nargs nrest nlocs 0 (lambda-meta x)
+ nargs nrest nlocs (lambda-meta x)
(with-output-to-code
(lambda (emit-code)
;; write bindings and source debugging info
-s Display stack
-l Display local variables
- -e Display external variables
-b Bytecode level trace"
(apply vm-trace (repl-vm repl)
(repl-compile repl (repl-parse repl form))
;;; Guile VM frame functions
-;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
;;; Copyright (C) 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
;;;
;;; This program is free software; you can redistribute it and/or modify
vm-frame-program
vm-frame-local-ref vm-frame-local-set!
vm-frame-return-address vm-frame-mv-return-address
- vm-frame-dynamic-link vm-frame-external-link
+ vm-frame-dynamic-link
vm-frame-stack
vm-frame-number vm-frame-address
- make-frame-chain
- print-frame print-frame-chain-as-backtrace
- frame-arguments frame-local-variables frame-external-variables
- frame-environment
- frame-variable-exists? frame-variable-ref frame-variable-set!
- frame-object-name
- frame-local-ref frame-external-link frame-local-set!
- frame-return-address frame-program
- frame-dynamic-link heap-frame?))
+ make-frame-chain
+ print-frame print-frame-chain-as-backtrace
+ frame-arguments frame-local-variables
+ frame-environment
+ frame-variable-exists? frame-variable-ref frame-variable-set!
+ frame-object-name
+ frame-local-ref frame-local-set!
+ frame-return-address frame-program
+ frame-dynamic-link heap-frame?))
(load-extension "libguile" "scm_init_frames")
(l '() (cons (frame-local-ref frame n) l)))
((< n 0) l))))
-(define (frame-external-variables frame)
- (frame-external-link frame))
-
-(define (frame-external-ref frame index)
- (list-ref (frame-external-link frame) index))
-
-(define (frame-external-set! frame index val)
- (list-set! (frame-external-link frame) index val))
-
(define (frame-binding-ref frame binding)
- (if (binding:extp binding)
- (frame-external-ref frame (binding:index binding))
- (frame-local-ref frame (binding:index binding))))
+ (let ((x (frame-local-ref frame (binding:index binding))))
+ (if (and (binding:boxed? binding) (variable? x))
+ (variable-ref x)
+ x)))
(define (frame-binding-set! frame binding val)
- (if (binding:extp binding)
- (frame-external-set! frame (binding:index binding) val)
- (frame-local-set! frame (binding:index binding) val)))
+ (if (binding:boxed? binding)
+ (let ((v (frame-local-ref frame binding)))
+ (if (variable? v)
+ (variable-set! v val)
+ (frame-local-set! frame binding (make-variable val))))
+ (frame-local-set! frame binding val)))
;; FIXME handle #f program-bindings return
(define (frame-bindings frame addr)
(define-module (system vm program)
#:export (make-program
- arity:nargs arity:nrest arity:nlocs arity:nexts
+ arity:nargs arity:nrest arity:nlocs
- make-binding binding:name binding:extp binding:index
+ make-binding binding:name binding:boxed? binding:index
binding:start binding:end
source:addr source:line source:column source:file
(define arity:nrest cadr)
(define arity:nlocs caddr)
-(define (make-binding name extp index start end)
- (list name extp index start end))
+(define (make-binding name boxed? index start end)
+ (list name boxed? index start end))
(define (binding:name b) (list-ref b 0))
-(define (binding:extp b) (list-ref b 1))
+(define (binding:boxed? b) (list-ref b 1))
(define (binding:index b) (list-ref b 2))
(define (binding:start b) (list-ref b 3))
(define (binding:end b) (list-ref b 4))
;;; Guile VM tracer
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 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
((null? opts) (newline))
(case (car opts)
((:s) (puts (truncate! (vm-fetch-stack vm) 3)))
- ((:l) (puts (vm-fetch-locals vm)))
- ((:e) (puts (vm-fetch-externals vm))))))
+ ((:l) (puts (vm-fetch-locals vm))))))
(define (trace-apply vm)
(if (vm-option vm 'trace-first)
(vector 'load-keyword 0 0 3 (char->integer #\q) (char->integer #\u)
(char->integer #\x)))
- (comp-test '(load-program 3 2 1 0 () 3 #f (make-int8 3) (return))
+ (comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return))
(list->vector
`(load-program
- 3 2 1 0 ;; nargs, nrest, nlocs, nexts
+ 3 2 1 0 ;; nargs, nrest, nlocs, unused
,@(u32->u8-list 3) ;; len
,@(u32->u8-list 0) ;; metalen
make-int8 3
return)))
- (comp-test '(load-program 3 2 1 0 () 3
- (load-program 3 2 1 0 () 3
+ (comp-test '(load-program 3 2 1 () 3
+ (load-program 3 2 1 () 3
#f
(make-int8 3) (return))
(make-int8 3) (return))
(list->vector
`(load-program
- 3 2 1 0 ;; nargs, nrest, nlocs, nexts
+ 3 2 1 0 ;; nargs, nrest, nlocs, unused
,@(u32->u8-list 3) ;; len
,@(u32->u8-list (+ 3 12)) ;; metalen
make-int8 3
return
- 3 2 1 0 ;; nargs, nrest, nlocs, nexts
+ 3 2 1 0 ;; nargs, nrest, nlocs, unused
,@(u32->u8-list 3) ;; len
,@(u32->u8-list 0) ;; metalen
make-int8 3
(with-test-prefix "void"
(assert-tree-il->glil
(void)
- (program 0 0 0 0 () (void) (call return 1)))
+ (program 0 0 0 () (void) (call return 1)))
(assert-tree-il->glil
(begin (void) (const 1))
- (program 0 0 0 0 () (const 1) (call return 1)))
+ (program 0 0 0 () (const 1) (call return 1)))
(assert-tree-il->glil
(apply (primitive +) (void) (const 1))
- (program 0 0 0 0 () (void) (const 1) (call add 2) (call return 1))))
+ (program 0 0 0 () (void) (const 1) (call add 2) (call return 1))))
(with-test-prefix "application"
(assert-tree-il->glil
(apply (toplevel foo) (const 1))
- (program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
+ (program 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
(assert-tree-il->glil/pmatch
(begin (apply (toplevel foo) (const 1)) (void))
- (program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
+ (program 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2)
(label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel bar)))
- (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
+ (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
(call goto/args 1))))
(with-test-prefix "conditional"
(assert-tree-il->glil/pmatch
(if (const #t) (const 1) (const 2))
- (program 0 0 0 0 () (const #t) (branch br-if-not ,l1)
+ (program 0 0 0 () (const #t) (branch br-if-not ,l1)
(const 1) (call return 1)
(label ,l2) (const 2) (call return 1))
(eq? l1 l2))
(assert-tree-il->glil/pmatch
(begin (if (const #t) (const 1) (const 2)) (const #f))
- (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2)
+ (program 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2)
(label ,l3) (label ,l4) (const #f) (call return 1))
(eq? l1 l3) (eq? l2 l4))
(assert-tree-il->glil/pmatch
(apply (primitive null?) (if (const #t) (const 1) (const 2)))
- (program 0 0 0 0 () (const #t) (branch br-if-not ,l1)
+ (program 0 0 0 () (const #t) (branch br-if-not ,l1)
(const 1) (branch br ,l2)
(label ,l3) (const 2) (label ,l4)
(call null? 1) (call return 1))
(with-test-prefix "primitive-ref"
(assert-tree-il->glil
(primitive +)
- (program 0 0 0 0 () (toplevel ref +) (call return 1)))
+ (program 0 0 0 () (toplevel ref +) (call return 1)))
(assert-tree-il->glil
(begin (primitive +) (const #f))
- (program 0 0 0 0 () (const #f) (call return 1)))
+ (program 0 0 0 () (const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (primitive +))
- (program 0 0 0 0 () (toplevel ref +) (call null? 1)
+ (program 0 0 0 () (toplevel ref +) (call null? 1)
(call return 1))))
(with-test-prefix "lexical refs"
(assert-tree-il->glil
(let (x) (y) ((const 1)) (lexical x y))
- (program 0 0 1 0 ()
+ (program 0 0 1 ()
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
- (program 0 0 1 0 ()
+ (program 0 0 1 ()
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(const #f) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
- (program 0 0 1 0 ()
+ (program 0 0 1 ()
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call null? 1) (call return 1)
(unbind))))
(with-test-prefix "lexical sets"
(assert-tree-il->glil
(let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
- (program 0 0 1 0 ()
+ (program 0 0 1 ()
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(const 2) (lexical #t #t set 0) (void) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f)))
- (program 0 0 1 0 ()
+ (program 0 0 1 ()
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(const 2) (lexical #t #t set 0) (const #f) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1))
(apply (primitive null?) (set! (lexical x y) (const 2))))
- (program 0 0 1 0 ()
+ (program 0 0 1 ()
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1)
(unbind))))
(with-test-prefix "module refs"
(assert-tree-il->glil
(@ (foo) bar)
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(module public ref (foo) bar)
(call return 1)))
(assert-tree-il->glil
(begin (@ (foo) bar) (const #f))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(module public ref (foo) bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (@ (foo) bar))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(module public ref (foo) bar)
(call null? 1) (call return 1)))
(assert-tree-il->glil
(@@ (foo) bar)
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(module private ref (foo) bar)
(call return 1)))
(assert-tree-il->glil
(begin (@@ (foo) bar) (const #f))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(module private ref (foo) bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (@@ (foo) bar))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(module private ref (foo) bar)
(call null? 1) (call return 1))))
(with-test-prefix "module sets"
(assert-tree-il->glil
(set! (@ (foo) bar) (const 2))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const 2) (module public set (foo) bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (@ (foo) bar) (const 2)) (const #f))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const 2) (module public set (foo) bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (@ (foo) bar) (const 2)))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const 2) (module public set (foo) bar)
(void) (call null? 1) (call return 1)))
(assert-tree-il->glil
(set! (@@ (foo) bar) (const 2))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const 2) (module private set (foo) bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (@@ (foo) bar) (const 2)) (const #f))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const 2) (module private set (foo) bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const 2) (module private set (foo) bar)
(void) (call null? 1) (call return 1))))
(with-test-prefix "toplevel refs"
(assert-tree-il->glil
(toplevel bar)
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(toplevel ref bar)
(call return 1)))
(assert-tree-il->glil
(begin (toplevel bar) (const #f))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(toplevel ref bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (toplevel bar))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(toplevel ref bar)
(call null? 1) (call return 1))))
(with-test-prefix "toplevel sets"
(assert-tree-il->glil
(set! (toplevel bar) (const 2))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const 2) (toplevel set bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (toplevel bar) (const 2)) (const #f))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const 2) (toplevel set bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (toplevel bar) (const 2)))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const 2) (toplevel set bar)
(void) (call null? 1) (call return 1))))
(with-test-prefix "toplevel defines"
(assert-tree-il->glil
(define bar (const 2))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const 2) (toplevel define bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (define bar (const 2)) (const #f))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const 2) (toplevel define bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (define bar (const 2)))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const 2) (toplevel define bar)
(void) (call null? 1) (call return 1))))
(with-test-prefix "constants"
(assert-tree-il->glil
(const 2)
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const 2) (call return 1)))
(assert-tree-il->glil
(begin (const 2) (const #f))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (const 2))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const 2) (call null? 1) (call return 1))))
(with-test-prefix "lambda"
(assert-tree-il->glil
(lambda (x) (y) () (const 2))
- (program 0 0 0 0 ()
- (program 1 0 0 0 ()
+ (program 0 0 0 ()
+ (program 1 0 0 ()
(bind (x #f 0))
(const 2) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x x1) (y y1) () (const 2))
- (program 0 0 0 0 ()
- (program 2 0 0 0 ()
+ (program 0 0 0 ()
+ (program 2 0 0 ()
(bind (x #f 0) (x1 #f 1))
(const 2) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda x y () (const 2))
- (program 0 0 0 0 ()
- (program 1 1 0 0 ()
+ (program 0 0 0 ()
+ (program 1 1 0 ()
(bind (x #f 0))
(const 2) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x . x1) (y . y1) () (const 2))
- (program 0 0 0 0 ()
- (program 2 1 0 0 ()
+ (program 0 0 0 ()
+ (program 2 1 0 ()
(bind (x #f 0) (x1 #f 1))
(const 2) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x . x1) (y . y1) () (lexical x y))
- (program 0 0 0 0 ()
- (program 2 1 0 0 ()
+ (program 0 0 0 ()
+ (program 2 1 0 ()
(bind (x #f 0) (x1 #f 1))
(lexical #t #f ref 0) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x . x1) (y . y1) () (lexical x1 y1))
- (program 0 0 0 0 ()
- (program 2 1 0 0 ()
+ (program 0 0 0 ()
+ (program 2 1 0 ()
(bind (x #f 0) (x1 #f 1))
(lexical #t #f ref 1) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
- (program 0 0 0 0 ()
- (program 1 0 0 0 ()
+ (program 0 0 0 ()
+ (program 1 0 0 ()
(bind (x #f 0))
- (program 1 0 0 0 ()
+ (program 1 0 0 ()
(bind (y #f 0))
(lexical #f #f ref 0) (call return 1))
(lexical #t #f ref 0)
(with-test-prefix "sequence"
(assert-tree-il->glil
(begin (begin (const 2) (const #f)) (const #t))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const #t) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (begin (const #f) (const 2)))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(const 2) (call null? 1) (call return 1))))
;; FIXME: binding info for or-hacked locals might bork the disassembler,
(lexical x y)
(let (a) (b) ((const 2))
(lexical a b))))
- (program 0 0 1 0 ()
+ (program 0 0 1 ()
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (branch br-if-not ,l1)
(lexical #t #f ref 0) (call return 1)
(lexical x y)
(let (a) (b) ((const 2))
(lexical x y))))
- (program 0 0 2 0 ()
+ (program 0 0 2 ()
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (branch br-if-not ,l1)
(lexical #t #f ref 0) (call return 1)
(with-test-prefix "apply"
(assert-tree-il->glil
(apply (primitive @apply) (toplevel foo) (toplevel bar))
- (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
+ (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
(assert-tree-il->glil/pmatch
(begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(toplevel ref foo)
(toplevel ref bar) (toplevel ref baz) (call apply 2)
(call goto/args 1))))
(with-test-prefix "call/cc"
(assert-tree-il->glil
(apply (primitive @call-with-current-continuation) (toplevel foo))
- (program 0 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
+ (program 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
(assert-tree-il->glil/pmatch
(begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
(assert-tree-il->glil
(apply (toplevel foo)
(apply (toplevel @call-with-current-continuation) (toplevel bar)))
- (program 0 0 0 0 ()
+ (program 0 0 0 ()
(toplevel ref foo)
(toplevel ref bar) (call call/cc 1)
(call goto/args 1))))
HCoop / bpt / guile.git / commitdiff