/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Copyright by The HDF Group. * * Copyright by the Board of Trustees of the University of Illinois. * * All rights reserved. * * * * This file is part of HDF5. The full HDF5 copyright notice, including * * terms governing use, modification, and redistribution, is contained in * * the files COPYING and Copyright.html. COPYING can be found at the root * * of the source code distribution tree; Copyright.html can be found at the * * root level of an installed copy of the electronic HDF5 document set and * * is linked from the top-level documents page. It can also be found at * * http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * * access to either file, you may request a copy from help@hdfgroup.org. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /*------------------------------------------------------------------------- * * Created: H5MF.c * Jul 11 1997 * Robb Matzke * * Purpose: File memory management functions. * *------------------------------------------------------------------------- */ /****************/ /* Module Setup */ /****************/ #define H5F_PACKAGE /*suppress error about including H5Fpkg */ #define H5MF_PACKAGE /*suppress error about including H5MFpkg */ /***********/ /* Headers */ /***********/ #include "H5private.h" /* Generic Functions */ #include "H5Eprivate.h" /* Error handling */ #include "H5Fpkg.h" /* File access */ #include "H5MFpkg.h" /* File memory management */ #include "H5Vprivate.h" /* Vectors and arrays */ /****************/ /* Local Macros */ /****************/ #define H5MF_FSPACE_SHRINK 80 /* Percent of "normal" size to shrink serialized free space size */ #define H5MF_FSPACE_EXPAND 120 /* Percent of "normal" size to expand serialized free space size */ /* Map an allocation request type to a free list */ #define H5MF_ALLOC_TO_FS_TYPE(F, T) ((H5FD_MEM_DEFAULT == (F)->shared->fs_type_map[T]) \ ? (T) : (F)->shared->fs_type_map[T]) /******************/ /* Local Typedefs */ /******************/ /* Enum for kind of free space section+aggregator merging allowed for a file */ typedef enum { H5MF_AGGR_MERGE_SEPARATE, /* Everything in separate free list */ H5MF_AGGR_MERGE_DICHOTOMY, /* Metadata in one free list and raw data in another */ H5MF_AGGR_MERGE_TOGETHER /* Metadata & raw data in one free list */ } H5MF_aggr_merge_t; /* User data for section info iterator callback for iterating over free space sections */ typedef struct { H5F_sect_info_t *sects; /* section info to be retrieved */ size_t sect_count; /* # of sections requested */ size_t sect_idx; /* the current count of sections */ } H5MF_sect_iter_ud_t; /********************/ /* Package Typedefs */ /********************/ /********************/ /* Local Prototypes */ /********************/ /* Allocator routines */ static herr_t H5MF_alloc_create(H5F_t *f, hid_t dxpl_id, H5FD_mem_t type); static herr_t H5MF_alloc_close(H5F_t *f, hid_t dxpl_id, H5FD_mem_t type); /*********************/ /* Package Variables */ /*********************/ /*****************************/ /* Library Private Variables */ /*****************************/ /*******************/ /* Local Variables */ /*******************/ /*------------------------------------------------------------------------- * Function: H5MF_init_merge_flags * * Purpose: Initialize the free space section+aggregator merge flags * for the file. * * Return: SUCCEED/FAIL * * Programmer: Quincey Koziol * Friday, February 1, 2008 * *------------------------------------------------------------------------- */ herr_t H5MF_init_merge_flags(H5F_t *f) { H5MF_aggr_merge_t mapping_type; /* Type of free list mapping */ H5FD_mem_t type; /* Memory type for iteration */ hbool_t all_same; /* Whether all the types map to the same value */ herr_t ret_value = SUCCEED; /* Return value */ FUNC_ENTER_NOAPI(FAIL) /* check args */ HDassert(f); HDassert(f->shared); HDassert(f->shared->lf); /* Iterate over all the free space types to determine if sections of that type * can merge with the metadata or small 'raw' data aggregator */ all_same = TRUE; for(type = H5FD_MEM_DEFAULT; type < H5FD_MEM_NTYPES; H5_INC_ENUM(H5FD_mem_t, type)) /* Check for any different type mappings */ if(f->shared->fs_type_map[type] != f->shared->fs_type_map[H5FD_MEM_DEFAULT]) { all_same = FALSE; break; } /* end if */ /* Check for all allocation types mapping to the same free list type */ if(all_same) { if(f->shared->fs_type_map[H5FD_MEM_DEFAULT] == H5FD_MEM_DEFAULT) mapping_type = H5MF_AGGR_MERGE_SEPARATE; else mapping_type = H5MF_AGGR_MERGE_TOGETHER; } /* end if */ else { /* Check for raw data mapping into same list as metadata */ if(f->shared->fs_type_map[H5FD_MEM_DRAW] == f->shared->fs_type_map[H5FD_MEM_SUPER]) mapping_type = H5MF_AGGR_MERGE_SEPARATE; else { hbool_t all_metadata_same; /* Whether all metadata go in same free list */ /* One or more allocation type don't map to the same free list type */ /* Check if all the metadata allocation types map to the same type */ all_metadata_same = TRUE; for(type = H5FD_MEM_SUPER; type < H5FD_MEM_NTYPES; H5_INC_ENUM(H5FD_mem_t, type)) /* Skip checking raw data free list mapping */ /* (global heap is treated as raw data) */ if(type != H5FD_MEM_DRAW && type != H5FD_MEM_GHEAP) { /* Check for any different type mappings */ if(f->shared->fs_type_map[type] != f->shared->fs_type_map[H5FD_MEM_SUPER]) { all_metadata_same = FALSE; break; } /* end if */ } /* end if */ /* Check for all metadata on same free list */ if(all_metadata_same) mapping_type = H5MF_AGGR_MERGE_DICHOTOMY; else mapping_type = H5MF_AGGR_MERGE_SEPARATE; } /* end else */ } /* end else */ /* Based on mapping type, initialize merging flags for each free list type */ switch(mapping_type) { case H5MF_AGGR_MERGE_SEPARATE: /* Don't merge any metadata together */ HDmemset(f->shared->fs_aggr_merge, 0, sizeof(f->shared->fs_aggr_merge)); /* Check if merging raw data should be allowed */ /* (treat global heaps as raw data) */ if(H5FD_MEM_DRAW == f->shared->fs_type_map[H5FD_MEM_DRAW] || H5FD_MEM_DEFAULT == f->shared->fs_type_map[H5FD_MEM_DRAW]) { f->shared->fs_aggr_merge[H5FD_MEM_DRAW] = H5F_FS_MERGE_RAWDATA; f->shared->fs_aggr_merge[H5FD_MEM_GHEAP] = H5F_FS_MERGE_RAWDATA; } /* end if */ break; case H5MF_AGGR_MERGE_DICHOTOMY: /* Merge all metadata together (but not raw data) */ HDmemset(f->shared->fs_aggr_merge, H5F_FS_MERGE_METADATA, sizeof(f->shared->fs_aggr_merge)); /* Allow merging raw data allocations together */ /* (treat global heaps as raw data) */ f->shared->fs_aggr_merge[H5FD_MEM_DRAW] = H5F_FS_MERGE_RAWDATA; f->shared->fs_aggr_merge[H5FD_MEM_GHEAP] = H5F_FS_MERGE_RAWDATA; break; case H5MF_AGGR_MERGE_TOGETHER: /* Merge all allocation types together */ HDmemset(f->shared->fs_aggr_merge, (H5F_FS_MERGE_METADATA | H5F_FS_MERGE_RAWDATA), sizeof(f->shared->fs_aggr_merge)); break; default: HGOTO_ERROR(H5E_RESOURCE, H5E_BADVALUE, FAIL, "invalid mapping type") } /* end switch */ done: FUNC_LEAVE_NOAPI(ret_value) } /* end H5MF_init_merge_flags() */ /*------------------------------------------------------------------------- * Function: H5MF_alloc_open * * Purpose: Open an existing free space manager of TYPE for file by * creating a free-space structure * * Return: Success: non-negative * Failure: negative * * Programmer: Quincey Koziol * koziol@hdfgroup.org * Jan 8 2008 * *------------------------------------------------------------------------- */ herr_t H5MF_alloc_open(H5F_t *f, hid_t dxpl_id, H5FD_mem_t type) { const H5FS_section_class_t *classes[] = { /* Free space section classes implemented for file */ H5MF_FSPACE_SECT_CLS_SIMPLE}; herr_t ret_value = SUCCEED; /* Return value */ FUNC_ENTER_NOAPI_NOINIT /* * Check arguments. */ HDassert(f); HDassert(f->shared); HDassert(type != H5FD_MEM_NOLIST); HDassert(H5F_addr_defined(f->shared->fs_addr[type])); HDassert(f->shared->fs_state[type] == H5F_FS_STATE_CLOSED); /* Open an existing free space structure for the file */ if(NULL == (f->shared->fs_man[type] = H5FS_open(f, dxpl_id, f->shared->fs_addr[type], NELMTS(classes), classes, f, f->shared->alignment, f->shared->threshold))) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTINIT, FAIL, "can't initialize free space info") /* Set the state for the free space manager to "open", if it is now */ if(f->shared->fs_man[type]) f->shared->fs_state[type] = H5F_FS_STATE_OPEN; done: FUNC_LEAVE_NOAPI(ret_value) } /* end H5MF_alloc_open() */ /*------------------------------------------------------------------------- * Function: H5MF_alloc_create * * Purpose: Create free space manager of TYPE for the file by creating * a free-space structure * * Return: Success: non-negative * Failure: negative * * Programmer: Quincey Koziol * koziol@hdfgroup.org * Jan 8 2008 * *------------------------------------------------------------------------- */ static herr_t H5MF_alloc_create(H5F_t *f, hid_t dxpl_id, H5FD_mem_t type) { const H5FS_section_class_t *classes[] = { /* Free space section classes implemented for file */ H5MF_FSPACE_SECT_CLS_SIMPLE}; herr_t ret_value = SUCCEED; /* Return value */ H5FS_create_t fs_create; /* Free space creation parameters */ FUNC_ENTER_NOAPI_NOINIT /* * Check arguments. */ HDassert(f); HDassert(f->shared); HDassert(type != H5FD_MEM_NOLIST); HDassert(!H5F_addr_defined(f->shared->fs_addr[type])); HDassert(f->shared->fs_state[type] == H5F_FS_STATE_CLOSED); /* Set the free space creation parameters */ fs_create.client = H5FS_CLIENT_FILE_ID; fs_create.shrink_percent = H5MF_FSPACE_SHRINK; fs_create.expand_percent = H5MF_FSPACE_EXPAND; fs_create.max_sect_addr = 1 + H5V_log2_gen((uint64_t)f->shared->maxaddr); fs_create.max_sect_size = f->shared->maxaddr; if(NULL == (f->shared->fs_man[type] = H5FS_create(f, dxpl_id, NULL, &fs_create, NELMTS(classes), classes, f, f->shared->alignment, f->shared->threshold))) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTINIT, FAIL, "can't initialize free space info") /* Set the state for the free space manager to "open", if it is now */ if(f->shared->fs_man[type]) f->shared->fs_state[type] = H5F_FS_STATE_OPEN; done: FUNC_LEAVE_NOAPI(ret_value) } /* end H5MF_alloc_create() */ /*------------------------------------------------------------------------- * Function: H5MF_alloc_start * * Purpose: Open or create a free space manager of a given type * * Return: Success: non-negative * Failure: negative * * Programmer: Quincey Koziol * koziol@hdfgroup.org * Jan 8 2008 * *------------------------------------------------------------------------- */ herr_t H5MF_alloc_start(H5F_t *f, hid_t dxpl_id, H5FD_mem_t type) { herr_t ret_value = SUCCEED; /* Return value */ FUNC_ENTER_NOAPI_NOINIT /* * Check arguments. */ HDassert(f); HDassert(f->shared); HDassert(type != H5FD_MEM_NOLIST); /* Check if the free space manager exists already */ if(H5F_addr_defined(f->shared->fs_addr[type])) { /* Open existing free space manager */ if(H5MF_alloc_open(f, dxpl_id, type) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTOPENOBJ, FAIL, "can't initialize file free space") } /* end if */ else { /* Create new free space manager */ if(H5MF_alloc_create(f, dxpl_id, type) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTCREATE, FAIL, "can't initialize file free space") } /* end else */ done: FUNC_LEAVE_NOAPI(ret_value) } /* end H5MF_alloc_start() */ /*------------------------------------------------------------------------- * Function: H5MF_alloc_close * * Purpose: Close an existing free space manager of TYPE for file * * Return: Success: non-negative * Failure: negative * * Programmer: Vailin Choi; July 1st, 2009 * *------------------------------------------------------------------------- */ static herr_t H5MF_alloc_close(H5F_t *f, hid_t dxpl_id, H5FD_mem_t type) { herr_t ret_value = SUCCEED; /* Return value */ FUNC_ENTER_NOAPI_NOINIT /* * Check arguments. */ HDassert(f); HDassert(f->shared); HDassert(type != H5FD_MEM_NOLIST); HDassert(f->shared->fs_man[type]); HDassert(f->shared->fs_state[type] != H5F_FS_STATE_CLOSED); /* Close an existing free space structure for the file */ if(H5FS_close(f, dxpl_id, f->shared->fs_man[type]) < 0) HGOTO_ERROR(H5E_FSPACE, H5E_CANTRELEASE, FAIL, "can't release free space info") f->shared->fs_man[type] = NULL; f->shared->fs_state[type] = H5F_FS_STATE_CLOSED; done: FUNC_LEAVE_NOAPI(ret_value) } /* end H5MF_alloc_close() */ /*------------------------------------------------------------------------- * Function: H5MF_alloc * * Purpose: Allocate SIZE bytes of file memory and return the relative * address where that contiguous chunk of file memory exists. * The TYPE argument describes the purpose for which the storage * is being requested. * * Return: Success: The file address of new chunk. * Failure: HADDR_UNDEF * * Programmer: Robb Matzke * matzke@llnl.gov * Jul 11 1997 * *------------------------------------------------------------------------- */ haddr_t H5MF_alloc(H5F_t *f, H5FD_mem_t alloc_type, hid_t dxpl_id, hsize_t size) { H5FD_mem_t fs_type; /* Free space type (mapped from allocation type) */ haddr_t ret_value; /* Return value */ FUNC_ENTER_NOAPI(HADDR_UNDEF) #ifdef H5MF_ALLOC_DEBUG HDfprintf(stderr, "%s: alloc_type = %u, size = %Hu\n", FUNC, (unsigned)alloc_type, size); #endif /* H5MF_ALLOC_DEBUG */ /* check arguments */ HDassert(f); HDassert(f->shared); HDassert(f->shared->lf); HDassert(size > 0); /* Get free space type from allocation type */ fs_type = H5MF_ALLOC_TO_FS_TYPE(f, alloc_type); /* Check if we are using the free space manager for this file */ if(H5F_HAVE_FREE_SPACE_MANAGER(f)) { /* Check if the free space manager for the file has been initialized */ if(!f->shared->fs_man[fs_type] && H5F_addr_defined(f->shared->fs_addr[fs_type])) if(H5MF_alloc_open(f, dxpl_id, fs_type) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTOPENOBJ, HADDR_UNDEF, "can't initialize file free space") /* Search for large enough space in the free space manager */ if(f->shared->fs_man[fs_type]) { H5MF_free_section_t *node; /* Free space section pointer */ htri_t node_found = FALSE; /* Whether an existing free list node was found */ /* Try to get a section from the free space manager */ if((node_found = H5FS_sect_find(f, dxpl_id, f->shared->fs_man[fs_type], size, (H5FS_section_info_t **)&node)) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTALLOC, HADDR_UNDEF, "error locating free space in file") #ifdef H5MF_ALLOC_DEBUG_MORE HDfprintf(stderr, "%s: Check 1.5, node_found = %t\n", FUNC, node_found); #endif /* H5MF_ALLOC_DEBUG_MORE */ /* Check for actually finding section */ if(node_found) { /* Sanity check */ HDassert(node); /* Retrieve return value */ ret_value = node->sect_info.addr; /* Check for eliminating the section */ if(node->sect_info.size == size) { #ifdef H5MF_ALLOC_DEBUG_MORE HDfprintf(stderr, "%s: Check 1.6, freeing node\n", FUNC); #endif /* H5MF_ALLOC_DEBUG_MORE */ /* Free section node */ if(H5MF_sect_simple_free((H5FS_section_info_t *)node) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTRELEASE, HADDR_UNDEF, "can't free simple section node") } /* end if */ else { H5MF_sect_ud_t udata; /* User data for callback */ /* Adjust information for section */ node->sect_info.addr += size; node->sect_info.size -= size; /* Construct user data for callbacks */ udata.f = f; udata.dxpl_id = dxpl_id; udata.alloc_type = alloc_type; udata.allow_sect_absorb = TRUE; #ifdef H5MF_ALLOC_DEBUG_MORE HDfprintf(stderr, "%s: Check 1.7, re-adding node, node->sect_info.size = %Hu\n", FUNC, node->sect_info.size); #endif /* H5MF_ALLOC_DEBUG_MORE */ /* Re-insert section node into file's free space */ if(H5FS_sect_add(f, dxpl_id, f->shared->fs_man[fs_type], (H5FS_section_info_t *)node, H5FS_ADD_RETURNED_SPACE, &udata) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTINSERT, HADDR_UNDEF, "can't re-add section to file free space") } /* end else */ /* Leave now */ HGOTO_DONE(ret_value) } /* end if */ } /* end if */ #ifdef H5MF_ALLOC_DEBUG_MORE HDfprintf(stderr, "%s: Check 2.0\n", FUNC); #endif /* H5MF_ALLOC_DEBUG_MORE */ } /* end if */ /* Allocate from the metadata aggregator (or the VFD) */ if(HADDR_UNDEF == (ret_value = H5MF_aggr_vfd_alloc(f, alloc_type, dxpl_id, size))) HGOTO_ERROR(H5E_VFL, H5E_CANTALLOC, HADDR_UNDEF, "allocation failed from aggr/vfd") done: #ifdef H5MF_ALLOC_DEBUG HDfprintf(stderr, "%s: Leaving: ret_value = %a, size = %Hu\n", FUNC, ret_value, size); #endif /* H5MF_ALLOC_DEBUG */ #ifdef H5MF_ALLOC_DEBUG_DUMP H5MF_sects_dump(f, dxpl_id, stderr); #endif /* H5MF_ALLOC_DEBUG_DUMP */ FUNC_LEAVE_NOAPI(ret_value) } /* end H5MF_alloc() */ /*------------------------------------------------------------------------- * Function: H5MF_alloc_tmp * * Purpose: Allocate temporary space in the file * * Note: The address returned is non-overlapping with any other address * in the file and suitable for insertion into the metadata * cache. * * The address is _not_ suitable for actual file I/O and will * cause an error if it is so used. * * The space allocated with this routine should _not_ be freed, * it should just be abandoned. Calling H5MF_xfree() with space * from this routine will cause an error. * * Return: Success: Temporary file address * Failure: HADDR_UNDEF * * Programmer: Quincey Koziol * Thursday, June 4, 2009 * *------------------------------------------------------------------------- */ haddr_t H5MF_alloc_tmp(H5F_t *f, hsize_t size) { haddr_t eoa; /* End of allocated space in the file */ haddr_t ret_value; /* Return value */ FUNC_ENTER_NOAPI(HADDR_UNDEF) #ifdef H5MF_ALLOC_DEBUG HDfprintf(stderr, "%s: size = %Hu\n", FUNC, size); #endif /* H5MF_ALLOC_DEBUG */ /* check args */ HDassert(f); HDassert(f->shared); HDassert(f->shared->lf); HDassert(size > 0); /* Retrieve the 'eoa' for the file */ if(HADDR_UNDEF == (eoa = H5FD_get_eoa(f->shared->lf, H5FD_MEM_DEFAULT))) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTGET, HADDR_UNDEF, "driver get_eoa request failed") /* Compute value to return */ ret_value = f->shared->tmp_addr - size; /* Check for overlap into the actual allocated space in the file */ if(H5F_addr_le(ret_value, eoa)) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTGET, HADDR_UNDEF, "driver get_eoa request failed") /* Adjust temporary address allocator in the file */ f->shared->tmp_addr = ret_value; done: FUNC_LEAVE_NOAPI(ret_value) } /* end H5MF_alloc_tmp() */ /*------------------------------------------------------------------------- * Function: H5MF_xfree * * Purpose: Frees part of a file, making that part of the file * available for reuse. * * Return: Non-negative on success/Negative on failure * * Programmer: Robb Matzke * matzke@llnl.gov * Jul 17 1997 * *------------------------------------------------------------------------- */ herr_t H5MF_xfree(H5F_t *f, H5FD_mem_t alloc_type, hid_t dxpl_id, haddr_t addr, hsize_t size) { H5MF_free_section_t *node = NULL; /* Free space section pointer */ H5MF_sect_ud_t udata; /* User data for callback */ H5FD_mem_t fs_type; /* Free space type (mapped from allocation type) */ herr_t ret_value = SUCCEED; /* Return value */ FUNC_ENTER_NOAPI(FAIL) #ifdef H5MF_ALLOC_DEBUG HDfprintf(stderr, "%s: Entering - alloc_type = %u, addr = %a, size = %Hu\n", FUNC, (unsigned)alloc_type, addr, size); #endif /* H5MF_ALLOC_DEBUG */ /* check arguments */ HDassert(f); if(!H5F_addr_defined(addr) || 0 == size) HGOTO_DONE(SUCCEED); HDassert(addr != 0); /* Can't deallocate the superblock :-) */ /* Check for attempting to free space that's a 'temporary' file address */ if(H5F_addr_le(f->shared->tmp_addr, addr)) HGOTO_ERROR(H5E_RESOURCE, H5E_BADRANGE, FAIL, "attempting to free temporary file space") /* Check if the space to free intersects with the file's metadata accumulator */ if(H5F_accum_free(f, dxpl_id, alloc_type, addr, size) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTFREE, FAIL, "can't check free space intersection w/metadata accumulator") /* Get free space type from allocation type */ fs_type = H5MF_ALLOC_TO_FS_TYPE(f, alloc_type); #ifdef H5MF_ALLOC_DEBUG_MORE HDfprintf(stderr, "%s: fs_type = %u\n", FUNC, (unsigned)fs_type); #endif /* H5MF_ALLOC_DEBUG_MORE */ /* Check if the free space manager for the file has been initialized */ if(!f->shared->fs_man[fs_type]) { /* If there's no free space manager for objects of this type, * see if we can avoid creating one by checking if the freed * space is at the end of the file */ #ifdef H5MF_ALLOC_DEBUG_MORE HDfprintf(stderr, "%s: f->shared->fs_addr[%u] = %a\n", FUNC, (unsigned)fs_type, f->shared->fs_addr[fs_type]); #endif /* H5MF_ALLOC_DEBUG_MORE */ if(!H5F_addr_defined(f->shared->fs_addr[fs_type])) { htri_t status; /* "can absorb" status for section into */ #ifdef H5MF_ALLOC_DEBUG_MORE HDfprintf(stderr, "%s: Trying to avoid starting up free space manager\n", FUNC); #endif /* H5MF_ALLOC_DEBUG_MORE */ /* Try to shrink the file or absorb the block into a block aggregator */ if((status = H5MF_try_shrink(f, alloc_type, dxpl_id, addr, size)) < 0) HGOTO_ERROR(H5E_FSPACE, H5E_CANTMERGE, FAIL, "can't check for absorbing block") else if(status > 0) /* Indicate success */ HGOTO_DONE(SUCCEED) else if(size < f->shared->fs_threshold) { #ifdef H5MF_ALLOC_DEBUG_MORE HDfprintf(stderr, "%s: dropping addr = %a, size = %Hu, on the floor!\n", FUNC, addr, size); #endif /* H5MF_ALLOC_DEBUG_MORE */ HGOTO_DONE(SUCCEED) } } /* end if */ /* If we are deleting the free space manager, leave now, to avoid * [re-]starting it. * or if file space strategy type is not using a free space manager * (H5F_FILE_SPACE_AGGR_VFD or H5F_FILE_SPACE_VFD), drop free space * section on the floor. * * Note: this drops the space to free on the floor... * */ if(f->shared->fs_state[fs_type] == H5F_FS_STATE_DELETING || !H5F_HAVE_FREE_SPACE_MANAGER(f)) { #ifdef H5MF_ALLOC_DEBUG_MORE HDfprintf(stderr, "%s: dropping addr = %a, size = %Hu, on the floor!\n", FUNC, addr, size); #endif /* H5MF_ALLOC_DEBUG_MORE */ HGOTO_DONE(SUCCEED) } /* end if */ /* There's either already a free space manager, or the freed * space isn't at the end of the file, so start up (or create) * the file space manager */ if(H5MF_alloc_start(f, dxpl_id, fs_type) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTINIT, FAIL, "can't initialize file free space") } /* end if */ /* Create free space section for block */ if(NULL == (node = H5MF_sect_simple_new(addr, size))) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTINIT, FAIL, "can't initialize free space section") /* Construct user data for callbacks */ udata.f = f; udata.dxpl_id = dxpl_id; udata.alloc_type = alloc_type; udata.allow_sect_absorb = TRUE; /* If size of section freed is larger than threshold, add it to the free space manager */ if(size >= f->shared->fs_threshold) { HDassert(f->shared->fs_man[fs_type]); #ifdef H5MF_ALLOC_DEBUG_MORE HDfprintf(stderr, "%s: Before H5FS_sect_add()\n", FUNC); #endif /* H5MF_ALLOC_DEBUG_MORE */ /* Add to the free space for the file */ if(H5FS_sect_add(f, dxpl_id, f->shared->fs_man[fs_type], (H5FS_section_info_t *)node, H5FS_ADD_RETURNED_SPACE, &udata) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTINSERT, FAIL, "can't add section to file free space") node = NULL; #ifdef H5MF_ALLOC_DEBUG_MORE HDfprintf(stderr, "%s: After H5FS_sect_add()\n", FUNC); #endif /* H5MF_ALLOC_DEBUG_MORE */ } /* end if */ else { htri_t merged; /* Whether node was merged */ /* Try to merge the section that is smaller than threshold */ if((merged = H5FS_sect_try_merge(f, dxpl_id, f->shared->fs_man[fs_type], (H5FS_section_info_t *)node, H5FS_ADD_RETURNED_SPACE, &udata)) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTINSERT, FAIL, "can't merge section to file free space") else if(merged == TRUE) /* successfully merged */ /* Indicate that the node was used */ node = NULL; } /* end else */ done: /* Release section node, if allocated and not added to section list or merged */ if(node) if(H5MF_sect_simple_free((H5FS_section_info_t *)node) < 0) HDONE_ERROR(H5E_RESOURCE, H5E_CANTRELEASE, FAIL, "can't free simple section node") #ifdef H5MF_ALLOC_DEBUG HDfprintf(stderr, "%s: Leaving, ret_value = %d\n", FUNC, ret_value); #endif /* H5MF_ALLOC_DEBUG */ #ifdef H5MF_ALLOC_DEBUG_DUMP H5MF_sects_dump(f, dxpl_id, stderr); #endif /* H5MF_ALLOC_DEBUG_DUMP */ FUNC_LEAVE_NOAPI(ret_value) } /* end H5MF_xfree() */ /*------------------------------------------------------------------------- * Function: H5MF_try_extend * * Purpose: Extend a block in the file if possible. * * Return: Success: TRUE(1) - Block was extended * FALSE(0) - Block could not be extended * Failure: FAIL * * Programmer: Quincey Koziol * Friday, June 11, 2004 * *------------------------------------------------------------------------- */ htri_t H5MF_try_extend(H5F_t *f, hid_t dxpl_id, H5FD_mem_t alloc_type, haddr_t addr, hsize_t size, hsize_t extra_requested) { haddr_t end; /* End of block to extend */ H5FD_mem_t map_type; /* Mapped type */ htri_t ret_value; /* Return value */ FUNC_ENTER_NOAPI(FAIL) #ifdef H5MF_ALLOC_DEBUG HDfprintf(stderr, "%s: Entering: alloc_type = %u, addr = %a, size = %Hu, extra_requested = %Hu\n", FUNC, (unsigned)alloc_type, addr, size, extra_requested); #endif /* H5MF_ALLOC_DEBUG */ /* Sanity check */ HDassert(f); HDassert(H5F_INTENT(f) & H5F_ACC_RDWR); /* Set mapped type, treating global heap as raw data */ map_type = (alloc_type == H5FD_MEM_GHEAP) ? H5FD_MEM_DRAW : alloc_type; /* Compute end of block to extend */ end = addr + size; /* Check if the block is exactly at the end of the file */ if((ret_value = H5FD_try_extend(f->shared->lf, map_type, f, end, extra_requested)) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTEXTEND, FAIL, "error extending file") else if(ret_value == FALSE) { H5F_blk_aggr_t *aggr; /* Aggregator to use */ /* Check for test block able to extend aggregation block */ aggr = (map_type == H5FD_MEM_DRAW) ? &(f->shared->sdata_aggr) : &(f->shared->meta_aggr); if((ret_value = H5MF_aggr_try_extend(f, aggr, map_type, end, extra_requested)) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTEXTEND, FAIL, "error extending aggregation block") else if(ret_value == FALSE) { H5FD_mem_t fs_type; /* Free space type (mapped from allocation type) */ /* Get free space type from allocation type */ fs_type = H5MF_ALLOC_TO_FS_TYPE(f, alloc_type); /* Check if the free space for the file has been initialized */ if(!f->shared->fs_man[fs_type] && H5F_addr_defined(f->shared->fs_addr[fs_type])) if(H5MF_alloc_open(f, dxpl_id, fs_type) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTINIT, FAIL, "can't initialize file free space") /* Check for test block able to block in free space manager */ if(f->shared->fs_man[fs_type]) if((ret_value = H5FS_sect_try_extend(f, dxpl_id, f->shared->fs_man[fs_type], addr, size, extra_requested)) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTEXTEND, FAIL, "error extending block in free space manager") } /* end if */ } /* end if */ done: #ifdef H5MF_ALLOC_DEBUG HDfprintf(stderr, "%s: Leaving: ret_value = %t\n", FUNC, ret_value); #endif /* H5MF_ALLOC_DEBUG */ #ifdef H5MF_ALLOC_DEBUG_DUMP H5MF_sects_dump(f, dxpl_id, stderr); #endif /* H5MF_ALLOC_DEBUG_DUMP */ FUNC_LEAVE_NOAPI(ret_value) } /* end H5MF_try_extend() */ /*------------------------------------------------------------------------- * Function: H5MF_get_freespace * * Purpose: Retrieve the amount of free space in a file. * * Return: Success: Amount of free space in file * Failure: Negative * * Programmer: Quincey Koziol * Monday, October 6, 2003 * *------------------------------------------------------------------------- */ herr_t H5MF_get_freespace(H5F_t *f, hid_t dxpl_id, hsize_t *tot_space, hsize_t *meta_size) { haddr_t eoa; /* End of allocated space in the file */ haddr_t ma_addr = HADDR_UNDEF; /* Base "metadata aggregator" address */ hsize_t ma_size = 0; /* Size of "metadata aggregator" */ haddr_t sda_addr = HADDR_UNDEF; /* Base "small data aggregator" address */ hsize_t sda_size = 0; /* Size of "small data aggregator" */ hsize_t tot_fs_size = 0; /* Amount of all free space managed */ hsize_t tot_meta_size = 0; /* Amount of metadata for free space managers */ H5FD_mem_t type; /* Memory type for iteration */ herr_t ret_value = SUCCEED; /* Return value */ FUNC_ENTER_NOAPI(FAIL) /* check args */ HDassert(f); HDassert(f->shared); HDassert(f->shared->lf); /* Retrieve the 'eoa' for the file */ if(HADDR_UNDEF == (eoa = H5FD_get_eoa(f->shared->lf, H5FD_MEM_DEFAULT))) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTGET, FAIL, "driver get_eoa request failed") /* Retrieve metadata aggregator info, if available */ if(H5MF_aggr_query(f, &(f->shared->meta_aggr), &ma_addr, &ma_size) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTGET, FAIL, "can't query metadata aggregator stats") /* Retrieve 'small data' aggregator info, if available */ if(H5MF_aggr_query(f, &(f->shared->sdata_aggr), &sda_addr, &sda_size) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTGET, FAIL, "can't query small data aggregator stats") /* Iterate over all the free space types that have managers and get each free list's space */ for(type = H5FD_MEM_DEFAULT; type < H5FD_MEM_NTYPES; H5_INC_ENUM(H5FD_mem_t, type)) { hbool_t fs_started = FALSE; /* Check if the free space for the file has been initialized */ if(!f->shared->fs_man[type] && H5F_addr_defined(f->shared->fs_addr[type])) { if(H5MF_alloc_open(f, dxpl_id, type) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTINIT, FAIL, "can't initialize file free space") HDassert(f->shared->fs_man[type]); fs_started = TRUE; } /* end if */ /* Check if there's free space of this type */ if(f->shared->fs_man[type]) { hsize_t type_fs_size = 0; /* Amount of free space managed for each type */ hsize_t type_meta_size = 0; /* Amount of free space metadata for each type */ /* Retrieve free space size from free space manager */ if(H5FS_sect_stats(f->shared->fs_man[type], &type_fs_size, NULL) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTGET, FAIL, "can't query free space stats") if(H5FS_size(f, f->shared->fs_man[type], &type_meta_size) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTGET, FAIL, "can't query free space metadata stats") /* Increment total free space for types */ tot_fs_size += type_fs_size; tot_meta_size += type_meta_size; } /* end if */ /* Close the free space manager, if we opened it here */ if(fs_started) if(H5MF_alloc_close(f, dxpl_id, type) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTINIT, FAIL, "can't close file free space") } /* end for */ /* Check for aggregating metadata allocations */ if(ma_size > 0) { /* Add in the reserved space for metadata to the available free space */ /* (if it's not at the tail of the file) */ if(H5F_addr_ne(ma_addr + ma_size, eoa)) tot_fs_size += ma_size; } /* end if */ /* Check for aggregating small data allocations */ if(sda_size > 0) { /* Add in the reserved space for metadata to the available free space */ /* (if it's not at the tail of the file) */ if(H5F_addr_ne(sda_addr + sda_size, eoa)) tot_fs_size += sda_size; } /* end if */ /* Set the value(s) to return */ if(tot_space) *tot_space = tot_fs_size; if(meta_size) *meta_size = tot_meta_size; done: FUNC_LEAVE_NOAPI(ret_value) } /* end H5MF_get_freespace() */ /*------------------------------------------------------------------------- * Function: H5MF_try_shrink * * Purpose: Try to shrink the size of a file with a block or absorb it * into a block aggregator. * * Return: Non-negative on success/Negative on failure * * Programmer: Quincey Koziol * koziol@hdfgroup.org * Feb 14 2008 * *------------------------------------------------------------------------- */ htri_t H5MF_try_shrink(H5F_t *f, H5FD_mem_t alloc_type, hid_t dxpl_id, haddr_t addr, hsize_t size) { H5MF_free_section_t *node = NULL; /* Free space section pointer */ H5MF_sect_ud_t udata; /* User data for callback */ htri_t ret_value; /* Return value */ FUNC_ENTER_NOAPI(FAIL) #ifdef H5MF_ALLOC_DEBUG HDfprintf(stderr, "%s: Entering - alloc_type = %u, addr = %a, size = %Hu\n", FUNC, (unsigned)alloc_type, addr, size); #endif /* H5MF_ALLOC_DEBUG */ /* check arguments */ HDassert(f); HDassert(f->shared); HDassert(f->shared->lf); HDassert(H5F_addr_defined(addr)); HDassert(size > 0); /* Create free space section for block */ if(NULL == (node = H5MF_sect_simple_new(addr, size))) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTINIT, FAIL, "can't initialize free space section") /* Construct user data for callbacks */ udata.f = f; udata.dxpl_id = dxpl_id; udata.alloc_type = alloc_type; udata.allow_sect_absorb = FALSE; /* Force section to be absorbed into aggregator */ /* Call the "can shrink" callback for the section */ if((ret_value = H5MF_sect_simple_can_shrink((const H5FS_section_info_t *)node, &udata)) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTMERGE, FAIL, "can't check if section can shrink container") else if(ret_value > 0) { /* Shrink or absorb the section */ if(H5MF_sect_simple_shrink((H5FS_section_info_t **)&node, &udata) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTSHRINK, FAIL, "can't shrink container") } /* end if */ done: /* Free section node allocated */ if(node && H5MF_sect_simple_free((H5FS_section_info_t *)node) < 0) HDONE_ERROR(H5E_RESOURCE, H5E_CANTRELEASE, FAIL, "can't free simple section node") #ifdef H5MF_ALLOC_DEBUG HDfprintf(stderr, "%s: Leaving, ret_value = %d\n", FUNC, ret_value); #endif /* H5MF_ALLOC_DEBUG */ FUNC_LEAVE_NOAPI(ret_value) } /* end H5MF_try_shrink() */ /*------------------------------------------------------------------------- * Function: H5MF_close * * Purpose: Close the free space tracker(s) for a file * * Return: SUCCEED/FAIL * * Programmer: Quincey Koziol * Tuesday, January 22, 2008 * *------------------------------------------------------------------------- */ herr_t H5MF_close(H5F_t *f, hid_t dxpl_id) { H5FD_mem_t type; /* Memory type for iteration */ herr_t ret_value = SUCCEED; /* Return value */ FUNC_ENTER_NOAPI(FAIL) #ifdef H5MF_ALLOC_DEBUG HDfprintf(stderr, "%s: Entering\n", FUNC); #endif /* H5MF_ALLOC_DEBUG */ /* check args */ HDassert(f); HDassert(f->shared); HDassert(f->shared->lf); HDassert(f->shared->sblock); /* Free the space in aggregators */ /* (for space not at EOF, it may be put into free space managers) */ if(H5MF_free_aggrs(f, dxpl_id) < 0) HGOTO_ERROR(H5E_FILE, H5E_CANTFREE, FAIL, "can't free aggregators") /* Making free-space managers persistent for superblock version >= 2 */ if(f->shared->sblock->super_vers >= HDF5_SUPERBLOCK_VERSION_2 && f->shared->fs_strategy == H5F_FILE_SPACE_ALL_PERSIST) { H5O_fsinfo_t fsinfo; /* Free space manager info message */ hbool_t update = FALSE; /* To update info for the message */ /* Check to remove free-space manager info message from superblock extension */ if(H5F_addr_defined(f->shared->sblock->ext_addr)) if(H5F_super_ext_remove_msg(f, dxpl_id, H5O_FSINFO_ID) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTRELEASE, FAIL, "error in removing message from superblock extension") /* Free free-space manager header and/or section info header */ for(type = H5FD_MEM_SUPER; type < H5FD_MEM_NTYPES; H5_INC_ENUM(H5FD_mem_t, type)) { H5FS_stat_t fs_stat; /* Information for free-space manager */ /* Check for free space manager of this type */ if(f->shared->fs_man[type]) { /* Switch to "about to be deleted" state */ f->shared->fs_state[type] = H5F_FS_STATE_DELETING; /* Query the free space manager's information */ if(H5FS_stat_info(f, f->shared->fs_man[type], &fs_stat) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTGET, FAIL, "can't get free-space info") /* Check if the free space manager has space in the file */ if(H5F_addr_defined(fs_stat.addr) || H5F_addr_defined(fs_stat.sect_addr)) { /* Delete the free space manager in the file */ /* (will re-allocate later) */ if(H5FS_free(f, f->shared->fs_man[type], dxpl_id) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTRELEASE, FAIL, "can't release free-space headers") f->shared->fs_addr[type] = HADDR_UNDEF; } /* end if */ } /* end iif */ fsinfo.fs_addr[type-1] = HADDR_UNDEF; } /* end for */ fsinfo.strategy = f->shared->fs_strategy; fsinfo.threshold = f->shared->fs_threshold; /* Write free-space manager info message to superblock extension object header */ /* Create the superblock extension object header in advance if needed */ if(H5F_super_ext_write_msg(f, dxpl_id, &fsinfo, H5O_FSINFO_ID, TRUE) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_WRITEERROR, FAIL, "error in writing message to superblock extension") /* Re-allocate free-space manager header and/or section info header */ for(type = H5FD_MEM_SUPER; type < H5FD_MEM_NTYPES; H5_INC_ENUM(H5FD_mem_t, type)) { H5FS_stat_t fs_stat; /* Information for free-space manager */ /* Check for active free space manager of this type */ if(f->shared->fs_man[type]) { /* Re-query free space manager info for this type */ if(H5FS_stat_info(f, f->shared->fs_man[type], &fs_stat) < 0) HGOTO_ERROR(H5E_FSPACE, H5E_CANTRELEASE, FAIL, "can't get free-space info") /* Are there sections to persist? */ if(fs_stat.serial_sect_count) { /* Allocate space for free-space manager header */ if(H5FS_alloc_hdr(f, f->shared->fs_man[type], &f->shared->fs_addr[type], dxpl_id) < 0) HGOTO_ERROR(H5E_FSPACE, H5E_NOSPACE, FAIL, "can't allocated free-space header") /* Allocate space for free-space maanger section info header */ if(H5FS_alloc_sect(f, f->shared->fs_man[type], dxpl_id) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_NOSPACE, FAIL, "can't allocate free-space section info") HDassert(f->shared->fs_addr[type]); fsinfo.fs_addr[type-1] = f->shared->fs_addr[type]; update = TRUE; } /* end if */ } else if(H5F_addr_defined(f->shared->fs_addr[type])) { fsinfo.fs_addr[type-1] = f->shared->fs_addr[type]; update = TRUE; } /* end else-if */ } /* end for */ /* Update the free space manager info message in superblock extension object header */ if(update) if(H5F_super_ext_write_msg(f, dxpl_id, &fsinfo, H5O_FSINFO_ID, FALSE) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_WRITEERROR, FAIL, "error in writing message to superblock extension") /* Final close of free-space managers */ for(type = H5FD_MEM_DEFAULT; type < H5FD_MEM_NTYPES; H5_INC_ENUM(H5FD_mem_t, type)) { if(f->shared->fs_man[type]) { if(H5FS_close(f, dxpl_id, f->shared->fs_man[type]) < 0) HGOTO_ERROR(H5E_FSPACE, H5E_CANTRELEASE, FAIL, "can't close free space manager") f->shared->fs_man[type] = NULL; f->shared->fs_state[type] = H5F_FS_STATE_CLOSED; } /* end if */ f->shared->fs_addr[type] = HADDR_UNDEF; } /* end for */ } /* end if */ else { /* super_vers can be 0, 1, 2 */ /* Iterate over all the free space types that have managers and get each free list's space */ for(type = H5FD_MEM_DEFAULT; type < H5FD_MEM_NTYPES; H5_INC_ENUM(H5FD_mem_t, type)) { #ifdef H5MF_ALLOC_DEBUG_MORE HDfprintf(stderr, "%s: Check 1.0 - f->shared->fs_man[%u] = %p, f->shared->fs_addr[%u] = %a\n", FUNC, (unsigned)type, f->shared->fs_man[type], (unsigned)type, f->shared->fs_addr[type]); #endif /* H5MF_ALLOC_DEBUG_MORE */ /* If the free space manager for this type is open, close it */ if(f->shared->fs_man[type]) { #ifdef H5MF_ALLOC_DEBUG_MORE HDfprintf(stderr, "%s: Before closing free space manager\n", FUNC); #endif /* H5MF_ALLOC_DEBUG_MORE */ if(H5FS_close(f, dxpl_id, f->shared->fs_man[type]) < 0) HGOTO_ERROR(H5E_FSPACE, H5E_CANTRELEASE, FAIL, "can't release free space info") f->shared->fs_man[type] = NULL; f->shared->fs_state[type] = H5F_FS_STATE_CLOSED; } /* end if */ #ifdef H5MF_ALLOC_DEBUG_MORE HDfprintf(stderr, "%s: Check 2.0 - f->shared->fs_man[%u] = %p, f->shared->fs_addr[%u] = %a\n", FUNC, (unsigned)type, f->shared->fs_man[type], (unsigned)type, f->shared->fs_addr[type]); #endif /* H5MF_ALLOC_DEBUG_MORE */ /* If there is free space manager info for this type, delete it */ if(H5F_addr_defined(f->shared->fs_addr[type])) { haddr_t tmp_fs_addr; /* Temporary holder for free space manager address */ /* Put address into temporary variable and reset it */ /* (Avoids loopback in file space freeing routine) */ tmp_fs_addr = f->shared->fs_addr[type]; f->shared->fs_addr[type] = HADDR_UNDEF; /* Shift to "deleting" state, to make certain we don't track any * file space freed as a result of deleting the free space manager. */ f->shared->fs_state[type] = H5F_FS_STATE_DELETING; #ifdef H5MF_ALLOC_DEBUG_MORE HDfprintf(stderr, "%s: Before deleting free space manager\n", FUNC); #endif /* H5MF_ALLOC_DEBUG_MORE */ /* Delete free space manager for this type */ if(H5FS_delete(f, dxpl_id, tmp_fs_addr) < 0) HGOTO_ERROR(H5E_FSPACE, H5E_CANTFREE, FAIL, "can't delete free space manager") /* Shift [back] to closed state */ HDassert(f->shared->fs_state[type] == H5F_FS_STATE_DELETING); f->shared->fs_state[type] = H5F_FS_STATE_CLOSED; /* Sanity check that the free space manager for this type wasn't started up again */ HDassert(!H5F_addr_defined(f->shared->fs_addr[type])); } /* end if */ } /* end for */ } /* end else */ /* Free the space in aggregators (again) */ /* (in case any free space information re-started them) */ if(H5MF_free_aggrs(f, dxpl_id) < 0) HGOTO_ERROR(H5E_FILE, H5E_CANTFREE, FAIL, "can't free aggregators") done: #ifdef H5MF_ALLOC_DEBUG HDfprintf(stderr, "%s: Leaving\n", FUNC); #endif /* H5MF_ALLOC_DEBUG */ FUNC_LEAVE_NOAPI(ret_value) } /* end H5MF_close() */ /*------------------------------------------------------------------------- * Function: H5MF_sects_cb() * * Purpose: Iterator callback for each free-space section * Retrieve address and size into user data * * Return: Always succeed * * Programmer: Vailin Choi * July 1st, 2009 * *------------------------------------------------------------------------- */ static herr_t H5MF_sects_cb(H5FS_section_info_t *_sect, void *_udata) { H5MF_free_section_t *sect = (H5MF_free_section_t *)_sect; H5MF_sect_iter_ud_t *udata = (H5MF_sect_iter_ud_t *)_udata; FUNC_ENTER_NOAPI_NOINIT_NOERR if(udata->sect_idx < udata->sect_count) { udata->sects[udata->sect_idx].addr = sect->sect_info.addr; udata->sects[udata->sect_idx].size = sect->sect_info.size; udata->sect_idx++; } /* end if */ FUNC_LEAVE_NOAPI(SUCCEED) } /* H5MF_sects_cb() */ /*------------------------------------------------------------------------- * Function: H5MF_get_free_sections() * * Purpose: To iterate over one or all free-space managers for: * # of sections * section info as defined in H5F_sect_info_t * * Return: SUCCEED/FAIL * * Programmer: Vailin Choi * July 1st, 2009 * *------------------------------------------------------------------------- */ ssize_t H5MF_get_free_sections(H5F_t *f, hid_t dxpl_id, H5FD_mem_t type, size_t nsects, H5F_sect_info_t *sect_info) { size_t total_sects = 0; /* total number of sections */ H5MF_sect_iter_ud_t sect_udata; /* User data for callback */ H5FD_mem_t start_type, end_type; /* Memory types to iterate over */ H5FD_mem_t ty; /* Memory type for iteration */ ssize_t ret_value; /* Return value */ FUNC_ENTER_NOAPI(FAIL) /* check args */ HDassert(f); HDassert(f->shared); HDassert(f->shared->lf); /* Determine start/end points for loop */ if(type == H5FD_MEM_DEFAULT) { start_type = H5FD_MEM_SUPER; end_type = H5FD_MEM_NTYPES; } /* end if */ else { start_type = end_type = type; H5_INC_ENUM(H5FD_mem_t, end_type); } /* end else */ /* Set up user data for section iteration */ sect_udata.sects = sect_info; sect_udata.sect_count = nsects; sect_udata.sect_idx = 0; /* Iterate over memory types, retrieving the number of sections of each type */ for(ty = start_type; ty < end_type; H5_INC_ENUM(H5FD_mem_t, ty)) { hbool_t fs_started = FALSE; /* Open free space manager of this type, if it isn't already */ if(!f->shared->fs_man[ty] && H5F_addr_defined(f->shared->fs_addr[ty])) { if(H5MF_alloc_open(f, dxpl_id, ty) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTOPENOBJ, FAIL, "can't initialize file free space") HDassert(f->shared->fs_man[ty]); fs_started = TRUE; } /* end if */ /* Check if f there's free space sections of this type */ if(f->shared->fs_man[ty]) { hsize_t hnums = 0; /* Total # of sections */ size_t nums; /* Total # of sections, cast to a size_t */ /* Query how many sections of this type */ if(H5FS_sect_stats(f->shared->fs_man[ty], NULL, &hnums) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTGET, FAIL, "can't query free space stats") H5_ASSIGN_OVERFLOW(nums, hnums, hsize_t, size_t); /* Increment total # of sections */ total_sects += nums; /* Check if we should retrieve the section info */ if(sect_info && nums > 0) { /* Iterate over all the free space sections of this type, adding them to the user's section info */ if(H5FS_sect_iterate(f, dxpl_id, f->shared->fs_man[ty], H5MF_sects_cb, §_udata) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_BADITER, FAIL, "can't iterate over sections") } /* end if */ } /* end if */ /* Close the free space manager of this type, if we started it here */ if(fs_started) if(H5MF_alloc_close(f, dxpl_id, ty) < 0) HGOTO_ERROR(H5E_RESOURCE, H5E_CANTCLOSEOBJ, FAIL, "can't close file free space") } /* end for */ /* Set return value */ ret_value = (ssize_t)total_sects; done: FUNC_LEAVE_NOAPI(ret_value) } /* H5MF_get_free_sections() */ 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 
/* 
 * tclProc.c --
 *
 *	This file contains routines that implement Tcl procedures,
 *	including the "proc" and "uplevel" commands.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclProc.c,v 1.44.2.4 2006/05/13 17:17:11 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for static functions in this file
 */

static void	ProcBodyDup _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr));
static void	ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr));
static int	ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp,
		Tcl_Obj *objPtr));
static void	ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr));
static int	ProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp,
		    Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr,
		    CONST char *description, CONST char *procName,
		    Proc **procPtrPtr));
static  int	ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp,
		    char *procName, int nameLen, int returnCode));
static int	TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp,
		    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));

/*
 * The ProcBodyObjType type
 */

Tcl_ObjType tclProcBodyType = {
    "procbody",			/* name for this type */
    ProcBodyFree,		/* FreeInternalRep procedure */
    ProcBodyDup,		/* DupInternalRep procedure */
    ProcBodyUpdateString,	/* UpdateString procedure */
    ProcBodySetFromAny		/* SetFromAny procedure */
};

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ProcObjCmd --
 *
 *	This object-based procedure is invoked to process the "proc" Tcl 
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	A new procedure gets created.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_ProcObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    register Interp *iPtr = (Interp *) interp;
    Proc *procPtr;
    char *fullName;
    CONST char *procName, *procArgs, *procBody;
    Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
    Tcl_Command cmd;
    Tcl_DString ds;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "name args body");
	return TCL_ERROR;
    }

    /*
     * Determine the namespace where the procedure should reside. Unless
     * the command name includes namespace qualifiers, this will be the
     * current namespace.
     */
    
    fullName = TclGetString(objv[1]);
    TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL,
	    0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName);

    if (nsPtr == NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"can't create procedure \"", fullName,
		"\": unknown namespace", (char *) NULL);
        return TCL_ERROR;
    }
    if (procName == NULL) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"can't create procedure \"", fullName,
		"\": bad procedure name", (char *) NULL);
        return TCL_ERROR;
    }
    if ((nsPtr != iPtr->globalNsPtr)
	    && (procName != NULL) && (procName[0] == ':')) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"can't create procedure \"", procName,
		"\" in non-global namespace with name starting with \":\"",
	        (char *) NULL);
        return TCL_ERROR;
    }

    /*
     *  Create the data structure to represent the procedure.
     */
    if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
        &procPtr) != TCL_OK) {
        return TCL_ERROR;
    }

    /*
     * Now create a command for the procedure. This will initially be in
     * the current namespace unless the procedure's name included namespace
     * qualifiers. To create the new command in the right namespace, we
     * generate a fully qualified name for it.
     */

    Tcl_DStringInit(&ds);
    if (nsPtr != iPtr->globalNsPtr) {
	Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
	Tcl_DStringAppend(&ds, "::", 2);
    }
    Tcl_DStringAppend(&ds, procName, -1);
    
    Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), TclProcInterpProc,
	    (ClientData) procPtr, TclProcDeleteProc);
    cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
	    TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);

    Tcl_DStringFree(&ds);
    /*
     * Now initialize the new procedure's cmdPtr field. This will be used
     * later when the procedure is called to determine what namespace the
     * procedure will run in. This will be different than the current
     * namespace if the proc was renamed into a different namespace.
     */
    
    procPtr->cmdPtr = (Command *) cmd;


    /*
     * Optimize for noop procs: if the body is not precompiled (like a TclPro
     * procbody), and the argument list is just "args" and the body is empty,
     * define a compileProc to compile a noop.
     *
     * Notes: 
     *   - cannot be done for any argument list without having different
     *     compiled/not-compiled behaviour in the "wrong argument #" case, 
     *     or making this code much more complicated. In any case, it doesn't 
     *     seem to make a lot of sense to verify the number of arguments we 
     *     are about to ignore ...
     *   - could be enhanced to handle also non-empty bodies that contain 
     *     only comments; however, parsing the body will slow down the 
     *     compilation of all procs whose argument list is just _args_ */

    if (objv[3]->typePtr == &tclProcBodyType) {
	goto done;
    }

    procArgs = Tcl_GetString(objv[2]);
    
    while (*procArgs == ' ') {
	procArgs++;
    }
    
    if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
	procArgs +=4;
	while(*procArgs != '\0') {
	    if (*procArgs != ' ') {
		goto done;
	    }
	    procArgs++;
	}	
	
	/* 
	 * The argument list is just "args"; check the body
	 */
	
	procBody = Tcl_GetString(objv[3]);
	while (*procBody != '\0') {
	    if (!isspace(UCHAR(*procBody))) {
		goto done;
	    }
	    procBody++;
	}	
	
	/* 
	 * The body is just spaces: link the compileProc
	 */
	
	((Command *) cmd)->compileProc = TclCompileNoOp;
    }

 done:
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCreateProc --
 *
 *	Creates the data associated with a Tcl procedure definition.
 *	This procedure knows how to handle two types of body objects:
 *	strings and procbody. Strings are the traditional (and common) value
 *	for bodies, procbody are values created by extensions that have
 *	loaded a previously compiled script.
 *
 * Results:
 *	Returns TCL_OK on success, along with a pointer to a Tcl
 *	procedure definition in procPtrPtr.  This definition should
 *	be freed by calling TclCleanupProc() when it is no longer
 *	needed.  Returns TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	If anything goes wrong, this procedure returns an error
 *	message in the interpreter.
 *
 *----------------------------------------------------------------------
 */
int
TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
    Tcl_Interp *interp;         /* interpreter containing proc */
    Namespace *nsPtr;           /* namespace containing this proc */
    CONST char *procName;       /* unqualified name of this proc */
    Tcl_Obj *argsPtr;           /* description of arguments */
    Tcl_Obj *bodyPtr;           /* command body */
    Proc **procPtrPtr;          /* returns:  pointer to proc data */
{
    Interp *iPtr = (Interp*)interp;
    CONST char **argArray = NULL;

    register Proc *procPtr;
    int i, length, result, numArgs;
    CONST char *args, *bytes, *p;
    register CompiledLocal *localPtr = NULL;
    Tcl_Obj *defPtr;
    int precompiled = 0;
    
    if (bodyPtr->typePtr == &tclProcBodyType) {
        /*
         * Because the body is a TclProProcBody, the actual body is already
         * compiled, and it is not shared with anyone else, so it's OK not to
         * unshare it (as a matter of fact, it is bad to unshare it, because
         * there may be no source code).
         *
         * We don't create and initialize a Proc structure for the procedure;
         * rather, we use what is in the body object. Note that
         * we initialize its cmdPtr field below after we've created the command
         * for the procedure. We increment the ref count of the Proc struct
         * since the command (soon to be created) will be holding a reference
         * to it.
         */
    
        procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr;
        procPtr->iPtr = iPtr;
        procPtr->refCount++;
        precompiled = 1;
    } else {
        /*
         * If the procedure's body object is shared because its string value is
         * identical to, e.g., the body of another procedure, we must create a
         * private copy for this procedure to use. Such sharing of procedure
         * bodies is rare but can cause problems. A procedure body is compiled
         * in a context that includes the number of compiler-allocated "slots"
         * for local variables. Each formal parameter is given a local variable
         * slot (the "procPtr->numCompiledLocals = numArgs" assignment
         * below). This means that the same code can not be shared by two
         * procedures that have a different number of arguments, even if their
         * bodies are identical. Note that we don't use Tcl_DuplicateObj since
         * we would not want any bytecode internal representation.
         */

        if (Tcl_IsShared(bodyPtr)) {
            bytes = Tcl_GetStringFromObj(bodyPtr, &length);
            bodyPtr = Tcl_NewStringObj(bytes, length);
        }

        /*
         * Create and initialize a Proc structure for the procedure. Note that
         * we initialize its cmdPtr field below after we've created the command
         * for the procedure. We increment the ref count of the procedure's
         * body object since there will be a reference to it in the Proc
         * structure.
         */
    
        Tcl_IncrRefCount(bodyPtr);

        procPtr = (Proc *) ckalloc(sizeof(Proc));
        procPtr->iPtr = iPtr;
        procPtr->refCount = 1;
        procPtr->bodyPtr = bodyPtr;
        procPtr->numArgs  = 0;	/* actual argument count is set below. */
        procPtr->numCompiledLocals = 0;
        procPtr->firstLocalPtr = NULL;
        procPtr->lastLocalPtr = NULL;
    }
    
    /*
     * Break up the argument list into argument specifiers, then process
     * each argument specifier.
     * If the body is precompiled, processing is limited to checking that
     * the the parsed argument is consistent with the one stored in the
     * Proc.
     * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS.
     */

    args = Tcl_GetStringFromObj(argsPtr, &length);
    result = Tcl_SplitList(interp, args, &numArgs, &argArray);
    if (result != TCL_OK) {
        goto procError;
    }

    if (precompiled) {
        if (numArgs > procPtr->numArgs) {
            char buf[64 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE];
            sprintf(buf, "\": arg list contains %d entries, precompiled header expects %d",
                    numArgs, procPtr->numArgs);
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                    "procedure \"", procName,
                    buf, (char *) NULL);
            goto procError;
        }
        localPtr = procPtr->firstLocalPtr;
    } else {
        procPtr->numArgs = numArgs;
        procPtr->numCompiledLocals = numArgs;
    }
    for (i = 0;  i < numArgs;  i++) {
        int fieldCount, nameLength, valueLength;
        CONST char **fieldValues;

        /*
         * Now divide the specifier up into name and default.
         */

        result = Tcl_SplitList(interp, argArray[i], &fieldCount,
                &fieldValues);
        if (result != TCL_OK) {
            goto procError;
        }
        if (fieldCount > 2) {
            ckfree((char *) fieldValues);
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                    "too many fields in argument specifier \"",
                    argArray[i], "\"", (char *) NULL);
            goto procError;
        }
        if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
            ckfree((char *) fieldValues);
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                    "procedure \"", procName,
                    "\" has argument with no name", (char *) NULL);
            goto procError;
        }
	
        nameLength = strlen(fieldValues[0]);
        if (fieldCount == 2) {
            valueLength = strlen(fieldValues[1]);
        } else {
            valueLength = 0;
        }

        /*
         * Check that the formal parameter name is a scalar.
         */

        p = fieldValues[0];
        while (*p != '\0') {
            if (*p == '(') {
                CONST char *q = p;
                do {
		    q++;
		} while (*q != '\0');
		q--;
		if (*q == ')') { /* we have an array element */
		    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		            "procedure \"", procName,
		            "\" has formal parameter \"", fieldValues[0],
			    "\" that is an array element",
			    (char *) NULL);
		    ckfree((char *) fieldValues);
		    goto procError;
		}
	    } else if ((*p == ':') && (*(p+1) == ':')) {
		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		        "procedure \"", procName,
		        "\" has formal parameter \"", fieldValues[0],
			"\" that is not a simple name",
			(char *) NULL);
		ckfree((char *) fieldValues);
		goto procError;
	    }
	    p++;
	}

	if (precompiled) {
	    /*
	     * Compare the parsed argument with the stored one.
	     * For the flags, we and out VAR_UNDEFINED to support bridging
	     * precompiled <= 8.3 code in 8.4 where this is now used as an
	     * optimization indicator.	Yes, this is a hack. -- hobbs
	     */

	    if ((localPtr->nameLength != nameLength)
		    || (strcmp(localPtr->name, fieldValues[0]))
		    || (localPtr->frameIndex != i)
		    || ((localPtr->flags & ~VAR_UNDEFINED)
			    != (VAR_SCALAR | VAR_ARGUMENT))
		    || ((localPtr->defValuePtr == NULL)
			    && (fieldCount == 2))
		    || ((localPtr->defValuePtr != NULL)
			    && (fieldCount != 2))) {
		char buf[80 + TCL_INTEGER_SPACE];
		sprintf(buf, "\": formal parameter %d is inconsistent with precompiled body",
			i);
		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
			"procedure \"", procName,
			buf, (char *) NULL);
		ckfree((char *) fieldValues);
		goto procError;
	    }

            /*
             * compare the default value if any
             */

            if (localPtr->defValuePtr != NULL) {
                int tmpLength;
                char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr,
                        &tmpLength);
                if ((valueLength != tmpLength)
                        || (strncmp(fieldValues[1], tmpPtr,
                                (size_t) tmpLength))) {
                    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                            "procedure \"", procName,
                            "\": formal parameter \"",
                            fieldValues[0],
                            "\" has default value inconsistent with precompiled body",
                            (char *) NULL);
                    ckfree((char *) fieldValues);
                    goto procError;
                }
            }

            localPtr = localPtr->nextPtr;
        } else {
            /*
             * Allocate an entry in the runtime procedure frame's array of
             * local variables for the argument. 
             */

            localPtr = (CompiledLocal *) ckalloc((unsigned) 
                    (sizeof(CompiledLocal) - sizeof(localPtr->name)
                            + nameLength+1));
            if (procPtr->firstLocalPtr == NULL) {
                procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
            } else {
                procPtr->lastLocalPtr->nextPtr = localPtr;
                procPtr->lastLocalPtr = localPtr;
            }
            localPtr->nextPtr = NULL;
            localPtr->nameLength = nameLength;
            localPtr->frameIndex = i;
            localPtr->flags = VAR_SCALAR | VAR_ARGUMENT;
            localPtr->resolveInfo = NULL;
	
            if (fieldCount == 2) {
                localPtr->defValuePtr =
		    Tcl_NewStringObj(fieldValues[1], valueLength);
                Tcl_IncrRefCount(localPtr->defValuePtr);
            } else {
                localPtr->defValuePtr = NULL;
            }
            strcpy(localPtr->name, fieldValues[0]);
	}

        ckfree((char *) fieldValues);
    }

    /*
     * Now initialize the new procedure's cmdPtr field. This will be used
     * later when the procedure is called to determine what namespace the
     * procedure will run in. This will be different than the current
     * namespace if the proc was renamed into a different namespace.
     */
    
    *procPtrPtr = procPtr;
    ckfree((char *) argArray);
    return TCL_OK;

