mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-18 17:50:29 +02:00
remove all mentions of "external" from the compiler and related code
With this, GHIL is effectively bitrotten. I need to port the ECMAScript
compiler to tree-il, then I'll remove it.
* module/language/assembly.scm (byte-length):
* module/language/assembly/compile-bytecode.scm (write-bytecode):
* module/language/assembly/decompile-bytecode.scm (decode-load-program):
* module/language/assembly/disassemble.scm (disassemble-load-program):
(disassemble-free-vars, code-annotation):
* module/language/glil.scm (<glil-program>, <glil-local>)
(<glil-exteral>, parse-glil, unparse-glil):
* module/language/glil/compile-assembly.scm (make-meta):
(compile-assembly, glil->assembly):
* module/language/glil/decompile-assembly.scm (decompile-toplevel):
(decompile-load-program):
* module/language/objcode/spec.scm (decompile-value):
* module/language/tree-il/compile-glil.scm (flatten-lambda):
* module/system/vm/frame.scm (frame-binding-ref):
(frame-binding-set!):
* module/system/vm/program.scm (binding:boxed?):
* module/system/vm/trace.scm (trace-next):
* test-suite/tests/asm-to-bytecode.test ("compiler"):
* test-suite/tests/tree-il.test: Remove all mentions of "external", and
of <glil-local>. Docs updates will come soon.
This commit is contained in:
Andy Wingo
parent
57ab0671d7
commit
476e357281
15 changed files with 196 additions and 269 deletions
|
|
@ -28,7 +28,7 @@
|
|||
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
|
||||
|
|
@ -54,7 +54,7 @@
|
|||
(+ 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)))
|
||||
|
|
|
|||
|
|
@ -89,12 +89,11 @@
|
|||
(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)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
|
|
@ -49,7 +49,7 @@
|
|||
(- 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)))
|
||||
|
|
@ -74,7 +74,7 @@
|
|||
(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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
|
|
@ -35,12 +35,11 @@
|
|||
|
||||
(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
|
||||
|
|
@ -63,13 +62,13 @@
|
|||
(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))
|
||||
|
||||
|
|
@ -92,13 +91,12 @@
|
|||
((= 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)))
|
||||
|
|
@ -122,7 +120,7 @@
|
|||
(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)))
|
||||
|
|
@ -133,7 +131,7 @@
|
|||
(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)
|
||||
|
|
@ -143,13 +141,9 @@
|
|||
(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))))
|
||||
|
|
|
|||
|
|
@ -24,9 +24,9 @@
|
|||
#: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
|
||||
|
||||
|
|
@ -43,12 +43,6 @@
|
|||
<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
|
||||
|
||||
|
|
@ -77,7 +71,7 @@
|
|||
|
||||
(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>)
|
||||
|
|
@ -86,8 +80,6 @@
|
|||
(<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?)
|
||||
|
|
@ -97,35 +89,18 @@
|
|||
(<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))
|
||||
|
||||
|
||||
|
||||
(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))
|
||||
|
|
@ -139,8 +114,8 @@
|
|||
(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))
|
||||
|
|
@ -149,8 +124,6 @@
|
|||
((<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)
|
||||
|
|
|
|||
|
|
@ -72,7 +72,7 @@
|
|||
(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))))))
|
||||
|
|
@ -128,13 +128,13 @@
|
|||
|
||||
(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))
|
||||
|
|
@ -142,60 +142,56 @@
|
|||
(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))
|
||||
(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) 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))))))))
|
||||
((<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 ,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)))))))))))
|
||||
(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
|
||||
(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
|
||||
;; otherwise emit a load directly
|
||||
(emit-code `(,@table ,@(align-program prog (addr+ addr table))))))))))))
|
||||
|
||||
|
||||
((<glil-bind> vars)
|
||||
(values '()
|
||||
|
|
@ -244,19 +240,6 @@
|
|||
,(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?
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
|
|
@ -31,8 +31,8 @@
|
|||
|
||||
(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
|
||||
|
|
@ -56,7 +56,7 @@
|
|||
((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))))
|
||||
|
|
@ -100,19 +100,11 @@
|
|||
(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)
|
||||
|
|
|
|||
|
|
@ -66,23 +66,16 @@
|
|||
((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))
|
||||
|
|
|
|||
|
|
@ -172,7 +172,7 @@
|
|||
(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
|
||||
|
|
|
|||
|
|
@ -386,7 +386,6 @@ Trace execution.
|
|||
|
||||
-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))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
|
|
@ -27,20 +27,20 @@
|
|||
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")
|
||||
|
||||
|
|
@ -158,24 +158,19 @@
|
|||
(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)
|
||||
|
|
|
|||
|
|
@ -21,9 +21,9 @@
|
|||
(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
|
||||
|
|
@ -41,10 +41,10 @@
|
|||
(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))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
|
|
@ -54,8 +54,7 @@
|
|||
((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)
|
||||
|
|
|
|||
|
|
@ -85,28 +85,28 @@
|
|||
(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
|
||||
|
|
|
|||
|
|
@ -64,21 +64,21 @@
|
|||
(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)
|
||||
|
|
@ -86,26 +86,26 @@
|
|||
(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))
|
||||
|
|
@ -114,35 +114,35 @@
|
|||
(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))))
|
||||
|
|
@ -150,14 +150,14 @@
|
|||
(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)))
|
||||
|
|
@ -165,7 +165,7 @@
|
|||
(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))))
|
||||
|
|
@ -173,205 +173,205 @@
|
|||
(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)
|
||||
|
|
@ -383,12 +383,12 @@
|
|||
(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,
|
||||
|
|
@ -400,7 +400,7 @@
|
|||
(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)
|
||||
|
|
@ -417,7 +417,7 @@
|
|||
(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)
|
||||
|
|
@ -431,10 +431,10 @@
|
|||
(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)
|
||||
|
|
@ -442,7 +442,7 @@
|
|||
(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))))
|
||||
|
|
@ -450,10 +450,10 @@
|
|||
(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)
|
||||
|
|
@ -462,7 +462,7 @@
|
|||
(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))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue