diff --git a/gdbinit b/gdbinit index 381cf8477..b66e3e249 100644 --- a/gdbinit +++ b/gdbinit @@ -148,11 +148,6 @@ define nextframe output $vmdl newline set $vmsp=$vmsp-1 - sputs "el:\t" - output $vmsp - sputs "\t" - gwrite *$vmsp - set $vmsp=$vmsp-1 set $vmnlocs=(int)$vmbp->nlocs while $vmnlocs > 0 sputs "loc #" diff --git a/libguile/chars.c b/libguile/chars.c index ca47c0d82..5a53c456a 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 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 @@ -24,6 +24,8 @@ #include #include +#include + #include "libguile/_scm.h" #include "libguile/validate.h" @@ -55,7 +57,7 @@ SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_char_less_p, "char?", scm_tc7_rpsubr, (SCM x, SCM y), - "Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n" + "Return @code{#t} iff @var{x} is greater than @var{y} in the Unicode\n" "sequence, else @code{#f}.") #define FUNC_NAME s_scm_char_gr_p { @@ -92,7 +94,7 @@ SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr, (SCM x, SCM y), "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n" - "ASCII sequence, else @code{#f}.") + "Unicode sequence, else @code{#f}.") #define FUNC_NAME s_scm_char_geq_p { SCM_VALIDATE_CHAR (1, x); @@ -104,7 +106,7 @@ SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, (SCM x, SCM y), "Return @code{#t} iff @var{x} is the same character as @var{y} ignoring\n" - "case, else @code{#f}.") + "case, else @code{#f}. Case is locale free and not context sensitive.") #define FUNC_NAME s_scm_char_ci_eq_p { SCM_VALIDATE_CHAR (1, x); @@ -115,8 +117,9 @@ SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_char_ci_less_p, "char-ci?", scm_tc7_rpsubr, (SCM x, SCM y), - "Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n" - "sequence ignoring case, else @code{#f}.") + "Return @code{#t} iff the Unicode uppercase form of @var{x} is greater\n" + "than the Unicode uppercase form of @var{y} in the Unicode\n" + "sequence, else @code{#f}.") #define FUNC_NAME s_scm_char_ci_gr_p { SCM_VALIDATE_CHAR (1, x); @@ -151,8 +156,9 @@ SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr, SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr, (SCM x, SCM y), - "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n" - "ASCII sequence ignoring case, else @code{#f}.") + "Return @code{#t} iff the Unicode uppercase form of @var{x} is greater\n" + "than or equal to the Unicode uppercase form of @var{y} in the\n" + "Unicode sequence, else @code{#f}.") #define FUNC_NAME s_scm_char_ci_geq_p { SCM_VALIDATE_CHAR (1, x); @@ -233,7 +239,7 @@ SCM_DEFINE (scm_char_to_integer, "char->integer", 1, 0, 0, #define FUNC_NAME s_scm_char_to_integer { SCM_VALIDATE_CHAR (1, chr); - return scm_from_ulong (SCM_CHAR(chr)); + return scm_from_uint32 (SCM_CHAR(chr)); } #undef FUNC_NAME @@ -244,7 +250,15 @@ SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0, "Return the character at position @var{n} in the ASCII sequence.") #define FUNC_NAME s_scm_integer_to_char { - return SCM_MAKE_CHAR (scm_to_uchar (n)); + scm_t_wchar cn; + + cn = scm_to_wchar (n); + + /* Avoid the surrogates. */ + if (!SCM_IS_UNICODE_CHAR (cn)) + scm_out_of_range (FUNC_NAME, n); + + return SCM_MAKE_CHAR (cn); } #undef FUNC_NAME @@ -255,7 +269,7 @@ SCM_DEFINE (scm_char_upcase, "char-upcase", 1, 0, 0, #define FUNC_NAME s_scm_char_upcase { SCM_VALIDATE_CHAR (1, chr); - return SCM_MAKE_CHAR (toupper (SCM_CHAR (chr))); + return SCM_MAKE_CHAR (scm_c_upcase (SCM_CHAR (chr))); } #undef FUNC_NAME @@ -266,7 +280,7 @@ SCM_DEFINE (scm_char_downcase, "char-downcase", 1, 0, 0, #define FUNC_NAME s_scm_char_downcase { SCM_VALIDATE_CHAR (1, chr); - return SCM_MAKE_CHAR (tolower (SCM_CHAR(chr))); + return SCM_MAKE_CHAR (scm_c_downcase (SCM_CHAR(chr))); } #undef FUNC_NAME @@ -279,80 +293,121 @@ TODO: change name to scm_i_.. ? --hwn */ -int -scm_c_upcase (unsigned int c) +scm_t_wchar +scm_c_upcase (scm_t_wchar c) { - if (c <= UCHAR_MAX) - return toupper (c); - else - return c; + return uc_toupper (c); } -int -scm_c_downcase (unsigned int c) +scm_t_wchar +scm_c_downcase (scm_t_wchar c) { - if (c <= UCHAR_MAX) - return tolower (c); - else - return c; + return uc_tolower (c); } + -#ifdef _DCC -# define ASCII -#else -# if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) -# define EBCDIC -# endif /* (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) */ -# if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) -# define ASCII -# endif /* (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) */ -#endif /* def _DCC */ +/* There are a few sets of character names: R5RS, Guile + extensions for control characters, and leftover Guile extensions. + They are listed in order of precedence. */ +const char *const scm_r5rs_charnames[] = + { + "space", "newline" + }; -#ifdef EBCDIC -char *const scm_charnames[] = +const scm_t_uint32 const scm_r5rs_charnums[] = + { + 0x20, 0x0A + }; + +const int scm_n_r5rs_charnames = sizeof (scm_r5rs_charnames) / sizeof (char *); + +/* The abbreviated names for control characters. */ +const char *const scm_C0_control_charnames[] = + { + /* C0 controls */ + "nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel", + "bs", "ht", "lf", "vt", "ff", "cr", "so", "si", + "dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb", + "can", "em", "sub", "esc", "fs", "gs", "rs", "us", + "sp", "del" + }; + +const scm_t_uint32 const scm_C0_control_charnums[] = + { + 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, + 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, + 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, + 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, + 0x20, 0x7f + }; + +int scm_n_C0_control_charnames = sizeof (scm_C0_control_charnames) / sizeof (char *); + +const char *const scm_alt_charnames[] = + { + "null", "backspace", "tab", "nl", "newline", "np", "page", "return", + }; + +const scm_t_uint32 const scm_alt_charnums[] = + { + 0x00, 0x08, 0x09, 0x0a, 0x0a, 0x0c, 0x0c, 0x0d + }; + +const int scm_n_alt_charnames = sizeof (scm_alt_charnames) / sizeof (char *); + +/* Returns the string charname for a character if it exists, or NULL + otherwise. */ +const char * +scm_i_charname (SCM chr) { - "nul", "soh", "stx", "etx", "pf", "ht", "lc", "del", - 0 , 0 , "smm", "vt", "ff", "cr", "so", "si", - "dle", "dc1", "dc2", "dc3", "res", "nl", "bs", "il", - "can", "em", "cc", 0 , "ifs", "igs", "irs", "ius", - "ds", "sos", "fs", 0 , "byp", "lf", "eob", "pre", - 0 , 0 , "sm", 0 , 0 , "enq", "ack", "bel", - 0 , 0 , "syn", 0 , "pn", "rs", "uc", "eot", - 0 , 0 , 0 , 0 , "dc4", "nak", 0 , "sub", - "space", scm_s_newline, "tab", "backspace", "return", "page", "null"}; + int c; + scm_t_uint32 i = SCM_CHAR (chr); -const char scm_charnums[] = -"\000\001\002\003\004\005\006\007\ -\010\011\012\013\014\015\016\017\ -\020\021\022\023\024\025\026\027\ -\030\031\032\033\034\035\036\037\ -\040\041\042\043\044\045\046\047\ -\050\051\052\053\054\055\056\057\ -\060\061\062\063\064\065\066\067\ -\070\071\072\073\074\075\076\077\ - \n\t\b\r\f\0"; -#endif /* def EBCDIC */ -#ifdef ASCII -char *const scm_charnames[] = + for (c = 0; c < scm_n_r5rs_charnames; c++) + if (scm_r5rs_charnums[c] == i) + return scm_r5rs_charnames[c]; + + for (c = 0; c < scm_n_C0_control_charnames; c++) + if (scm_C0_control_charnums[c] == i) + return scm_C0_control_charnames[c]; + + for (c = 0; c < scm_n_alt_charnames; c++) + if (scm_alt_charnums[c] == i) + return scm_alt_charnames[i]; + + return NULL; +} + +/* Return a character from a string charname. */ +SCM +scm_i_charname_to_char (const char *charname, size_t charname_len) { - "nul","soh","stx","etx","eot","enq","ack","bel", - "bs", "ht", "newline", "vt", "np", "cr", "so", "si", - "dle","dc1","dc2","dc3","dc4","nak","syn","etb", - "can", "em","sub","esc", "fs", "gs", "rs", "us", - "space", "sp", "nl", "tab", "backspace", "return", "page", "null", "del"}; -const char scm_charnums[] = -"\000\001\002\003\004\005\006\007\ -\010\011\012\013\014\015\016\017\ -\020\021\022\023\024\025\026\027\ -\030\031\032\033\034\035\036\037\ - \n\t\b\r\f\0\177"; -#endif /* def ASCII */ + int c; -int scm_n_charnames = sizeof (scm_charnames) / sizeof (char *); + /* The R5RS charnames. These are supposed to be case + insensitive. */ + for (c = 0; c < scm_n_r5rs_charnames; c++) + if ((strlen (scm_r5rs_charnames[c]) == charname_len) + && (!strncasecmp (scm_r5rs_charnames[c], charname, charname_len))) + return SCM_MAKE_CHAR (scm_r5rs_charnums[c]); + /* Then come the controls. These are not case sensitive. */ + for (c = 0; c < scm_n_C0_control_charnames; c++) + if ((strlen (scm_C0_control_charnames[c]) == charname_len) + && (!strncasecmp (scm_C0_control_charnames[c], charname, charname_len))) + return SCM_MAKE_CHAR (scm_C0_control_charnums[c]); + + /* Lastly are some old names carried over for compatibility. */ + for (c = 0; c < scm_n_alt_charnames; c++) + if ((strlen (scm_alt_charnames[c]) == charname_len) + && (!strncasecmp (scm_alt_charnames[c], charname, charname_len))) + return SCM_MAKE_CHAR (scm_alt_charnums[c]); + + return SCM_BOOL_F; +} diff --git a/libguile/chars.h b/libguile/chars.h index 88dde4bd9..e68f06d21 100644 --- a/libguile/chars.h +++ b/libguile/chars.h @@ -3,7 +3,7 @@ #ifndef SCM_CHARS_H #define SCM_CHARS_H -/* Copyright (C) 1995,1996,2000,2001,2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,2000,2001,2004, 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 @@ -28,15 +28,24 @@ /* Immediate Characters */ + +#ifndef SCM_WCHAR_DEFINED +typedef scm_t_int32 scm_t_wchar; +#define SCM_WCHAR_DEFINED +#endif + #define SCM_CHARP(x) (SCM_ITAG8(x) == scm_tc8_char) -#define SCM_CHAR(x) ((unsigned int)SCM_ITAG8_DATA(x)) -#define SCM_MAKE_CHAR(x) SCM_MAKE_ITAG8((scm_t_bits) (unsigned char) (x), scm_tc8_char) +#define SCM_CHAR(x) ((scm_t_wchar)SCM_ITAG8_DATA(x)) - +#define SCM_MAKE_CHAR(x) ({scm_t_int32 _x = (x); \ + _x < 0 \ + ? SCM_MAKE_ITAG8((scm_t_bits)(unsigned char)_x, scm_tc8_char) \ + : SCM_MAKE_ITAG8((scm_t_bits)_x, scm_tc8_char);}) -SCM_API char *const scm_charnames[]; -SCM_API int scm_n_charnames; -SCM_API const char scm_charnums[]; +#define SCM_CODEPOINT_MAX (0x10ffff) +#define SCM_IS_UNICODE_CHAR(c) \ + ((scm_t_wchar)(c)<=0xd7ff || \ + ((scm_t_wchar)(c)>=0xe000 && (scm_t_wchar)(c)<=SCM_CODEPOINT_MAX)) @@ -61,8 +70,11 @@ SCM_API SCM scm_char_to_integer (SCM chr); SCM_API SCM scm_integer_to_char (SCM n); SCM_API SCM scm_char_upcase (SCM chr); SCM_API SCM scm_char_downcase (SCM chr); -SCM_API int scm_c_upcase (unsigned int c); -SCM_API int scm_c_downcase (unsigned int c); +SCM_API scm_t_wchar scm_c_upcase (scm_t_wchar c); +SCM_API scm_t_wchar scm_c_downcase (scm_t_wchar c); +SCM_INTERNAL const char *scm_i_charname (SCM chr); +SCM_INTERNAL SCM scm_i_charname_to_char (const char *charname, + size_t charname_len); SCM_INTERNAL void scm_init_chars (void); #endif /* SCM_CHARS_H */ diff --git a/libguile/frames.c b/libguile/frames.c index 76552f54f..e89184d79 100644 --- a/libguile/frames.c +++ b/libguile/frames.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 @@ -222,16 +222,6 @@ SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_vm_frame_external_link, "vm-frame-external-link", 1, 0, 0, - (SCM frame), - "") -#define FUNC_NAME s_scm_vm_frame_external_link -{ - SCM_VALIDATE_VM_FRAME (1, frame); - return SCM_FRAME_EXTERNAL_LINK (SCM_VM_FRAME_FP (frame)); -} -#undef FUNC_NAME - SCM_DEFINE (scm_vm_frame_stack, "vm-frame-stack", 1, 0, 0, (SCM frame), "") diff --git a/libguile/frames.h b/libguile/frames.h index 99623fb16..1b3153a3e 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -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 @@ -30,12 +30,11 @@ /* VM Frame Layout --------------- - | | <- fp + bp->nargs + bp->nlocs + 4 + | | <- fp + bp->nargs + bp->nlocs + 3 +------------------+ = SCM_FRAME_UPPER_ADDRESS (fp) | Return address | | MV return address| - | Dynamic link | - | External link | <- fp + bp->nargs + bp->nlocs + | Dynamic link | <- fp + bp->nargs + bp->blocs | Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp) | Local variable 0 | <- fp + bp->nargs | Argument 1 | @@ -51,21 +50,20 @@ #define SCM_FRAME_DATA_ADDRESS(fp) \ (fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \ + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs) -#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 4) +#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 3) #define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 1) #define SCM_FRAME_BYTE_CAST(x) ((scm_byte_t *) SCM_UNPACK (x)) #define SCM_FRAME_STACK_CAST(x) ((SCM *) SCM_UNPACK (x)) #define SCM_FRAME_RETURN_ADDRESS(fp) \ - (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3])) -#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \ (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2])) +#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \ + (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1])) #define SCM_FRAME_DYNAMIC_LINK(fp) \ - (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1])) + (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0])) #define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \ - ((SCM_FRAME_DATA_ADDRESS (fp)[1])) = (SCM)(dl); -#define SCM_FRAME_EXTERNAL_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[0]) + ((SCM_FRAME_DATA_ADDRESS (fp)[0])) = (SCM)(dl); #define SCM_FRAME_VARIABLE(fp,i) fp[i] #define SCM_FRAME_PROGRAM(fp) fp[-1] @@ -106,7 +104,6 @@ SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val); SCM_API SCM scm_vm_frame_return_address (SCM frame); SCM_API SCM scm_vm_frame_mv_return_address (SCM frame); SCM_API SCM scm_vm_frame_dynamic_link (SCM frame); -SCM_API SCM scm_vm_frame_external_link (SCM frame); SCM_API SCM scm_vm_frame_stack (SCM frame); SCM_API SCM scm_c_vm_frame_prev (SCM frame); diff --git a/libguile/numbers.c b/libguile/numbers.c index c7e098151..5f56b7a29 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5863,6 +5863,14 @@ scm_i_range_error (SCM bad_val, SCM min, SCM max) #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg) #include "libguile/conv-uinteger.i.c" +#define TYPE scm_t_wchar +#define TYPE_MIN (scm_t_int32)-1 +#define TYPE_MAX (scm_t_int32)0x10ffff +#define SIZEOF_TYPE 4 +#define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg) +#define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg) +#include "libguile/conv-integer.i.c" + #if SCM_HAVE_T_INT64 #define TYPE scm_t_int64 diff --git a/libguile/numbers.h b/libguile/numbers.h index 5bad4478b..f30f7d061 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -3,7 +3,7 @@ #ifndef SCM_NUMBERS_H #define SCM_NUMBERS_H -/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 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 @@ -174,6 +174,11 @@ typedef struct scm_t_complex double imag; } scm_t_complex; +#ifndef SCM_WCHAR_DEFINED +typedef scm_t_int32 scm_t_wchar; +#define SCM_WCHAR_DEFINED +#endif + SCM_API SCM scm_exact_p (SCM x); @@ -322,6 +327,9 @@ SCM_API SCM scm_from_int32 (scm_t_int32 x); SCM_API scm_t_uint32 scm_to_uint32 (SCM x); SCM_API SCM scm_from_uint32 (scm_t_uint32 x); +SCM_API scm_t_wchar scm_to_wchar (SCM x); +SCM_API SCM scm_from_wchar (scm_t_wchar x); + #if SCM_HAVE_T_INT64 SCM_API scm_t_int64 scm_to_int64 (SCM x); diff --git a/libguile/objcodes.c b/libguile/objcodes.c index a2105530f..91691a70a 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -50,7 +50,7 @@ /* The objcode magic header. */ #define OBJCODE_COOKIE \ - "GOOF-0.6-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---" + "GOOF-0.9-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---" /* The length of the header must be a multiple of 8 bytes. */ verify (((sizeof (OBJCODE_COOKIE) - 1) & 7) == 0); diff --git a/libguile/objcodes.h b/libguile/objcodes.h index e9b1cdbff..2bb4e6040 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -25,11 +25,11 @@ struct scm_objcode { scm_t_uint8 nargs; scm_t_uint8 nrest; - scm_t_uint8 nlocs; - scm_t_uint8 nexts; + 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]; }; @@ -49,7 +49,6 @@ SCM_API scm_t_bits scm_tc16_objcode; #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_NEXTS(x) (SCM_OBJCODE_DATA (x)->nexts) #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/print.c b/libguile/print.c index 6c44d59db..1a5aebe1b 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -23,6 +23,7 @@ #endif #include +#include #include "libguile/_scm.h" #include "libguile/chars.h" @@ -436,21 +437,39 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc3_imm24: if (SCM_CHARP (exp)) { - long i = SCM_CHAR (exp); + scm_t_wchar i = SCM_CHAR (exp); + const char *name; if (SCM_WRITINGP (pstate)) { scm_puts ("#\\", port); - if ((i >= 0) && (i <= ' ') && scm_charnames[i]) - scm_puts (scm_charnames[i], port); -#ifndef EBCDIC - else if (i == '\177') - scm_puts (scm_charnames[scm_n_charnames - 1], port); -#endif - else if (i < 0 || i > '\177') - scm_intprint (i, 8, port); - else - scm_putc (i, port); + name = scm_i_charname (exp); + if (name != NULL) + scm_puts (name, port); + else if (uc_is_general_category_withtable (i, UC_CATEGORY_MASK_L + | UC_CATEGORY_MASK_M + | UC_CATEGORY_MASK_N + | UC_CATEGORY_MASK_P + | UC_CATEGORY_MASK_S)) + /* Print the character if is graphic character. */ + { + if (i<256) + { + /* Character is graphic. Print it. */ + scm_putc (i, port); + } + else + { + /* Character is graphic but unrepresentable in + this port's encoding. */ + scm_intprint (i, 8, port); + } + } + else + { + /* Character is a non-graphical character. */ + scm_intprint (i, 8, port); + } } else scm_putc (i, port); diff --git a/libguile/programs.c b/libguile/programs.c index 892b6770f..5c43ac525 100644 --- a/libguile/programs.c +++ b/libguile/programs.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 @@ -36,7 +36,7 @@ scm_t_bits scm_tc16_program; static SCM write_program = SCM_BOOL_F; SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0, - (SCM objcode, SCM objtable, SCM external), + (SCM objcode, SCM objtable, SCM free_variables), "") #define FUNC_NAME s_scm_make_program { @@ -45,18 +45,12 @@ SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0, objtable = SCM_BOOL_F; else if (scm_is_true (objtable)) SCM_VALIDATE_VECTOR (2, objtable); - if (SCM_UNLIKELY (SCM_UNBNDP (external))) - external = SCM_EOL; - else - /* FIXME: currently this test is quite expensive (can be 2-3% of total - execution time in programs that make many closures). We could remove it, - yes, but we'd get much better gains if we used some other method, like - just capturing the variables that we need instead of all heap-allocated - variables. Dunno. Keeping the check for now, as it's a user-callable - function, and inlining the op in the vm's make-closure operation. */ - SCM_VALIDATE_LIST (3, external); + if (SCM_UNLIKELY (SCM_UNBNDP (free_variables))) + free_variables = SCM_BOOL_F; + else if (free_variables != SCM_BOOL_F) + SCM_VALIDATE_VECTOR (3, free_variables); - SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, external); + SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, free_variables); } #undef FUNC_NAME @@ -65,8 +59,8 @@ program_mark (SCM obj) { if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj))) scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj)); - if (!scm_is_null (SCM_PROGRAM_EXTERNALS (obj))) - scm_gc_mark (SCM_PROGRAM_EXTERNALS (obj)); + if (scm_is_true (SCM_PROGRAM_FREE_VARIABLES (obj))) + scm_gc_mark (SCM_PROGRAM_FREE_VARIABLES (obj)); return SCM_PROGRAM_OBJCODE (obj); } @@ -151,10 +145,9 @@ SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0, SCM_VALIDATE_PROGRAM (1, program); p = SCM_PROGRAM_DATA (program); - return scm_list_4 (SCM_I_MAKINUM (p->nargs), + return scm_list_3 (SCM_I_MAKINUM (p->nargs), SCM_I_MAKINUM (p->nrest), - SCM_I_MAKINUM (p->nlocs), - SCM_I_MAKINUM (p->nexts)); + SCM_I_MAKINUM (p->nlocs)); } #undef FUNC_NAME @@ -191,7 +184,7 @@ SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0, metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program)); if (scm_is_true (metaobj)) - return scm_make_program (metaobj, SCM_BOOL_F, SCM_EOL); + return scm_make_program (metaobj, SCM_BOOL_F, SCM_BOOL_F); else return SCM_BOOL_F; } @@ -300,26 +293,13 @@ scm_c_program_source (SCM program, size_t ip) return source; /* (addr . (filename . (line . column))) */ } -SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0, +SCM_DEFINE (scm_program_free_variables, "program-free-variables", 1, 0, 0, (SCM program), "") -#define FUNC_NAME s_scm_program_external +#define FUNC_NAME s_scm_program_free_variables { SCM_VALIDATE_PROGRAM (1, program); - return SCM_PROGRAM_EXTERNALS (program); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_program_external_set_x, "program-external-set!", 2, 0, 0, - (SCM program, SCM external), - "Modify the list of closure variables of @var{program} (for " - "debugging purposes).") -#define FUNC_NAME s_scm_program_external_set_x -{ - SCM_VALIDATE_PROGRAM (1, program); - SCM_VALIDATE_LIST (2, external); - SCM_PROGRAM_EXTERNALS (program) = external; - return SCM_UNSPECIFIED; + return SCM_PROGRAM_FREE_VARIABLES (program); } #undef FUNC_NAME diff --git a/libguile/programs.h b/libguile/programs.h index 16a15500f..040e8ea2c 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -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 @@ -35,12 +35,12 @@ SCM_API scm_t_bits scm_tc16_program; #define SCM_PROGRAM_P(x) (SCM_SMOB_PREDICATE (scm_tc16_program, x)) #define SCM_PROGRAM_OBJCODE(x) (SCM_SMOB_OBJECT (x)) #define SCM_PROGRAM_OBJTABLE(x) (SCM_SMOB_OBJECT_2 (x)) -#define SCM_PROGRAM_EXTERNALS(x) (SCM_SMOB_OBJECT_3 (x)) +#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_SMOB_OBJECT_3 (x)) #define SCM_PROGRAM_DATA(x) (SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x))) #define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P) #define SCM_PROGRAM_IS_BOOT(x) (SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT) -SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM externals); +SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables); SCM_API SCM scm_program_p (SCM obj); SCM_API SCM scm_program_base (SCM program); @@ -53,8 +53,7 @@ SCM_API SCM scm_program_properties (SCM program); SCM_API SCM scm_program_name (SCM program); SCM_API SCM scm_program_objects (SCM program); SCM_API SCM scm_program_module (SCM program); -SCM_API SCM scm_program_external (SCM program); -SCM_API SCM scm_program_external_set_x (SCM program, SCM external); +SCM_API SCM scm_program_free_variables (SCM program); SCM_API SCM scm_program_objcode (SCM program); SCM_API SCM scm_c_program_source (SCM program, size_t ip); diff --git a/libguile/read.c b/libguile/read.c index bd028ea52..2140fed25 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -801,7 +801,7 @@ static SCM scm_read_character (int chr, SCM port) #define FUNC_NAME "scm_lreadr" { - unsigned c; + SCM ch; char charname[READER_CHAR_NAME_MAX_SIZE]; size_t charname_len; @@ -834,10 +834,9 @@ scm_read_character (int chr, SCM port) return SCM_MAKE_CHAR (SCM_I_INUM (p)); } - for (c = 0; c < scm_n_charnames; c++) - if (scm_charnames[c] - && (!strncasecmp (scm_charnames[c], charname, charname_len))) - return SCM_MAKE_CHAR (scm_charnums[c]); + ch = scm_i_charname_to_char (charname, charname_len); + if (scm_is_true (ch)) + return ch; char_error: scm_i_input_error (FUNC_NAME, port, "unknown character name ~a", diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 90cf697f8..98a6e491b 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -21,14 +21,14 @@ #if (VM_ENGINE == SCM_VM_REGULAR_ENGINE) #define VM_USE_HOOKS 0 /* Various hooks */ #define VM_USE_CLOCK 0 /* Bogoclock */ -#define VM_CHECK_EXTERNAL 1 /* Check external link */ #define VM_CHECK_OBJECT 1 /* Check object table */ +#define VM_CHECK_FREE_VARIABLES 1 /* Check free variable access */ #define VM_PUSH_DEBUG_FRAMES 0 /* Push frames onto the evaluator debug stack */ #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE) #define VM_USE_HOOKS 1 #define VM_USE_CLOCK 1 -#define VM_CHECK_EXTERNAL 1 #define VM_CHECK_OBJECT 1 +#define VM_CHECK_FREE_VARIABLES 1 #define VM_PUSH_DEBUG_FRAMES 1 #else #error unknown debug engine VM_ENGINE @@ -47,7 +47,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) /* Cache variables */ struct scm_objcode *bp = NULL; /* program base pointer */ - SCM external = SCM_EOL; /* external environment */ + SCM *free_vars = NULL; /* free variables */ + size_t free_vars_count = 0; /* length of FREE_VARS */ SCM *objects = NULL; /* constant objects */ size_t object_count = 0; /* length of OBJECTS */ SCM *stack_base = vp->stack_base; /* stack base address */ @@ -226,16 +227,16 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) goto vm_error; #endif -#if VM_CHECK_EXTERNAL - vm_error_external: - err_msg = scm_from_locale_string ("VM: Invalid external access"); +#if VM_CHECK_OBJECT + vm_error_object: + err_msg = scm_from_locale_string ("VM: Invalid object table access"); finish_args = SCM_EOL; goto vm_error; #endif -#if VM_CHECK_OBJECT - vm_error_object: - err_msg = scm_from_locale_string ("VM: Invalid object table access"); +#if VM_CHECK_FREE_VARIABLES + vm_error_free_variable: + err_msg = scm_from_locale_string ("VM: Invalid free variable access"); finish_args = SCM_EOL; goto vm_error; #endif @@ -252,8 +253,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) #undef VM_USE_HOOKS #undef VM_USE_CLOCK -#undef VM_CHECK_EXTERNAL #undef VM_CHECK_OBJECT +#undef VM_CHECK_FREE_VARIABLE #undef VM_PUSH_DEBUG_FRAMES /* diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index d6849799c..c0f772fb8 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -117,26 +117,36 @@ vp->fp = fp; \ } +/* FIXME */ +#define ASSERT_VARIABLE(x) \ + do { if (!SCM_VARIABLEP (x)) { SYNC_REGISTER (); abort(); } \ + } while (0) +#define ASSERT_BOUND_VARIABLE(x) \ + do { ASSERT_VARIABLE (x); \ + if (SCM_VARIABLE_REF (x) == SCM_UNDEFINED) \ + { SYNC_REGISTER (); abort(); } \ + } while (0) + #ifdef VM_ENABLE_PARANOID_ASSERTIONS #define CHECK_IP() \ do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0) +#define ASSERT_ALIGNED_PROCEDURE() \ + do { if ((scm_t_bits)bp % 8) abort (); } while (0) #define ASSERT_BOUND(x) \ do { if ((x) == SCM_UNDEFINED) { SYNC_REGISTER (); abort(); } \ } while (0) #else #define CHECK_IP() +#define ASSERT_ALIGNED_PROCEDURE() #define ASSERT_BOUND(x) #endif -/* Get a local copy of the program's "object table" (i.e. the vector of - external bindings that are referenced by the program), initialized by - `load-program'. */ -/* XXX: We could instead use the "simple vector macros", thus not having to - call `scm_vector_writable_elements ()' and the likes. */ +/* Cache the object table and free variables. */ #define CACHE_PROGRAM() \ { \ if (bp != SCM_PROGRAM_DATA (program)) { \ bp = SCM_PROGRAM_DATA (program); \ + ASSERT_ALIGNED_PROCEDURE (); \ if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \ objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \ object_count = SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program)); \ @@ -145,6 +155,19 @@ object_count = 0; \ } \ } \ + { \ + SCM c = SCM_PROGRAM_FREE_VARIABLES (program); \ + if (SCM_I_IS_VECTOR (c)) \ + { \ + free_vars = SCM_I_VECTOR_WELTS (c); \ + free_vars_count = SCM_I_VECTOR_LENGTH (c); \ + } \ + else \ + { \ + free_vars = NULL; \ + free_vars_count = 0; \ + } \ + } \ } #define SYNC_BEFORE_GC() \ @@ -162,14 +185,6 @@ * Error check */ -#undef CHECK_EXTERNAL -#if VM_CHECK_EXTERNAL -#define CHECK_EXTERNAL(e) \ - do { if (SCM_UNLIKELY (!SCM_CONSP (e))) goto vm_error_external; } while (0) -#else -#define CHECK_EXTERNAL(e) -#endif - /* Accesses to a program's object table. */ #if VM_CHECK_OBJECT #define CHECK_OBJECT(_num) \ @@ -178,6 +193,13 @@ #define CHECK_OBJECT(_num) #endif +#if VM_CHECK_FREE_VARIABLES +#define CHECK_FREE_VARIABLE(_num) \ + do { if (SCM_UNLIKELY ((_num) >= free_vars_count)) goto vm_error_free_variable; } while (0) +#else +#define CHECK_FREE_VARIABLE(_num) +#endif + /* * Hooks @@ -376,7 +398,7 @@ do { \ /* New registers */ \ fp = sp - bp->nargs + 1; \ data = SCM_FRAME_DATA_ADDRESS (fp); \ - sp = data + 3; \ + sp = data + 2; \ CHECK_OVERFLOW (); \ stack_base = sp; \ ip = bp->base; \ @@ -386,23 +408,11 @@ do { \ data[-i] = SCM_UNDEFINED; \ \ /* Set frame data */ \ - data[3] = (SCM)ra; \ - data[2] = 0x0; \ - data[1] = (SCM)dl; \ - \ - /* Postpone initializing external vars, \ - because if the CONS causes a GC, we \ - want the stack marker to see the data \ - array formatted as expected. */ \ - data[0] = SCM_UNDEFINED; \ - external = SCM_PROGRAM_EXTERNALS (fp[-1]); \ - for (i = 0; i < bp->nexts; i++) \ - CONS (external, SCM_UNDEFINED, external); \ - data[0] = external; \ + data[2] = (SCM)ra; \ + data[1] = 0x0; \ + data[0] = (SCM)dl; \ } -#define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs] - /* Local Variables: c-file-style: "gnu" diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c index 86d0fc443..9ae49ed65 100644 --- a/libguile/vm-i-loader.c +++ b/libguile/vm-i-loader.c @@ -20,7 +20,7 @@ /* This file is included in vm_engine.c */ -VM_DEFINE_LOADER (59, load_unsigned_integer, "load-unsigned-integer") +VM_DEFINE_LOADER (80, load_unsigned_integer, "load-unsigned-integer") { size_t len; @@ -38,7 +38,7 @@ VM_DEFINE_LOADER (59, load_unsigned_integer, "load-unsigned-integer") SCM_MISC_ERROR ("load-unsigned-integer: not implemented yet", SCM_EOL); } -VM_DEFINE_LOADER (60, load_integer, "load-integer") +VM_DEFINE_LOADER (81, load_integer, "load-integer") { size_t len; @@ -56,7 +56,7 @@ VM_DEFINE_LOADER (60, load_integer, "load-integer") SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL); } -VM_DEFINE_LOADER (61, load_number, "load-number") +VM_DEFINE_LOADER (82, load_number, "load-number") { size_t len; @@ -69,7 +69,7 @@ VM_DEFINE_LOADER (61, load_number, "load-number") NEXT; } -VM_DEFINE_LOADER (62, load_string, "load-string") +VM_DEFINE_LOADER (83, load_string, "load-string") { size_t len; FETCH_LENGTH (len); @@ -80,7 +80,7 @@ VM_DEFINE_LOADER (62, load_string, "load-string") NEXT; } -VM_DEFINE_LOADER (63, load_symbol, "load-symbol") +VM_DEFINE_LOADER (84, load_symbol, "load-symbol") { size_t len; FETCH_LENGTH (len); @@ -90,7 +90,7 @@ VM_DEFINE_LOADER (63, load_symbol, "load-symbol") NEXT; } -VM_DEFINE_LOADER (64, load_keyword, "load-keyword") +VM_DEFINE_LOADER (85, load_keyword, "load-keyword") { size_t len; FETCH_LENGTH (len); @@ -100,7 +100,7 @@ VM_DEFINE_LOADER (64, load_keyword, "load-keyword") NEXT; } -VM_DEFINE_LOADER (65, load_program, "load-program") +VM_DEFINE_LOADER (86, load_program, "load-program") { scm_t_uint32 len; SCM objs, objcode; @@ -114,14 +114,14 @@ VM_DEFINE_LOADER (65, load_program, "load-program") objcode = scm_c_make_objcode_slice (SCM_PROGRAM_OBJCODE (fp[-1]), ip); len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode); - PUSH (scm_make_program (objcode, objs, SCM_EOL)); + PUSH (scm_make_program (objcode, objs, SCM_BOOL_F)); ip += len; NEXT; } -VM_DEFINE_INSTRUCTION (66, link_now, "link-now", 0, 1, 1) +VM_DEFINE_INSTRUCTION (87, link_now, "link-now", 0, 1, 1) { SCM what; POP (what); @@ -130,7 +130,7 @@ VM_DEFINE_INSTRUCTION (66, link_now, "link-now", 0, 1, 1) NEXT; } -VM_DEFINE_LOADER (67, define, "define") +VM_DEFINE_LOADER (88, define, "define") { SCM sym; size_t len; @@ -145,7 +145,7 @@ VM_DEFINE_LOADER (67, define, "define") NEXT; } -VM_DEFINE_LOADER (68, load_array, "load-array") +VM_DEFINE_LOADER (89, load_array, "load-array") { SCM type, shape; size_t len; @@ -163,7 +163,7 @@ VM_DEFINE_LOADER (68, load_array, "load-array") "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" (interactive "") (save-excursion - (let ((counter 59)) (goto-char (point-min)) + (let ((counter 79)) (goto-char (point-min)) (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t) (replace-match (number-to-string (setq counter (1+ counter))) diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 42f8bac35..dce9b5fbc 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -29,43 +29,43 @@ #define RETURN(x) do { *sp = x; NEXT; } while (0) -VM_DEFINE_FUNCTION (80, not, "not", 1) +VM_DEFINE_FUNCTION (100, not, "not", 1) { ARGS1 (x); RETURN (SCM_BOOL (SCM_FALSEP (x))); } -VM_DEFINE_FUNCTION (81, not_not, "not-not", 1) +VM_DEFINE_FUNCTION (101, not_not, "not-not", 1) { ARGS1 (x); RETURN (SCM_BOOL (!SCM_FALSEP (x))); } -VM_DEFINE_FUNCTION (82, eq, "eq?", 2) +VM_DEFINE_FUNCTION (102, eq, "eq?", 2) { ARGS2 (x, y); RETURN (SCM_BOOL (SCM_EQ_P (x, y))); } -VM_DEFINE_FUNCTION (83, not_eq, "not-eq?", 2) +VM_DEFINE_FUNCTION (103, not_eq, "not-eq?", 2) { ARGS2 (x, y); RETURN (SCM_BOOL (!SCM_EQ_P (x, y))); } -VM_DEFINE_FUNCTION (84, nullp, "null?", 1) +VM_DEFINE_FUNCTION (104, nullp, "null?", 1) { ARGS1 (x); RETURN (SCM_BOOL (SCM_NULLP (x))); } -VM_DEFINE_FUNCTION (85, not_nullp, "not-null?", 1) +VM_DEFINE_FUNCTION (105, not_nullp, "not-null?", 1) { ARGS1 (x); RETURN (SCM_BOOL (!SCM_NULLP (x))); } -VM_DEFINE_FUNCTION (86, eqv, "eqv?", 2) +VM_DEFINE_FUNCTION (106, eqv, "eqv?", 2) { ARGS2 (x, y); if (SCM_EQ_P (x, y)) @@ -76,7 +76,7 @@ VM_DEFINE_FUNCTION (86, eqv, "eqv?", 2) RETURN (scm_eqv_p (x, y)); } -VM_DEFINE_FUNCTION (87, equal, "equal?", 2) +VM_DEFINE_FUNCTION (107, equal, "equal?", 2) { ARGS2 (x, y); if (SCM_EQ_P (x, y)) @@ -87,13 +87,13 @@ VM_DEFINE_FUNCTION (87, equal, "equal?", 2) RETURN (scm_equal_p (x, y)); } -VM_DEFINE_FUNCTION (88, pairp, "pair?", 1) +VM_DEFINE_FUNCTION (108, pairp, "pair?", 1) { ARGS1 (x); RETURN (SCM_BOOL (SCM_CONSP (x))); } -VM_DEFINE_FUNCTION (89, listp, "list?", 1) +VM_DEFINE_FUNCTION (109, listp, "list?", 1) { ARGS1 (x); RETURN (SCM_BOOL (scm_ilength (x) >= 0)); @@ -104,7 +104,7 @@ VM_DEFINE_FUNCTION (89, listp, "list?", 1) * Basic data */ -VM_DEFINE_FUNCTION (90, cons, "cons", 2) +VM_DEFINE_FUNCTION (110, cons, "cons", 2) { ARGS2 (x, y); CONS (x, x, y); @@ -117,21 +117,21 @@ VM_DEFINE_FUNCTION (90, cons, "cons", 2) goto vm_error_not_a_pair; \ } -VM_DEFINE_FUNCTION (91, car, "car", 1) +VM_DEFINE_FUNCTION (111, car, "car", 1) { ARGS1 (x); VM_VALIDATE_CONS (x); RETURN (SCM_CAR (x)); } -VM_DEFINE_FUNCTION (92, cdr, "cdr", 1) +VM_DEFINE_FUNCTION (112, cdr, "cdr", 1) { ARGS1 (x); VM_VALIDATE_CONS (x); RETURN (SCM_CDR (x)); } -VM_DEFINE_INSTRUCTION (93, set_car, "set-car!", 0, 2, 0) +VM_DEFINE_INSTRUCTION (113, set_car, "set-car!", 0, 2, 0) { SCM x, y; POP (y); @@ -141,7 +141,7 @@ VM_DEFINE_INSTRUCTION (93, set_car, "set-car!", 0, 2, 0) NEXT; } -VM_DEFINE_INSTRUCTION (94, set_cdr, "set-cdr!", 0, 2, 0) +VM_DEFINE_INSTRUCTION (114, set_cdr, "set-cdr!", 0, 2, 0) { SCM x, y; POP (y); @@ -166,27 +166,27 @@ VM_DEFINE_INSTRUCTION (94, set_cdr, "set-cdr!", 0, 2, 0) RETURN (srel (x, y)); \ } -VM_DEFINE_FUNCTION (95, ee, "ee?", 2) +VM_DEFINE_FUNCTION (115, ee, "ee?", 2) { REL (==, scm_num_eq_p); } -VM_DEFINE_FUNCTION (96, lt, "lt?", 2) +VM_DEFINE_FUNCTION (116, lt, "lt?", 2) { REL (<, scm_less_p); } -VM_DEFINE_FUNCTION (97, le, "le?", 2) +VM_DEFINE_FUNCTION (117, le, "le?", 2) { REL (<=, scm_leq_p); } -VM_DEFINE_FUNCTION (98, gt, "gt?", 2) +VM_DEFINE_FUNCTION (118, gt, "gt?", 2) { REL (>, scm_gr_p); } -VM_DEFINE_FUNCTION (99, ge, "ge?", 2) +VM_DEFINE_FUNCTION (119, ge, "ge?", 2) { REL (>=, scm_geq_p); } @@ -210,45 +210,45 @@ VM_DEFINE_FUNCTION (99, ge, "ge?", 2) RETURN (SFUNC (x, y)); \ } -VM_DEFINE_FUNCTION (100, add, "add", 2) +VM_DEFINE_FUNCTION (120, add, "add", 2) { FUNC2 (+, scm_sum); } -VM_DEFINE_FUNCTION (101, sub, "sub", 2) +VM_DEFINE_FUNCTION (121, sub, "sub", 2) { FUNC2 (-, scm_difference); } -VM_DEFINE_FUNCTION (102, mul, "mul", 2) +VM_DEFINE_FUNCTION (122, mul, "mul", 2) { ARGS2 (x, y); SYNC_REGISTER (); RETURN (scm_product (x, y)); } -VM_DEFINE_FUNCTION (103, div, "div", 2) +VM_DEFINE_FUNCTION (123, div, "div", 2) { ARGS2 (x, y); SYNC_REGISTER (); RETURN (scm_divide (x, y)); } -VM_DEFINE_FUNCTION (104, quo, "quo", 2) +VM_DEFINE_FUNCTION (124, quo, "quo", 2) { ARGS2 (x, y); SYNC_REGISTER (); RETURN (scm_quotient (x, y)); } -VM_DEFINE_FUNCTION (105, rem, "rem", 2) +VM_DEFINE_FUNCTION (125, rem, "rem", 2) { ARGS2 (x, y); SYNC_REGISTER (); RETURN (scm_remainder (x, y)); } -VM_DEFINE_FUNCTION (106, mod, "mod", 2) +VM_DEFINE_FUNCTION (126, mod, "mod", 2) { ARGS2 (x, y); SYNC_REGISTER (); @@ -259,7 +259,7 @@ VM_DEFINE_FUNCTION (106, mod, "mod", 2) /* * GOOPS support */ -VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2) +VM_DEFINE_FUNCTION (127, slot_ref, "slot-ref", 2) { size_t slot; ARGS2 (instance, idx); @@ -267,7 +267,7 @@ VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2) RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot])); } -VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (128, slot_set, "slot-set", 0, 3, 0) { SCM instance, idx, val; size_t slot; @@ -279,7 +279,7 @@ VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0) NEXT; } -VM_DEFINE_FUNCTION (109, vector_ref, "vector-ref", 2) +VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2) { long i = 0; ARGS2 (vect, idx); @@ -292,7 +292,7 @@ VM_DEFINE_FUNCTION (109, vector_ref, "vector-ref", 2) RETURN (scm_vector_ref (vect, idx)); } -VM_DEFINE_INSTRUCTION (110, vector_set, "vector-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0) { long i = 0; SCM vect, idx, val; @@ -325,21 +325,21 @@ VM_DEFINE_INSTRUCTION (110, vector_set, "vector-set", 0, 3, 0) } \ } -VM_DEFINE_FUNCTION (111, bv_u16_ref, "bv-u16-ref", 3) +VM_DEFINE_FUNCTION (131, bv_u16_ref, "bv-u16-ref", 3) BV_REF_WITH_ENDIANNESS (u16, u16) -VM_DEFINE_FUNCTION (112, bv_s16_ref, "bv-s16-ref", 3) +VM_DEFINE_FUNCTION (132, bv_s16_ref, "bv-s16-ref", 3) BV_REF_WITH_ENDIANNESS (s16, s16) -VM_DEFINE_FUNCTION (113, bv_u32_ref, "bv-u32-ref", 3) +VM_DEFINE_FUNCTION (133, bv_u32_ref, "bv-u32-ref", 3) BV_REF_WITH_ENDIANNESS (u32, u32) -VM_DEFINE_FUNCTION (114, bv_s32_ref, "bv-s32-ref", 3) +VM_DEFINE_FUNCTION (134, bv_s32_ref, "bv-s32-ref", 3) BV_REF_WITH_ENDIANNESS (s32, s32) -VM_DEFINE_FUNCTION (115, bv_u64_ref, "bv-u64-ref", 3) +VM_DEFINE_FUNCTION (135, bv_u64_ref, "bv-u64-ref", 3) BV_REF_WITH_ENDIANNESS (u64, u64) -VM_DEFINE_FUNCTION (116, bv_s64_ref, "bv-s64-ref", 3) +VM_DEFINE_FUNCTION (136, bv_s64_ref, "bv-s64-ref", 3) BV_REF_WITH_ENDIANNESS (s64, s64) -VM_DEFINE_FUNCTION (117, bv_f32_ref, "bv-f32-ref", 3) +VM_DEFINE_FUNCTION (137, bv_f32_ref, "bv-f32-ref", 3) BV_REF_WITH_ENDIANNESS (f32, ieee_single) -VM_DEFINE_FUNCTION (118, bv_f64_ref, "bv-f64-ref", 3) +VM_DEFINE_FUNCTION (138, bv_f64_ref, "bv-f64-ref", 3) BV_REF_WITH_ENDIANNESS (f64, ieee_double) #undef BV_REF_WITH_ENDIANNESS @@ -392,26 +392,26 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) RETURN (scm_bytevector_##fn_stem##_native_ref (bv, idx)); \ } -VM_DEFINE_FUNCTION (119, bv_u8_ref, "bv-u8-ref", 2) +VM_DEFINE_FUNCTION (139, bv_u8_ref, "bv-u8-ref", 2) BV_FIXABLE_INT_REF (u8, u8, uint8, 1) -VM_DEFINE_FUNCTION (120, bv_s8_ref, "bv-s8-ref", 2) +VM_DEFINE_FUNCTION (140, bv_s8_ref, "bv-s8-ref", 2) BV_FIXABLE_INT_REF (s8, s8, int8, 1) -VM_DEFINE_FUNCTION (121, bv_u16_native_ref, "bv-u16-native-ref", 2) +VM_DEFINE_FUNCTION (141, bv_u16_native_ref, "bv-u16-native-ref", 2) BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2) -VM_DEFINE_FUNCTION (122, bv_s16_native_ref, "bv-s16-native-ref", 2) +VM_DEFINE_FUNCTION (142, bv_s16_native_ref, "bv-s16-native-ref", 2) BV_FIXABLE_INT_REF (s16, s16_native, int16, 2) -VM_DEFINE_FUNCTION (123, bv_u32_native_ref, "bv-u32-native-ref", 2) +VM_DEFINE_FUNCTION (143, bv_u32_native_ref, "bv-u32-native-ref", 2) /* FIXME: u32 is always a fixnum on 64-bit builds */ BV_INT_REF (u32, uint32, 4) -VM_DEFINE_FUNCTION (124, bv_s32_native_ref, "bv-s32-native-ref", 2) +VM_DEFINE_FUNCTION (144, bv_s32_native_ref, "bv-s32-native-ref", 2) BV_INT_REF (s32, int32, 4) -VM_DEFINE_FUNCTION (125, bv_u64_native_ref, "bv-u64-native-ref", 2) +VM_DEFINE_FUNCTION (145, bv_u64_native_ref, "bv-u64-native-ref", 2) BV_INT_REF (u64, uint64, 8) -VM_DEFINE_FUNCTION (126, bv_s64_native_ref, "bv-s64-native-ref", 2) +VM_DEFINE_FUNCTION (146, bv_s64_native_ref, "bv-s64-native-ref", 2) BV_INT_REF (s64, int64, 8) -VM_DEFINE_FUNCTION (127, bv_f32_native_ref, "bv-f32-native-ref", 2) +VM_DEFINE_FUNCTION (147, bv_f32_native_ref, "bv-f32-native-ref", 2) BV_FLOAT_REF (f32, ieee_single, float, 4) -VM_DEFINE_FUNCTION (128, bv_f64_native_ref, "bv-f64-native-ref", 2) +VM_DEFINE_FUNCTION (148, bv_f64_native_ref, "bv-f64-native-ref", 2) BV_FLOAT_REF (f64, ieee_double, double, 8) #undef BV_FIXABLE_INT_REF @@ -433,21 +433,21 @@ BV_FLOAT_REF (f64, ieee_double, double, 8) } \ } -VM_DEFINE_INSTRUCTION (129, bv_u16_set, "bv-u16-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (149, bv_u16_set, "bv-u16-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u16, u16) -VM_DEFINE_INSTRUCTION (130, bv_s16_set, "bv-s16-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (150, bv_s16_set, "bv-s16-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s16, s16) -VM_DEFINE_INSTRUCTION (131, bv_u32_set, "bv-u32-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (151, bv_u32_set, "bv-u32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u32, u32) -VM_DEFINE_INSTRUCTION (132, bv_s32_set, "bv-s32-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (152, bv_s32_set, "bv-s32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s32, s32) -VM_DEFINE_INSTRUCTION (133, bv_u64_set, "bv-u64-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (153, bv_u64_set, "bv-u64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u64, u64) -VM_DEFINE_INSTRUCTION (134, bv_s64_set, "bv-s64-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (154, bv_s64_set, "bv-s64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s64, s64) -VM_DEFINE_INSTRUCTION (135, bv_f32_set, "bv-f32-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (155, bv_f32_set, "bv-f32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (f32, ieee_single) -VM_DEFINE_INSTRUCTION (136, bv_f64_set, "bv-f64-set", 0, 4, 0) +VM_DEFINE_INSTRUCTION (156, bv_f64_set, "bv-f64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (f64, ieee_double) #undef BV_SET_WITH_ENDIANNESS @@ -500,26 +500,26 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) NEXT; \ } -VM_DEFINE_INSTRUCTION (137, bv_u8_set, "bv-u8-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (157, bv_u8_set, "bv-u8-set", 0, 3, 0) BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1) -VM_DEFINE_INSTRUCTION (138, bv_s8_set, "bv-s8-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (158, bv_s8_set, "bv-s8-set", 0, 3, 0) BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1) -VM_DEFINE_INSTRUCTION (139, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (159, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0) BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2) -VM_DEFINE_INSTRUCTION (140, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (160, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0) BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2) -VM_DEFINE_INSTRUCTION (141, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (161, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0) /* FIXME: u32 is always a fixnum on 64-bit builds */ BV_INT_SET (u32, uint32, 4) -VM_DEFINE_INSTRUCTION (142, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (162, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0) BV_INT_SET (s32, int32, 4) -VM_DEFINE_INSTRUCTION (143, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (163, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0) BV_INT_SET (u64, uint64, 8) -VM_DEFINE_INSTRUCTION (144, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (164, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0) BV_INT_SET (s64, int64, 8) -VM_DEFINE_INSTRUCTION (145, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (165, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0) BV_FLOAT_SET (f32, ieee_single, float, 4) -VM_DEFINE_INSTRUCTION (146, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0) +VM_DEFINE_INSTRUCTION (166, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0) BV_FLOAT_SET (f64, ieee_double, double, 8) #undef BV_FIXABLE_INT_SET @@ -531,7 +531,7 @@ BV_FLOAT_SET (f64, ieee_double, double, 8) "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" (interactive "") (save-excursion - (let ((counter 79)) (goto-char (point-min)) + (let ((counter 99)) (goto-char (point-min)) (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t) (replace-match (number-to-string (setq counter (1+ counter))) diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 03d0c1711..5a4809db4 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -145,7 +145,7 @@ VM_DEFINE_INSTRUCTION (13, make_int16, "make-int16", 2, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (55, make_int64, "make-int64", 8, 0, 1) +VM_DEFINE_INSTRUCTION (14, make_int64, "make-int64", 8, 0, 1) { scm_t_uint64 v = 0; v += FETCH (); @@ -160,7 +160,7 @@ VM_DEFINE_INSTRUCTION (55, make_int64, "make-int64", 8, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (56, make_uint64, "make-uint64", 8, 0, 1) +VM_DEFINE_INSTRUCTION (15, make_uint64, "make-uint64", 8, 0, 1) { scm_t_uint64 v = 0; v += FETCH (); @@ -175,13 +175,26 @@ VM_DEFINE_INSTRUCTION (56, make_uint64, "make-uint64", 8, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (14, make_char8, "make-char8", 1, 0, 1) +VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0, 1) { PUSH (SCM_MAKE_CHAR (FETCH ())); NEXT; } -VM_DEFINE_INSTRUCTION (15, list, "list", 2, -1, 1) +VM_DEFINE_INSTRUCTION (42, make_char32, "make-char32", 4, 0, 1) +{ + scm_t_wchar v = 0; + v += FETCH (); + v <<= 8; v += FETCH (); + v <<= 8; v += FETCH (); + v <<= 8; v += FETCH (); + PUSH (SCM_MAKE_CHAR (v)); + NEXT; +} + + + +VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1) { unsigned h = FETCH (); unsigned l = FETCH (); @@ -190,7 +203,7 @@ VM_DEFINE_INSTRUCTION (15, list, "list", 2, -1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (16, vector, "vector", 2, -1, 1) +VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1) { unsigned h = FETCH (); unsigned l = FETCH (); @@ -208,19 +221,19 @@ VM_DEFINE_INSTRUCTION (16, vector, "vector", 2, -1, 1) NEXT; } -VM_DEFINE_INSTRUCTION (17, list_mark, "list-mark", 0, 0, 0) +VM_DEFINE_INSTRUCTION (19, list_mark, "list-mark", 0, 0, 0) { POP_LIST_MARK (); NEXT; } -VM_DEFINE_INSTRUCTION (18, cons_mark, "cons-mark", 0, 0, 0) +VM_DEFINE_INSTRUCTION (20, cons_mark, "cons-mark", 0, 0, 0) { POP_CONS_MARK (); NEXT; } -VM_DEFINE_INSTRUCTION (19, vector_mark, "vector-mark", 0, 0, 0) +VM_DEFINE_INSTRUCTION (21, vector_mark, "vector-mark", 0, 0, 0) { POP_LIST_MARK (); SYNC_REGISTER (); @@ -228,7 +241,7 @@ VM_DEFINE_INSTRUCTION (19, vector_mark, "vector-mark", 0, 0, 0) NEXT; } -VM_DEFINE_INSTRUCTION (20, list_break, "list-break", 0, 0, 0) +VM_DEFINE_INSTRUCTION (22, list_break, "list-break", 0, 0, 0) { SCM l; POP (l); @@ -254,9 +267,11 @@ VM_DEFINE_INSTRUCTION (20, list_break, "list-break", 0, 0, 0) #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) #define VARIABLE_BOUNDP(v) (VARIABLE_REF (v) != SCM_UNDEFINED) +#define FREE_VARIABLE_REF(i) free_vars[i] + /* ref */ -VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (23, object_ref, "object-ref", 1, 0, 1) { register unsigned objnum = FETCH (); CHECK_OBJECT (objnum); @@ -264,29 +279,35 @@ VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1) +/* FIXME: necessary? elt 255 of the vector could be a vector... */ +VM_DEFINE_INSTRUCTION (24, long_object_ref, "long-object-ref", 2, 0, 1) +{ + unsigned int objnum = FETCH (); + objnum <<= 8; + objnum += FETCH (); + CHECK_OBJECT (objnum); + PUSH (OBJECT_REF (objnum)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (25, local_ref, "local-ref", 1, 0, 1) { PUSH (LOCAL_REF (FETCH ())); ASSERT_BOUND (*sp); NEXT; } -VM_DEFINE_INSTRUCTION (23, external_ref, "external-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (26, long_local_ref, "long-local-ref", 2, 0, 1) { - unsigned int i; - SCM e = external; - for (i = FETCH (); i; i--) - { - CHECK_EXTERNAL(e); - e = SCM_CDR (e); - } - CHECK_EXTERNAL(e); - PUSH (SCM_CAR (e)); + unsigned int i = FETCH (); + i <<= 8; + i += FETCH (); + PUSH (LOCAL_REF (i)); ASSERT_BOUND (*sp); NEXT; } -VM_DEFINE_INSTRUCTION (24, variable_ref, "variable-ref", 0, 0, 1) +VM_DEFINE_INSTRUCTION (27, variable_ref, "variable-ref", 0, 0, 1) { SCM x = *sp; @@ -305,7 +326,7 @@ VM_DEFINE_INSTRUCTION (24, variable_ref, "variable-ref", 0, 0, 1) NEXT; } -VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1) +VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1, 0, 1) { unsigned objnum = FETCH (); SCM what; @@ -328,38 +349,58 @@ VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1) NEXT; } +VM_DEFINE_INSTRUCTION (29, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1) +{ + SCM what; + unsigned int objnum = FETCH (); + objnum <<= 8; + objnum += FETCH (); + CHECK_OBJECT (objnum); + what = OBJECT_REF (objnum); + + if (!SCM_VARIABLEP (what)) + { + SYNC_REGISTER (); + what = resolve_variable (what, scm_program_module (program)); + if (!VARIABLE_BOUNDP (what)) + { + finish_args = scm_list_1 (what); + goto vm_error_unbound; + } + OBJECT_SET (objnum, what); + } + + PUSH (VARIABLE_REF (what)); + NEXT; +} + /* set */ -VM_DEFINE_INSTRUCTION (26, local_set, "local-set", 1, 1, 0) +VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0) { LOCAL_SET (FETCH (), *sp); DROP (); NEXT; } -VM_DEFINE_INSTRUCTION (27, external_set, "external-set", 1, 1, 0) +VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0) { - unsigned int i; - SCM e = external; - for (i = FETCH (); i; i--) - { - CHECK_EXTERNAL(e); - e = SCM_CDR (e); - } - CHECK_EXTERNAL(e); - SCM_SETCAR (e, *sp); + unsigned int i = FETCH (); + i <<= 8; + i += FETCH (); + LOCAL_SET (i, *sp); DROP (); NEXT; } -VM_DEFINE_INSTRUCTION (28, variable_set, "variable-set", 0, 1, 0) +VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 1, 0) { VARIABLE_SET (sp[0], sp[-1]); DROPN (2); NEXT; } -VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0) +VM_DEFINE_INSTRUCTION (33, toplevel_set, "toplevel-set", 1, 1, 0) { unsigned objnum = FETCH (); SCM what; @@ -378,12 +419,33 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0) NEXT; } +VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0) +{ + SCM what; + unsigned int objnum = FETCH (); + objnum <<= 8; + objnum += FETCH (); + CHECK_OBJECT (objnum); + what = OBJECT_REF (objnum); + + if (!SCM_VARIABLEP (what)) + { + SYNC_BEFORE_GC (); + what = resolve_variable (what, scm_program_module (program)); + OBJECT_SET (objnum, what); + } + + VARIABLE_SET (what, *sp); + DROP (); + NEXT; +} + /* * branch and jump */ -/* offset must be a signed short!!! */ +/* offset must be a signed 16 bit int!!! */ #define FETCH_OFFSET(offset) \ { \ int h = FETCH (); \ @@ -393,51 +455,51 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0) #define BR(p) \ { \ - signed short offset; \ + scm_t_int16 offset; \ FETCH_OFFSET (offset); \ if (p) \ - ip += offset; \ + ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8); \ NULLSTACK (1); \ DROP (); \ NEXT; \ } -VM_DEFINE_INSTRUCTION (31, br, "br", 2, 0, 0) +VM_DEFINE_INSTRUCTION (35, br, "br", 2, 0, 0) { - int h = FETCH (); - int l = FETCH (); - ip += (signed short) (h << 8) + l; + scm_t_int16 offset; + FETCH_OFFSET (offset); + ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8); NEXT; } -VM_DEFINE_INSTRUCTION (32, br_if, "br-if", 2, 0, 0) +VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 2, 0, 0) { BR (!SCM_FALSEP (*sp)); } -VM_DEFINE_INSTRUCTION (33, br_if_not, "br-if-not", 2, 0, 0) +VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 2, 0, 0) { BR (SCM_FALSEP (*sp)); } -VM_DEFINE_INSTRUCTION (34, br_if_eq, "br-if-eq", 2, 0, 0) +VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 2, 0, 0) { sp--; /* underflow? */ BR (SCM_EQ_P (sp[0], sp[1])); } -VM_DEFINE_INSTRUCTION (35, br_if_not_eq, "br-if-not-eq", 2, 0, 0) +VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq", 2, 0, 0) { sp--; /* underflow? */ BR (!SCM_EQ_P (sp[0], sp[1])); } -VM_DEFINE_INSTRUCTION (36, br_if_null, "br-if-null", 2, 0, 0) +VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 2, 0, 0) { BR (SCM_NULLP (*sp)); } -VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0) +VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 2, 0, 0) { BR (!SCM_NULLP (*sp)); } @@ -447,15 +509,7 @@ VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0) * Subprogram call */ -VM_DEFINE_INSTRUCTION (38, make_closure, "make-closure", 0, 1, 1) -{ - SYNC_BEFORE_GC (); - SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp), - SCM_PROGRAM_OBJTABLE (*sp), external); - NEXT; -} - -VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1) +VM_DEFINE_INSTRUCTION (43, call, "call", 1, -1, 1) { SCM x; nargs = FETCH (); @@ -576,7 +630,7 @@ VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1) goto vm_error_wrong_type_apply; } -VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1) +VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1, 1) { register SCM x; nargs = FETCH (); @@ -603,12 +657,6 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1) sp -= 2; NULLSTACK (bp->nargs + 1); - /* Freshen the externals */ - external = SCM_PROGRAM_EXTERNALS (x); - for (i = 0; i < bp->nexts; i++) - CONS (external, SCM_UNDEFINED, external); - SCM_FRAME_DATA_ADDRESS (fp)[0] = external; - /* Init locals to valid SCM values */ for (i = 0; i < bp->nlocs; i++) LOCAL_SET (i + bp->nargs, SCM_UNDEFINED); @@ -657,7 +705,7 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1) sure we have space for the locals now */ data = SCM_FRAME_DATA_ADDRESS (fp); ip = bp->base; - stack_base = data + 3; + stack_base = data + 2; sp = stack_base; CHECK_OVERFLOW (); @@ -672,17 +720,9 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1) data[-i] = SCM_UNDEFINED; /* Set frame data */ - data[3] = (SCM)ra; - data[2] = (SCM)mvra; - data[1] = (SCM)dl; - - /* Postpone initializing external vars, because if the CONS causes a GC, - we want the stack marker to see the data array formatted as expected. */ - data[0] = SCM_UNDEFINED; - external = SCM_PROGRAM_EXTERNALS (fp[-1]); - for (i = 0; i < bp->nexts; i++) - CONS (external, SCM_UNDEFINED, external); - data[0] = external; + data[2] = (SCM)ra; + data[1] = (SCM)mvra; + data[0] = (SCM)dl; ENTER_HOOK (); APPLY_HOOK (); @@ -770,7 +810,7 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1) goto vm_error_wrong_type_apply; } -VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1) +VM_DEFINE_INSTRUCTION (45, goto_nargs, "goto/nargs", 0, 0, 1) { SCM x; POP (x); @@ -779,7 +819,7 @@ VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1) goto vm_goto_args; } -VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1) +VM_DEFINE_INSTRUCTION (46, call_nargs, "call/nargs", 0, 0, 1) { SCM x; POP (x); @@ -788,13 +828,15 @@ VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1) goto vm_call; } -VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1) +VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1) { SCM x; - signed short offset; + scm_t_int16 offset; + scm_t_uint8 *mvra; nargs = FETCH (); FETCH_OFFSET (offset); + mvra = ip + ((scm_t_ptrdiff)offset) * 8 - ((unsigned long)ip) % 8; x = sp[-nargs]; @@ -807,7 +849,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1) CACHE_PROGRAM (); INIT_ARGS (); NEW_FRAME (); - SCM_FRAME_DATA_ADDRESS (fp)[2] = (SCM)(SCM_FRAME_RETURN_ADDRESS (fp) + offset); + SCM_FRAME_DATA_ADDRESS (fp)[1] = (SCM)mvra; ENTER_HOOK (); APPLY_HOOK (); NEXT; @@ -832,7 +874,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1) len = scm_length (values); PUSH_LIST (values, SCM_NULLP); PUSH (len); - ip += offset; + ip = mvra; } NEXT; } @@ -849,7 +891,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1) goto vm_error_wrong_type_apply; } -VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1) +VM_DEFINE_INSTRUCTION (48, apply, "apply", 1, -1, 1) { int len; SCM ls; @@ -868,7 +910,7 @@ VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1) goto vm_call; } -VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1) +VM_DEFINE_INSTRUCTION (49, goto_apply, "goto/apply", 1, -1, 1) { int len; SCM ls; @@ -887,7 +929,7 @@ VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1) goto vm_goto_args; } -VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1) +VM_DEFINE_INSTRUCTION (50, call_cc, "call/cc", 0, 1, 1) { int first; SCM proc, cont; @@ -921,7 +963,7 @@ VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1) } } -VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1) +VM_DEFINE_INSTRUCTION (51, goto_cc, "goto/cc", 0, 1, 1) { int first; SCM proc, cont; @@ -953,7 +995,7 @@ VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1) } } -VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1) +VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1) { vm_return: EXIT_HOOK (); @@ -966,12 +1008,12 @@ VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1) POP (ret); ASSERT (sp == stack_base); - ASSERT (stack_base == data + 3); + ASSERT (stack_base == data + 2); /* Restore registers */ sp = SCM_FRAME_LOWER_ADDRESS (fp); - ip = SCM_FRAME_BYTE_CAST (data[3]); - fp = SCM_FRAME_STACK_CAST (data[1]); + ip = SCM_FRAME_BYTE_CAST (data[2]); + fp = SCM_FRAME_STACK_CAST (data[0]); { #ifdef VM_ENABLE_STACK_NULLING int nullcount = stack_base - sp; @@ -987,12 +1029,11 @@ VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1) /* Restore the last program */ program = SCM_FRAME_PROGRAM (fp); CACHE_PROGRAM (); - CACHE_EXTERNAL (); CHECK_IP (); NEXT; } -VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1) +VM_DEFINE_INSTRUCTION (53, return_values, "return/values", 1, -1, -1) { /* nvalues declared at top level, because for some reason gcc seems to think that perhaps it might be used without declaration. Fooey to that, I say. */ @@ -1004,16 +1045,16 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1) RETURN_HOOK (); data = SCM_FRAME_DATA_ADDRESS (fp); - ASSERT (stack_base == data + 3); + ASSERT (stack_base == data + 2); - /* data[2] is the mv return address */ - if (nvalues != 1 && data[2]) + /* data[1] is the mv return address */ + if (nvalues != 1 && data[1]) { int i; /* Restore registers */ sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; - ip = SCM_FRAME_BYTE_CAST (data[2]); /* multiple value ra */ - fp = SCM_FRAME_STACK_CAST (data[1]); + ip = SCM_FRAME_BYTE_CAST (data[1]); /* multiple value ra */ + fp = SCM_FRAME_STACK_CAST (data[0]); /* Push return values, and the number of values */ for (i = 0; i < nvalues; i++) @@ -1032,8 +1073,8 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1) continuation.) */ /* Restore registers */ sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; - ip = SCM_FRAME_BYTE_CAST (data[3]); /* single value ra */ - fp = SCM_FRAME_STACK_CAST (data[1]); + ip = SCM_FRAME_BYTE_CAST (data[2]); /* single value ra */ + fp = SCM_FRAME_STACK_CAST (data[0]); /* Push first value */ *++sp = stack_base[1]; @@ -1048,12 +1089,11 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1) /* Restore the last program */ program = SCM_FRAME_PROGRAM (fp); CACHE_PROGRAM (); - CACHE_EXTERNAL (); CHECK_IP (); NEXT; } -VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1) +VM_DEFINE_INSTRUCTION (54, return_values_star, "return/values*", 1, -1, -1) { SCM l; @@ -1076,7 +1116,7 @@ VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1) goto vm_return_values; } -VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1) +VM_DEFINE_INSTRUCTION (55, truncate_values, "truncate-values", 2, -1, -1) { SCM x; int nbinds, rest; @@ -1099,62 +1139,100 @@ VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1) NEXT; } -VM_DEFINE_INSTRUCTION (52, long_object_ref, "long-object-ref", 2, 0, 1) +VM_DEFINE_INSTRUCTION (56, box, "box", 1, 1, 0) { - unsigned int objnum = FETCH (); - objnum <<= 8; - objnum += FETCH (); - CHECK_OBJECT (objnum); - PUSH (OBJECT_REF (objnum)); + SCM val; + POP (val); + SYNC_BEFORE_GC (); + LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val))); NEXT; } -VM_DEFINE_INSTRUCTION (53, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1) +/* for letrec: + (let ((a *undef*) (b *undef*) ...) + (set! a (lambda () (b ...))) + ...) + */ +VM_DEFINE_INSTRUCTION (57, empty_box, "empty-box", 1, 0, 0) { - SCM what; - unsigned int objnum = FETCH (); - objnum <<= 8; - objnum += FETCH (); - CHECK_OBJECT (objnum); - what = OBJECT_REF (objnum); - - if (!SCM_VARIABLEP (what)) - { - SYNC_REGISTER (); - what = resolve_variable (what, scm_program_module (program)); - if (!VARIABLE_BOUNDP (what)) - { - finish_args = scm_list_1 (what); - goto vm_error_unbound; - } - OBJECT_SET (objnum, what); - } - - PUSH (VARIABLE_REF (what)); + SYNC_BEFORE_GC (); + LOCAL_SET (FETCH (), + scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED))); NEXT; } -VM_DEFINE_INSTRUCTION (54, long_toplevel_set, "long-toplevel-set", 2, 1, 0) +VM_DEFINE_INSTRUCTION (58, local_boxed_ref, "local-boxed-ref", 1, 0, 1) { - SCM what; - unsigned int objnum = FETCH (); - objnum <<= 8; - objnum += FETCH (); - CHECK_OBJECT (objnum); - what = OBJECT_REF (objnum); - - if (!SCM_VARIABLEP (what)) - { - SYNC_BEFORE_GC (); - what = resolve_variable (what, scm_program_module (program)); - OBJECT_SET (objnum, what); - } - - VARIABLE_SET (what, *sp); - DROP (); + SCM v = LOCAL_REF (FETCH ()); + ASSERT_BOUND_VARIABLE (v); + PUSH (VARIABLE_REF (v)); NEXT; } +VM_DEFINE_INSTRUCTION (59, local_boxed_set, "local-boxed-set", 1, 1, 0) +{ + SCM v, val; + v = LOCAL_REF (FETCH ()); + POP (val); + ASSERT_VARIABLE (v); + VARIABLE_SET (v, val); + NEXT; +} + +VM_DEFINE_INSTRUCTION (60, free_ref, "free-ref", 1, 0, 1) +{ + scm_t_uint8 idx = FETCH (); + + CHECK_FREE_VARIABLE (idx); + PUSH (FREE_VARIABLE_REF (idx)); + NEXT; +} + +/* no free-set -- if a var is assigned, it should be in a box */ + +VM_DEFINE_INSTRUCTION (61, free_boxed_ref, "free-boxed-ref", 1, 0, 1) +{ + SCM v; + scm_t_uint8 idx = FETCH (); + CHECK_FREE_VARIABLE (idx); + v = FREE_VARIABLE_REF (idx); + ASSERT_BOUND_VARIABLE (v); + PUSH (VARIABLE_REF (v)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (62, free_boxed_set, "free-boxed-set", 1, 1, 0) +{ + SCM v, val; + scm_t_uint8 idx = FETCH (); + POP (val); + CHECK_FREE_VARIABLE (idx); + v = FREE_VARIABLE_REF (idx); + ASSERT_BOUND_VARIABLE (v); + VARIABLE_SET (v, val); + NEXT; +} + +VM_DEFINE_INSTRUCTION (63, make_closure, "make-closure", 0, 2, 1) +{ + SCM vect; + POP (vect); + SYNC_BEFORE_GC (); + /* fixme underflow */ + SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp), + SCM_PROGRAM_OBJTABLE (*sp), vect); + NEXT; +} + +VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1) +{ + SYNC_BEFORE_GC (); + /* fixme underflow */ + PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED))); + NEXT; +} + + /* (defun renumber-ops () "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" diff --git a/libguile/vm.c b/libguile/vm.c index f753ea251..cc5e4f924 100644 --- a/libguile/vm.c +++ b/libguile/vm.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 @@ -220,46 +220,35 @@ static SCM sym_vm_run; static SCM sym_vm_error; static SCM sym_debug; -static SCM make_u8vector (const scm_t_uint8 *bytes, size_t len) -{ - scm_t_uint8 *new_bytes = scm_gc_malloc (len, "make-u8vector"); - memcpy (new_bytes, bytes, len); - return scm_take_u8vector (new_bytes, len); -} - -/* Dummy structure to guarantee 32-bit alignment. */ -struct t_32bit_aligned -{ - scm_t_int32 dummy; - scm_t_uint8 bytes[18]; -}; - static SCM really_make_boot_program (long nargs) { SCM u8vec; - struct t_32bit_aligned bytes = - { - .dummy = 0, - .bytes = { 0, 0, 0, 0, - 0, 0, 0, 0, - 0, 0, 0, 0, - scm_op_mv_call, 0, 0, 1, - scm_op_make_int8_1, scm_op_halt } - }; - + /* Make sure "bytes" is 64-bit aligned. */ + scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 1, + scm_op_make_int8_1, scm_op_nop, scm_op_nop, scm_op_nop, + scm_op_halt }; + struct scm_objcode *bp; SCM ret; - /* Set length in current endianness, no meta. */ - ((scm_t_uint32 *) bytes.bytes)[1] = 6; - if (SCM_UNLIKELY (nargs > 255 || nargs < 0)) abort (); - bytes.bytes[13] = (scm_byte_t) nargs; + text[1] = (scm_t_uint8)nargs; - u8vec = make_u8vector (bytes.bytes, sizeof (bytes.bytes)); + bp = scm_gc_malloc (sizeof (struct scm_objcode) + sizeof (text), + "make-u8vector"); + 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)); ret = scm_make_program (scm_bytecode_to_objcode (u8vec), - SCM_BOOL_F, SCM_EOL); + SCM_BOOL_F, SCM_BOOL_F); SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT); return ret; @@ -325,7 +314,7 @@ resolve_variable (SCM what, SCM program_module) } -#define VM_DEFAULT_STACK_SIZE (16 * 1024) +#define VM_DEFAULT_STACK_SIZE (64 * 1024) #define VM_NAME vm_regular_engine #define FUNC_NAME "vm-regular-engine" @@ -663,7 +652,7 @@ SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0, SCM scm_load_compiled_with_vm (SCM file) { SCM program = scm_make_program (scm_load_objcode (file), - SCM_BOOL_F, SCM_EOL); + SCM_BOOL_F, SCM_BOOL_F); return scm_c_vm_run (scm_the_vm (), program, NULL, 0); } diff --git a/module/Makefile.am b/module/Makefile.am index a904a8f8e..2971fc6b5 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -34,6 +34,7 @@ SOURCES = \ ice-9/psyntax-pp.scm \ system/base/pmatch.scm system/base/syntax.scm \ system/base/compile.scm system/base/language.scm \ + system/base/message.scm \ \ language/tree-il.scm \ language/ghil.scm language/glil.scm language/assembly.scm \ diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 113269b2e..de0db95de 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -54,7 +54,8 @@ (let ((id293 (if (syntax-object?99 id292) (syntax-object-expression100 id292) id292))) - (gensym (symbol->string id293))))) + (gensym + (string-append (symbol->string id293) " "))))) (strip161 (lambda (x294 w295) (if (memq (quote top) (wrap-marks118 w295)) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index f1f6e9ae0..6ecf24ee6 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1,6 +1,6 @@ ;;;; -*-scheme-*- ;;;; -;;;; Copyright (C) 2001, 2003, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2003, 2006, 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 @@ -529,10 +529,10 @@ `(letrec ,(map list vars val-exps) ,body-exp) src)))))) -;; FIXME: wingo: use make-lexical ? +;; FIXME: use a faster gensym (define-syntax build-lexical-var (syntax-rules () - ((_ src id) (gensym (symbol->string id))))) + ((_ src id) (gensym (string-append (symbol->string id) " "))))) (define-structure (syntax-object expression wrap module)) diff --git a/module/language/assembly.scm b/module/language/assembly.scm index 6ccac99dd..2427c4247 100644 --- a/module/language/assembly.scm +++ b/module/language/assembly.scm @@ -24,12 +24,12 @@ #:use-module (system vm instruction) #:use-module ((srfi srfi-1) #:select (fold)) #:export (byte-length - addr+ align-program align-code + addr+ align-program align-code align-block assembly-pack assembly-unpack object->assembly assembly->object)) -;; nargs, nrest, nlocs, nexts, len, metalen -(define *program-header-len* (+ 1 1 1 1 4 4)) +;; nargs, nrest, nlocs, len, metalen, padding +(define *program-header-len* (+ 1 1 2 4 4 4)) ;; lengths are encoded in 3 bytes (define *len-len* 3) @@ -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))) @@ -63,17 +63,24 @@ (define *program-alignment* 8) +(define *block-alignment* 8) + (define (addr+ addr code) (fold (lambda (x len) (+ (byte-length x) len)) addr code)) +(define (code-alignment addr alignment header-len) + (make-list (modulo (- alignment + (modulo (+ addr header-len) alignment)) + alignment) + '(nop))) + +(define (align-block addr) + (code-alignment addr *block-alignment* 0)) (define (align-code code addr alignment header-len) - `(,@(make-list (modulo (- alignment - (modulo (+ addr header-len) alignment)) - alignment) - '(nop)) + `(,@(code-alignment addr alignment header-len) ,code)) (define (align-program prog addr) @@ -110,7 +117,7 @@ ((null? x) `(make-eol)) ((and (integer? x) (exact? x)) (cond ((and (<= -128 x) (< x 128)) - `(make-int8 ,(modulo x 256))) + (assembly-pack `(make-int8 ,(modulo x 256)))) ((and (<= -32768 x) (< x 32768)) (let ((n (if (< x 0) (+ x 65536) x))) `(make-int16 ,(quotient n 256) ,(modulo n 256)))) @@ -125,7 +132,11 @@ (bytevector-s64-set! bv 0 x (endianness big)) bv)))) (else #f))) - ((char? x) `(make-char8 ,(char->integer x))) + ((char? x) + (cond ((<= (char->integer x) #xff) + `(make-char8 ,(char->integer x))) + (else + `(make-char32 ,(char->integer x))))) (else #f))) (define (assembly->object code) @@ -151,6 +162,11 @@ (endianness big))) ((make-char8 ,n) (integer->char n)) + ((make-char32 ,n1 ,n2 ,n3 ,n4) + (integer->char (+ (* n1 #x1000000) + (* n2 #x10000) + (* n3 #x100) + n4))) ((load-string ,s) s) ((load-symbol ,s) (string->symbol s)) ((load-keyword ,s) (symbol->keyword (string->symbol s))) diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index 4b9f7b701..bed0fb2dc 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -77,10 +77,19 @@ ;; Ew! (for-each write-byte (bytevector->u8-list bv))) (define (write-break label) - (write-uint16-be (- (assq-ref labels label) (+ (get-addr) 2)))) + (let ((offset (- (assq-ref labels label) + (logand (+ (get-addr) 2) (lognot #x7))))) + (cond ((not (= 0 (modulo offset 8))) (error "unaligned jump" offset)) + ((>= offset (ash 1 18)) (error "jump too far forward" offset)) + ((< offset (- (ash 1 18))) (error "jump too far backwards" offset)) + (else (write-uint16-be (ash offset -3)))))) (let ((inst (car asm)) (args (cdr asm)) + (write-uint16 (case byte-order + ((1234) write-uint16-le) + ((4321) write-uint16-be) + (else (error "unknown endianness" byte-order)))) (write-uint32 (case byte-order ((1234) write-uint32-le) ((4321) write-uint32-be) @@ -89,14 +98,13 @@ (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-uint16 nlocs) (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))) @@ -114,6 +122,7 @@ ;; meets the alignment requirements of `scm_objcode'. See ;; `scm_c_make_objcode_slice ()'. (write-bytecode meta write get-addr '())))) + ((make-char32 ,x) (write-uint32-be x)) ((load-unsigned-integer ,str) (write-loader str)) ((load-integer ,str) (write-loader str)) ((load-number ,str) (write-loader str)) diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm index fdf27ec62..0e34ab4a2 100644 --- a/module/language/assembly/decompile-bytecode.scm +++ b/module/language/assembly/decompile-bytecode.scm @@ -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 @@ -48,17 +48,21 @@ x (- x (ash 1 16))))) +;; FIXME: this is a little-endian disassembly!!! (define (decode-load-program pop) - (let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (nexts (pop)) + (let* ((nargs (pop)) (nrest (pop)) (nlocs0 (pop)) (nlocs1 (pop)) + (nlocs (+ nlocs0 (ash nlocs1 8))) (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))) (totlen (+ len metalen)) + (pad0 (pop)) (pad1 (pop)) (pad2 (pop)) (pad3 (pop)) (labels '()) (i 0)) (define (ensure-label rel1 rel2) - (let ((where (+ i (bytes->s16 rel1 rel2)))) + (let ((where (+ (logand i (lognot #x7)) + (* (bytes->s16 rel1 rel2) 8)))) (or (assv-ref labels where) (begin (let ((l (gensym ":L"))) @@ -74,7 +78,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 diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm index 0a35050b3..d41c8161d 100644 --- a/module/language/assembly/disassemble.scm +++ b/module/language/assembly/disassemble.scm @@ -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)))) diff --git a/module/language/glil.scm b/module/language/glil.scm index 38b915f9e..0777073f6 100644 --- a/module/language/glil.scm +++ b/module/language/glil.scm @@ -1,6 +1,6 @@ ;;; Guile Low Intermediate Language -;; 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 @@ -24,9 +24,9 @@ #:use-module ((srfi srfi-1) #:select (fold)) #:export ( 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 + make-glil-bind glil-bind? glil-bind-vars @@ -43,11 +43,8 @@ make-glil-const glil-const? glil-const-obj - make-glil-local glil-local? - glil-local-op glil-local-index - - make-glil-external glil-external? - glil-external-op glil-external-depth glil-external-index + make-glil-lexical glil-lexical? + glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index make-glil-toplevel glil-toplevel? glil-toplevel-op glil-toplevel-name @@ -74,7 +71,7 @@ (define-type ( #:printer print-glil) ;; Meta operations - ( nargs nrest nlocs nexts meta body (closure-level #f)) + ( nargs nrest nlocs meta body) ( vars) ( vars rest) () @@ -83,8 +80,7 @@ () ( obj) ;; Variables - ( op index) - ( op depth index) + ( local? boxed? op index) ( op name) ( op mod name public?) ;; Controls @@ -93,35 +89,19 @@ ( inst nargs) ( nargs ra)) -(define (compute-closure-level body) - (fold (lambda (x ret) - (record-case x - (( closure-level) (max ret closure-level)) - (( 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)) ((module private ,op ,mod ,name) (make-glil-module op mod name #f)) @@ -134,8 +114,8 @@ (define (unparse-glil glil) (record-case glil ;; meta - (( nargs nrest nlocs nexts meta body) - `(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body))) + (( nargs nrest nlocs meta body) + `(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body))) (( vars) `(bind ,@vars)) (( vars rest) `(mv-bind ,vars ,rest)) (() `(unbind)) @@ -144,10 +124,8 @@ (() `(void)) (( obj) `(const ,obj)) ;; variables - (( op index) - `(local ,op ,index)) - (( op depth index) - `(external ,op ,depth ,index)) + (( local? boxed? op index) + `(lexical ,local? ,boxed? ,op ,index)) (( op name) `(toplevel ,op ,name)) (( op mod name public?) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index 0b92a4e7d..fa5805757 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -72,14 +72,14 @@ (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)))))) ;; A functional stack of names of live variables. -(define (make-open-binding name ext? index) - (list name ext? index)) +(define (make-open-binding name boxed? index) + (list name boxed? index)) (define (make-closed-binding open-binding start end) (make-binding (car open-binding) (cadr open-binding) (caddr open-binding) start end)) @@ -89,8 +89,8 @@ (map (lambda (v) (pmatch v - ((,name local ,i) (make-open-binding name #f i)) - ((,name external ,i) (make-open-binding name #t i)) + ((,name ,boxed? ,i) + (make-open-binding name boxed? i)) (else (error "unknown binding type" v)))) vars) (car bindings)) @@ -128,74 +128,77 @@ (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 x bindings source-alist label-alist object-alist)) (define (emit-code/object x object-alist) - (values (map assembly-pack x) bindings source-alist label-alist object-alist)) + (values x bindings source-alist label-alist object-alist)) (record-case glil - (( 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)))))))) + (( 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 (if (> closure-level 0) '((make-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* ((meta (make-meta bindings sources meta)) + (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0)) + (prog `(load-program ,nargs ,nrest ,nlocs ,labels + ,(+ len meta-pad) + ,meta + ,@code + ,@(if meta + (make-list meta-pad '(nop)) + '())))) + (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 (make-object-table objects))) + (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 + (let ((table-code (dump-object table addr))) + (emit-code + `(,@table-code + ,@(align-program prog (addr+ addr table-code))))))))))))) (( vars) (values '() @@ -244,19 +247,45 @@ ,(modulo i 256)))) object-alist))))) - (( op index) - (emit-code (if (eq? op 'ref) - `((local-ref ,index)) - `((local-set ,index))))) - - (( 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)))))))) - + (( local? boxed? op index) + (emit-code + (if local? + (if (< index 256) + `((,(case op + ((ref) (if boxed? 'local-boxed-ref 'local-ref)) + ((set) (if boxed? 'local-boxed-set 'local-set)) + ((box) 'box) + ((empty-box) 'empty-box) + (else (error "what" op))) + ,index)) + (let ((a (quotient i 256)) + (b (modulo i 256))) + `((,(case op + ((ref) + (if boxed? + `((long-local-ref ,a ,b) + (variable-ref)) + `((long-local-ref ,a ,b)))) + ((set) + (if boxed? + `((long-local-ref ,a ,b) + (variable-set)) + `((long-local-set ,a ,b)))) + ((box) + `((make-variable) + (variable-set) + (long-local-set ,a ,b))) + ((empty-box) + `((make-variable) + (long-local-set ,a ,b))) + (else (error "what" op))) + ,index)))) + `((,(case op + ((ref) (if boxed? 'free-boxed-ref 'free-ref)) + ((set) (if boxed? 'free-boxed-set (error "what." glil))) + (else (error "what" op))) + ,index))))) + (( op name) (case op ((ref set) @@ -311,11 +340,12 @@ (error "unknown module var kind" op key))))) (( label) - (values '() - bindings - source-alist - (acons label addr label-alist) - object-alist)) + (let ((code (align-block addr))) + (values code + bindings + source-alist + (acons label (addr+ addr code) label-alist) + object-alist))) (( inst label) (emit-code `((,inst ,label)))) @@ -348,9 +378,10 @@ ((object->assembly x) => list) ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr)) ((subprogram? x) - `(,@(subprogram-table x) - ,@(align-program (subprogram-prog x) - (addr+ addr (subprogram-table x))))) + (let ((table-code (dump-object (subprogram-table x) addr))) + `(,@table-code + ,@(align-program (subprogram-prog x) + (addr+ addr table-code))))) ((number? x) `((load-number ,(number->string x)))) ((string? x) diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm index 6c222ba31..69aa1eb5c 100644 --- a/module/language/glil/decompile-assembly.scm +++ b/module/language/glil/decompile-assembly.scm @@ -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) diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm index 76c1cbcb9..4cb600f1d 100644 --- a/module/language/objcode/spec.scm +++ b/module/language/objcode/spec.scm @@ -1,6 +1,6 @@ ;;; Guile Lowlevel Intermediate Language -;; 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,7 +31,7 @@ (if env (car env) (current-module))) (define (objcode-env-externals env) - (if env (cdr env) '())) + (and env (vector? (cdr env)) (cdr env))) (define (objcode->value x e opts) (let ((thunk (make-program x #f (objcode-env-externals e)))) @@ -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)) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 0f8448a44..aec4eedb9 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -17,6 +17,7 @@ (define-module (language tree-il) + #:use-module (srfi srfi-1) #:use-module (system base pmatch) #:use-module (system base syntax) #:export (tree-il-src @@ -38,11 +39,12 @@ let? make-let let-src let-names let-vars let-vals let-body letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body - + parse-tree-il unparse-tree-il tree-il->scheme + tree-il-fold post-order! pre-order!)) @@ -258,6 +260,51 @@ `(call-with-values (lambda () ,(tree-il->scheme exp)) (lambda ,vars ,(tree-il->scheme body)))))) + +(define (tree-il-fold leaf down up seed tree) + "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent +into a sub-tree, and UP when leaving a sub-tree. Each of these procedures is +invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered +and SEED is the current result, intially seeded with SEED. + +This is an implementation of `foldts' as described by Andy Wingo in +``Applications of fold to XML transformation''." + (let loop ((tree tree) + (result seed)) + (if (or (null? tree) (pair? tree)) + (fold loop result tree) + (record-case tree + (( exp) + (up tree (loop exp (down tree result)))) + (( exp) + (up tree (loop exp (down tree result)))) + (( exp) + (up tree (loop exp (down tree result)))) + (( exp) + (up tree (loop exp (down tree result)))) + (( test then else) + (up tree (loop else + (loop then + (loop test (down tree result)))))) + (( proc args) + (up tree (loop (cons proc args) (down tree result)))) + (( exps) + (up tree (loop exps (down tree result)))) + (( body) + (up tree (loop body (down tree result)))) + (( vals body) + (up tree (loop body + (loop vals + (down tree result))))) + (( vals body) + (up tree (loop body + (loop vals + (down tree result))))) + (( body) + (up tree (loop body (down tree result)))) + (else + (leaf tree result)))))) + (define (post-order! f x) (let lp ((x x)) (record-case x diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 976807718..1b39b2dd4 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -19,14 +19,40 @@ ;;; Code: (define-module (language tree-il analyze) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (system base syntax) + #:use-module (system base message) #:use-module (language tree-il) - #:export (analyze-lexicals)) + #:export (analyze-lexicals + report-unused-variables)) -;; allocation: the process of assigning a type and index to each var -;; a var is external if it is heaps; assigning index is easy -;; args are assigned in order -;; locals are indexed as their linear position in the binding path +;; Allocation is the process of assigning storage locations for lexical +;; variables. A lexical variable has a distinct "address", or storage +;; location, for each procedure in which it is referenced. +;; +;; A variable is "local", i.e., allocated on the stack, if it is +;; referenced from within the procedure that defined it. Otherwise it is +;; a "closure" variable. For example: +;; +;; (lambda (a) a) ; a will be local +;; `a' is local to the procedure. +;; +;; (lambda (a) (lambda () a)) +;; `a' is local to the outer procedure, but a closure variable with +;; respect to the inner procedure. +;; +;; If a variable is ever assigned, it needs to be heap-allocated +;; ("boxed"). This is so that closures and continuations capture the +;; variable's identity, not just one of the values it may have over the +;; course of program execution. If the variable is never assigned, there +;; is no distinction between value and identity, so closing over its +;; identity (whether through closures or continuations) can make a copy +;; of its value instead. +;; +;; Local variables are stored on the stack within a procedure's call +;; frame. Their index into the stack is determined from their linear +;; postion within a procedure's binding path: ;; (let (0 1) ;; (let (2 3) ...) ;; (let (2) ...)) @@ -48,49 +74,67 @@ ;; case. A proper solution would be some sort of liveness analysis, and ;; not our linear allocation algorithm. ;; -;; allocation: -;; sym -> (local . index) | (heap level . index) -;; lambda -> (nlocs . nexts) +;; Closure variables are captured when a closure is created, and stored +;; in a vector. Each closure variable has a unique index into that +;; vector. +;; +;; +;; The return value of `analyze-lexicals' is a hash table, the +;; "allocation". +;; +;; The allocation maps gensyms -- recall that each lexically bound +;; variable has a unique gensym -- to storage locations ("addresses"). +;; Since one gensym may have many storage locations, if it is referenced +;; in many procedures, it is a two-level map. +;; +;; The allocation also stored information on how many local variables +;; need to be allocated for each procedure, and information on what free +;; variables to capture from its lexical parent procedure. +;; +;; That is: +;; +;; sym -> {lambda -> address} +;; lambda -> (nlocs . free-locs) +;; +;; address := (local? boxed? . index) +;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) +;; free variable addresses are relative to parent proc. + +(define (make-hashq k v) + (let ((res (make-hash-table))) + (hashq-set! res k v) + res)) (define (analyze-lexicals x) - ;; parents: lambda -> parent - ;; useful when we see a closed-over var, so we can calculate its - ;; coordinates (depth and index). - ;; bindings: lambda -> (sym ...) - ;; useful for two reasons: one, so we know how much space to allocate - ;; when we go into a lambda; and two, so that we know when to stop, - ;; when looking for closed-over vars. - ;; heaps: sym -> lambda - ;; allows us to heapify vars in an O(1) fashion + ;; bound-vars: lambda -> (sym ...) + ;; all identifiers bound within a lambda + ;; free-vars: lambda -> (sym ...) + ;; all identifiers referenced in a lambda, but not bound + ;; NB, this includes identifiers referenced by contained lambdas + ;; assigned: sym -> #t + ;; variables that are assigned ;; refcounts: sym -> count - ;; allows us to detect the or-expansion an O(1) time - - (define (find-heap sym parent) - ;; fixme: check displaced lexicals here? - (if (memq sym (hashq-ref bindings parent)) - parent - (find-heap sym (hashq-ref parents parent)))) - - (define (analyze! x parent level) - (define (step y) (analyze! y parent level)) - (define (recur x parent) (analyze! x parent (1+ level))) + ;; allows us to detect the or-expansion in O(1) time + + ;; returns variables referenced in expr + (define (analyze! x proc) + (define (step y) (analyze! y proc)) + (define (recur x new-proc) (analyze! x new-proc)) (record-case x (( proc args) - (step proc) (for-each step args)) + (apply lset-union eq? (step proc) (map step args))) (( test then else) - (step test) (step then) (step else)) + (lset-union eq? (step test) (step then) (step else))) (( name gensym) (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) - (if (and (not (memq gensym (hashq-ref bindings parent))) - (not (hashq-ref heaps gensym))) - (hashq-set! heaps gensym (find-heap gensym parent)))) + (list gensym)) (( name gensym exp) - (step exp) - (if (not (hashq-ref heaps gensym)) - (hashq-set! heaps gensym (find-heap gensym parent)))) + (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) + (hashq-set! assigned gensym #t) + (lset-adjoin eq? (step exp) gensym)) (( mod name public? exp) (step exp)) @@ -102,157 +146,292 @@ (step exp)) (( exps) - (for-each step exps)) + (apply lset-union eq? (map step exps))) (( vars meta body) - (hashq-set! parents x parent) - (hashq-set! bindings x - (let rev* ((vars vars) (out '())) - (cond ((null? vars) out) - ((pair? vars) (rev* (cdr vars) - (cons (car vars) out))) - (else (cons vars out))))) - (recur body x) - (hashq-set! bindings x (reverse! (hashq-ref bindings x)))) - + (let ((locally-bound (let rev* ((vars vars) (out '())) + (cond ((null? vars) out) + ((pair? vars) (rev* (cdr vars) + (cons (car vars) out))) + (else (cons vars out)))))) + (hashq-set! bound-vars x locally-bound) + (let* ((referenced (recur body x)) + (free (lset-difference eq? referenced locally-bound)) + (all-bound (reverse! (hashq-ref bound-vars x)))) + (hashq-set! bound-vars x all-bound) + (hashq-set! free-vars x free) + free))) + (( vars vals body) - (for-each step vals) - (hashq-set! bindings parent - (append (reverse vars) (hashq-ref bindings parent))) - (step body)) + (hashq-set! bound-vars proc + (append (reverse vars) (hashq-ref bound-vars proc))) + (lset-difference eq? + (apply lset-union eq? (step body) (map step vals)) + vars)) (( vars vals body) - (hashq-set! bindings parent - (append (reverse vars) (hashq-ref bindings parent))) - (for-each step vals) - (step body)) - + (hashq-set! bound-vars proc + (append (reverse vars) (hashq-ref bound-vars proc))) + (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars) + (lset-difference eq? + (apply lset-union eq? (step body) (map step vals)) + vars)) + (( vars exp body) - (hashq-set! bindings parent - (let lp ((out (hashq-ref bindings parent)) (in vars)) + (hashq-set! bound-vars proc + (let lp ((out (hashq-ref bound-vars proc)) (in vars)) (if (pair? in) (lp (cons (car in) out) (cdr in)) (if (null? in) out (cons in out))))) - (step exp) - (step body)) + (lset-difference eq? + (lset-union eq? (step exp) (step body)) + vars)) + + (else '()))) + + (define (allocate! x proc n) + (define (recur y) (allocate! y proc n)) + (record-case x + (( proc args) + (apply max (recur proc) (map recur args))) - (else #f))) + (( test then else) + (max (recur test) (recur then) (recur else))) - (define (allocate-heap! binder) - (hashq-set! heap-indexes binder - (1+ (hashq-ref heap-indexes binder -1)))) + (( name gensym exp) + (recur exp)) + + (( mod name public? exp) + (recur exp)) + + (( name exp) + (recur exp)) + + (( name exp) + (recur exp)) + + (( exps) + (apply max (map recur exps))) + + (( vars meta body) + ;; allocate closure vars in order + (let lp ((c (hashq-ref free-vars x)) (n 0)) + (if (pair? c) + (begin + (hashq-set! (hashq-ref allocation (car c)) + x + `(#f ,(hashq-ref assigned (car c)) . ,n)) + (lp (cdr c) (1+ n))))) + + (let ((nlocs + (let lp ((vars vars) (n 0)) + (if (not (null? vars)) + ;; allocate args + (let ((v (if (pair? vars) (car vars) vars))) + (hashq-set! allocation v + (make-hashq + x `(#t ,(hashq-ref assigned v) . ,n))) + (lp (if (pair? vars) (cdr vars) '()) (1+ n))) + ;; allocate body, return number of additional locals + (- (allocate! body x n) n)))) + (free-addresses + (map (lambda (v) + (hashq-ref (hashq-ref allocation v) proc)) + (hashq-ref free-vars x)))) + ;; set procedure allocations + (hashq-set! allocation x (cons nlocs free-addresses))) + n) - (define (allocate! x level n) - (define (recur y) (allocate! y level n)) - (record-case x - (( proc args) - (apply max (recur proc) (map recur args))) - - (( test then else) - (max (recur test) (recur then) (recur else))) - - (( name gensym exp) - (recur exp)) - - (( mod name public? exp) - (recur exp)) - - (( name exp) - (recur exp)) - - (( name exp) - (recur exp)) - - (( exps) - (apply max (map recur exps))) - - (( vars meta body) - (let lp ((vars vars) (n 0)) - (if (null? vars) - (hashq-set! allocation x - (let ((nlocs (- (allocate! body (1+ level) n) n))) - (cons nlocs (1+ (hashq-ref heap-indexes x -1))))) - (let ((v (if (pair? vars) (car vars) vars))) - (let ((binder (hashq-ref heaps v))) - (hashq-set! - allocation v - (if binder - (cons* 'heap (1+ level) (allocate-heap! binder)) - (cons 'stack n)))) - (lp (if (pair? vars) (cdr vars) '()) (1+ n))))) - n) - - (( vars vals body) - (let ((nmax (apply max (map recur vals)))) - (cond - ;; the `or' hack - ((and (conditional? body) - (= (length vars) 1) - (let ((v (car vars))) - (and (not (hashq-ref heaps v)) - (= (hashq-ref refcounts v 0) 2) - (lexical-ref? (conditional-test body)) - (eq? (lexical-ref-gensym (conditional-test body)) v) - (lexical-ref? (conditional-then body)) - (eq? (lexical-ref-gensym (conditional-then body)) v)))) - (hashq-set! allocation (car vars) (cons 'stack n)) - ;; the 1+ for this var - (max nmax (1+ n) (allocate! (conditional-else body) level n))) - (else - (let lp ((vars vars) (n n)) - (if (null? vars) - (max nmax (allocate! body level n)) - (let ((v (car vars))) - (let ((binder (hashq-ref heaps v))) - (hashq-set! - allocation v - (if binder - (cons* 'heap level (allocate-heap! binder)) - (cons 'stack n))) - (lp (cdr vars) (if binder n (1+ n))))))))))) - - (( vars vals body) - (let lp ((vars vars) (n n)) - (if (null? vars) - (let ((nmax (apply max - (map (lambda (x) - (allocate! x level n)) - vals)))) - (max nmax (allocate! body level n))) - (let ((v (car vars))) - (let ((binder (hashq-ref heaps v))) - (hashq-set! - allocation v - (if binder - (cons* 'heap level (allocate-heap! binder)) - (cons 'stack n))) - (lp (cdr vars) (if binder n (1+ n)))))))) - - (( vars exp body) - (let ((nmax (recur exp))) + (( vars vals body) + (let ((nmax (apply max (map recur vals)))) + (cond + ;; the `or' hack + ((and (conditional? body) + (= (length vars) 1) + (let ((v (car vars))) + (and (not (hashq-ref assigned v)) + (= (hashq-ref refcounts v 0) 2) + (lexical-ref? (conditional-test body)) + (eq? (lexical-ref-gensym (conditional-test body)) v) + (lexical-ref? (conditional-then body)) + (eq? (lexical-ref-gensym (conditional-then body)) v)))) + (hashq-set! allocation (car vars) + (make-hashq proc `(#t #f . ,n))) + ;; the 1+ for this var + (max nmax (1+ n) (allocate! (conditional-else body) proc n))) + (else (let lp ((vars vars) (n n)) (if (null? vars) - (max nmax (allocate! body level n)) - (let ((v (if (pair? vars) (car vars) vars))) - (let ((binder (hashq-ref heaps v))) - (hashq-set! - allocation v - (if binder - (cons* 'heap level (allocate-heap! binder)) - (cons 'stack n))) - (lp (if (pair? vars) (cdr vars) '()) - (if binder n (1+ n))))))))) - - (else n))) + (max nmax (allocate! body proc n)) + (let ((v (car vars))) + (hashq-set! + allocation v + (make-hashq proc + `(#t ,(hashq-ref assigned v) . ,n))) + (lp (cdr vars) (1+ n))))))))) + + (( vars vals body) + (let lp ((vars vars) (n n)) + (if (null? vars) + (let ((nmax (apply max + (map (lambda (x) + (allocate! x proc n)) + vals)))) + (max nmax (allocate! body proc n))) + (let ((v (car vars))) + (hashq-set! + allocation v + (make-hashq proc + `(#t ,(hashq-ref assigned v) . ,n))) + (lp (cdr vars) (1+ n)))))) - (define parents (make-hash-table)) - (define bindings (make-hash-table)) - (define heaps (make-hash-table)) + (( vars exp body) + (let ((nmax (recur exp))) + (let lp ((vars vars) (n n)) + (if (null? vars) + (max nmax (allocate! body proc n)) + (let ((v (if (pair? vars) (car vars) vars))) + (let ((v (car vars))) + (hashq-set! + allocation v + (make-hashq proc + `(#t ,(hashq-ref assigned v) . ,n))) + (lp (cdr vars) (1+ n)))))))) + + (else n))) + + (define bound-vars (make-hash-table)) + (define free-vars (make-hash-table)) + (define assigned (make-hash-table)) (define refcounts (make-hash-table)) + (define allocation (make-hash-table)) - (define heap-indexes (make-hash-table)) - - (analyze! x #f -1) - (allocate! x -1 0) + + (analyze! x #f) + (allocate! x #f 0) allocation) + + +;;; +;;; Unused variable analysis. +;;; + +;; records are used during tree traversals in +;; `report-unused-variables'. They contain a list of the local vars +;; currently in scope, a list of locals vars that have been referenced, and a +;; "location stack" (the stack of `tree-il-src' values for each parent tree). +(define-record-type + (make-binding-info vars refs locs) + binding-info? + (vars binding-info-vars) ;; ((GENSYM NAME LOCATION) ...) + (refs binding-info-refs) ;; (GENSYM ...) + (locs binding-info-locs)) ;; (LOCATION ...) + +(define (report-unused-variables tree) + "Report about unused variables in TREE. Return TREE." + + (define (dotless-list lst) + ;; If LST is a dotted list, return a proper list equal to LST except that + ;; the very last element is a pair; otherwise return LST. + (let loop ((lst lst) + (result '())) + (cond ((null? lst) + (reverse result)) + ((pair? lst) + (loop (cdr lst) (cons (car lst) result))) + (else + (loop '() (cons lst result)))))) + + (tree-il-fold (lambda (x info) + ;; X is a leaf: extend INFO's refs accordingly. + (let ((refs (binding-info-refs info)) + (vars (binding-info-vars info)) + (locs (binding-info-locs info))) + (record-case x + (( gensym) + (make-binding-info vars (cons gensym refs) locs)) + (else info)))) + + (lambda (x info) + ;; Going down into X: extend INFO's variable list + ;; accordingly. + (let ((refs (binding-info-refs info)) + (vars (binding-info-vars info)) + (locs (binding-info-locs info)) + (src (tree-il-src x))) + (define (extend inner-vars inner-names) + (append (map (lambda (var name) + (list var name src)) + inner-vars + inner-names) + vars)) + (record-case x + (( gensym) + (make-binding-info vars (cons gensym refs) + (cons src locs))) + (( vars names) + (let ((vars (dotless-list vars)) + (names (dotless-list names))) + (make-binding-info (extend vars names) refs + (cons src locs)))) + (( vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) + (( vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) + (( vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) + (else info)))) + + (lambda (x info) + ;; Leaving X's scope: shrink INFO's variable list + ;; accordingly and reported unused nested variables. + (let ((refs (binding-info-refs info)) + (vars (binding-info-vars info)) + (locs (binding-info-locs info))) + (define (shrink inner-vars refs) + (for-each (lambda (var) + (let ((gensym (car var))) + ;; Don't report lambda parameters as + ;; unused. + (if (and (not (memq gensym refs)) + (not (and (lambda? x) + (memq gensym + inner-vars)))) + (let ((name (cadr var)) + ;; We can get approximate + ;; source location by going up + ;; the LOCS location stack. + (loc (or (caddr var) + (find pair? locs)))) + (warning 'unused-variable loc name))))) + (filter (lambda (var) + (memq (car var) inner-vars)) + vars)) + (fold alist-delete vars inner-vars)) + + ;; For simplicity, we leave REFS untouched, i.e., with + ;; names of variables that are now going out of scope. + ;; It doesn't hurt as these are unique names, it just + ;; makes REFS unnecessarily fat. + (record-case x + (( vars) + (let ((vars (dotless-list vars))) + (make-binding-info (shrink vars refs) refs + (cdr locs)))) + (( vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) + (( vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) + (( vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) + (else info)))) + (make-binding-info '() '() '()) + tree) + tree) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index e0df038d8..bf4699797 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -20,6 +20,8 @@ (define-module (language tree-il compile-glil) #:use-module (system base syntax) + #:use-module (system base pmatch) + #:use-module (system base message) #:use-module (ice-9 receive) #:use-module (language glil) #:use-module (system vm instruction) @@ -34,18 +36,37 @@ ;; basic degenerate-case reduction ;; allocation: -;; sym -> (local . index) | (heap level . index) -;; lambda -> (nlocs . nexts) +;; sym -> {lambda -> address} +;; lambda -> (nlocs . closure-vars) +;; +;; address := (local? boxed? . index) +;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) +;; free variable addresses are relative to parent proc. (define *comp-module* (make-fluid)) +(define %warning-passes + `((unused-variable . ,report-unused-variables))) + (define (compile-glil x e opts) + (define warnings + (or (and=> (memq #:warnings opts) cadr) + '())) + (let* ((x (make-lambda (tree-il-src x) '() '() '() x)) (x (optimize! x e opts)) (allocation (analyze-lexicals x))) + + ;; Go throught the warning passes. + (for-each (lambda (kind) + (let ((warn (assoc-ref %warning-passes kind))) + (and (procedure? warn) + (warn x)))) + warnings) + (with-fluid* *comp-module* (or (and e (car e)) (current-module)) (lambda () - (values (flatten-lambda x -1 allocation) + (values (flatten-lambda x allocation) (and e (cons (car e) (cddr e))) e))))) @@ -131,20 +152,19 @@ (define (make-label) (gensym ":L")) -(define (vars->bind-list ids vars allocation) +(define (vars->bind-list ids vars allocation proc) (map (lambda (id v) - (let ((loc (hashq-ref allocation v))) - (case (car loc) - ((stack) (list id 'local (cdr loc))) - ((heap) (list id 'external (cddr loc))) - (else (error "badness" id v loc))))) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t ,boxed? . ,n) + (list id boxed? n)) + (,x (error "badness" x)))) ids vars)) -(define (emit-bindings src ids vars allocation emit-code) +(define (emit-bindings src ids vars allocation proc emit-code) (if (pair? vars) (emit-code src (make-glil-bind - (vars->bind-list ids vars allocation))))) + (vars->bind-list ids vars allocation proc))))) (define (with-output-to-code proc) (let ((out '())) @@ -155,7 +175,7 @@ (proc emit-code) (reverse out))) -(define (flatten-lambda x level allocation) +(define (flatten-lambda x allocation) (receive (ids vars nargs nrest) (let lp ((ids (lambda-names x)) (vars (lambda-vars x)) (oids '()) (ovars '()) (n 0)) @@ -166,31 +186,27 @@ (else (values (reverse (cons ids oids)) (reverse (cons vars ovars)) (1+ n) 1)))) - (let ((nlocs (car (hashq-ref allocation x))) - (nexts (cdr (hashq-ref allocation x)))) + (let ((nlocs (car (hashq-ref allocation x)))) (make-glil-program - nargs nrest nlocs nexts (lambda-meta x) + nargs nrest nlocs (lambda-meta x) (with-output-to-code (lambda (emit-code) ;; write bindings and source debugging info - (emit-bindings #f ids vars allocation emit-code) + (emit-bindings #f ids vars allocation x emit-code) (if (lambda-src x) (emit-code #f (make-glil-source (lambda-src x)))) - - ;; copy args to the heap if necessary - (let lp ((in vars) (n 0)) - (if (not (null? in)) - (let ((loc (hashq-ref allocation (car in)))) - (case (car loc) - ((heap) - (emit-code #f (make-glil-local 'ref n)) - (emit-code #f (make-glil-external 'set 0 (cddr loc))))) - (lp (cdr in) (1+ n))))) - + ;; box args if necessary + (for-each + (lambda (v) + (pmatch (hashq-ref (hashq-ref allocation v) x) + ((#t #t . ,n) + (emit-code #f (make-glil-lexical #t #f 'ref n)) + (emit-code #f (make-glil-lexical #t #t 'box n))))) + vars) ;; and here, here, dear reader: we compile. - (flatten (lambda-body x) (1+ level) allocation emit-code))))))) + (flatten (lambda-body x) allocation x emit-code))))))) -(define (flatten x level allocation emit-code) +(define (flatten x allocation proc emit-code) (define (emit-label label) (emit-code #f (make-glil-label label))) (define (emit-branch src inst label) @@ -424,27 +440,21 @@ (( src name gensym) (case context ((push vals tail) - (let ((loc (hashq-ref allocation gensym))) - (case (car loc) - ((stack) - (emit-code src (make-glil-local 'ref (cdr loc)))) - ((heap) - (emit-code src (make-glil-external - 'ref (- level (cadr loc)) (cddr loc)))) - (else (error "badness" x loc))) - (if (eq? context 'tail) - (emit-code #f (make-glil-call 'return 1))))))) - + (pmatch (hashq-ref (hashq-ref allocation gensym) proc) + ((,local? ,boxed? . ,index) + (emit-code src (make-glil-lexical local? boxed? 'ref index))) + (,loc + (error "badness" x loc))))) + (case context + ((tail) (emit-code #f (make-glil-call 'return 1))))) + (( src name gensym exp) (comp-push exp) - (let ((loc (hashq-ref allocation gensym))) - (case (car loc) - ((stack) - (emit-code src (make-glil-local 'set (cdr loc)))) - ((heap) - (emit-code src (make-glil-external - 'set (- level (cadr loc)) (cddr loc)))) - (else (error "badness" x loc)))) + (pmatch (hashq-ref (hashq-ref allocation gensym) proc) + ((,local? ,boxed? . ,index) + (emit-code src (make-glil-lexical local? boxed? 'set index))) + (,loc + (error "badness" x loc))) (case context ((push vals) (emit-code #f (make-glil-void))) @@ -495,39 +505,52 @@ (emit-code #f (make-glil-call 'return 1))))) (() - (case context - ((push vals) - (emit-code #f (flatten-lambda x level allocation))) - ((tail) - (emit-code #f (flatten-lambda x level allocation)) - (emit-code #f (make-glil-call 'return 1))))) - + (let ((free-locs (cdr (hashq-ref allocation x)))) + (case context + ((push vals tail) + (emit-code #f (flatten-lambda x allocation)) + (if (not (null? free-locs)) + (begin + (for-each + (lambda (loc) + (pmatch loc + ((,local? ,boxed? . ,n) + (emit-code #f (make-glil-lexical local? #f 'ref n))) + (else (error "what" x loc)))) + free-locs) + (emit-code #f (make-glil-call 'vector (length free-locs))) + (emit-code #f (make-glil-call 'make-closure 2)))) + (if (eq? context 'tail) + (emit-code #f (make-glil-call 'return 1))))))) + (( src names vars vals body) (for-each comp-push vals) - (emit-bindings src names vars allocation emit-code) + (emit-bindings src names vars allocation proc emit-code) (for-each (lambda (v) - (let ((loc (hashq-ref allocation v))) - (case (car loc) - ((stack) - (emit-code src (make-glil-local 'set (cdr loc)))) - ((heap) - (emit-code src (make-glil-external 'set 0 (cddr loc)))) - (else (error "badness" x loc))))) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t #f . ,n) + (emit-code src (make-glil-lexical #t #f 'set n))) + ((#t #t . ,n) + (emit-code src (make-glil-lexical #t #t 'box n))) + (,loc (error "badness" x loc)))) (reverse vars)) (comp-tail body) (emit-code #f (make-glil-unbind))) (( src names vars vals body) - (for-each comp-push vals) - (emit-bindings src names vars allocation emit-code) (for-each (lambda (v) - (let ((loc (hashq-ref allocation v))) - (case (car loc) - ((stack) - (emit-code src (make-glil-local 'set (cdr loc)))) - ((heap) - (emit-code src (make-glil-external 'set 0 (cddr loc)))) - (else (error "badness" x loc))))) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t #t . ,n) + (emit-code src (make-glil-lexical #t #t 'empty-box n))) + (,loc (error "badness" x loc)))) + vars) + (for-each comp-push vals) + (emit-bindings src names vars allocation proc emit-code) + (for-each (lambda (v) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t #t . ,n) + (emit-code src (make-glil-lexical #t #t 'set n))) + (,loc (error "badness" x loc)))) (reverse vars)) (comp-tail body) (emit-code #f (make-glil-unbind))) @@ -548,16 +571,15 @@ (emit-code #f (make-glil-const 1)) (emit-label MV) (emit-code src (make-glil-mv-bind - (vars->bind-list names vars allocation) + (vars->bind-list names vars allocation proc) rest?)) (for-each (lambda (v) - (let ((loc (hashq-ref allocation v))) - (case (car loc) - ((stack) - (emit-code src (make-glil-local 'set (cdr loc)))) - ((heap) - (emit-code src (make-glil-external 'set 0 (cddr loc)))) - (else (error "badness" x loc))))) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t #f . ,n) + (emit-code src (make-glil-lexical #t #f 'set n))) + ((#t #t . ,n) + (emit-code src (make-glil-lexical #t #t 'box n))) + (,loc (error "badness" x loc)))) (reverse vars)) (comp-tail body) (emit-code #f (make-glil-unbind)))))))))) diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index 311e35bad..89d35bcb5 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -30,9 +30,11 @@ (define-module (scripts compile) #:use-module ((system base compile) #:select (compile-file)) + #:use-module (system base message) #:use-module (srfi srfi-1) #:use-module (srfi srfi-13) #:use-module (srfi srfi-37) + #:use-module (ice-9 format) #:export (compile)) @@ -58,6 +60,17 @@ (fail "`-o' option cannot be specified more than once") (alist-cons 'output-file arg result)))) + (option '(#\W "warn") #t #f + (lambda (opt name arg result) + (if (string=? arg "help") + (begin + (show-warning-help) + (exit 0)) + (let ((warnings (assoc-ref result 'warnings))) + (alist-cons 'warnings + (cons (string->symbol arg) warnings) + (alist-delete 'warnings result)))))) + (option '(#\O "optimize") #f #f (lambda (opt name arg result) (alist-cons 'optimize? #t result))) @@ -86,13 +99,27 @@ options." ;; default option values '((input-files) - (load-path)))) + (load-path) + (warnings unsupported-warning)))) + +(define (show-warning-help) + (format #t "The available warning types are:~%~%") + (for-each (lambda (wt) + (format #t " ~22A ~A~%" + (format #f "`~A'" (warning-type-name wt)) + (warning-type-description wt))) + %warning-types) + (format #t "~%")) (define (compile . args) (let* ((options (parse-args args)) (help? (assoc-ref options 'help?)) - (compile-opts (if (assoc-ref options 'optimize?) '(#:O) '())) + (compile-opts (let ((o `(#:warnings + ,(assoc-ref options 'warnings)))) + (if (assoc-ref options 'optimize?) + (cons #:O o) + o))) (from (or (assoc-ref options 'from) 'scheme)) (to (or (assoc-ref options 'to) 'objcode)) (input-files (assoc-ref options 'input-files)) @@ -108,6 +135,9 @@ Compile each Guile source file FILE into a Guile object. -L, --load-path=DIR add DIR to the front of the module load path -o, --output=OFILE write output to OFILE + -W, --warn=WARNING emit warnings of type WARNING; use `--warn=help' + for a list of available warnings + -f, --from=LANG specify a source language other than `scheme' -t, --to=LANG specify a target language other than `objcode' diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 7e26609b9..8470f39e2 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -21,6 +21,7 @@ (define-module (system base compile) #:use-module (system base syntax) #:use-module (system base language) + #:use-module (system base message) #:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho #:use-module (ice-9 regex) #:use-module (ice-9 optargs) @@ -213,6 +214,16 @@ (from (current-language)) (to 'value) (opts '())) + + (let ((warnings (memq #:warnings opts))) + (if (pair? warnings) + (let ((warnings (cadr warnings))) + ;; Sanity-check the requested warnings. + (for-each (lambda (w) + (or (lookup-warning-type w) + (warning 'unsupported-warning #f w))) + warnings)))) + (receive (exp env cenv) (compile-fold (compile-passes from to opts) x env opts) exp)) diff --git a/module/system/base/message.scm b/module/system/base/message.scm new file mode 100644 index 000000000..6b68c5639 --- /dev/null +++ b/module/system/base/message.scm @@ -0,0 +1,102 @@ +;;; User interface messages + +;; Copyright (C) 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 as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; This module provide a simple interface to send messages to the user. +;;; TODO: Internationalize messages. +;;; +;;; Code: + +(define-module (system base message) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:export (*current-warning-port* warning + + warning-type? warning-type-name warning-type-description + warning-type-printer lookup-warning-type + + %warning-types)) + + +;;; +;;; Source location +;;; + +(define (location-string loc) + (if (pair? loc) + (format #f "~a:~a:~a" + (or (assoc-ref loc 'filename) "") + (1+ (assoc-ref loc 'line)) + (assoc-ref loc 'column)) + "")) + + +;;; +;;; Warnings +;;; + +(define *current-warning-port* + ;; The port where warnings are sent. + (make-fluid)) + +(fluid-set! *current-warning-port* (current-error-port)) + +(define-record-type + (make-warning-type name description printer) + warning-type? + (name warning-type-name) + (description warning-type-description) + (printer warning-type-printer)) + +(define %warning-types + ;; List of know warning types. + (map (lambda (args) + (apply make-warning-type args)) + + `((unsupported-warning ;; a "meta warning" + "warn about unknown warning types" + ,(lambda (port unused name) + (format port "warning: unknown warning type `~A'~%" + name))) + + (unused-variable + "report unused variables" + ,(lambda (port loc name) + (format port "~A: warning: unused variable `~A'~%" + loc name)))))) + +(define (lookup-warning-type name) + "Return the warning type NAME or `#f' if not found." + (find (lambda (wt) + (eq? name (warning-type-name wt))) + %warning-types)) + +(define (warning type location . args) + "Emit a warning of type TYPE for source location LOCATION (a source +property alist) using the data in ARGS." + (let ((wt (lookup-warning-type type)) + (port (fluid-ref *current-warning-port*))) + (if (warning-type? wt) + (apply (warning-type-printer wt) + port (location-string location) + args) + (format port "~A: unknown warning type `~A': ~A~%" + (location-string location) type args)))) + +;;; message.scm ends here diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 6f45bd7f6..a99e1bae9 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -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)) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 33a1e1b60..332cd6172 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -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 ;;; ;;; 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) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 9db4a754b..755c606e2 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -1,6 +1,6 @@ ;;; Guile VM program functions -;;; 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 @@ -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 @@ -31,21 +31,20 @@ program-properties program-property program-documentation program-name program-arguments - program-arity program-external-set! program-meta + program-arity program-meta program-objcode program? program-objects - program-module program-base program-external)) + program-module program-base program-free-variables)) (load-extension "libguile" "scm_init_programs") (define arity:nargs car) (define arity:nrest cadr) (define arity:nlocs caddr) -(define arity:nexts cadddr) -(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)) diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index 6ff09a779..d8165f202 100644 --- a/module/system/vm/trace.scm +++ b/module/system/vm/trace.scm @@ -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) diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index 01ba84687..33a2a45f0 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -20,16 +20,28 @@ #:use-module (system vm instruction) #:use-module (language assembly compile-bytecode)) +(define (->u8-list sym val) + (let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!) + (uint32 4 ,bytevector-u32-native-set!)) + sym))) + (or entry (error "unknown sym" sym)) + (let ((bv (make-bytevector (car entry)))) + ((cadr entry) bv 0 val) + (bytevector->u8-list bv)))) + (define (munge-bytecode v) - (let ((newv (make-u8vector (vector-length v)))) - (let lp ((i 0)) - (if (= i (vector-length v)) - newv - (let ((x (vector-ref v i))) - (u8vector-set! newv i (if (symbol? x) - (instruction->opcode x) - x)) - (lp (1+ i))))))) + (let lp ((i 0) (out '())) + (if (= i (vector-length v)) + (list->u8vector (reverse out)) + (let ((x (vector-ref v i))) + (cond + ((symbol? x) + (lp (1+ i) (cons (instruction->opcode x) out))) + ((integer? x) + (lp (1+ i) (cons x out))) + ((pair? x) + (lp (1+ i) (append (reverse (apply ->u8-list x)) out))) + (else (error "bad test bytecode" x))))))) (define (comp-test x y) (let* ((y (munge-bytecode y)) @@ -46,13 +58,6 @@ (lambda () (equal? v y))))) -(define (u32->u8-list x) - ;; Return a 4 uint8 list corresponding to the host's native representation - ;; of X, a uint32. - (let ((bv (make-bytevector 4))) - (bytevector-u32-native-set! bv 0 x) - (bytevector->u8-list bv))) - (with-test-prefix "compiler" (with-test-prefix "asm-to-bytecode" @@ -85,29 +90,34 @@ (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)) - (list->vector - `(load-program - 3 2 1 0 ;; nargs, nrest, nlocs, nexts - ,@(u32->u8-list 3) ;; len - ,@(u32->u8-list 0) ;; metalen - make-int8 3 - return))) + (comp-test '(load-program 3 2 1 () 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)) - (comp-test '(load-program 3 2 1 0 () 3 - (load-program 3 2 1 0 () 3 + ;; 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 #f (make-int8 3) (return)) - (make-int8 3) (return)) - (list->vector - `(load-program - 3 2 1 0 ;; nargs, nrest, nlocs, nexts - ,@(u32->u8-list 3) ;; len - ,@(u32->u8-list (+ 3 12)) ;; metalen - make-int8 3 - return - 3 2 1 0 ;; nargs, nrest, nlocs, nexts - ,@(u32->u8-list 3) ;; len - ,@(u32->u8-list 0) ;; metalen - 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 + 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 ec410b52b..896206b1f 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -21,8 +21,10 @@ #:use-module (test-suite lib) #:use-module (system base compile) #:use-module (system base pmatch) + #:use-module (system base message) #:use-module (language tree-il) - #:use-module (language glil)) + #:use-module (language glil) + #:use-module (srfi srfi-13)) ;; Of course, the GLIL that is emitted depends on the source info of the ;; input. Here we're not concerned about that, so we strip source @@ -64,21 +66,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 +88,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,279 +116,281 @@ (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 () - (const 1) (bind (x local 0)) (local set 0) - (local ref 0) (call return 1) + (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 () - (const 1) (bind (x local 0)) (local set 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 () - (const 1) (bind (x local 0)) (local set 0) - (local ref 0) (call null? 1) (call return 1) + (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 0 1 () - (const 1) (bind (x external 0)) (external set 0 0) - (const 2) (external set 0 0) (void) (call return 1) + (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 0 1 () - (const 1) (bind (x external 0)) (external set 0 0) - (const 2) (external set 0 0) (const #f) (call return 1) + (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 0 1 () - (const 1) (bind (x external 0)) (external set 0 0) - (const 2) (external set 0 0) (void) (call null? 1) (call return 1) + (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 () - (bind (x local 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 () - (bind (x local 0) (x1 local 1)) + (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 () - (bind (x local 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 () - (bind (x local 0) (x1 local 1)) + (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 () - (bind (x local 0) (x1 local 1)) - (local ref 0) (call return 1)) + (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 () - (bind (x local 0) (x1 local 1)) - (local ref 1) (call return 1)) + (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 1 () - (bind (x external 0)) - (local ref 0) (external set 0 0) - (program 1 0 0 0 () - (bind (y local 0)) - (external ref 1 0) (call return 1)) + (program 0 0 0 () + (program 1 0 0 () + (bind (x #f 0)) + (program 1 0 0 () + (bind (y #f 0)) + (lexical #f #f ref 0) (call return 1)) + (lexical #t #f ref 0) + (call vector 1) + (call make-closure 2) (call return 1)) (call return 1)))) (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, @@ -398,13 +402,13 @@ (lexical x y) (let (a) (b) ((const 2)) (lexical a b)))) - (program 0 0 1 0 () - (const 1) (bind (x local 0)) (local set 0) - (local ref 0) (branch br-if-not ,l1) - (local ref 0) (call return 1) + (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) (label ,l2) - (const 2) (bind (a local 0)) (local set 0) - (local ref 0) (call return 1) + (const 2) (bind (a #f 0)) (lexical #t #f set 0) + (lexical #t #f ref 0) (call return 1) (unbind) (unbind)) (eq? l1 l2)) @@ -415,13 +419,13 @@ (lexical x y) (let (a) (b) ((const 2)) (lexical x y)))) - (program 0 0 2 0 () - (const 1) (bind (x local 0)) (local set 0) - (local ref 0) (branch br-if-not ,l1) - (local ref 0) (call return 1) + (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) (label ,l2) - (const 2) (bind (a local 1)) (local set 1) - (local ref 0) (call return 1) + (const 2) (bind (a #f 1)) (lexical #t #f set 1) + (lexical #t #f ref 0) (call return 1) (unbind) (unbind)) (eq? l1 l2))) @@ -429,10 +433,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) @@ -440,7 +444,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)))) @@ -448,10 +452,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) @@ -460,8 +464,121 @@ (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)))) + +(with-test-prefix "tree-il-fold" + + (pass-if "empty tree" + (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark))) + (and (eq? mark + (tree-il-fold (lambda (x y) (set! leaf? #t) y) + (lambda (x y) (set! down? #t) y) + (lambda (x y) (set! up? #t) y) + mark + '())) + (not leaf?) + (not up?) + (not down?)))) + + (pass-if "lambda and application" + (let* ((leaves '()) (ups '()) (downs '()) + (result (tree-il-fold (lambda (x y) + (set! leaves (cons x leaves)) + (1+ y)) + (lambda (x y) + (set! downs (cons x downs)) + (1+ y)) + (lambda (x y) + (set! ups (cons x ups)) + (1+ y)) + 0 + (parse-tree-il + '(lambda (x y) (x1 y1) + (apply (toplevel +) + (lexical x x1) + (lexical y y1))))))) + (and (equal? (map strip-source leaves) + (list (make-lexical-ref #f 'y 'y1) + (make-lexical-ref #f 'x 'x1) + (make-toplevel-ref #f '+))) + (= (length downs) 2) + (equal? (reverse (map strip-source ups)) + (map strip-source downs)))))) + + +;;; +;;; Warnings. +;;; + +;; Make sure we get English messages. +(setlocale LC_ALL "C") + +(define (call-with-warnings thunk) + (let ((port (open-output-string))) + (with-fluid* *current-warning-port* port + thunk) + (let ((warnings (get-output-string port))) + (string-tokenize warnings + (char-set-complement (char-set #\newline)))))) + +(define %opts-w-unused + '(#:warnings (unused-variable))) + + +(with-test-prefix "warnings" + + (pass-if "unknown warning type" + (let ((w (call-with-warnings + (lambda () + (compile #t #:opts '(#:warnings (does-not-exist))))))) + (and (= (length w) 1) + (number? (string-contains (car w) "unknown warning"))))) + + (with-test-prefix "unused-variable" + + (pass-if "quiet" + (null? (call-with-warnings + (lambda () + (compile '(lambda (x y) (+ x y)) + #:opts %opts-w-unused))))) + + (pass-if "let/unused" + (let ((w (call-with-warnings + (lambda () + (compile '(lambda (x) + (let ((y (+ x 2))) + x)) + #:opts %opts-w-unused))))) + (and (= (length w) 1) + (number? (string-contains (car w) "unused variable `y'"))))) + + (pass-if "shadowed variable" + (let ((w (call-with-warnings + (lambda () + (compile '(lambda (x) + (let ((y x)) + (let ((y (+ x 2))) + (+ x y)))) + #:opts %opts-w-unused))))) + (and (= (length w) 1) + (number? (string-contains (car w) "unused variable `y'"))))) + + (pass-if "letrec" + (null? (call-with-warnings + (lambda () + (compile '(lambda () + (letrec ((x (lambda () (y))) + (y (lambda () (x)))) + y)) + #:opts %opts-w-unused))))) + + (pass-if "unused argument" + ;; Unused arguments should not be reported. + (null? (call-with-warnings + (lambda () + (compile '(lambda (x y z) #t) + #:opts %opts-w-unused)))))))