procError:
    if (precompiled) {
        procPtr->refCount--;
    } else {
        Tcl_DecrRefCount(bodyPtr);
        while (procPtr->firstLocalPtr != NULL) {
            localPtr = procPtr->firstLocalPtr;
            procPtr->firstLocalPtr = localPtr->nextPtr;
	
            defPtr = localPtr->defValuePtr;
            if (defPtr != NULL) {
                Tcl_DecrRefCount(defPtr);
            }
	
            ckfree((char *) localPtr);
        }
        ckfree((char *) procPtr);
    }
    if (argArray != NULL) {
	ckfree((char *) argArray);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetFrame --
 *
 *	Given a description of a procedure frame, such as the first
 *	argument to an "uplevel" or "upvar" command, locate the
 *	call frame for the appropriate level of procedure.
 *
 * Results:
 *	The return value is -1 if an error occurred in finding the frame
 *	(in this case an error message is left in the interp's result).
 *	1 is returned if string was either a number or a number preceded
 *	by "#" and it specified a valid frame.  0 is returned if string
 *	isn't one of the two things above (in this case, the lookup
 *	acts as if string were "1").  The variable pointed to by
 *	framePtrPtr is filled in with the address of the desired frame
 *	(unless an error occurs, in which case it isn't modified).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGetFrame(interp, string, framePtrPtr)
    Tcl_Interp *interp;		/* Interpreter in which to find frame. */
    CONST char *string;		/* String describing frame. */
    CallFrame **framePtrPtr;	/* Store pointer to frame here (or NULL
				 * if global frame indicated). */
{
    register Interp *iPtr = (Interp *) interp;
    int curLevel, level, result;
    CallFrame *framePtr;

    /*
     * Parse string to figure out which level number to go to.
     */

    result = 1;
    curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
    if (*string == '#') {
	if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
	    return -1;
	}
	if (level < 0) {
	    levelError:
	    Tcl_AppendResult(interp, "bad level \"", string, "\"",
		    (char *) NULL);
	    return -1;
	}
    } else if (isdigit(UCHAR(*string))) { /* INTL: digit */
	if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
	    return -1;
	}
	level = curLevel - level;
    } else {
	level = curLevel - 1;
	result = 0;
    }

    /*
     * Figure out which frame to use, and modify the interpreter so
     * its variables come from that frame.
     */

    if (level == 0) {
	framePtr = NULL;
    } else {
	for (framePtr = iPtr->varFramePtr; framePtr != NULL;
		framePtr = framePtr->callerVarPtr) {
	    if (framePtr->level == level) {
		break;
	    }
	}
	if (framePtr == NULL) {
	    goto levelError;
	}
    }
    *framePtrPtr = framePtr;
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UplevelObjCmd --
 *
 *	This object procedure is invoked to process the "uplevel" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_UplevelObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    register Interp *iPtr = (Interp *) interp;
    char *optLevel;
    int result;
    CallFrame *savedVarFramePtr, *framePtr;

    if (objc < 2) {
	uplevelSyntax:
	Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
	return TCL_ERROR;
    }

    /*
     * Find the level to use for executing the command.
     */

    optLevel = TclGetString(objv[1]);
    result = TclGetFrame(interp, optLevel, &framePtr);
    if (result == -1) {
	return TCL_ERROR;
    }
    objc -= (result+1);
    if (objc == 0) {
	goto uplevelSyntax;
    }
    objv += (result+1);

    /*
     * Modify the interpreter state to execute in the given frame.
     */

    savedVarFramePtr = iPtr->varFramePtr;
    iPtr->varFramePtr = framePtr;

    /*
     * Execute the residual arguments as a command.
     */

    if (objc == 1) {
	result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
    } else {
	/*
	 * More than one argument: concatenate them together with spaces
	 * between, then evaluate the result.  Tcl_EvalObjEx will delete
	 * the object when it decrements its refcount after eval'ing it.
	 */
	Tcl_Obj *objPtr;

	objPtr = Tcl_ConcatObj(objc, objv);
	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
    }
    if (result == TCL_ERROR) {
	char msg[32 + TCL_INTEGER_SPACE];
	sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
	Tcl_AddObjErrorInfo(interp, msg, -1);
    }

    /*
     * Restore the variable frame, and return.
     */

    iPtr->varFramePtr = savedVarFramePtr;
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFindProc --
 *
 *	Given the name of a procedure, return a pointer to the
 *	record describing the procedure. The procedure will be
 *	looked up using the usual rules: first in the current
 *	namespace and then in the global namespace.
 *
 * Results:
 *	NULL is returned if the name doesn't correspond to any
 *	procedure. Otherwise, the return value is a pointer to
 *	the procedure's record. If the name is found but refers
 *	to an imported command that points to a "real" procedure
 *	defined in another namespace, a pointer to that "real"
 *	procedure's structure is returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Proc *
TclFindProc(iPtr, procName)
    Interp *iPtr;		/* Interpreter in which to look. */
    CONST char *procName;		/* Name of desired procedure. */
{
    Tcl_Command cmd;
    Tcl_Command origCmd;
    Command *cmdPtr;
    
    cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName,
            (Tcl_Namespace *) NULL, /*flags*/ 0);
    if (cmd == (Tcl_Command) NULL) {
        return NULL;
    }
    cmdPtr = (Command *) cmd;

    origCmd = TclGetOriginalCommand(cmd);
    if (origCmd != NULL) {
	cmdPtr = (Command *) origCmd;
    }
    if (cmdPtr->proc != TclProcInterpProc) {
	return NULL;
    }
    return (Proc *) cmdPtr->clientData;
}

