diff options
-rw-r--r-- | libguile/_scm.h | 2 | ||||
-rw-r--r-- | libguile/gc.c | 1 | ||||
-rw-r--r-- | libguile/objcodes.h | 7 | ||||
-rw-r--r-- | libguile/procprop.c | 115 | ||||
-rw-r--r-- | libguile/procprop.h | 8 | ||||
-rw-r--r-- | libguile/procs.c | 14 | ||||
-rw-r--r-- | libguile/programs.c | 40 | ||||
-rw-r--r-- | libguile/programs.h | 1 | ||||
-rw-r--r-- | libguile/root.h | 15 | ||||
-rw-r--r-- | libguile/vm.c | 4 | ||||
-rw-r--r-- | module/language/assembly.scm | 6 | ||||
-rw-r--r-- | module/language/assembly/compile-bytecode.scm | 6 | ||||
-rw-r--r-- | module/language/assembly/decompile-bytecode.scm | 8 | ||||
-rw-r--r-- | module/language/assembly/disassemble.scm | 6 | ||||
-rw-r--r-- | module/language/glil.scm | 11 | ||||
-rw-r--r-- | module/language/glil/compile-assembly.scm | 6 | ||||
-rw-r--r-- | module/language/glil/decompile-assembly.scm | 13 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 2 | ||||
-rw-r--r-- | module/system/xref.scm | 2 | ||||
-rw-r--r-- | test-suite/tests/asm-to-bytecode.test | 14 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 134 |
21 files changed, 210 insertions, 205 deletions
diff --git a/libguile/_scm.h b/libguile/_scm.h index f506f55b8..53b698e98 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -172,7 +172,7 @@ /* Major and minor versions must be single characters. */ #define SCM_OBJCODE_MAJOR_VERSION 0 -#define SCM_OBJCODE_MINOR_VERSION G +#define SCM_OBJCODE_MINOR_VERSION H #define SCM_OBJCODE_MAJOR_VERSION_STRING \ SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION) #define SCM_OBJCODE_MINOR_VERSION_STRING \ diff --git a/libguile/gc.c b/libguile/gc.c index 7c508affd..9c56d0412 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -680,7 +680,6 @@ scm_init_storage () #endif - scm_stand_in_procs = scm_make_weak_key_hash_table (scm_from_int (257)); scm_protects = scm_c_make_hash_table (31); return 0; diff --git a/libguile/objcodes.h b/libguile/objcodes.h index 2bb4e6040..ab4db3dab 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -23,13 +23,9 @@ /* objcode data should be directly mappable to this C structure. */ struct scm_objcode { - scm_t_uint8 nargs; - scm_t_uint8 nrest; - scm_t_uint16 nlocs; scm_t_uint32 len; /* the maximum index of base[] */ scm_t_uint32 metalen; /* well, i lie. this many bytes at the end of base[] for metadata */ - scm_t_uint32 unused; /* pad so that `base' is 8-byte aligned */ scm_t_uint8 base[0]; }; @@ -46,9 +42,6 @@ SCM_API scm_t_bits scm_tc16_objcode; #define SCM_OBJCODE_LEN(x) (SCM_OBJCODE_DATA (x)->len) #define SCM_OBJCODE_META_LEN(x) (SCM_OBJCODE_DATA (x)->metalen) #define SCM_OBJCODE_TOTAL_LEN(x) (SCM_OBJCODE_LEN (x) + SCM_OBJCODE_META_LEN (x)) -#define SCM_OBJCODE_NARGS(x) (SCM_OBJCODE_DATA (x)->nargs) -#define SCM_OBJCODE_NREST(x) (SCM_OBJCODE_DATA (x)->nrest) -#define SCM_OBJCODE_NLOCS(x) (SCM_OBJCODE_DATA (x)->nlocs) #define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base) #define SCM_OBJCODE_IS_MMAP(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP) diff --git a/libguile/procprop.c b/libguile/procprop.c index 5054291b1..4f18dff75 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -42,6 +42,9 @@ SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure"); SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity"); +static SCM non_closure_props; +static scm_i_pthread_mutex_t non_closure_props_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; + SCM scm_i_procedure_arity (SCM proc) { @@ -74,10 +77,10 @@ scm_i_procedure_arity (SCM proc) r = 1; break; case scm_tc7_program: - a += SCM_PROGRAM_DATA (proc)->nargs; - r = SCM_PROGRAM_DATA (proc)->nrest; - a -= r; - break; + if (scm_i_program_arity (proc, &a, &o, &r)) + break; + else + return SCM_BOOL_F; case scm_tc7_lsubr_2: a += 2; r = 1; @@ -137,92 +140,77 @@ scm_i_procedure_arity (SCM proc) return scm_list_3 (scm_from_int (a), scm_from_int (o), scm_from_bool(r)); } -/* XXX - instead of using a stand-in value for everything except - closures, we should find other ways to store the procedure - properties for those other kinds of procedures. For example, subrs - have their own property slot, which is unused at present. -*/ - -static SCM -scm_stand_in_scm_proc(SCM proc) -{ - SCM handle, answer; - handle = scm_hashq_get_handle (scm_stand_in_procs, proc); - if (scm_is_false (handle)) - { - answer = scm_closure (scm_list_2 (SCM_EOL, SCM_BOOL_F), SCM_EOL); - scm_hashq_set_x (scm_stand_in_procs, proc, answer); - } - else - answer = SCM_CDR (handle); - return answer; -} +/* FIXME: instead of the weak hash, perhaps for some kinds of procedures, use + other means; for example subrs have their own property slot, which is unused + at present. */ SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0, (SCM proc), "Return @var{obj}'s property list.") #define FUNC_NAME s_scm_procedure_properties { + SCM props; + SCM_VALIDATE_PROC (1, proc); - return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc), - SCM_PROCPROPS (SCM_CLOSUREP (proc) - ? proc - : scm_stand_in_scm_proc (proc))); + if (SCM_CLOSUREP (proc)) + props = SCM_PROCPROPS (proc); + else + { + scm_i_pthread_mutex_lock (&non_closure_props_lock); + props = scm_hashq_ref (non_closure_props, proc, SCM_EOL); + scm_i_pthread_mutex_unlock (&non_closure_props_lock); + } + return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc), props); } #undef FUNC_NAME SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0, - (SCM proc, SCM new_val), - "Set @var{obj}'s property list to @var{alist}.") + (SCM proc, SCM alist), + "Set @var{proc}'s property list to @var{alist}.") #define FUNC_NAME s_scm_set_procedure_properties_x { - if (!SCM_CLOSUREP (proc)) - proc = scm_stand_in_scm_proc(proc); - SCM_VALIDATE_CLOSURE (1, proc); - SCM_SETPROCPROPS (proc, new_val); + SCM_VALIDATE_PROC (1, proc); + + if (SCM_CLOSUREP (proc)) + SCM_SETPROCPROPS (proc, alist); + else + { + scm_i_pthread_mutex_lock (&non_closure_props_lock); + scm_hashq_set_x (non_closure_props, proc, alist); + scm_i_pthread_mutex_unlock (&non_closure_props_lock); + } return SCM_UNSPECIFIED; } #undef FUNC_NAME SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0, - (SCM p, SCM k), - "Return the property of @var{obj} with name @var{key}.") + (SCM proc, SCM key), + "Return the property of @var{proc} with name @var{key}.") #define FUNC_NAME s_scm_procedure_property { - SCM assoc; - if (scm_is_eq (k, scm_sym_arity)) - { - SCM arity; - SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (p)), - p, SCM_ARG1, FUNC_NAME); - return arity; - } - SCM_VALIDATE_PROC (1, p); - assoc = scm_sloppy_assq (k, - SCM_PROCPROPS (SCM_CLOSUREP (p) - ? p - : scm_stand_in_scm_proc (p))); - return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F); + SCM_VALIDATE_PROC (1, proc); + + if (scm_is_eq (key, scm_sym_arity)) + /* avoid a cons in this case */ + return scm_i_procedure_arity (proc); + else + return scm_assq_ref (scm_procedure_properties (proc), key); } #undef FUNC_NAME SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, - (SCM p, SCM k, SCM v), - "In @var{obj}'s property list, set the property named @var{key} to\n" - "@var{value}.") + (SCM proc, SCM key, SCM val), + "In @var{proc}'s property list, set the property named @var{key} to\n" + "@var{val}.") #define FUNC_NAME s_scm_set_procedure_property_x { - SCM assoc; - if (!SCM_CLOSUREP (p)) - p = scm_stand_in_scm_proc(p); - SCM_VALIDATE_CLOSURE (1, p); - if (scm_is_eq (k, scm_sym_arity)) + SCM_VALIDATE_PROC (1, proc); + + if (scm_is_eq (key, scm_sym_arity)) SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL); - assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p)); - if (SCM_NIMP (assoc)) - SCM_SETCDR (assoc, v); - else - SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p))); + scm_set_procedure_properties_x + (proc, + scm_assq_set_x (scm_procedure_properties (proc), key, val)); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -233,6 +221,7 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, void scm_init_procprop () { + non_closure_props = scm_make_doubly_weak_hash_table (SCM_UNDEFINED); #include "libguile/procprop.x" } diff --git a/libguile/procprop.h b/libguile/procprop.h index 04cd38442..7a1131489 100644 --- a/libguile/procprop.h +++ b/libguile/procprop.h @@ -3,7 +3,7 @@ #ifndef SCM_PROCPROP_H #define SCM_PROCPROP_H -/* Copyright (C) 1995,1996,1998,2000, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 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 @@ -35,9 +35,9 @@ SCM_API SCM scm_sym_system_procedure; SCM_INTERNAL SCM scm_i_procedure_arity (SCM proc); SCM_API SCM scm_procedure_properties (SCM proc); -SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM new_val); -SCM_API SCM scm_procedure_property (SCM p, SCM k); -SCM_API SCM scm_set_procedure_property_x (SCM p, SCM k, SCM v); +SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist); +SCM_API SCM scm_procedure_property (SCM proc, SCM key); +SCM_API SCM scm_set_procedure_property_x (SCM proc, SCM key, SCM val); SCM_INTERNAL void scm_init_procprop (void); #endif /* SCM_PROCPROP_H */ diff --git a/libguile/procs.c b/libguile/procs.c index 40d6231bb..5de2f33f1 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -144,16 +144,18 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, case scm_tc7_gsubr: return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0); case scm_tc7_program: - return scm_from_bool (SCM_PROGRAM_DATA (obj)->nargs == 0 - || (SCM_PROGRAM_DATA (obj)->nargs == 1 - && SCM_PROGRAM_DATA (obj)->nrest)); + { + int a, o, r; + if (scm_i_program_arity (obj, &a, &o, &r)) + return scm_from_bool (a == 0); + else + return SCM_BOOL_F; + } case scm_tc7_pws: obj = SCM_PROCEDURE (obj); goto again; default: - if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_DATA (obj)->nargs == 0) - return SCM_BOOL_T; - /* otherwise fall through */ + return SCM_BOOL_F; } } return SCM_BOOL_F; diff --git a/libguile/programs.c b/libguile/programs.c index 773dc991a..61a0f11e7 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -282,11 +282,51 @@ SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0, } #undef FUNC_NAME +/* This one is a shim to pre-case-lambda internal interfaces. Avoid it if you + can -- use program-arguments or the like. */ +static SCM sym_arglist; +int +scm_i_program_arity (SCM program, int *req, int *opt, int *rest) +{ + SCM arities, x; + + arities = scm_program_arities (program); + if (!scm_is_pair (arities)) + return 0; + /* take the last arglist, it will be least specific */ + while (scm_is_pair (scm_cdr (arities))) + arities = scm_cdr (arities); + x = scm_cdar (arities); + if (scm_is_pair (x)) + { + *req = scm_to_int (scm_car (x)); + x = scm_cdr (x); + if (scm_is_pair (x)) + { + *opt = scm_to_int (scm_car (x)); + x = scm_cdr (x); + if (scm_is_pair (x)) + *rest = scm_is_true (scm_car (x)); + else + *rest = 0; + } + else + *opt = *rest = 0; + } + else + *req = *opt = *rest = 0; + + return 1; +} + void scm_bootstrap_programs (void) { + /* arglist can't be snarfed, because snarfage is only loaded when (system vm + program) is loaded. perhaps static-alloc will fix this. */ + sym_arglist = scm_from_locale_symbol ("arglist"); scm_c_register_extension ("libguile", "scm_init_programs", (scm_t_extension_init_func)scm_init_programs, NULL); } diff --git a/libguile/programs.h b/libguile/programs.h index b114ad942..836f1ff0d 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -54,6 +54,7 @@ SCM_API SCM scm_program_objcode (SCM program); SCM_API SCM scm_c_program_source (SCM program, size_t ip); +SCM_INTERNAL int scm_i_program_arity (SCM program, int *req, int *opt, int *rest); SCM_INTERNAL void scm_i_program_print (SCM program, SCM port, scm_print_state *pstate); SCM_INTERNAL void scm_bootstrap_programs (void); diff --git a/libguile/root.h b/libguile/root.h index 676a7b44c..46b9be013 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -3,7 +3,7 @@ #ifndef SCM_ROOT_H #define SCM_ROOT_H -/* Copyright (C) 1996,1998,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1996,1998,2000,2001, 2002, 2006, 2008, 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,13 +34,12 @@ #define scm_nullvect scm_sys_protects[2] #define scm_nullstr scm_sys_protects[3] #define scm_keyword_obarray scm_sys_protects[4] -#define scm_stand_in_procs scm_sys_protects[5] -#define scm_object_whash scm_sys_protects[6] -#define scm_asyncs scm_sys_protects[7] -#define scm_protects scm_sys_protects[8] -#define scm_properties_whash scm_sys_protects[9] -#define scm_source_whash scm_sys_protects[10] -#define SCM_NUM_PROTECTS 11 +#define scm_object_whash scm_sys_protects[5] +#define scm_asyncs scm_sys_protects[6] +#define scm_protects scm_sys_protects[7] +#define scm_properties_whash scm_sys_protects[8] +#define scm_source_whash scm_sys_protects[9] +#define SCM_NUM_PROTECTS 10 SCM_API SCM scm_sys_protects[]; diff --git a/libguile/vm.c b/libguile/vm.c index cd730511f..df02f0595 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -191,12 +191,8 @@ really_make_boot_program (long nargs) bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text)); memcpy (bp->base, text, sizeof (text)); - bp->nargs = 0; - bp->nrest = 0; - bp->nlocs = 0; bp->len = sizeof(text); bp->metalen = 0; - bp->unused = 0; u8vec = scm_take_u8vector ((scm_t_uint8*)bp, sizeof (struct scm_objcode) + sizeof (text)); diff --git a/module/language/assembly.scm b/module/language/assembly.scm index 2b22fd834..a7c47492e 100644 --- a/module/language/assembly.scm +++ b/module/language/assembly.scm @@ -28,8 +28,8 @@ assembly-pack assembly-unpack object->assembly assembly->object)) -;; nargs, nrest, nlocs, len, metalen, padding -(define *program-header-len* (+ 1 1 2 4 4 4)) +;; len, metalen +(define *program-header-len* (+ 4 4)) ;; lengths are encoded in 3 bytes (define *len-len* 3) @@ -49,7 +49,7 @@ (+ 1 *len-len* (string-length str))) ((load-array ,bv) (+ 1 *len-len* (bytevector-length bv))) - ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code) + ((load-program ,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))) diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index 5a8098112..d92821cc9 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -104,13 +104,9 @@ (len (instruction-length inst))) (write-byte opcode) (pmatch asm - ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code) - (write-byte nargs) - (write-byte nrest) - (write-uint16 nlocs) + ((load-program ,labels ,length ,meta . ,code) (write-uint32 length) (write-uint32 (if meta (1- (byte-length meta)) 0)) - (write-uint32 0) ; padding (letrec ((i 0) (write (lambda (x) (set! i (1+ i)) (write-byte x))) (get-addr (lambda () i))) diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm index 559abeab7..6c929cb33 100644 --- a/module/language/assembly/decompile-bytecode.scm +++ b/module/language/assembly/decompile-bytecode.scm @@ -51,13 +51,10 @@ ;; FIXME: this is a little-endian disassembly!!! (define (decode-load-program pop) - (let* ((nargs (pop)) (nrest (pop)) (nlocs0 (pop)) (nlocs1 (pop)) - (nlocs (+ nlocs0 (ash nlocs1 8))) - (a (pop)) (b (pop)) (c (pop)) (d (pop)) + (let* ((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))) (metalen (+ e (ash f 8) (ash g 16) (ash h 24))) - (%unused-pad (begin (pop) (pop) (pop) (pop))) (labels '()) (i 0)) (define (ensure-label rel1 rel2 rel3) @@ -77,8 +74,7 @@ (cond ((> i len) (error "error decoding program -- read too many bytes" out)) ((= i len) - `(load-program ,nargs ,nrest ,nlocs - ,(map (lambda (x) (cons (cdr x) (car x))) + `(load-program ,(map (lambda (x) (cons (cdr x) (car x))) (reverse labels)) ,len ,(if (zero? metalen) #f (decode-load-program pop)) diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm index c7b9df96d..ae2d32787 100644 --- a/module/language/assembly/disassemble.scm +++ b/module/language/assembly/disassemble.scm @@ -35,7 +35,7 @@ (define (disassemble-load-program asm env) (pmatch asm - ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code) + ((load-program ,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))) @@ -64,7 +64,9 @@ (lp (+ pos (byte-length asm)) (cdr code) programs)) (else (print-info pos asm - (code-annotation end asm objs nargs blocs + ;; FIXME: code-annotation for whether it's + ;; an arg or not, currently passing nargs=-1 + (code-annotation end asm objs -1 blocs labels) (and=> (and srcs (assq end srcs)) source->string)) (lp (+ pos (byte-length asm)) (cdr code) programs))))))) diff --git a/module/language/glil.scm b/module/language/glil.scm index 7f326efc1..7e8d73d94 100644 --- a/module/language/glil.scm +++ b/module/language/glil.scm @@ -24,7 +24,6 @@ #: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-meta glil-program-body <glil-arity> make-glil-arity glil-arity? @@ -74,7 +73,7 @@ (define-type (<glil> #:printer print-glil) ;; Meta operations - (<glil-program> nargs nrest nlocs meta body) + (<glil-program> meta body) (<glil-arity> nargs nrest label) (<glil-bind> vars) (<glil-mv-bind> vars rest) @@ -97,8 +96,8 @@ (define (parse-glil x) (pmatch x - ((program ,nargs ,nrest ,nlocs ,meta . ,body) - (make-glil-program nargs nrest nlocs meta (map parse-glil body))) + ((program ,meta . ,body) + (make-glil-program meta (map parse-glil body))) ((arity ,nargs ,nrest ,label) (make-glil-arity nargs nrest label)) ((bind . ,vars) (make-glil-bind vars)) ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest)) @@ -119,8 +118,8 @@ (define (unparse-glil glil) (record-case glil ;; meta - ((<glil-program> nargs nrest nlocs meta body) - `(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body))) + ((<glil-program> meta body) + `(program ,meta ,@(map unparse-glil body))) ((<glil-arity> nargs nrest label) `(arity ,nargs ,nrest ,label)) ((<glil-bind> vars) `(bind ,@vars)) ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest)) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index 8ff35ca7b..48d747453 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -72,7 +72,7 @@ (if (and (null? bindings) (null? sources) (null? tail)) #f (compile-assembly - (make-glil-program 0 0 0 '() + (make-glil-program '() (list (make-glil-const `(,bindings ,sources ,arities ,@tail)) (make-glil-call 'return 1)))))) @@ -156,7 +156,7 @@ (begin-arity (addr+ addr x) nreq nopt rest? kw arities))) (record-case glil - ((<glil-program> nargs nrest nlocs meta body) + ((<glil-program> meta body) (define (process-body) (let lp ((body body) (code '()) (bindings '(())) (source-alist '()) (label-alist '()) (object-alist (if toplevel? #f '())) @@ -184,7 +184,7 @@ (process-body) (let* ((meta (make-meta bindings sources arities meta)) (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0)) - (prog `(load-program ,nargs ,nrest ,nlocs ,labels + (prog `(load-program ,labels ,(+ len meta-pad) ,meta ,@code diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm index 3cb887d44..937a67858 100644 --- a/module/language/glil/decompile-assembly.scm +++ b/module/language/glil/decompile-assembly.scm @@ -31,9 +31,8 @@ (define (decompile-toplevel x) (pmatch x - ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body) - (decompile-load-program nargs nrest nlocs - (decompile-meta meta) + ((load-program ,labels ,len ,meta . ,body) + (decompile-load-program (decompile-meta meta) body labels #f)) (else (error "invalid assembly" x)))) @@ -56,7 +55,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 meta body labels +(define (decompile-load-program meta body labels objects) (let ((glil-labels (sort (map (lambda (x) (cons (cdr x) (make-glil-label (car x)))) @@ -100,7 +99,7 @@ (cond ((null? in) (or (null? stack) (error "leftover stack insts" stack body)) - (make-glil-program nargs nrest nlocs props (reverse out) #f)) + (make-glil-program props (reverse out))) ((pop-bindings! pos) => (lambda (bindings) (lp in stack @@ -123,9 +122,9 @@ (lp (cdr in) stack out (1+ pos))) ((make-false) (lp (cdr in) (cons #f stack) out (1+ pos))) - ((load-program ,a ,b ,c ,d ,labels ,sublen ,meta . ,body) + ((load-program ,labels ,sublen ,meta . ,body) (lp (cdr in) - (cons (decompile-load-program a b c d (decompile-meta meta) + (cons (decompile-load-program (decompile-meta meta) body labels (car stack)) (cdr stack)) out diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index fa10d2003..f80ff0378 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -186,7 +186,7 @@ (let ((nlocs (car (hashq-ref allocation x))) (labels (cadr (hashq-ref allocation x)))) (make-glil-program - nargs nrest nlocs (lambda-meta x) + (lambda-meta x) (with-output-to-code (lambda (emit-code) ;; write source info for proc diff --git a/module/system/xref.scm b/module/system/xref.scm index 906ec8e4a..94ecb5bbf 100644 --- a/module/system/xref.scm +++ b/module/system/xref.scm @@ -35,7 +35,7 @@ (progv (make-vector (vector-length objects) #f)) (asm (decompile (program-objcode prog) #:to 'assembly))) (pmatch asm - ((load-program ,nargs ,nrest ,nlocs ,labels ,len . ,body) + ((load-program ,labels ,len . ,body) (for-each (lambda (x) (pmatch x diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index a8e251b83..304a84da9 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -77,34 +77,28 @@ (vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o) (char->integer #\o))) - (comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return)) + (comp-test '(load-program () 3 #f (make-int8 3) (return)) #(load-program - 3 2 (uint16 1) ;; nargs, nrest, nlocs (uint32 3) ;; len (uint32 0) ;; metalen - (uint32 0) ;; padding make-int8 3 return)) ;; the nops are to pad meta to an 8-byte alignment. not strictly ;; necessary for this test, but representative of the common case. - (comp-test '(load-program 3 2 1 () 8 - (load-program 3 2 1 () 3 + (comp-test '(load-program () 8 + (load-program () 3 #f (make-int8 3) (return)) (make-int8 3) (return) (nop) (nop) (nop) (nop) (nop)) #(load-program - 3 2 (uint16 1) ;; nargs, nrest, nlocs (uint32 8) ;; len - (uint32 19) ;; metalen - (uint32 0) ;; padding + (uint32 11) ;; metalen make-int8 3 return nop nop nop nop nop - 3 2 (uint16 1) ;; nargs, nrest, nlocs (uint32 3) ;; len (uint32 0) ;; metalen - (uint32 0) ;; padding make-int8 3 return)))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 41b5d56ba..06e2a3e27 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -69,21 +69,21 @@ (with-test-prefix "void" (assert-tree-il->glil (void) - (program 0 0 0 () (arity 0 0 #f) (void) (call return 1))) + (program () (arity 0 0 #f) (void) (call return 1))) (assert-tree-il->glil (begin (void) (const 1)) - (program 0 0 0 () (arity 0 0 #f) (const 1) (call return 1))) + (program () (arity 0 0 #f) (const 1) (call return 1))) (assert-tree-il->glil (apply (primitive +) (void) (const 1)) - (program 0 0 0 () (arity 0 0 #f) (void) (call add1 1) (call return 1)))) + (program () (arity 0 0 #f) (void) (call add1 1) (call return 1)))) (with-test-prefix "application" (assert-tree-il->glil (apply (toplevel foo) (const 1)) - (program 0 0 0 () (arity 0 0 #f) (toplevel ref foo) (const 1) (call goto/args 1))) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1) + (program () (arity 0 0 #f) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) (label ,l4) @@ -91,26 +91,26 @@ (and (eq? l1 l3) (eq? l2 l4))) (assert-tree-il->glil (apply (toplevel foo) (apply (toplevel bar))) - (program 0 0 0 () (arity 0 0 #f)(toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0) + (program () (arity 0 0 #f)(toplevel ref foo) (call new-frame 0) (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 () (arity 0 0 #f) (const #t) (branch br-if-not ,l1) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) (const #t) (branch br-if-not ,l1) (branch br ,l2) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) (const #t) (branch br-if-not ,l1) + (program () (arity 0 0 #f) (const #t) (branch br-if-not ,l1) (const 1) (branch br ,l2) (label ,l3) (const 2) (label ,l4) (call null? 1) (call return 1)) @@ -119,35 +119,35 @@ (with-test-prefix "primitive-ref" (assert-tree-il->glil (primitive +) - (program 0 0 0 () (arity 0 0 #f) (toplevel ref +) (call return 1))) + (program () (arity 0 0 #f) (toplevel ref +) (call return 1))) (assert-tree-il->glil (begin (primitive +) (const #f)) - (program 0 0 0 () (arity 0 0 #f) (const #f) (call return 1))) + (program () (arity 0 0 #f) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (primitive +)) - (program 0 0 0 () (arity 0 0 #f) (toplevel ref +) (call null? 1) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) (call reserve-locals 1) + (program () (arity 0 0 #f) (call reserve-locals 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 () (arity 0 0 #f) (call reserve-locals 1) + (program () (arity 0 0 #f) (call reserve-locals 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 () (arity 0 0 #f) (call reserve-locals 1) + (program () (arity 0 0 #f) (call reserve-locals 1) (const 1) (bind (x #f 0)) (lexical #t #f set 0) (lexical #t #f ref 0) (call null? 1) (call return 1) (unbind)))) @@ -157,7 +157,7 @@ ;; unreferenced sets may be optimized away -- make sure they are ref'd (let (x) (y) ((const 1)) (set! (lexical x y) (apply (primitive 1+) (lexical x y)))) - (program 0 0 1 () (arity 0 0 #f) (call reserve-locals 1) + (program () (arity 0 0 #f) (call reserve-locals 1) (const 1) (bind (x #t 0)) (lexical #t #t box 0) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void) (call return 1) @@ -167,7 +167,7 @@ (let (x) (y) ((const 1)) (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y))) (lexical x y))) - (program 0 0 1 () (arity 0 0 #f) (call reserve-locals 1) + (program () (arity 0 0 #f) (call reserve-locals 1) (const 1) (bind (x #t 0)) (lexical #t #t box 0) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (lexical #t #t ref 0) (call return 1) @@ -177,7 +177,7 @@ (let (x) (y) ((const 1)) (apply (primitive null?) (set! (lexical x y) (apply (primitive 1+) (lexical x y))))) - (program 0 0 1 () (arity 0 0 #f) (call reserve-locals 1) + (program () (arity 0 0 #f) (call reserve-locals 1) (const 1) (bind (x #t 0)) (lexical #t #t box 0) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void) (call null? 1) (call return 1) @@ -186,205 +186,205 @@ (with-test-prefix "module refs" (assert-tree-il->glil (@ (foo) bar) - (program 0 0 0 () (arity 0 0 #f) + (program () (arity 0 0 #f) (module public ref (foo) bar) (call return 1))) (assert-tree-il->glil (begin (@ (foo) bar) (const #f)) - (program 0 0 0 () (arity 0 0 #f) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (module public ref (foo) bar) (call null? 1) (call return 1))) (assert-tree-il->glil (@@ (foo) bar) - (program 0 0 0 () (arity 0 0 #f) + (program () (arity 0 0 #f) (module private ref (foo) bar) (call return 1))) (assert-tree-il->glil (begin (@@ (foo) bar) (const #f)) - (program 0 0 0 () (arity 0 0 #f) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (toplevel ref bar) (call return 1))) (assert-tree-il->glil (begin (toplevel bar) (const #f)) - (program 0 0 0 () (arity 0 0 #f) + (program () (arity 0 0 #f) (toplevel ref bar) (call drop 1) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (toplevel bar)) - (program 0 0 0 () (arity 0 0 #f) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (const 2) (toplevel define bar) (void) (call return 1))) (assert-tree-il->glil (begin (define bar (const 2)) (const #f)) - (program 0 0 0 () (arity 0 0 #f) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (const 2) (call return 1))) (assert-tree-il->glil (begin (const 2) (const #f)) - (program 0 0 0 () (arity 0 0 #f) + (program () (arity 0 0 #f) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (const 2)) - (program 0 0 0 () (arity 0 0 #f) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) - (program 1 0 0 () (arity 1 0 #f) + (program () (arity 0 0 #f) + (program () (arity 1 0 #f) (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 () (arity 0 0 #f) - (program 2 0 0 () (arity 2 0 #f) + (program () (arity 0 0 #f) + (program () (arity 2 0 #f) (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 () (arity 0 0 #f) - (program 1 1 0 () (arity 1 1 #f) + (program () (arity 0 0 #f) + (program () (arity 1 1 #f) (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 () (arity 0 0 #f) - (program 2 1 0 () (arity 2 1 #f) + (program () (arity 0 0 #f) + (program () (arity 2 1 #f) (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 () (arity 0 0 #f) - (program 2 1 0 () (arity 2 1 #f) + (program () (arity 0 0 #f) + (program () (arity 2 1 #f) (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 () (arity 0 0 #f) - (program 2 1 0 () (arity 2 1 #f) + (program () (arity 0 0 #f) + (program () (arity 2 1 #f) (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 () (arity 0 0 #f) - (program 1 0 0 () (arity 1 0 #f) + (program () (arity 0 0 #f) + (program () (arity 1 0 #f) (bind (x #f 0)) - (program 1 0 0 () (arity 1 0 #f) + (program () (arity 1 0 #f) (bind (y #f 0)) (lexical #f #f ref 0) (call return 1)) (lexical #t #f ref 0) @@ -396,12 +396,12 @@ (with-test-prefix "sequence" (assert-tree-il->glil (begin (begin (const 2) (const #f)) (const #t)) - (program 0 0 0 () (arity 0 0 #f) + (program () (arity 0 0 #f) (const #t) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (begin (const #f) (const 2))) - (program 0 0 0 () (arity 0 0 #f) + (program () (arity 0 0 #f) (const 2) (call null? 1) (call return 1)))) ;; FIXME: binding info for or-hacked locals might bork the disassembler, @@ -413,7 +413,7 @@ (lexical x y) (let (a) (b) ((const 2)) (lexical a b)))) - (program 0 0 1 () (arity 0 0 #f) (call reserve-locals 1) + (program () (arity 0 0 #f) (call reserve-locals 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) @@ -431,7 +431,7 @@ (lexical x y) (let (a) (b) ((const 2)) (lexical x y)))) - (program 0 0 1 () (arity 0 0 #f) (call reserve-locals 1) + (program () (arity 0 0 #f) (call reserve-locals 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) @@ -443,10 +443,10 @@ (with-test-prefix "apply" (assert-tree-il->glil (apply (primitive @apply) (toplevel foo) (toplevel bar)) - (program 0 0 0 () (arity 0 0 #f) (toplevel ref foo) (toplevel ref bar) (call goto/apply 2))) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (call new-frame 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) @@ -454,7 +454,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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2) (call goto/args 1)))) @@ -462,10 +462,10 @@ (with-test-prefix "call/cc" (assert-tree-il->glil (apply (primitive @call-with-current-continuation) (toplevel foo)) - (program 0 0 0 () (arity 0 0 #f) (toplevel ref foo) (call goto/cc 1))) + (program () (arity 0 0 #f) (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 () (arity 0 0 #f) + (program () (arity 0 0 #f) (call new-frame 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) @@ -474,7 +474,7 @@ (assert-tree-il->glil (apply (toplevel foo) (apply (toplevel @call-with-current-continuation) (toplevel bar))) - (program 0 0 0 () (arity 0 0 #f) + (program () (arity 0 0 #f) (toplevel ref foo) (toplevel ref bar) (call call/cc 1) (call goto/args 1)))) |