From c05805a4ea764dec5a0559edefcdfb9761191d07 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 18 Mar 2012 20:04:28 +0100 Subject: [PATCH 1/5] make applicable smob calls cheaper, and fix a memory leak * libguile/vm.c (prepare_smob_call): New helper. Now, instead of making a per-smob trampoline, we will shuffle the smob into the args and use a gsubr. This prevents a memory leak in which the trampolines, which were values in a weak-key table, were preventing the smobs from being collected. * libguile/vm-i-system.c (call, tail-call, mv-call): Adapt to new smob application mechanism. (smob-call): Remove this instruction. * libguile/smob.h (scm_smob_descriptor): Rename apply_trampoline_objcode to apply_trampoline. * libguile/smob.c: Remove our own objcode trampolines in favor of using scm_c_make_gsubr. (scm_smob_prehistory): No more trampoline weak map. * libguile/procprop.c (scm_i_procedure_arity): Adapt to applicable smob representation change. --- libguile/procprop.c | 12 +- libguile/smob.c | 333 +++++++++-------------------------------- libguile/smob.h | 3 +- libguile/vm-i-system.c | 14 +- libguile/vm.c | 19 +++ 5 files changed, 109 insertions(+), 272 deletions(-) diff --git a/libguile/procprop.c b/libguile/procprop.c index 9a75254a2..36228d3f3 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -80,8 +80,16 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest) case scm_tc7_smob: if (!SCM_SMOB_APPLICABLE_P (proc)) return 0; - proc = scm_i_smob_apply_trampoline (proc); - break; + if (!scm_i_program_arity + (SCM_SMOB_DESCRIPTOR (proc).apply_trampoline_objcode, + req, opt, rest)) + return 0; + + /* The trampoline gets the smob too, which users don't + see. */ + *req -= 1; + + return 1; case scm_tcs_struct: if (!SCM_STRUCT_APPLICABLE_P (proc)) return 0; diff --git a/libguile/smob.c b/libguile/smob.c index 6a341ef5d..1911460cf 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -120,233 +120,81 @@ scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) /* {Apply} */ -#ifdef WORDS_BIGENDIAN -#define OBJCODE_HEADER 0, 0, 0, 16, 0, 0, 0, 40 -#define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0 -#else -#define OBJCODE_HEADER 16, 0, 0, 0, 40, 0, 0, 0 -#define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0 -#endif - -/* This code is the same as in gsubr.c, except we use smob_call instead of - struct_call. */ - -/* A: req; B: opt; C: rest */ -#define A(nreq) \ - OBJCODE_HEADER, \ - /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \ - /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \ - /* 5 */ scm_op_smob_call, nreq, /* and call (will return value as well) */ \ - /* 7 */ scm_op_nop, \ - /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \ - /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \ - /* 16 */ META (3, 7, nreq, 0, 0) - -#define B(nopt) \ - OBJCODE_HEADER, \ - /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */ \ - /* 3 */ scm_op_assert_nargs_ee, 0, nopt, /* assert number of args */ \ - /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \ - /* 8 */ scm_op_smob_call, nopt, /* and call (will return value as well) */ \ - /* 10 */ scm_op_nop, scm_op_nop, \ - /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \ - /* 16 */ META (6, 10, 0, nopt, 0) - -#define C() \ - OBJCODE_HEADER, \ - /* 0 */ scm_op_push_rest, 0, 0, /* cons all args into a list */ \ - /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \ - /* 5 */ scm_op_smob_call, 1, /* and call (will return value as well) */ \ - /* 7 */ scm_op_nop, \ - /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \ - /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \ - /* 16 */ META (3, 7, 0, 0, 1) - -#define AB(nreq, nopt) \ - OBJCODE_HEADER, \ - /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \ - /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */ \ - /* 6 */ scm_op_assert_nargs_ee, 0, nreq+nopt, /* assert number of args */ \ - /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \ - /* 11 */ scm_op_smob_call, nreq+nopt, /* and call (will return value as well) */ \ - /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop, \ - /* 16 */ META (9, 13, nreq, nopt, 0) - -#define AC(nreq) \ - OBJCODE_HEADER, \ - /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \ - /* 3 */ scm_op_push_rest, 0, nreq, /* cons rest list */ \ - /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \ - /* 8 */ scm_op_smob_call, nreq+1, /* and call (will return value as well) */ \ - /* 10 */ scm_op_nop, scm_op_nop, \ - /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \ - /* 16 */ META (6, 10, nreq, 0, 1) - -#define BC(nopt) \ - OBJCODE_HEADER, \ - /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */ \ - /* 3 */ scm_op_push_rest, 0, nopt, /* cons rest list */ \ - /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \ - /* 8 */ scm_op_smob_call, nopt+1, /* and call (will return value as well) */ \ - /* 10 */ scm_op_nop, scm_op_nop, \ - /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \ - /* 16 */ META (6, 10, 0, nopt, 1) - -#define ABC(nreq, nopt) \ - OBJCODE_HEADER, \ - /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \ - /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */ \ - /* 6 */ scm_op_push_rest, 0, nreq+nopt, /* cons rest list */ \ - /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \ - /* 11 */ scm_op_smob_call, nreq+nopt+1, /* and call (will return value as well) */ \ - /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop, \ - /* 16 */ META (9, 13, nreq, nopt, 1) +static SCM scm_smob_trampolines[16]; -#define META(start, end, nreq, nopt, rest) \ - META_HEADER, \ - /* 0 */ scm_op_make_eol, /* bindings */ \ - /* 1 */ scm_op_make_eol, /* sources */ \ - /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \ - /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */ \ - /* 8 */ scm_op_make_int8, nopt, /* N optionals */ \ - /* 10 */ rest ? scm_op_make_true : scm_op_make_false, /* maybe a rest arg */ \ - /* 11 */ scm_op_list, 0, 5, /* make a list of those 5 vals */ \ - /* 14 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \ - /* 17 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \ - /* 25 */ scm_op_object_ref, 1, /* the name from the object table */ \ - /* 27 */ scm_op_cons, /* make a pair for the properties */ \ - /* 28 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \ - /* 31 */ scm_op_return /* and return */ \ - /* 32 */ - -static const struct -{ - scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */ - const scm_t_uint8 bytes[16 * (sizeof (struct scm_objcode) + 16 - + sizeof (struct scm_objcode) + 32)]; -} raw_bytecode = { - 0, - { - /* Use the elisp macros from gsubr.c */ - /* C-u 3 M-x generate-bytecodes RET */ - /* 0 arguments */ - A(0), - /* 1 arguments */ - A(1), B(1), C(), - /* 2 arguments */ - A(2), AB(1,1), B(2), AC(1), BC(1), - /* 3 arguments */ - A(3), AB(2,1), AB(1,2), B(3), AC(2), ABC(1,1), BC(2) - } -}; - -#undef A -#undef B -#undef C -#undef AB -#undef AC -#undef BC -#undef ABC -#undef OBJCODE_HEADER -#undef META_HEADER -#undef META - -#define STATIC_OBJCODE_TAG \ - SCM_PACK (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0)) - -static const struct -{ - scm_t_uint64 dummy; /* alignment */ - scm_t_cell cells[16 * 2]; /* 4*4 double cells */ -} objcode_cells = { - 0, - /* C-u 3 M-x generate-objcode-cells RET */ - { - /* 0 arguments */ - { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) }, - { SCM_BOOL_F, SCM_PACK (0) }, - - /* 1 arguments */ - { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 64) }, - { SCM_BOOL_F, SCM_PACK (0) }, - { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 128) }, - { SCM_BOOL_F, SCM_PACK (0) }, - - { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 192) }, - { SCM_BOOL_F, SCM_PACK (0) }, - - /* 2 arguments */ - { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 256) }, - { SCM_BOOL_F, SCM_PACK (0) }, - { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 320) }, - { SCM_BOOL_F, SCM_PACK (0) }, - { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 384) }, - { SCM_BOOL_F, SCM_PACK (0) }, - - { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) }, - { SCM_BOOL_F, SCM_PACK (0) }, - { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 512) }, - { SCM_BOOL_F, SCM_PACK (0) }, - - /* 3 arguments */ - { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 576) }, - { SCM_BOOL_F, SCM_PACK (0) }, - { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 640) }, - { SCM_BOOL_F, SCM_PACK (0) }, - { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 704) }, - { SCM_BOOL_F, SCM_PACK (0) }, - { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 768) }, - { SCM_BOOL_F, SCM_PACK (0) }, - - { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 832) }, - { SCM_BOOL_F, SCM_PACK (0) }, - { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 896) }, - { SCM_BOOL_F, SCM_PACK (0) }, - { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 960) }, - { SCM_BOOL_F, SCM_PACK (0) } - } -}; - -static const SCM scm_smob_objcode_trampolines[16] = { - /* C-u 3 M-x generate-objcodes RET */ - /* 0 arguments */ - SCM_PACK (objcode_cells.cells+0), - - /* 1 arguments */ - SCM_PACK (objcode_cells.cells+2), - SCM_PACK (objcode_cells.cells+4), - SCM_PACK (objcode_cells.cells+6), - - /* 2 arguments */ - SCM_PACK (objcode_cells.cells+8), - SCM_PACK (objcode_cells.cells+10), - SCM_PACK (objcode_cells.cells+12), - SCM_PACK (objcode_cells.cells+14), - SCM_PACK (objcode_cells.cells+16), - - /* 3 arguments */ - SCM_PACK (objcode_cells.cells+18), - SCM_PACK (objcode_cells.cells+20), - SCM_PACK (objcode_cells.cells+22), - SCM_PACK (objcode_cells.cells+24), - SCM_PACK (objcode_cells.cells+26), - SCM_PACK (objcode_cells.cells+28), - SCM_PACK (objcode_cells.cells+30) -}; - /* (nargs * nargs) + nopt + rest * (nargs + 1) */ -#define SCM_SMOB_OBJCODE_TRAMPOLINE(nreq,nopt,rest) \ - scm_smob_objcode_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \ - + nopt + rest * (nreq + nopt + rest + 1)] +#define SCM_SMOB_TRAMPOLINE(nreq,nopt,rest) \ + scm_smob_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \ + + nopt + rest * (nreq + nopt + rest + 1)] static SCM -scm_smob_objcode_trampoline (unsigned int nreq, unsigned int nopt, - unsigned int rest) +apply_0 (SCM smob) { + SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply; + return subr (smob); +} + +static SCM +apply_1 (SCM smob, SCM a) +{ + SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply; + return subr (smob, a); +} + +static SCM +apply_2 (SCM smob, SCM a, SCM b) +{ + SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply; + return subr (smob, a, b); +} + +static SCM +apply_3 (SCM smob, SCM a, SCM b, SCM c) +{ + SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply; + return subr (smob, a, b, c); +} + +static SCM +scm_smob_trampoline (unsigned int nreq, unsigned int nopt, + unsigned int rest) +{ + SCM trampoline; + if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 3)) scm_out_of_range ("make-smob", scm_from_uint (nreq + nopt + rest)); - return SCM_SMOB_OBJCODE_TRAMPOLINE (nreq, nopt, rest); + trampoline = SCM_SMOB_TRAMPOLINE (nreq, nopt, rest); + + if (SCM_LIKELY (SCM_UNPACK (trampoline))) + return trampoline; + + switch (nreq + nopt + rest) + { + /* The + 1 is for the smob itself. */ + case 0: + trampoline = scm_c_make_gsubr ("apply-smob/0", nreq + 1, nopt, rest, + apply_0); + break; + case 1: + trampoline = scm_c_make_gsubr ("apply-smob/1", nreq + 1, nopt, rest, + apply_1); + break; + case 2: + trampoline = scm_c_make_gsubr ("apply-smob/2", nreq + 1, nopt, rest, + apply_2); + break; + case 3: + trampoline = scm_c_make_gsubr ("apply-smob/3", nreq + 1, nopt, rest, + apply_3); + break; + default: + abort (); + } + + SCM_SMOB_TRAMPOLINE (nreq, nopt, rest) = trampoline; + + return trampoline; } @@ -406,51 +254,16 @@ void scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (), unsigned int req, unsigned int opt, unsigned int rst) { - scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply; - scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode - = scm_smob_objcode_trampoline (req, opt, rst); + SCM trampoline = scm_smob_trampoline (req, opt, rst); + + scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply; + /* In 2.2 this field is renamed to "apply_trampoline". */ + scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode = trampoline; if (SCM_UNPACK (scm_smob_class[0]) != 0) scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]); } -static SCM tramp_weak_map = SCM_BOOL_F; -static scm_i_pthread_mutex_t tramp_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; - -SCM -scm_i_smob_apply_trampoline (SCM smob) -{ - SCM tramp; - - scm_i_pthread_mutex_lock (&tramp_lock); - tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F); - scm_i_pthread_mutex_unlock (&tramp_lock); - - if (scm_is_true (tramp)) - return tramp; - else - { - const char *name; - SCM objtable; - - name = SCM_SMOBNAME (SCM_SMOBNUM (smob)); - if (!name) - name = "smob-apply"; - objtable = scm_c_make_vector (2, SCM_UNDEFINED); - SCM_SIMPLE_VECTOR_SET (objtable, 0, smob); - SCM_SIMPLE_VECTOR_SET (objtable, 1, scm_from_locale_symbol (name)); - tramp = scm_make_program (SCM_SMOB_DESCRIPTOR (smob).apply_trampoline_objcode, - objtable, SCM_BOOL_F); - - /* Race conditions (between the ref and this set!) cannot cause - any harm here. */ - scm_i_pthread_mutex_lock (&tramp_lock); - scm_hashq_set_x (tramp_weak_map, smob, tramp); - scm_i_pthread_mutex_unlock (&tramp_lock); - return tramp; - } -} - SCM scm_make_smob (scm_t_bits tc) { @@ -679,8 +492,6 @@ scm_smob_prehistory () scm_smobs[i].apply = 0; scm_smobs[i].apply_trampoline_objcode = SCM_BOOL_F; } - - tramp_weak_map = scm_make_weak_key_hash_table (SCM_UNDEFINED); } /* diff --git a/libguile/smob.h b/libguile/smob.h index cfe12c3b1..d4b7c6cea 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -40,6 +40,7 @@ typedef struct scm_smob_descriptor int (*print) (SCM exp, SCM port, scm_print_state *pstate); SCM (*equalp) (SCM, SCM); scm_t_subr apply; + /* In 2.2 this field is renamed to "apply_trampoline". */ SCM apply_trampoline_objcode; } scm_smob_descriptor; @@ -204,8 +205,6 @@ SCM_API void scm_assert_smob_type (scm_t_bits tag, SCM val); SCM_API SCM scm_make_smob (scm_t_bits tc); -SCM_INTERNAL SCM scm_i_smob_apply_trampoline (SCM smob); - SCM_API void scm_smob_prehistory (void); #endif /* SCM_SMOB_H */ diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 474fe7883..21fa5a195 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc. +/* Copyright (C) 2001,2008,2009,2010,2011,2012 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 @@ -790,8 +790,8 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1) else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob && SCM_SMOB_APPLICABLE_P (program)) { - SYNC_REGISTER (); - sp[-nargs] = scm_i_smob_apply_trampoline (program); + PUSH (program); + prepare_smob_call (sp, ++nargs, program); goto vm_call; } else @@ -838,8 +838,8 @@ VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1) else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob && SCM_SMOB_APPLICABLE_P (program)) { - SYNC_REGISTER (); - sp[-nargs] = scm_i_smob_apply_trampoline (program); + PUSH (program); + prepare_smob_call (sp, ++nargs, program); goto vm_tail_call; } else @@ -1099,8 +1099,8 @@ VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1) else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob && SCM_SMOB_APPLICABLE_P (program)) { - SYNC_REGISTER (); - sp[-nargs] = scm_i_smob_apply_trampoline (program); + PUSH (program); + prepare_smob_call (sp, ++nargs, program); goto vm_mv_call; } else diff --git a/libguile/vm.c b/libguile/vm.c index 8fae65604..d1c7bbcb0 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -423,6 +423,25 @@ vm_make_boot_program (long nargs) * VM */ +/* We are calling a SMOB. The calling code pushed the SMOB after the + args, and incremented nargs. That nargs is passed here. This + function's job is to replace the procedure with the trampoline, and + shuffle the smob itself to be argument 0. This function must not + allocate or throw, as the VM registers are not synchronized. */ +static void +prepare_smob_call (SCM *sp, int nargs, SCM smob) +{ + SCM *args = sp - nargs + 1; + + /* Shuffle args up. */ + while (nargs--) + args[nargs + 1] = args[nargs]; + + args[0] = smob; + /* apply_trampoline_objcode is actually a program. */ + args[-1] = SCM_SMOB_DESCRIPTOR (smob).apply_trampoline_objcode; +} + static SCM resolve_variable (SCM what, SCM program_module) { From 47153f29b02cee6324aec523cfa44b48e1cb29b9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 7 Mar 2012 12:39:30 +0100 Subject: [PATCH 2/5] micro-optimizations to string-trim-both, and to (web http) * libguile/srfi-13.c (scm_string_trim, scm_string_trim_right) (scm_string_trim_both): Take the whitespace fast-path if the char_pred is scm_char_set_whitespace. * module/web/http.scm (read-header, split-and-trim, parse-quality-list): (parse-param-component, parse-credentials, "Content-Type"): (read-request-line, read-response-line): Use char-set:whitespace instead of char-whitespace?. It avoids recursing into the VM. --- libguile/srfi-13.c | 11 +++++++---- module/web/http.scm | 44 ++++++++++++++++++++------------------------ 2 files changed, 27 insertions(+), 28 deletions(-) diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c index 75feae3b2..28345532e 100644 --- a/libguile/srfi-13.c +++ b/libguile/srfi-13.c @@ -1,6 +1,6 @@ /* srfi-13.c --- SRFI-13 procedures for Guile * - * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011, 2012 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 @@ -719,7 +719,8 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0, MY_VALIDATE_SUBSTRING_SPEC (1, s, 3, start, cstart, 4, end, cend); - if (SCM_UNBNDP (char_pred)) + if (SCM_UNBNDP (char_pred) + || scm_is_eq (char_pred, scm_char_set_whitespace)) { while (cstart < cend) { @@ -794,7 +795,8 @@ SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0, MY_VALIDATE_SUBSTRING_SPEC (1, s, 3, start, cstart, 4, end, cend); - if (SCM_UNBNDP (char_pred)) + if (SCM_UNBNDP (char_pred) + || scm_is_eq (char_pred, scm_char_set_whitespace)) { while (cstart < cend) { @@ -869,7 +871,8 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0, MY_VALIDATE_SUBSTRING_SPEC (1, s, 3, start, cstart, 4, end, cend); - if (SCM_UNBNDP (char_pred)) + if (SCM_UNBNDP (char_pred) + || scm_is_eq (char_pred, scm_char_set_whitespace)) { while (cstart < cend) { diff --git a/module/web/http.scm b/module/web/http.scm index 879923f81..ad9063cd2 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -185,7 +185,7 @@ body was reached (i.e., a blank line)." sym (read-continuation-line port - (string-trim-both line char-whitespace? (1+ delim))))))))) + (string-trim-both line char-set:whitespace (1+ delim))))))))) (define (parse-header sym val) "Parse @var{val}, a string, with the parser registered for the header @@ -277,7 +277,7 @@ ordered alist." (let lp ((i start)) (if (< i end) (let* ((idx (string-index str delim i end)) - (tok (string-trim-both str char-whitespace? i (or idx end)))) + (tok (string-trim-both str char-set:whitespace i (or idx end)))) (cons tok (split-and-trim str delim (if idx (1+ idx) end) end))) '()))) @@ -420,13 +420,13 @@ ordered alist." (cond ((string-rindex part #\;) => (lambda (idx) - (let ((qpart (string-trim-both part char-whitespace? (1+ idx)))) + (let ((qpart (string-trim-both part char-set:whitespace (1+ idx)))) (if (string-prefix? "q=" qpart) (cons (parse-quality qpart 2) - (string-trim-both part char-whitespace? 0 idx)) + (string-trim-both part char-set:whitespace 0 idx)) (bad-header-component 'quality qpart))))) (else - (cons 1000 (string-trim-both part char-whitespace?))))) + (cons 1000 (string-trim-both part char-set:whitespace))))) (string-split str #\,))) (define (validate-quality-list l) @@ -541,15 +541,15 @@ ordered alist." ;; param-component = token [ "=" (token | quoted-string) ] \ ;; *(";" token [ "=" (token | quoted-string) ]) ;; +(define param-delimiters (char-set #\, #\; #\=)) +(define param-value-delimiters (char-set-adjoin char-set:whitespace #\, #\;)) (define* (parse-param-component str #:optional (val-parser default-val-parser) (start 0) (end (string-length str))) (let lp ((i start) (out '())) (if (not (< i end)) (values (reverse! out) end) - (let ((delim (string-index str - (lambda (c) (memq c '(#\, #\; #\=))) - i))) + (let ((delim (string-index str param-delimiters i))) (let ((k (string->symbol (substring str i (trim-whitespace str i (or delim end))))) (delimc (and delim (string-ref str delim)))) @@ -561,13 +561,8 @@ ordered alist." (if (and (< i end) (eqv? (string-ref str i) #\")) (parse-qstring str i end #:incremental? #t) (let ((delim - (or (string-index - str - (lambda (c) - (or (eqv? c #\;) - (eqv? c #\,) - (char-whitespace? c))) - i end) + (or (string-index str param-value-delimiters + i end) end))) (values (substring str i delim) delim))))) @@ -853,7 +848,7 @@ ordered alist." (define* (parse-credentials str #:optional (val-parser default-val-parser) (start 0) (end (string-length str))) (let* ((start (skip-whitespace str start end)) - (delim (or (string-index str char-whitespace? start end) end))) + (delim (or (string-index str char-set:whitespace start end) end))) (if (= start end) (bad-header-component 'authorization str)) (let ((scheme (string->symbol @@ -1038,8 +1033,8 @@ not have to have a scheme or host name. The result is a URI object." "Read the first line of an HTTP request from @var{port}, returning three values: the method, the URI, and the version." (let* ((line (read-line* port)) - (d0 (string-index line char-whitespace?)) ; "delimiter zero" - (d1 (string-rindex line char-whitespace?))) + (d0 (string-index line char-set:whitespace)) ; "delimiter zero" + (d1 (string-rindex line char-set:whitespace))) (if (and d0 d1 (< d0 d1)) (values (parse-http-method line 0 d0) (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1) @@ -1100,14 +1095,14 @@ three values: the method, the URI, and the version." three values: the HTTP version, the response code, and the \"reason phrase\"." (let* ((line (read-line* port)) - (d0 (string-index line char-whitespace?)) ; "delimiter zero" - (d1 (and d0 (string-index line char-whitespace? + (d0 (string-index line char-set:whitespace)) ; "delimiter zero" + (d1 (and d0 (string-index line char-set:whitespace (skip-whitespace line d0))))) (if (and d0 d1) (values (parse-http-version line 0 d0) (parse-non-negative-integer line (skip-whitespace line d0 d1) d1) - (string-trim-both line char-whitespace? d1)) + (string-trim-both line char-set:whitespace d1)) (bad-response "Bad Response-Line: ~s" line)))) (define (write-response-line version code reason-phrase port) @@ -1488,9 +1483,10 @@ phrase\"." (map (lambda (x) (let ((eq (string-index x #\=))) (if (and eq (= eq (string-rindex x #\=))) - (cons (string->symbol - (string-trim x char-whitespace? 0 eq)) - (string-trim-right x char-whitespace? (1+ eq))) + (cons + (string->symbol + (string-trim x char-set:whitespace 0 eq)) + (string-trim-right x char-set:whitespace (1+ eq))) (bad-header 'content-type str)))) (cdr parts))))) (lambda (val) From 1be6c7d34d7e1e40e78c8983bd8b40b3fbf7d01c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 11 Mar 2012 10:24:08 +0100 Subject: [PATCH 3/5] add exception printers for bad-header, bad-header-component * module/web/http.scm (bad-header-component): Throw 'bad-header-component instead of 'bad-header. (bad-header-printer, bad-header-component-printer): Add exception printers. --- module/web/http.scm | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/module/web/http.scm b/module/web/http.scm index ad9063cd2..d579c5267 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -240,7 +240,22 @@ ordered alist." (define (bad-header sym val) (throw 'bad-header sym val)) (define (bad-header-component sym val) - (throw 'bad-header sym val)) + (throw 'bad-header-component sym val)) + +(define (bad-header-printer port key args default-printer) + (apply (case-lambda + ((sym val) + (format port "Bad ~a header: ~a\n" (header->string sym) val)) + (_ (default-printer))) + args)) +(define (bad-header-component-printer port key args default-printer) + (apply (case-lambda + ((sym val) + (format port "Bad ~a header component: ~a\n" sym val)) + (_ (default-printer))) + args)) +(set-exception-printer! 'bad-header bad-header-printer) +(set-exception-printer! 'bad-header-component bad-header-component-printer) (define (parse-opaque-string str) str) From da03005a2a362847db2ac7e876cd9e31b20f9c73 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 11 Mar 2012 10:57:05 +0100 Subject: [PATCH 4/5] add bad-request printer * module/web/request.scm (bad-request-printer): Add printer for these exceptions. --- module/web/request.scm | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/module/web/request.scm b/module/web/request.scm index 8259887c0..40d4a668f 100644 --- a/module/web/request.scm +++ b/module/web/request.scm @@ -1,6 +1,6 @@ ;;; HTTP request objects -;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011, 2012 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 @@ -131,6 +131,17 @@ (define (bad-request message . args) (throw 'bad-request message args)) +(define (bad-request-printer port key args default-printer) + (apply (case-lambda + ((msg args) + (display "Bad request: " port) + (apply format port msg args) + (newline port)) + (_ (default-printer))) + args)) + +(set-exception-printer! 'bad-request bad-request-printer) + (define (non-negative-integer? n) (and (number? n) (>= n 0) (exact? n) (integer? n))) From a8004dcb4d7148ec66cbaa109a18715d757700eb Mon Sep 17 00:00:00 2001 From: BT Templeton Date: Sat, 10 Mar 2012 03:31:58 -0500 Subject: [PATCH 5/5] primitive resolution for public refs * module/language/tree-il/primitives.scm (resolve-primitives!): Resolve public module-refs to primitives. * test-suite/tests/tree-il.test: New tests for primitive resolution. --- module/language/tree-il/primitives.scm | 16 +++++++++------- test-suite/tests/tree-il.test | 10 +++++++++- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index c825d9a0a..2039faa63 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -240,13 +240,15 @@ (module-variable mod name)) (lambda (name) (make-primitive-ref src name)))) (( src mod name public?) - ;; for the moment, we're disabling primitive resolution for - ;; public refs because resolve-interface can raise errors. - (let ((m (and (not public?) (resolve-module mod)))) - (and m - (and=> (hashq-ref *interesting-primitive-vars* - (module-variable m name)) - (lambda (name) (make-primitive-ref src name)))))) + (and=> (and=> (resolve-module mod) + (if public? + module-public-interface + identity)) + (lambda (m) + (and=> (hashq-ref *interesting-primitive-vars* + (module-variable m name)) + (lambda (name) + (make-primitive-ref src name)))))) (else #f))) x)) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 3d5989e06..0be563623 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -1585,7 +1585,15 @@ (lambda _ (lambda-case (((x y) #f #f #f () (_ _)) - _))))) + _)))) + + (pass-if-peval resolve-primitives + ((@ (guile) car) '(1 2)) + (const 1)) + + (pass-if-peval resolve-primitives + ((@@ (guile) car) '(1 2)) + (const 1)))