/*
 *----------------------------------------------------------------------
 *
 * TclIsProc --
 *
 *	Tells whether a command is a Tcl procedure or not.
 *
 * Results:
 *	If the given command is actually a Tcl procedure, the
 *	return value is the address of the record describing
 *	the procedure.  Otherwise the return value is 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Proc *
TclIsProc(cmdPtr)
    Command *cmdPtr;		/* Command to test. */
{
    Tcl_Command origCmd;

    origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
    if (origCmd != NULL) {
	cmdPtr = (Command *) origCmd;
    }
    if (cmdPtr->proc == TclProcInterpProc) {
	return (Proc *) cmdPtr->clientData;
    }
    return (Proc *) 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclProcInterpProc --
 *
 *	When a Tcl procedure gets invoked with an argc/argv array of
 *	strings, this routine gets invoked to interpret the procedure.
 *
 * Results:
 *	A standard Tcl result value, usually TCL_OK.
 *
 * Side effects:
 *	Depends on the commands in the procedure.
 *
 *----------------------------------------------------------------------
 */

int
TclProcInterpProc(clientData, interp, argc, argv)
    ClientData clientData;	/* Record describing procedure to be
				 * interpreted. */
    Tcl_Interp *interp;		/* Interpreter in which procedure was
				 * invoked. */
    int argc;			/* Count of number of arguments to this
				 * procedure. */
    register CONST char **argv;	/* Argument values. */
{
    register Tcl_Obj *objPtr;
    register int i;
    int result;

    /*
     * This procedure generates an objv array for object arguments that hold
     * the argv strings. It starts out with stack-allocated space but uses
     * dynamically-allocated storage if needed.
     */

#define NUM_ARGS 20
    Tcl_Obj *(objStorage[NUM_ARGS]);
    register Tcl_Obj **objv = objStorage;

    /*
     * Create the object argument array "objv". Make sure objv is large
     * enough to hold the objc arguments plus 1 extra for the zero
     * end-of-objv word.
     */

    if ((argc + 1) > NUM_ARGS) {
	objv = (Tcl_Obj **)
	    ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
    }

    for (i = 0;  i < argc;  i++) {
	objv[i] = Tcl_NewStringObj(argv[i], -1);
	Tcl_IncrRefCount(objv[i]);
    }
    objv[argc] = 0;

    /*
     * Use TclObjInterpProc to actually interpret the procedure.
     */

    result = TclObjInterpProc(clientData, interp, argc, objv);

    /*
     * Move the interpreter's object result to the string result, 
     * then reset the object result.
     */
    
    Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
	    TCL_VOLATILE);

    /*
     * Decrement the ref counts on the objv elements since we are done
     * with them.
     */

    for (i = 0;  i < argc;  i++) {
	objPtr = objv[i];
	TclDecrRefCount(objPtr);
    }
    
    /*
     * Free the objv array if malloc'ed storage was used.
     */

    if (objv != objStorage) {
	ckfree((char *) objv);
    }
    return result;
#undef NUM_ARGS
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjInterpProc --
 *
 *	When a Tcl procedure gets invoked during bytecode evaluation, this 
 *	object-based routine gets invoked to interpret the procedure.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	Depends on the commands in the procedure.
 *
 *----------------------------------------------------------------------
 */

int
TclObjInterpProc(clientData, interp, objc, objv)
    ClientData clientData; 	 /* Record describing procedure to be
				  * interpreted. */
    register Tcl_Interp *interp; /* Interpreter in which procedure was
				  * invoked. */
    int objc;			 /* Count of number of arguments to this
				  * procedure. */
    Tcl_Obj *CONST objv[];	 /* Argument value objects. */
{
    Interp *iPtr = (Interp *) interp;
    Proc *procPtr = (Proc *) clientData;
    Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
    CallFrame frame;
    register CallFrame *framePtr = &frame;
    register Var *varPtr;
    register CompiledLocal *localPtr;
    char *procName;
    int nameLen, localCt, numArgs, argCt, i, result;

    /*
     * This procedure generates an array "compiledLocals" that holds the
     * storage for local variables. It starts out with stack-allocated space
     * but uses dynamically-allocated storage if needed.
     */

#define NUM_LOCALS 20
    Var localStorage[NUM_LOCALS];
    Var *compiledLocals = localStorage;

    /*
     * Get the procedure's name.
     */
    
    procName = Tcl_GetStringFromObj(objv[0], &nameLen);

    /*
     * If necessary, compile the procedure's body. The compiler will
     * allocate frame slots for the procedure's non-argument local
     * variables.  Note that compiling the body might increase
     * procPtr->numCompiledLocals if new local variables are found
     * while compiling.
     */

    result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
	    "body of proc", procName, &procPtr);
    
    if (result != TCL_OK) {
        return result;
    }

    /*
     * Create the "compiledLocals" array. Make sure it is large enough to
     * hold all the procedure's compiled local variables, including its
     * formal parameters.
     */

    localCt = procPtr->numCompiledLocals;
    if (localCt > NUM_LOCALS) {
	compiledLocals = (Var *) ckalloc((unsigned) localCt * sizeof(Var));
    }
    
    /*
     * Set up and push a new call frame for the new procedure invocation.
     * This call frame will execute in the proc's namespace, which might
     * be different than the current namespace. The proc's namespace is
     * that of its command, which can change if the command is renamed
     * from one namespace to another.
     */

    result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
            (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1);

    if (result != TCL_OK) {
        return result;
    }

    framePtr->objc = objc;
    framePtr->objv = objv;  /* ref counts for args are incremented below */

    /*
     * Initialize and resolve compiled variable references.
     */

    framePtr->procPtr = procPtr;
    framePtr->numCompiledLocals = localCt;
    framePtr->compiledLocals = compiledLocals;

    TclInitCompiledLocals(interp, framePtr, nsPtr);

    /*
     * Match and assign the call's actual parameters to the procedure's
     * formal arguments. The formal arguments are described by the first
     * numArgs entries in both the Proc structure's local variable list and
     * the call frame's local variable array.
     */

    numArgs = procPtr->numArgs;
    varPtr = framePtr->compiledLocals;
    localPtr = procPtr->firstLocalPtr;
    argCt = objc;
    for (i = 1, argCt -= 1;  i <= numArgs;  i++, argCt--) {
	if (!TclIsVarArgument(localPtr)) {
	    panic("TclObjInterpProc: local variable %s is not argument but should be",
		  localPtr->name);
	    return TCL_ERROR;
	}
	if (TclIsVarTemporary(localPtr)) {
	    panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i);
	    return TCL_ERROR;
	}

	/*
	 * Handle the special case of the last formal being "args".  When
	 * it occurs, assign it a list consisting of all the remaining
	 * actual arguments.
	 */

	if ((i == numArgs) && ((localPtr->name[0] == 'a')
	        && (strcmp(localPtr->name, "args") == 0))) {
	    Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i]));
	    varPtr->value.objPtr = listPtr;
	    Tcl_IncrRefCount(listPtr); /* local var is a reference */
	    TclClearVarUndefined(varPtr);
	    argCt = 0;
	    break;		/* done processing args */
	} else if (argCt > 0) {
	    Tcl_Obj *objPtr = objv[i];
	    varPtr->value.objPtr = objPtr;
	    TclClearVarUndefined(varPtr);
	    Tcl_IncrRefCount(objPtr);  /* since the local variable now has
					* another reference to object. */
	} else if (localPtr->defValuePtr != NULL) {
	    Tcl_Obj *objPtr = localPtr->defValuePtr;
	    varPtr->value.objPtr = objPtr;
	    TclClearVarUndefined(varPtr);
	    Tcl_IncrRefCount(objPtr);  /* since the local variable now has
					* another reference to object. */
	} else {
	    goto incorrectArgs;
	}
	varPtr++;
	localPtr = localPtr->nextPtr;
    }
    if (argCt > 0) {
	Tcl_Obj *objResult;
	int len, flags;

	incorrectArgs:
	/*
	 * Build up equivalent to Tcl_WrongNumArgs message for proc
	 */

	Tcl_ResetResult(interp);
	objResult = Tcl_GetObjResult(interp);
	Tcl_AppendToObj(objResult, "wrong # args: should be \"", -1);

	/*
	 * Quote the proc name if it contains spaces (Bug 942757).
	 */
	
	len = Tcl_ScanCountedElement(procName, nameLen, &flags);
	if (len != nameLen) {
	    char *procName1 = ckalloc((unsigned) len);
	    len = Tcl_ConvertCountedElement(procName, nameLen, procName1, flags);
	    Tcl_AppendToObj(objResult, procName1, len);
	    ckfree(procName1);
	} else {
	    Tcl_AppendToObj(objResult, procName, len);
	}

	localPtr = procPtr->firstLocalPtr;
	for (i = 1;  i <= numArgs;  i++) {
	    if (localPtr->defValuePtr != NULL) {
		Tcl_AppendStringsToObj(objResult,
			" ?", localPtr->name, "?", (char *) NULL);
	    } else {
		Tcl_AppendStringsToObj(objResult,
			" ", localPtr->name, (char *) NULL);
	    }
	    localPtr = localPtr->nextPtr;
	}
	Tcl_AppendStringsToObj(objResult, "\"", (char *) NULL);

	result = TCL_ERROR;
	goto procDone;
    }

    /*
     * Invoke the commands in the procedure's body.
     */

