diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 6b69fb77f..fc59c09a4 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -1,4 +1,4 @@ -/* 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 License @@ -34,7 +34,7 @@ #include "objcodes.h" /* nb, the length of the header should be a multiple of 8 bytes */ -#define OBJCODE_COOKIE "GOOF-0.5" +#define OBJCODE_COOKIE "GOOF-0.6" /* diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 02139c073..4fc026c48 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -1,4 +1,4 @@ -/* 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 License @@ -131,20 +131,24 @@ VM_DEFINE_FUNCTION (92, cdr, "cdr", 1) RETURN (SCM_CDR (x)); } -VM_DEFINE_FUNCTION (93, set_car, "set-car!", 2) +VM_DEFINE_INSTRUCTION (93, set_car, "set-car!", 0, 2, 0) { - ARGS2 (x, y); + SCM x, y; + POP (y); + POP (x); VM_VALIDATE_CONS (x); SCM_SETCAR (x, y); - RETURN (SCM_UNSPECIFIED); + NEXT; } -VM_DEFINE_FUNCTION (94, set_cdr, "set-cdr!", 2) +VM_DEFINE_INSTRUCTION (94, set_cdr, "set-cdr!", 0, 2, 0) { - ARGS2 (x, y); + SCM x, y; + POP (y); + POP (x); VM_VALIDATE_CONS (x); SCM_SETCDR (x, y); - RETURN (SCM_UNSPECIFIED); + NEXT; } @@ -263,13 +267,16 @@ VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2) RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot])); } -VM_DEFINE_FUNCTION (108, slot_set, "slot-set", 3) +VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0) { + SCM instance, idx, val; size_t slot; - ARGS3 (instance, idx, val); + POP (val); + POP (idx); + POP (instance); slot = SCM_I_INUM (idx); SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val); - RETURN (SCM_UNSPECIFIED); + NEXT; } /* diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 6dade3592..a75843d2f 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -22,6 +22,7 @@ #:use-module (system base syntax) #:use-module (ice-9 receive) #:use-module (language glil) + #:use-module (system vm instruction) #:use-module (language tree-il) #:use-module (language tree-il optimize) #:use-module (language tree-il analyze) @@ -305,10 +306,20 @@ => (lambda (op) (for-each comp-push args) (emit-code src (make-glil-call op (length args))) - (case context - ((tail) (emit-code #f (make-glil-call 'return 1))) - ((drop) (emit-code #f (make-glil-call 'drop 1)))))) - + (case (instruction-pushes op) + ((0) + (case context + ((tail) (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))) + ((push vals) (emit-code #f (make-glil-void))))) + ((1) + (case context + ((tail) (emit-code #f (make-glil-call 'return 1))) + ((drop) (emit-code #f (make-glil-call 'drop 1))))) + (else + (error "bad primitive op: too many pushes" + op (instruction-pushes op)))))) + (else (comp-push proc) (for-each comp-push args)