view release on metacpan or  search on metacpan

lib/C/Blocks.xs  view on Meta::CPAN

			sv_setpvn_mg(package_lists, (char*)&new_table, sizeof(available_extended_symtab));
		}
		
		/* inject the import method */
		SV * has_import = get_sv(form("%s::__cblocks_injected_import",
			SvPVbyte_nolen(PL_curstname)), GV_ADDMULTI | GV_ADD);
		if (!SvOK(has_import)) {
			inject_import(aTHX);
			sv_setuv(has_import, 1);
		}
	}
}

int my_keyword_plugin(pTHX_
	char *keyword_ptr, STRLEN keyword_len, OP **op_ptr
) {
	/* See if this is a keyword we know */
	int keyword_type = identify_keyword(keyword_ptr, keyword_len);
	if (!keyword_type)
		return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
	
	/**********************/
	/*   Initialization   */
	/**********************/
	
	/* Clear out any leading whitespace, including comments. Do this before
	 * initialization so that the assignment of the end pointer is correct. */
	lex_read_space(0);
	
	/* Create the compilation data struct */
	c_blocks_data data;
	initialize_c_blocks_data(aTHX_ &data);
	
	add_msg_function_decl(aTHX_ &data);
	if (keyword_type == IS_CBLOCK) add_function_signature_to_block(aTHX_ &data);
	else if (keyword_type == IS_CSUB) fixup_xsub_name(aTHX_ &data);
	else if (keyword_type == IS_CSHARE || keyword_type == IS_CLEX) {
		data.keep_curly_brackets = 0;
	}
	
	/************************/
	/* Extract and compile! */
	/************************/
	
	extract_C_code(aTHX_ &data, keyword_type);
	run_filters(aTHX_ &data, keyword_type);
	
	TCCState * state = tcc_new();
	if (!state) croak("Unable to create C::TinyCompiler state!\n");
	setup_compiler(aTHX_ state, &data);
	
	/* Ask to save state if it's a cshare or clex block*/
	if (keyword_type == IS_CSHARE || keyword_type == IS_CLEX) {
		tcc_save_extended_symtab(state);
	}
	
	/* Compile the extracted code */
	execute_compiler(aTHX_ state, &data, keyword_type);
	
	/******************************************/
	/* Apply the list of symbols and relocate */
	/******************************************/
	
	/* test symbols */
	if (SvOK(data.add_test_SV)) {
		tcc_add_symbol(state, "c_blocks_send_msg", _c_blocks_send_msg);
		tcc_add_symbol(state, "c_blocks_send_bytes", _c_blocks_send_bytes);
		tcc_add_symbol(state, "c_blocks_get_msg", _c_blocks_get_msg);
	}
	
	/* prepare for relocation; store in a global so that we can free everything
	 * at the end of the Perl program's execution. Allocate up to on page size
	 * more memory than we need so that we can align the code at the start of
	 * the page. */
	int machine_code_size = tcc_relocate(state, 0);
	if (machine_code_size > 0) {
		/* XXX uses hard-coded page sizes. This could stand to be cleaned up, I suspect */
		SV * machine_code_SV = newSV(machine_code_size + 4096);
		AV * machine_code_cache = get_av("C::Blocks::__code_cache_array", GV_ADDMULTI | GV_ADD);
		uintptr_t machine_code_loc = (uintptr_t)SvPVX(machine_code_SV);
		unsigned int PAGESIZE = 4096;
		if ((machine_code_loc & 0xfff) != 0) {
			machine_code_loc &= ~0xfff;
			machine_code_loc += 4096;
		}
		int relocate_returned = tcc_relocate(state, (void*)machine_code_loc);
		av_push(machine_code_cache, machine_code_SV);
		if (SvPOK(data.error_msg_sv)) {
			/* Look for errors and croak */
			if (strstr(SvPV_nolen(data.error_msg_sv), "error")) {
				croak("C::Blocks linker error:\n%s", SvPV_nolen(data.error_msg_sv));
			}
			/* Otherwise report warnings */
			my_warnif(aTHX_ "linker", sv_2mortal(newSVsv(data.error_msg_sv)));
		}
		if (relocate_returned < 0) {
			croak("C::Blocks linker error: unable to relocate\n");
		}
	}
	
	/********************************************************/
	/* Build op tree or serialize the symbol table; cleanup */
	/********************************************************/

	*op_ptr = build_op(aTHX_ state, keyword_type);
	if (keyword_type == IS_CSUB) extract_xsub(aTHX_ state, &data);
	else if (keyword_type == IS_CSHARE || keyword_type == IS_CLEX) {
		serialize_symbol_table(aTHX_ state, &data, keyword_type);
	}
	
	/* cleanup */
	cleanup_c_blocks_data(aTHX_ &data);
	tcc_delete(state);
	
	/* insert a semicolon to make the parser happy */
	lex_stuff_pvn(";", 1, 0);
	
	/* Make the parser count the number of lines correctly */
	int i;
	for (i = 0; i < data.N_newlines; i++) lex_stuff_pv("\n", 0);
	
	/* Return success */
	return KEYWORD_PLUGIN_STMT;
}

MODULE = C::Blocks       PACKAGE = C::Blocks

void
_import()
CODE:
	if (PL_keyword_plugin != my_keyword_plugin) {
		PL_keyword_plugin = my_keyword_plugin;
	}
	
	/*
	COPHH* hints_hash = CopHINTHASH_get(PL_curcop);
	SV * extended_symtab_tables_SV = cophh_fetch_pvs(hints_hash, "C::Blocks/extended_symtab_tables", 0);
	if (extended_symtab_tables_SV == &PL_sv_placeholder) extended_symtab_tables_SV = newSVpvn("", 0);
	hints_hash = cophh_store_pvs(hints_hash, "C::Blocks/extended_symtab_tables", extended_symtab_tables_SV, 0);
	*/


void
unimport(...)
CODE:
	/* This appears to be broken. But I'll put it on the backburner
	 * for now and see if switching to Devel::CallChecker and
	 * Devel::CallParser fix it. */
	PL_keyword_plugin = next_keyword_plugin;

void
_cleanup()
CODE:
	/* Remove all of the extended symol tables. Note that the code pages
	 * were stored directly into Perl SV's, which were pushed into an
	 * array, so they are cleaned up for us automatically. */
	AV * cache = get_av("C::Blocks::__symtab_cache_array", GV_ADDMULTI | GV_ADD);