#ifdef TCL_COMPILE_DEBUG
    if (tclTraceExec >= 1) {
	fprintf(stdout, "Calling proc ");
	for (i = 0;  i < objc;  i++) {
	    TclPrintObject(stdout, objv[i], 15);
	    fprintf(stdout, " ");
	}
	fprintf(stdout, "\n");
	fflush(stdout);
    }
#endif /*TCL_COMPILE_DEBUG*/

    iPtr->returnCode = TCL_OK;
    procPtr->refCount++;
    result = TclCompEvalObj(interp, procPtr->bodyPtr);
    procPtr->refCount--;
    if (procPtr->refCount <= 0) {
	TclProcCleanupProc(procPtr);
    }

    if (result != TCL_OK) {
	result = ProcessProcResultCode(interp, procName, nameLen, result);
    }
    
    /*
     * Pop and free the call frame for this procedure invocation, then
     * free the compiledLocals array if malloc'ed storage was used.
     */
    
    procDone:
    Tcl_PopCallFrame(interp);
    if (compiledLocals != localStorage) {
	ckfree((char *) compiledLocals);
    }
    return result;
#undef NUM_LOCALS
}

/*
 *----------------------------------------------------------------------
 *
 * TclProcCompileProc --
 *
 *	Called just before a procedure is executed to compile the
 *	body to byte codes.  If the type of the body is not
 *	"byte code" or if the compile conditions have changed
 *	(namespace context, epoch counters, etc.) then the body
 *	is recompiled.  Otherwise, this procedure does nothing.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May change the internal representation of the body object
 *	to compiled code.
 *
 *----------------------------------------------------------------------
 */
 
