mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 08:40:19 +02:00
Code Activity

allow primcall ops to push 0 values

Browse source 
* libguile/objcodes.c (OBJCODE_COOKIE): Bump the objcode cookie. We'll
  be doing this on incompatible changes until 2.0.

* libguile/vm-i-scheme.c (set_car, set_cdr, slot_set): These
  instructions don't have natural return values -- so declare them that
  way, that they push 0 values.

* module/language/tree-il/compile-glil.scm (flatten): When compiling
  primitive calls, check `(instruction-pushes op)' to see how many
  values that instruction will push, and do something appropriate,
  instead of just assuming that all primcall ops push 1 value.
This commit is contained in:
Andy Wingo 2009-06-24 15:14:00 +02:00
parent a84673a68b
commit 60ed31d28b
3 changed files with 34 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

4
libguile/objcodes.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -34,7 +34,7 @@
#include "objcodes.h" #include "objcodes.h"
/* nb, the length of the header should be a multiple of 8 bytes */ /* 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"
/* /*

27
libguile/vm-i-scheme.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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)); 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); VM_VALIDATE_CONS (x);
SCM_SETCAR (x, y); 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); VM_VALIDATE_CONS (x);
SCM_SETCDR (x, y); 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])); 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; size_t slot;
ARGS3 (instance, idx, val); POP (val);
POP (idx);
POP (instance);
slot = SCM_I_INUM (idx); slot = SCM_I_INUM (idx);
SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val); SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
RETURN (SCM_UNSPECIFIED); NEXT;
} }
/* /*

13
module/language/tree-il/compile-glil.scm
View file

@ -22,6 +22,7 @@
#:use-module (system base syntax) #:use-module (system base syntax)
#:use-module (ice-9 receive) #:use-module (ice-9 receive)
#:use-module (language glil) #:use-module (language glil)
#:use-module (system vm instruction)
#:use-module (language tree-il) #:use-module (language tree-il)
#:use-module (language tree-il optimize) #:use-module (language tree-il optimize)
#:use-module (language tree-il analyze) #:use-module (language tree-il analyze)
@ -305,9 +306,19 @@
=> (lambda (op) => (lambda (op)
(for-each comp-push args) (for-each comp-push args)
(emit-code src (make-glil-call op (length args))) (emit-code src (make-glil-call op (length args)))
(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 (case context
((tail) (emit-code #f (make-glil-call 'return 1))) ((tail) (emit-code #f (make-glil-call 'return 1)))
((drop) (emit-code #f (make-glil-call 'drop 1)))))) ((drop) (emit-code #f (make-glil-call 'drop 1)))))
(else
(error "bad primitive op: too many pushes"
op (instruction-pushes op))))))
(else (else
(comp-push proc) (comp-push proc)