int
TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
    Tcl_Interp *interp;		/* Interpreter containing procedure. */
    Proc *procPtr;		/* Data associated with procedure. */
    Tcl_Obj *bodyPtr;		/* Body of proc. (Usually procPtr->bodyPtr,
 				 * but could be any code fragment compiled
 				 * in the context of this procedure.) */
    Namespace *nsPtr;		/* Namespace containing procedure. */
    CONST char *description;	/* string describing this body of code. */
    CONST char *procName;	/* Name of this procedure. */
{
    return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr,
	    description, procName, NULL);
}

static int
ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description,
		procName, procPtrPtr)
    Tcl_Interp *interp;		/* Interpreter containing procedure. */
    Proc *procPtr;		/* Data associated with procedure. */
    Tcl_Obj *bodyPtr;		/* Body of proc. (Usually procPtr->bodyPtr,
 				 * but could be any code fragment compiled
 				 * in the context of this procedure.) */
    Namespace *nsPtr;		/* Namespace containing procedure. */
    CONST char *description;	/* string describing this body of code. */
    CONST char *procName;	/* Name of this procedure. */
    Proc **procPtrPtr;		/* points to storage where a replacement
				 * (Proc *) value may be written, when
				 * appropriate */
{
    Interp *iPtr = (Interp*)interp;
    int i, result;
    Tcl_CallFrame frame;
    Proc *saveProcPtr;
    ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;
    CompiledLocal *localPtr;
 
    /*
     * If necessary, compile the procedure's body. The compiler will
     * allocate frame slots for the procedure's non-argument local
     * variables. If the ByteCode already exists, make sure it hasn't been
     * invalidated by someone redefining a core command (this might make the
     * compiled code wrong). Also, if the code was compiled in/for a
     * different interpreter, we recompile it. Note that compiling the body
     * might increase procPtr->numCompiledLocals if new local variables are
     * found while compiling.
     *
     * Precompiled procedure bodies, however, are immutable and therefore
     * they are not recompiled, even if things have changed.
     */
 
    if (bodyPtr->typePtr == &tclByteCodeType) {
 	if (((Interp *) *codePtr->interpHandle != iPtr)
 	        || (codePtr->compileEpoch != iPtr->compileEpoch)
 	        || (codePtr->nsPtr != nsPtr)) {
            if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
                if ((Interp *) *codePtr->interpHandle != iPtr) {
                    Tcl_AppendResult(interp,
                            "a precompiled script jumped interps", NULL);
                    return TCL_ERROR;
                }
	        codePtr->compileEpoch = iPtr->compileEpoch;
                codePtr->nsPtr = nsPtr;
            } else {
                (*tclByteCodeType.freeIntRepProc)(bodyPtr);
                bodyPtr->typePtr = (Tcl_ObjType *) NULL;
            }
 	}
    }
    if (bodyPtr->typePtr != &tclByteCodeType) {
 	int numChars;
 	char *ellipsis;
 	
#ifdef TCL_COMPILE_DEBUG
 	if (tclTraceCompile >= 1) {
 	    /*
 	     * Display a line summarizing the top level command we
 	     * are about to compile.
 	     */
 
 	    numChars = strlen(procName);
 	    ellipsis = "";
 	    if (numChars > 50) {
 		numChars = 50;
 		ellipsis = "...";
 	    }
 	    fprintf(stdout, "Compiling %s \"%.*s%s\"\n",
 		    description, numChars, procName, ellipsis);
 	}
#endif
 	
 	/*
 	 * Plug the current procPtr into the interpreter and coerce
 	 * the code body to byte codes.  The interpreter needs to
 	 * know which proc it's compiling so that it can access its
 	 * list of compiled locals.
 	 *
 	 * TRICKY NOTE:  Be careful to push a call frame with the
 	 *   proper namespace context, so that the byte codes are
 	 *   compiled in the appropriate class context.
 	 */

 	saveProcPtr = iPtr->compiledProcPtr;

	if (procPtrPtr != NULL && procPtr->refCount > 1) {
	    Tcl_Command token;
	    Tcl_CmdInfo info;
	    Proc *new = (Proc *) ckalloc(sizeof(Proc));

	    new->iPtr = procPtr->iPtr;
	    new->refCount = 1;
	    token = (Tcl_Command) new->cmdPtr = procPtr->cmdPtr;
	    new->bodyPtr = Tcl_DuplicateObj(bodyPtr);
	    bodyPtr = new->bodyPtr;
	    Tcl_IncrRefCount(bodyPtr);
	    new->numArgs = procPtr->numArgs;

	    new->numCompiledLocals = new->numArgs;
	    new->firstLocalPtr = NULL;
	    new->lastLocalPtr = NULL;
	    localPtr = procPtr->firstLocalPtr;
	    for (i = 0; i < new->numArgs; i++, localPtr = localPtr->nextPtr) {
		CompiledLocal *copy = (CompiledLocal *) ckalloc((unsigned)
			(sizeof(CompiledLocal) -sizeof(localPtr->name)
			 + localPtr->nameLength + 1));
		if (new->firstLocalPtr == NULL) {
		    new->firstLocalPtr = new->lastLocalPtr = copy;
		} else {
		    new->lastLocalPtr->nextPtr = copy;
		    new->lastLocalPtr = copy;
		}
		copy->nextPtr = NULL;
		copy->nameLength = localPtr->nameLength;
		copy->frameIndex = localPtr->frameIndex;
		copy->flags = localPtr->flags;
		copy->defValuePtr = localPtr->defValuePtr;
		if (copy->defValuePtr) {
		    Tcl_IncrRefCount(copy->defValuePtr);
		}
		copy->resolveInfo = localPtr->resolveInfo;
		strcpy(copy->name, localPtr->name);
	    }


	    /* Reset the ClientData */
	    Tcl_GetCommandInfoFromToken(token, &info);
	    if (info.objClientData == (ClientData) procPtr) {
	        info.objClientData = (ClientData) new;
	    }
	    if (info.clientData == (ClientData) procPtr) {
	        info.clientData = (ClientData) new;
	    }
	    if (info.deleteData == (ClientData) procPtr) {
	        info.deleteData = (ClientData) new;
	    }
	    Tcl_SetCommandInfoFromToken(token, &info);

	    procPtr->refCount--;
	    *procPtrPtr = procPtr = new;
	}
 	iPtr->compiledProcPtr = procPtr;
 
 	result = Tcl_PushCallFrame(interp, &frame,
		(Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0);
 
 	if (result == TCL_OK) {
	    result = tclByteCodeType.setFromAnyProc(interp, bodyPtr);
	    Tcl_PopCallFrame(interp);
	}
 
 	iPtr->compiledProcPtr = saveProcPtr;
 	
 	if (result != TCL_OK) {
 	    if (result == TCL_ERROR) {
		char buf[100 + TCL_INTEGER_SPACE];

		numChars = strlen(procName);
 		ellipsis = "";
 		if (numChars > 50) {
 		    numChars = 50;
 		    ellipsis = "...";
 		}
		while ( (procName[numChars] & 0xC0) == 0x80 ) {
	            /*
		     * Back up truncation point so that we don't truncate
		     * in the middle of a multi-byte character (in UTF-8)
		     */
		    numChars--;
		    ellipsis = "...";
		}
 		sprintf(buf, "\n    (compiling %s \"%.*s%s\", line %d)",
 			description, numChars, procName, ellipsis,
 			interp->errorLine);
 		Tcl_AddObjErrorInfo(interp, buf, -1);
 	    }
 	    return result;
 	}
    } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
 	
	/*
	 * The resolver epoch has changed, but we only need to invalidate
	 * the resolver cache.
	 */

	for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;
	    localPtr = localPtr->nextPtr) {
	    localPtr->flags &= ~(VAR_RESOLVED);
	    if (localPtr->resolveInfo) {
		if (localPtr->resolveInfo->deleteProc) {
		    localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
		} else {
		    ckfree((char*)localPtr->resolveInfo);
		}
		localPtr->resolveInfo = NULL;
	    }
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ProcessProcResultCode --
 *
 *	Procedure called by TclObjInterpProc to process a return code other
 *	than TCL_OK returned by a Tcl procedure.
 *
 * Results:
 *	Depending on the argument return code, the result returned is
 *	another return code and the interpreter's result is set to a value
 *	to supplement that return code.
 *
 * Side effects:
 *	If the result returned is TCL_ERROR, traceback information about
 *	the procedure just executed is appended to the interpreter's
 *	"errorInfo" variable.
 *
 *----------------------------------------------------------------------
 */

static int
ProcessProcResultCode(interp, procName, nameLen, returnCode)
    Tcl_Interp *interp;		/* The interpreter in which the procedure
				 * was called and returned returnCode. */
    char *procName;		/* Name of the procedure. Used for error
				 * messages and trace information. */
    int nameLen;		/* Number of bytes in procedure's name. */
    int returnCode;		/* The unexpected result code. */
{
    Interp *iPtr = (Interp *) interp;
    char msg[100 + TCL_INTEGER_SPACE];
    char *ellipsis = "";

    if (returnCode == TCL_OK) {
	return TCL_OK;
    }
    if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) {
	return returnCode;
    }
    if (returnCode == TCL_RETURN) {
	return TclUpdateReturnInfo(iPtr);
    } 
    if (returnCode != TCL_ERROR) {
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp), ((returnCode == TCL_BREAK) 
		? "invoked \"break\" outside of a loop"
		: "invoked \"continue\" outside of a loop"), -1);
    }
    if (nameLen > 60) {
	nameLen = 60;
	ellipsis = "...";
    }
    while ( (procName[nameLen] & 0xC0) == 0x80 ) {
        /*
	 * Back up truncation point so that we don't truncate in the
	 * middle of a multi-byte character (in UTF-8)
	 */
	nameLen--;
	ellipsis = "...";
    }
    sprintf(msg, "\n    (procedure \"%.*s%s\" line %d)", nameLen, procName,
	    ellipsis, iPtr->errorLine);
    Tcl_AddObjErrorInfo(interp, msg, -1);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclProcDeleteProc --
 *
 *	This procedure is invoked just before a command procedure is
 *	removed from an interpreter.  Its job is to release all the
 *	resources allocated to the procedure.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory gets freed, unless the procedure is actively being
 *	executed.  In this case the cleanup is delayed until the
 *	last call to the current procedure completes.
 *
 *----------------------------------------------------------------------
 */

void
TclProcDeleteProc(clientData)
    ClientData clientData;		/* Procedure to be deleted. */
{
    Proc *procPtr = (Proc *) clientData;

    procPtr->refCount--;
    if (procPtr->refCount <= 0) {
	TclProcCleanupProc(procPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclProcCleanupProc --
 *
 *	This procedure does all the real work of freeing up a Proc
 *	structure.  It's called only when the structure's reference
 *	count becomes zero.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory gets freed.
 *
 *----------------------------------------------------------------------
 */

void
TclProcCleanupProc(procPtr)
    register Proc *procPtr;		/* Procedure to be deleted. */
{
    register CompiledLocal *localPtr;
    Tcl_Obj *bodyPtr = procPtr->bodyPtr;
    Tcl_Obj *defPtr;
    Tcl_ResolvedVarInfo *resVarInfo;

    if (bodyPtr != NULL) {
	Tcl_DecrRefCount(bodyPtr);
    }
    for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;  ) {
	CompiledLocal *nextPtr = localPtr->nextPtr;

        resVarInfo = localPtr->resolveInfo;
	if (resVarInfo) {
	    if (resVarInfo->deleteProc) {
		(*resVarInfo->deleteProc)(resVarInfo);
	    } else {
		ckfree((char *) resVarInfo);
	    }
        }

	if (localPtr->defValuePtr != NULL) {
	    defPtr = localPtr->defValuePtr;
	    Tcl_DecrRefCount(defPtr);
	}
	ckfree((char *) localPtr);
	localPtr = nextPtr;
    }
    ckfree((char *) procPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclUpdateReturnInfo --
 *
 *	This procedure is called when procedures return, and at other
 *	points where the TCL_RETURN code is used.  It examines fields
 *	such as iPtr->returnCode and iPtr->errorCode and modifies
 *	the real return status accordingly.
 *
 * Results:
 *	The return value is the true completion code to use for
 *	the procedure, instead of TCL_RETURN.
 *
 * Side effects:
 *	The errorInfo and errorCode variables may get modified.
 *
 *----------------------------------------------------------------------
 */

int
TclUpdateReturnInfo(iPtr)
    Interp *iPtr;		/* Interpreter for which TCL_RETURN
				 * exception is being processed. */
{
    int code;
    char *errorCode;
    Tcl_Obj *objPtr;

    code = iPtr->returnCode;
    iPtr->returnCode = TCL_OK;
    if (code == TCL_ERROR) {
	errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE");
	objPtr = Tcl_NewStringObj(errorCode, -1);
	Tcl_IncrRefCount(objPtr);
	Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
	        NULL, objPtr, TCL_GLOBAL_ONLY);
	Tcl_DecrRefCount(objPtr);
	iPtr->flags |= ERROR_CODE_SET;
	if (iPtr->errorInfo != NULL) {
	    objPtr = Tcl_NewStringObj(iPtr->errorInfo, -1);
	    Tcl_IncrRefCount(objPtr);
	    Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo,
		    NULL, objPtr, TCL_GLOBAL_ONLY);
	    Tcl_DecrRefCount(objPtr);
	    iPtr->flags |= ERR_IN_PROGRESS;
	}
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetInterpProc --
 *
 *  Returns a pointer to the TclProcInterpProc procedure; this is different
 *  from the value obtained from the TclProcInterpProc reference on systems
 *  like Windows where import and export versions of a procedure exported
 *  by a DLL exist.
 *
 * Results:
 *  Returns the internal address of the TclProcInterpProc procedure.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

TclCmdProcType
TclGetInterpProc()
{
    return (TclCmdProcType) TclProcInterpProc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetObjInterpProc --
 *
 *  Returns a pointer to the TclObjInterpProc procedure; this is different
 *  from the value obtained from the TclObjInterpProc reference on systems
 *  like Windows where import and export versions of a procedure exported
 *  by a DLL exist.
 *
 * Results:
 *  Returns the internal address of the TclObjInterpProc procedure.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

TclObjCmdProcType
TclGetObjInterpProc()
{
    return (TclObjCmdProcType) TclObjInterpProc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclNewProcBodyObj --
 *
 *  Creates a new object, of type "procbody", whose internal
 *  representation is the given Proc struct.
 *  The newly created object's reference count is 0.
 *
 * Results:
 *  Returns a pointer to a newly allocated Tcl_Obj, 0 on error.
 *
 * Side effects:
 *  The reference count in the ByteCode attached to the Proc is bumped up
 *  by one, since the internal rep stores a pointer to it.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclNewProcBodyObj(procPtr)
    Proc *procPtr;	/* the Proc struct to store as the internal
                         * representation. */
{
    Tcl_Obj *objPtr;

    if (!procPtr) {
        return (Tcl_Obj *) NULL;
    }
    
    objPtr = Tcl_NewStringObj("", 0);

    if (objPtr) {
        objPtr->typePtr = &tclProcBodyType;
        objPtr->internalRep.otherValuePtr = (VOID *) procPtr;

        procPtr->refCount++;
    }

    return objPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * ProcBodyDup --
 *
 *  Tcl_ObjType's Dup function for the proc body object.
 *  Bumps the reference count on the Proc stored in the internal
 *  representation.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  Sets up the object in dupPtr to be a duplicate of the one in srcPtr.
 *
 *----------------------------------------------------------------------
 */

static void ProcBodyDup(srcPtr, dupPtr)
    Tcl_Obj *srcPtr;		/* object to copy */
    Tcl_Obj *dupPtr;		/* target object for the duplication */
{
    Proc *procPtr = (Proc *) srcPtr->internalRep.otherValuePtr;
    
    dupPtr->typePtr = &tclProcBodyType;
    dupPtr->internalRep.otherValuePtr = (VOID *) procPtr;
    procPtr->refCount++;
}

/*
 *----------------------------------------------------------------------
 *
 * ProcBodyFree --
 *
 *  Tcl_ObjType's Free function for the proc body object.
 *  The reference count on its Proc struct is decreased by 1; if the count
 *  reaches 0, the proc is freed.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  If the reference count on the Proc struct reaches 0, the struct is freed.
 *
 *----------------------------------------------------------------------
 */

static void
ProcBodyFree(objPtr)
    Tcl_Obj *objPtr;		/* the object to clean up */
{
    Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr;
    procPtr->refCount--;
    if (procPtr->refCount <= 0) {
        TclProcCleanupProc(procPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ProcBodySetFromAny --
 *
 *  Tcl_ObjType's SetFromAny function for the proc body object.
 *  Calls panic.
 *
 * Results:
 *  Theoretically returns a TCL result code.
 *
 * Side effects:
 *  Calls panic, since we can't set the value of the object from a string
 *  representation (or any other internal ones).
 *
 *----------------------------------------------------------------------
 */

static int
ProcBodySetFromAny(interp, objPtr)
    Tcl_Interp *interp;			/* current interpreter */
    Tcl_Obj *objPtr;			/* object pointer */
{
    panic("called ProcBodySetFromAny");

    /*
     * this to keep compilers happy.
     */
    
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ProcBodyUpdateString --
 *
 *  Tcl_ObjType's UpdateString function for the proc body object.
 *  Calls panic.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  Calls panic, since we this type has no string representation.
 *
 *----------------------------------------------------------------------
 */

static void
ProcBodyUpdateString(objPtr)
    Tcl_Obj *objPtr;		/* the object to update */
{
    panic("called ProcBodyUpdateString");
}


/*
 *----------------------------------------------------------------------
 *
 * TclCompileNoOp --
 *
 *	Procedure called to compile noOp's
 *
 * Results:
 *	The return value is TCL_OK, indicating successful compilation.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute a noOp at runtime.
 *
 *----------------------------------------------------------------------
 */

static int
TclCompileNoOp(interp, parsePtr, envPtr)
    Tcl_Interp *interp;         /* Used for error reporting. */
    Tcl_Parse *parsePtr;        /* Points to a parse structure for the
                                 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;         /* Holds resulting instructions. */
{
    Tcl_Token *tokenPtr;
    int i, code;
    int savedStackDepth = envPtr->currStackDepth;

    tokenPtr = parsePtr->tokenPtr;
    for(i = 1; i < parsePtr->numWords; i++) {
	tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
	envPtr->currStackDepth = savedStackDepth;

	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { 
	    code = TclCompileTokens(interp, tokenPtr+1,
	            tokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		return code;
	    }
	    TclEmitOpcode(INST_POP, envPtr);
	} 
    }
    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
    return TCL_OK;
}
generated by cgit v0.12 at 2024-09-02 04:36:16 (GMT)