implementation module write_dynamic; import cg_name_mangling; import read_dynamic; import compute_graph; import dynamics; import ExtInt; import DebugUtilities; from type_io_common import get_type_name_and_module_name_from_type_string; import DynID; import StdEnv; import StdDynamicLowLevelInterface; import DefaultElem; import StdMaybe; import pdExtInt; import ddState; import BitSet; import StdDynamicTypes; // Layout SepSpaces :== " "; s_SepSpaces :== 2; // size of SepSpaces s_offset_header :== 8; write_one_line block_i is_indirection_line i file index_in_desc_addr_table graph markup_commands {block_table,header} // offset #! file = fwrites SepSpaces file; # bk_offset = block_table.[block_i].bk_offset; #! file = fwrites (hex_int (i - bk_offset)) file; // Raw data #! file = fwrites SepSpaces file; #! file = fwrites (hex (toInt graph.[i + 0])) file; #! file = fwritec ' ' file; #! file = fwrites (hex (toInt graph.[i + 1])) file; #! file = fwritec ' ' file; #! file = fwrites (hex (toInt graph.[i + 2])) file; #! file = fwritec ' ' file; #! file = fwrites (hex (toInt graph.[i + 3])) file; // Prefix #! (prefix,partial_arity,expanded_desc_table_o) = decode_descriptor_offset header index_in_desc_addr_table i graph; #! file = fwrites SepSpaces file; #! file = case is_indirection_line of { True #! file = ljustify_f 6 "" file; -> file; False #! prefix_string = case prefix of { DPREFIX #! prefix = (toString (bit_n_to_char prefix)) +++ " (" +++ toString partial_arity +++ ")"; -> prefix; _ -> toString (bit_n_to_char prefix); }; #! file = ljustify_f 6 prefix_string file; -> file; }; // Descriptor #! file = fwrites SepSpaces file; #! (file,markup_commands) = case is_indirection_line of { True #! file = ljustify_f 10 "" file; -> (file,markup_commands); False #! (file,markup_commands) = case True /*(DYNAMIC_CONTAINS_BLOCKTABLE header)*/ of { True #! bk_entries = block_table.[block_i].bk_entries; #! bk_offset = block_table.[block_i].bk_offset; #! searched_offset = i - bk_offset; #! (entry_found,entry_n) = look_for_index 0 (size bk_entries) searched_offset bk_entries bk_offset | not entry_found <<- ("look_for_index", searched_offset) -> (ljustify_f 10 "" file,markup_commands); #! markup_commands = markup_commands -> (ljustify_f 10 (hex_int_without_prefixed_zeroes entry_n) file,markup_commands); }; -> (file,markup_commands); }; #! file = fwrites SepSpaces file; = (expanded_desc_table_o,file,markup_commands); where { look_for_index i limit searched_offset bk_entries bk_offset | searched_offset == 0 = (True,0); = look_for_index2 i limit searched_offset bk_entries bk_offset; look_for_index2 i limit searched_offset bk_entries bk_offset | i == limit = (False,0); | (bk_entries.[i] - bk_offset) == searched_offset = (True,i); = look_for_index2 (inc i) limit searched_offset bk_entries bk_offset; }; write_title file #! title = " Offset Raw data Prefix Entry node Comment\n"; #! title_underlined = " -------- ----------- ------ ---------- -------\n"; #! file = fwrites title file; #! file = fwrites title_underlined file; = file; WriteDescriptorAddressTable :: !Int !Int !BinaryDynamic !DescriptorAddressTable !*File -> (!*File,!DescriptorAddressTable); WriteDescriptorAddressTable max_desc_name max_mod_name dynamic_info=:{descriptor_usage_table,header} /*=:{header={start_fp,descriptortable_s,descriptortable_i},descriptortable,stringtable}*/ desc_table file // Write header #! file = write_header file; #! file = fwritec '\n' file; #! file = fwrites title_text file; #! file = fwritec '\n' file; #! file = fwrites title_underlined file; #! file = fwritec '\n' file; #! (s_desc_table,desc_table) = usize_desc_addr_table desc_table; #! (file,desc_table) = write_entry3 0 s_desc_table desc_table file; = (file,desc_table); where { (binary_dynamic=:{header={graph_s,graph_i,stringtable_i,stringtable_s,descriptortable_i,descriptortable_s},descriptortable,stringtable}) = dynamic_info; write_entry3 i limit desc_table file | i == limit = (file,desc_table); // Offset #! file = fwrites SepSpaces file; #! file = fwrites (hex_int (i << 2)) file; // Raw data #! file = fwrites SepSpaces file; #! file = fwrites (hex (toInt descriptortable.[i << 2 + 0])) file; #! file = fwritec ' ' file; #! file = fwrites (hex (toInt descriptortable.[i << 2 + 1])) file; #! file = fwritec ' ' file; #! file = fwrites (hex (toInt descriptortable.[i << 2 + 2])) file; #! file = fwritec ' ' file; #! file = fwrites (hex (toInt descriptortable.[i << 2 + 3])) file; // Descriptor name #! file = fwrites SepSpaces file; #! (descriptor_name,desc_table) = desc_table!desc_addr_table.[i].descriptor_name; #! descriptor_name = expand_special_chars descriptor_name; #! file = ljustify_f descriptor_name_max descriptor_name file; // Module name #! file = fwrites SepSpaces file; #! (module_name,desc_table) = desc_table!desc_addr_table.[i].DescriptorAddressTableEntry.module_name; #! module_name = (expand_special_chars module_name); #! file = ljustify_f module_name_max module_name file; // Write prefix #! file = fwrites SepSpaces file; #! (prefix_kind_set,desc_table) = desc_table!desc_addr_table.[i].prefixes.prefix_kind_set #! (prefix_found,first_prefix_bit_n) = find_prefix (dec N_PREFIXES) prefix_kind_set; #! prefix = (bit_n_to_char first_prefix_bit_n); | not prefix_found = abort ("WriteDescriptorAddressTable; prefix not found" +++ toString first_prefix_bit_n); #! file = ljustify_f prefix_size (toString prefix) file; // write library instance #! (date_library_instance_nr_on_disk,desc_table) = desc_table!desc_addr_table.[i].date_library_instance_nr_on_disk; #! file = fwrites SepSpaces file; #! file = ljustify_f s_library_text (toString date_library_instance_nr_on_disk) file; // write descriptor usage table #! file = case (DYNAMIC_CONTAINS_BLOCKTABLE header) of { True #! file = fwrites SepSpaces file; #! (_,set_string) = enum_setSt (\j string -> string +++ "," +++ hex_int_without_prefixed_zeroes j) descriptor_usage_table.[i].bitset ""; #! set_string = "{" +++ set_string % (1,dec (size set_string)) +++ "}"; #! file = fwrites set_string file; -> file; False -> file; }; #! file = fwritec '\n' file; #! file = write_prefix (dec first_prefix_bit_n) (descriptor_name,module_name,file) prefix_kind_set = write_entry3 (inc i) limit desc_table file; where { write_prefix bit_n (descriptor_name,module_name,file) prefix_kind_set #! (prefix_found,bit_n) = find_prefix bit_n prefix_kind_set; | not prefix_found = file; // convert prefix bit_n to character #! prefix = (bit_n_to_char bit_n); // write prefix #! file = fwrites (createArray (prefix_start + size SepSpaces) ' ') file; #! file = ljustify_f prefix_size (toString prefix) file; #! file = fwritec '\n' file; = write_prefix (dec bit_n) (descriptor_name,module_name,file) prefix_kind_set; } // write_entry // Offset/Raw data offset_raw_data_text // 12345678 12345678901 = "Offset " +++ SepSpaces +++ "Raw data " +++ SepSpaces; offset_raw_data_underlined = "--------" +++ SepSpaces +++ "-----------" +++ SepSpaces; // Descriptor name desc_name = "Descriptor"; descriptor_name_max = (max max_desc_name (size desc_name)); descriptor_name_text = (ljustify_s descriptor_name_max desc_name) +++ SepSpaces; descriptor_name_underlined = (createArray descriptor_name_max '-') +++ SepSpaces; // Module name module_name = "Module name"; module_name_max = max max_mod_name (size module_name); module_name_text = (ljustify_s module_name_max module_name) +++ SepSpaces; module_name_underlined = (createArray module_name_max '-') +++ SepSpaces; // Prefix prefix_text = "Prefix" +++ SepSpaces; prefix_underlined = "------" +++ SepSpaces; prefix_size = (size prefix_text) - (size SepSpaces); s_label_text = size label_text; label_text = if (DYNAMIC_CONTAINS_BLOCKTABLE header) ("Block set") ("Label"); label_underlined = if (DYNAMIC_CONTAINS_BLOCKTABLE header) ("---------") ("-----"); // Library s_library_text = size library_text1; library_text1 = "Library"; library_text = library_text1 +++ SepSpaces; library_underlined = "-------" +++ SepSpaces; // Title title_text = SepSpaces +++ offset_raw_data_text +++ descriptor_name_text +++ module_name_text +++ prefix_text +++ library_text +++ label_text; title_underlined1 = SepSpaces +++ offset_raw_data_underlined +++ descriptor_name_underlined +++ module_name_underlined; prefix_start = (size title_underlined1) - (size SepSpaces); title_underlined = title_underlined1 +++ prefix_underlined +++ library_underlined +++ label_underlined ; ljustify_s :: !Int !String -> String; ljustify_s max s = {c \\ c <- (ljustify max [ c \\ c <-: s ])}; write_header file #! file = fwrites "DESCRIPTOR ADDRESS TABLE\n" file; #! file = write_entry2 (descriptortable_s >> 2) "entries" file; #! file = write_entry2 descriptortable_i "relative file pointer" file; = file; } // WriteDescriptorAddressTable write_entry2 n comment file #! file = fwrites SepSpaces file; #! file = fwrites {c \\ c <- (rjustify s_offset_header [ c \\ c <-: (hex_int_without_prefixed_zeroes n) ])} file; #! file = fwrites SepSpaces file; #! file = fwrites comment file; #! file = fwritec '\n' file; = file; ljustify_f :: !Int !String !*File -> *File; ljustify_f max1 s file | max1 == size s = fwrites s file; #! file = fwrites s file; | (max1 - (size s)) < 1 = abort ("!max1: " +++ toString max1 +++ " " +++ toString (size s)) #! file = fwrites (createArray (max1 - (size s)) ' ') file; = file; WriteHeader :: !BinaryDynamic !*File -> *File; WriteHeader dynamic_info=:{header} file #! start_fp = 0; // start in dynamic file of header #! size1 = 0; #! file = fwrites "HEADER\n\n" file; #! file = write_entry2 header.version_number "version number" file; // graph #! file = write_entry2 (start_fp + header.graph_i) "graph file pointer start" file; #! file = write_entry2 header.graph_s "graph size" file; // blocktable #! file = case (DYNAMIC_CONTAINS_BLOCKTABLE header) of { True #! file = write_entry2 (start_fp + header.block_table_i) "block table file pointer start" file; #! file = write_entry2 (header.block_table_s) "blocktable size" file; -> file; False -> file; }; // stringtable #! file = write_entry2 (start_fp + header.stringtable_i) "stringtable file pointer start" file; #! file = write_entry2 header.stringtable_s "stringtable size" file; //descriptortable #! file = write_entry2 (start_fp + header.descriptortable_i) "descriptortable file pointer start" file; #! file = write_entry2 header.descriptortable_s "descriptortable size" file; // n_nodes #! file = write_entry2 header.n_nodes "graph nodes" file; //descriptortable #! file = write_entry2 (start_fp + header.descriptor_bitset_i) "descriptor bitset file pointer start" file; #! file = write_entry2 header.descriptor_bitset_s "descriptor bitset size" file; = file; WriteStringTable :: !BinaryDynamic !*File -> *File; WriteStringTable dynamic_info file #! file = fwrites ("STRING TABLE\n") file; #! file = write_entry2 stringtable_s "total size" file; #! file = write_entry2 stringtable_i "relative file pointer" file; #! file = fwritec '\n' file; #! raw_data_text = "Raw data"; #! ascii_text = "Ascii"; #! offset_text = "Offset" #! title = SepSpaces +++ offset_text +++ createArray (8 - (size offset_text)) ' ' +++ SepSpaces +++ raw_data_text +++ createArray (hex_line * 3 - (size raw_data_text) + 1) ' ' +++ ascii_text; #! title_underlined = SepSpaces +++ createArray 8 '-' +++ SepSpaces +++ createArray (hex_line * 3 - 1) '-' +++ SepSpaces +++ createArray hex_line '-'; #! file = fwrites title file; #! file = fwritec '\n' file; #! file = fwrites title_underlined file; #! file = fwritec '\n' file; #! file = write_string_table 0 (createArray hex_line ' ') file; = file; where { (binary_dynamic=:{header={graph_s,graph_i,stringtable_i,stringtable_s,descriptortable_i,descriptortable_s},stringtable}) = dynamic_info; start_fp = 0; hex_line = 16; // 12 bytes per line write_string_table :: !Int !*{Char} !*File -> *File; write_string_table i buffer file | i == stringtable_s = file; // write offset #! file = fwrites SepSpaces file; #! file = fwrites (hex_int i) file; #! file = fwritec ' ' file; // write one hex line #! (i,buffer,file) = write_one_hex_line 0 i buffer file; = write_string_table i buffer file; where { write_one_hex_line :: !Int !Int !*{Char} !*File -> (!Int,!*{Char},!*File); write_one_hex_line j i buffer file | (j == hex_line) || (i == stringtable_s) #! file = fwrites (createArray ((hex_line - j) * 3 + (size SepSpaces)) ' ') file; #! (buffer,file) = write_buffer 0 j buffer file; #! file = fwritec '\n' file; = (i,buffer,file); #! file = fwritec ' ' file; #! c = stringtable.[i]; #! file = fwrites (hex (toInt c)) file; = write_one_hex_line (inc j) (inc i) { buffer & [j] = c } file; where { write_buffer i limit buffer file | i == limit = (buffer,file); #! (c,buffer) = buffer![i] #! file = fwritec (if (isPrint c) c '.') file; = write_buffer (inc i) limit buffer file; } // write_one_hex_line } // write_string_table } // ---------------------------------------------------------------------------------------- import ExtArray; import RWSDebugChoice; import utilities; instance toString Child where { toString (Internal True child_node_i) = "@" +++ toString child_node_i; toString (External True child_node_i) = "*" +++ toString child_node_i; toString _ = "??"; }; create_string :: [String] -> String; create_string [] = ""; create_string l | False <<- ("&&&",l) = undef; # x = count_string_size l 0; # s = createArray (x) ' '; | False <<- ("create_string",x) = undef; = collect_strings 0 l s; where { count_string_size [] size1 = size1; count_string_size [x:xs] size1 = count_string_size xs (size1 + size x); collect_strings _ [] s = s; collect_strings i [x:xs] s # s_x = size x; # s = { s & [i+j] = x.[j] \\ j <- [0..dec s_x] }; = collect_strings (i + s_x) xs s; }; convert_node node=:{graph_index, info=Record r0 r1 r2 r3 (record_info=:{ri_descriptor_name,ri_args}),children} #! record_info = { record_info & ri_args.rai_n_boxed_args = length children }; #! node = { node & info = Record r0 r1 r2 r3 record_info , children = reversed_children }; = node; where { reversed_children = reverse children; }; convert_node node=:{graph_index, info=ArrayNode r0 r1 r2 r3 (array_info=:{ai_element_descriptor}),children} # node = case ai_element_descriptor of { AED_Invalid -> abort "convert_node; invalid array descriptor"; AED_Boxed #! record_args_info = { { default_elem & rai_n_boxed_args = length children} }; #! array_info = { array_info & ai_record_args_info = record_args_info }; #! node = { node & info = ArrayNode r0 r1 r2 r3 array_info , children = reversed_children }; -> node; AED_BasicValue _ -> node; AED_Record _ -> node; }; = node; where { reversed_children = reverse children; } convert_node node=:{children} = {node & children = reverse children }; to_string_unboxed_record_arg _ _ (BV_Int int) (node_index_in_string,strings) #! strings = { strings & [node_index_in_string] = toString int +++ " (Int)" }; = (inc node_index_in_string,strings); to_string_unboxed_record_arg is_unboxed_value_record ith_bool (BV_Bool bool) (node_index_in_string,strings) | is_unboxed_value_record #! (string,strings) = strings![node_index_in_string]; #! strings = { strings & [node_index_in_string] = string +++ toString bool +++ " "}; #! node_index_in_string = if ((ith_bool rem 4) == 3) (inc node_index_in_string) node_index_in_string; = (node_index_in_string,strings); #! strings = { strings & [node_index_in_string] = toString bool +++ " (Bool)" }; = (inc node_index_in_string,strings); to_string_unboxed_record_arg is_unboxed_value_record ith_bool (BV_Char char) (node_index_in_string,strings) | is_unboxed_value_record #! (string,strings) = strings![node_index_in_string]; #! strings = { strings & [node_index_in_string] = string +++ "'" +++ toString char +++ "' "}; #! node_index_in_string = if ((ith_bool rem 4) == 3) (inc node_index_in_string) node_index_in_string; = (node_index_in_string,strings); #! strings = { strings & [node_index_in_string] = toString char +++ " (Char)" }; = (inc node_index_in_string,strings); to_string_unboxed_record_arg _ _ (BV_Real real) (node_index_in_string,strings) #! strings = { strings & [node_index_in_string] = toString real +++ " (Real)" }; = (node_index_in_string + 2,strings); to_string_unboxed_record_arg _ _ k _ | True <<- ("to_string_unboxed_record_arg",k) = abort "to_string_unboxed_record_arg"; import runtime_system; find_internal_node node_offset node_i node=:{graph_index} | node_offset <> graph_index = Nothing; = Just node_i; node_index_to_string node_i = "@" +++ toString node_i; import typetable; import type_io_read; :: *LazyDynamic = { ld_dynamic_info :: !DynamicInfo , ld_type_table :: !*{*TypeTable} }; instance DefaultElemU LazyDynamic where { default_elemU = { ld_dynamic_info = default_elem , ld_type_table = {} }; }; read_type_table i type_name (type_tables,files) # (ok,rti,tio_common_defs,type_io_state,names_table,files) = read_type_information_new False (ADD_TYPE_LIBRARY_EXTENSION type_name) {} files; // create new type table # new_type_table = { default_type_table & tt_type_io_state = type_io_state , tt_tio_common_defs = { x \\ x <-: tio_common_defs } , tt_n_tio_common_defs = size tio_common_defs , tt_rti = rti }; #! type_tables = { type_tables & [i] = new_type_table }; = (type_tables,files); WriteDynamicInfo :: !.DynamicInfo !*File !*Files -> (!*File,!*Files); WriteDynamicInfo bd_dynamic_info=:{di_disk_type_equivalent_classes,di_library_instance_to_library_index,di_library_index_to_library_name,di_lazy_dynamics_a,di_type_redirection_table} file files // Library instance table #! file = fwrites ("\nLIBRARY INSTANCE TABLE (format: lazy(library_instance_i,lazy_dynamic_index))\n\n") file; #! file = fwrites title file; #! file = fwrites title_underlined file; #! file = mapAiStS print_library_instance di_library_instance_to_library_index file RTID_DISKID_RENUMBER_START; #! file = fwritec '\n' file; // Library String Table #! file = fwrites ("\nLIBRARY STRING TABLE\n\n") file; #! file = fwrites title2 file; #! file = fwrites title2_underlined file; #! file = mapAiSt (print_library_name s_library_string_table_index) di_library_index_to_library_name file; #! file = fwritec '\n' file; // External Dynamics Table #! file = case (size di_lazy_dynamics_a) of { 0 -> file; _ #! file = fwrites ("\nLAZY DYNAMICS TABLE\n\n") file; #! file = fwrites title3 file; #! file = fwrites title3_underlined file; #! file = mapAiSt (print_library_name s_dynamic_index_name) di_lazy_dynamics_a file; #! file = fwritec '\n' file; -> file; }; // TYPE EQUIVALENT CLASSES ...; read type tables from main dynamic #! type_tables = to_help_the_type_checker { default_type_table \\ _ <- [1.. (size di_library_index_to_library_name)] }; #! (type_tables,files) = mapAiSt read_type_table di_library_index_to_library_name (type_tables,files); // print type tables #! (file,type_tables) = case (size di_disk_type_equivalent_classes == 0) of { False // title #! file = fwrites ("\nTYPE EQUIVALENT CLASSES\n\n") file; #! file = fwrites title4 file; #! file = fwrites title4_underlined file; #! (type_tables,file) = mapAiSt print_type_equivalent_class di_disk_type_equivalent_classes (type_tables,file); #! file = fwrites "\n\n" file; -> (file,type_tables); _ -> (file,type_tables); }; // ... TYPE EQUIVALENT CLASSES = (file,files); where { to_help_the_type_checker :: {#TypeTable} -> {#TypeTable}; to_help_the_type_checker i = i; print_type_equivalent_class i type_equations (type_tables,file) | size type_equations < 2 = abort "print_type_equivalent_class: internal error; type equivalent table-entry must at least have two types in it"; // write #! file = fwrites SepSpaces file; #! file = ljustify_f s_dynamic_index_name (toString i) file; #! (type_name,type_tables) = get_type_name type_equations.[0] type_tables; #! file = fwrites (SepSpaces +++ type_name +++ ":") file; // print eager type equations #! file = fwrites " {" file; # (type_tables,_,file) = mapAiSt filter_eager_type_equation type_equations (type_tables,False,file); #! file = fwritec '}' file; #! file = fwrites " - " file; // print lazy type equations #! file = fwrites "{" file; # (type_tables,_,file) = mapAiSt filter_lazy_type_equation type_equations (type_tables,False,file); #! file = fwritec '}' file; #! file = fwritec '\n' file; = (type_tables,file); where { filter_eager_type_equation i t=:(LIT_TypeReference (LibRef _) _) s = print_type_equation i t s; filter_eager_type_equation i _ s = s; filter_lazy_type_equation i _ s = s; } get_type_name (LIT_TypeReference library_instance_reference tio_type_reference=:{tio_type_without_definition,tio_tr_module_n,tio_tr_type_def_n}) type_tables # maybe_type_table_i = case library_instance_reference of { LibRef disk_library_instance_i | not (isTypeWithoutDefinition tio_type_reference) # type_table_i = get_index_in_di_library_index_to_library_name di_library_instance_to_library_index.[disk_library_instance_i]; -> Just type_table_i; -> Nothing; }; # (type_name,type_tables) = case maybe_type_table_i of { Just type_table_i -> get_type_name_from_type_tables tio_tr_type_def_n tio_tr_module_n type_table_i type_tables; Nothing -> (fromJust tio_type_without_definition,type_tables) }; = (type_name,type_tables); get_type_name_from_type_tables dtr_tr_type_def_n dtr_tr_module_n type_table_i type_tables #! (tio_td_name,type_tables) = type_tables![type_table_i].tt_tio_common_defs.[dtr_tr_module_n].tio_com_type_defs.[dtr_tr_type_def_n].tio_td_name; #! (tis_string_table,type_tables) = type_tables![type_table_i].tt_type_io_state.tis_string_table; #! type_name = get_name_from_string_table tio_td_name tis_string_table; = (type_name,type_tables); get_module_name_from_type_tables {tio_type_without_definition=Just s} type_table_i type_tables # (type_name,module_name) = get_type_name_and_module_name_from_type_string s = (module_name,type_tables); get_module_name_from_type_tables {tio_tr_module_n=dtr_tr_module_n} type_table_i type_tables #! (tio_module,type_tables) = type_tables![type_table_i].tt_tio_common_defs.[dtr_tr_module_n].tio_module; #! (tis_string_table,type_tables) = type_tables![type_table_i].tt_type_io_state.tis_string_table; #! module_name = get_name_from_string_table tio_module tis_string_table; = (module_name,type_tables); print_type_redirection i type_reference (type_tables,file) // write #! file = fwrites SepSpaces file; #! file = ljustify_f s_dynamic_index_name (toString i) file; #! file = fwrites SepSpaces file; #! (type_name,type_tables) = get_type_name type_reference type_tables; #! file = fwrites type_name file; #! file = fwrites " " file; #! (type_tables,_,file) = print_type_equation i type_reference (type_tables,False,file) #! file = fwritec '\n' file; = (type_tables,file); print_type_equation i (LIT_TypeReference (LibRef disk_library_instance_i) tio_type_reference=:{tio_type_without_definition,tio_tr_module_n,tio_tr_type_def_n}) (type_tables,first_type_equation_printed,file) #! file = case (not first_type_equation_printed) of { True -> fwrites "(" file; _ -> fwrites ",(" file; }; #! (module_name,type_tables) = case tio_type_without_definition of { Nothing // The type equivalent equations may not contain predefined types without definition because they will // be mapped to a shared library instance which contains among other things the run-time system which // provides the definitions for these types. # type_table_i = get_index_in_di_library_index_to_library_name di_library_instance_to_library_index.[disk_library_instance_i]; # (module_name,type_tables) = get_module_name_from_type_tables tio_type_reference type_table_i type_tables; -> (module_name,type_tables); Just type_name -> (type_name,type_tables); }; #! file = fwrites module_name file; #! file = fwrites ("," +++ toString disk_library_instance_i +++ ")") file; = (type_tables,first_type_equation_printed,file); print_library_name s_column1 library_name_index library_name file // write library stringtable index #! file = fwrites SepSpaces file; #! file = ljustify_f s_column1 (toString library_name_index) file; // write library string #! file = fwrites SepSpaces file; #! file = fwrites (FILE_IDENTIFICATION (extract_dynamic_or_library_identification library_name) library_name) file; #! file = fwritec '\n' file; = file; print disk_library_instance_i maybe_library_name_index comments file // write library instance number #! file = fwrites SepSpaces file; #! file = ljustify_f s_library_instance (toString disk_library_instance_i) file; // write library stringtable index #! file = fwrites SepSpaces file; #! file = ljustify_f s_library_string_table_index (if (isNothing maybe_library_name_index) "" (fromJust maybe_library_name_index)) file; // write comments #! file = fwrites SepSpaces file; #! file = fwrites comments file; #! file = fwritec '\n' file; = file; print_library_instance disk_library_instance_i (LIK_LibraryInstance {LIK_LibraryInstance | lik_index_in_di_library_index_to_library_name}) file # library_name = di_library_index_to_library_name.[lik_index_in_di_library_index_to_library_name]; # comments = FILE_IDENTIFICATION (extract_dynamic_or_library_identification library_name) library_name; # file = print disk_library_instance_i (Just (toString lik_index_in_di_library_index_to_library_name)) comments file = file; s_library_instance = size library_instance; library_instance = "Instance"; library_instance_underlined = "--------"; s_library_string_table_index = size library_string_table_index; library_string_table_index = "String table index"; library_string_table_index_underlined = "------------------"; s_library_name = size library_name; library_name = "Library name"; library_name_underlined = "------------"; s_dynamic_index_name = size dynamic_index_name; dynamic_index_name = "Index"; dynamic_index_underlined = "-----"; s_external_dynamic_name = size external_dynamic_name; external_dynamic_name = "Name"; external_dynamic_name_underlined = "----"; s_type_equivalent_class_name = size type_equivalent_class_name; type_equivalent_class_name = "Type name: (module name,ith library instance) - (module name,ith library instance,lazy dynamic index)"; type_equivalent_class_name_underlined = "-----------------------------------------------------------------------------------------------------"; s_type_redirection = size type_redirection; type_redirection = "Type redirection"; type_redirection_underlined = "----------------"; s_comments_name = size comments_name; comments_name = "Comments"; comments_name_underlined = "--------"; title = SepSpaces +++ library_instance +++ SepSpaces +++ library_string_table_index +++ SepSpaces +++ comments_name +++ "\n"; title_underlined = SepSpaces +++ library_instance_underlined +++ SepSpaces +++ library_string_table_index_underlined +++ SepSpaces +++ comments_name_underlined +++ "\n"; title2 = SepSpaces +++ library_string_table_index +++ SepSpaces +++ library_name +++ "\n"; title2_underlined = SepSpaces +++ library_string_table_index_underlined +++ SepSpaces +++ library_name_underlined +++ "\n"; title3 = SepSpaces +++ dynamic_index_name +++ SepSpaces +++ external_dynamic_name +++ "\n"; title3_underlined = SepSpaces +++ dynamic_index_underlined +++ SepSpaces +++ external_dynamic_name_underlined +++ "\n"; title4 = SepSpaces +++ dynamic_index_name +++ SepSpaces +++ type_equivalent_class_name +++ "\n"; title4_underlined = SepSpaces +++ dynamic_index_underlined +++ SepSpaces +++ type_equivalent_class_name_underlined +++ "\n"; title5 = SepSpaces +++ dynamic_index_name +++ SepSpaces +++ type_redirection +++ "\n"; title5_underlined = SepSpaces +++ dynamic_index_underlined +++ SepSpaces +++ type_redirection_underlined +++ "\n"; }; force_bool_array :: !*{*{#Bool}} -> *{*{#Bool}}; force_bool_array i = i; force_string_array :: !*{*{#{#Char}}} -> *{*{#{#Char}}}; force_string_array i = i; WriteGraph :: !*DescriptorAddressTable !BinaryDynamic *(Nodes NodeKind) !*File !*DDState -> *(*Nodes NodeKind,!*File,!*DescriptorAddressTable,!*DDState); WriteGraph desc_table=:{root_nodes} dynamic_info=:{header={graph_i,graph_s},graph,block_table,bd_dynamic_info={di_lazy_dynamics_a}} nodes file ddState=:{e__StdDynamic__rDynamicTemp} // to be moved; general #! (nodes_a,nodes) = get_nodes nodes; #! nodes_a = { convert_node node \\ node <-: nodes_a }; // specific for writegraph #! nodes = { nodes & nodes = nodes_a }; // header ... #! file = fwrites ("ENCODED GRAPH\n") file; #! file = write_entry2 graph_s "total size" file; #! file = write_entry2 graph_i "relative file pointer" file; #! file = fwritec '\n' file; #! file = write_title file; // ... header # n_blocks = size block_table; # block_strings = force_string_array { {} \\ _ <- [1..n_blocks] }; # line_is_node_start = force_bool_array { {} \\ _ <- [1..n_blocks] }; # indirections = force_bool_array { {} \\ _ <- [1..n_blocks] }; # (block_strings,line_is_node_start,indirections,nodes,markup_nodes) = loopAst convert_block_to_readable_string (block_strings,line_is_node_start,indirections,nodes,[]) n_blocks; # (file,desc_table,nodes) = mapAiSt (write_block line_is_node_start indirections) block_strings (file,desc_table,nodes); = (nodes,file,desc_table,ddState); where { write_block line_is_node_start indirections block_i block_string (file,desc_table,nodes) # file = fwrites ("\nBlock: " +++ toString block_i +++ "\n") file; # (file,desc_table,nodes) = mapAiSt write_line block_string (file,desc_table,nodes); = (file,desc_table,nodes) ; where { write_line ith_line string (file,desc_table,nodes) #! (index_in_desc_addr_table,desc_table) = desc_table!indices_array.[block_i]; #! extra = not line_is_node_start.[block_i].[ith_line]; #! graph_offset = (bk_offset + (ith_line << 2)); #! (_,file,_) = write_one_line block_i extra graph_offset file index_in_desc_addr_table graph [] dynamic_info; # (file,nodes) = case string of { "" | indirections.[block_i].[ith_line] #! reference = FromStringToInt graph graph_offset; | is_internal_reference reference # reference_relative_to_block_start = dereference_internal_reference (graph_offset - bk_offset) reference; #! (nodes1,nodes) = get_nodes nodes; #! (start_node_i,end_node_i) = root_nodes.[block_i]; #! (maybe_node_i,nodes1) = findAieuSE (find_internal_node reference_relative_to_block_start) start_node_i (inc end_node_i) nodes1; | isNothing maybe_node_i -> (fwrites ("CORRUPT: internal reference to ?? \n") file,nodes); #! node_i = fromJust maybe_node_i; #! nodes = { nodes & nodes = nodes1 }; -> (fwrites ("internal reference to " +++ node_index_to_string node_i +++ "\n") file,nodes); #! indirection_text = "external reference to block " +++ hex_int_without_prefixed_zeroes (get_block_i reference) +++ " with entry node " +++ hex_int_without_prefixed_zeroes (get_en_node_i reference) +++ "\n"; -> (fwrites indirection_text file,nodes); // no indirection; just empty -> (fwritec '\n' file,nodes); _ -> (fwrites (string +++ "\n") file,nodes); }; = (file,desc_table,nodes); bk_offset = block_table.[block_i].bk_offset; }; convert_block_to_readable_string block_i s=:(block_strings,line_is_node_start,indirections,nodes,markup_nodes) | False <<- ("???",block_i) = undef; #! bk_size = block_table.[block_i].bk_size; | False <<- ("convert_block_to_readable_string",block_i,bk_size >> 2) = undef; #! string = createArray (bk_size >> 2) ""; | False <<- ("aaaa",size string, bk_size) = undef; #! line_is_node_start_for_block_i = createArray (bk_size >> 2) False; #! indirection = createArray (bk_size >> 2) True; #! (start_node,end_node) = root_nodes.[block_i]; #! (string,line_is_node_start_for_block_i,indirection,nodes) = foldSt (line_print bk_size) [start_node..end_node] (string,line_is_node_start_for_block_i,indirection,nodes); #! indirections = { indirections & [block_i] = indirection }; #! line_is_node_start = { line_is_node_start & [block_i] = line_is_node_start_for_block_i }; #! (s_string,string) = usize string; #! block_strings = { block_strings & [block_i] = string }; = (block_strings,line_is_node_start,indirections,nodes,markup_nodes); where { get_nodes_size nodes1=:{nodes} # (size,nodes) = usize nodes; = (size,{nodes1 & nodes = nodes}); ({bk_offset,bk_size}) = block_table.[block_i]; line_print bk_size node_i (string,line_is_node_start_for_block_i,indirection,nodes) # (s_nodes,nodes) = get_nodes_size nodes; | not (between 0 node_i (dec s_nodes)) <<- ("line_print",node_i) = abort ("line_print; invalid range " +++ toString node_i +++ " in 0 - " +++ toString (dec s_nodes)); # (node=:{graph_index},nodes) = nodes!nodes.[node_i]; | graph_index == (-1) <<- ("graph_index",graph_index) = (string,line_is_node_start_for_block_i,indirection,nodes); # node_index_in_string = graph_index >> 2; | not (between 0 graph_index (dec bk_size)) = abort "line_print: block is corrupt"; // mark as node start # line_is_node_start_for_block_i = { line_is_node_start_for_block_i & [node_index_in_string] = True }; # (string,indirection) = case node.info of { NK -> (string,indirection); _ #! (end_node_index_in_string,string) = to_string node_index_in_string node string; | False <<- ("-- ",node_index_in_string,size string,end_node_index_in_string) -> undef; // test... #! (s_indirection,indirection) = usize indirection; | not ((between 0 node_index_in_string (dec s_indirection)) && (between 0 (dec end_node_index_in_string) (dec s_indirection))) -> abort ("kdkd" +++ toString end_node_index_in_string +++ toString s_indirection); // ...test #! indirection = { indirection & [line_i] = False \\ line_i <- [node_index_in_string..dec end_node_index_in_string] }; -> (string,indirection); }; = (string,line_is_node_start_for_block_i,indirection,nodes); where { prefix_string graph_index = node_index_to_string node_i +++ ": "; to_string node_index_in_string {info=IntLeaf _ (BV_Int int),graph_index} strings #! strings = { strings & [node_index_in_string] = prefix_string graph_index +++ "Int" , [node_index_in_string + 1] = toString int }; = (node_index_in_string + 2,strings); to_string node_index_in_string {info=CharLeaf _ (BV_Char chartje),graph_index} strings #! strings = { strings & [node_index_in_string] = prefix_string graph_index +++ "Char" , [node_index_in_string + 1] = toString chartje }; = (node_index_in_string + 2,strings); to_string node_index_in_string {info=RealLeaf _ (BV_Real realtje),graph_index} strings #! strings = { strings & [node_index_in_string] = prefix_string graph_index +++ "Real" , [inc node_index_in_string] = toString realtje }; = (node_index_in_string + 3,strings); to_string node_index_in_string {info=BoolLeaf _ (BV_Bool bool),graph_index} strings #! strings = { strings & [node_index_in_string] = prefix_string graph_index +++ "Bool" , [node_index_in_string + 1] = toString bool }; = (node_index_in_string + 2,strings); to_string node_index_in_string {children,info=Closure _ {ci_closure_name,ci_is_build_lazy_block,ci_args={rai_unboxed_args}},graph_index} strings #! children_string = map (\k -> " " +++ toString k) children; #! strings = { strings & [node_index_in_string] = prefix_string graph_index +++ (if (size rai_unboxed_args == 0) "Closure '" ("Unboxed closure " +++ toString (size rai_unboxed_args) +++ " '") ) +++ toString ci_closure_name +++ "'" +++ create_string children_string}; #! (is_lazy_block,node_index,dynamic_index) = isBuildLazyBlock ci_is_build_lazy_block; | is_lazy_block | not (between 0 dynamic_index (dec (size di_lazy_dynamics_a))) = abort "to_string (Closure): dynamic is corrupt"; #! strings = { strings & [node_index_in_string + 1] = "Block: " +++ toString (get_block_i node_index) +++ ", entry: " +++ toString (get_en_node_i node_index) , [node_index_in_string + 2] = "Dynamic index: " +++ toString dynamic_index +++ " '" +++ di_lazy_dynamics_a.[dynamic_index] +++ "'" }; = (node_index_in_string + 3,strings); #! strings = foldSt (\i strings -> {strings & [node_index_in_string + i] = f (rai_unboxed_args.[dec i]) } ) [1..size rai_unboxed_args] strings; with { f (BV_Unknown i) = toString i +++ " (Unknown type)"; } = (node_index_in_string + 1 + size rai_unboxed_args,strings); to_string node_index_in_string {children,info=Record _ _ _ _ {ri_descriptor_name,ri_args},graph_index} strings | False <<- ("Record", children) = undef; // #! (n_unboxed_args,n_boxed_args) = (size ri_args.rai_unboxed_args, ri_args.rai_n_boxed_args); // create node_string #! children_string = map (\k -> " " +++ toString k) children; #! node_string = prefix_string graph_index +++ ri_descriptor_name +++ create_string children_string // +++ " >>" +++ toString n_unboxed_args +++ " " +++ toString n_boxed_args; #! strings = { strings & [node_index_in_string] = node_string }; #! (node_index_in_string_end_unboxed_args,strings) = mapAiSt (to_string_unboxed_record_arg False) ri_args.rai_unboxed_args (inc node_index_in_string,strings); = (node_index_in_string_end_unboxed_args,strings); // Node to_string node_index_in_string {info=StringLeaf _ _ {si_string},graph_index} strings #! strings = { strings & [node_index_in_string] = prefix_string graph_index +++ "String" , [node_index_in_string + 1] = toString (size si_string) , [node_index_in_string + 2] = "'" +++ si_string +++ "'" }; = (node_index_in_string + 2 /* ERROR */ + ((roundup_to_multiple (size si_string) ALIGNMENT) >> 2),strings); to_string node_index_in_string {info=Dynamic _ _ _ _ _} strings = abort "dynamics are not recognised"; to_string node_index_in_string {children,info=ArrayNode _ _ _ _ {ai_n_elements,ai_element_descriptor,ai_record_args_info},graph_index} strings | False <<- ("ArrayNode") = undef; #! children_string = map (\k -> " " +++ toString k) children; #! node_string = prefix_string graph_index +++ "Array" +++ create_string children_string #! strings = { strings & [node_index_in_string] = node_string }; #! strings = { strings & [inc node_index_in_string] = "size: " +++ toString ai_n_elements}; #! strings = { strings & [node_index_in_string + 2] = "element: " +++ toString ai_element_descriptor}; // print all unboxed arguments #! is_unboxed_value_record = case ai_element_descriptor of { AED_BasicValue _ -> True; _ -> False; }; #! (node_index_in_string,strings) = mapASt (to_string_unboxed_records is_unboxed_value_record) ai_record_args_info (node_index_in_string + 3,strings); = (node_index_in_string,strings); where { to_string_unboxed_records is_unboxed_value_record record_args_info (node_index_in_string,strings) #! (node_index_in_string,strings) = mapAiSt (to_string_unboxed_record_arg is_unboxed_value_record) record_args_info.rai_unboxed_args (node_index_in_string,strings); = (node_index_in_string,strings); }; }; // line_print } }; instance toString ArrayElementDescriptor where { toString (AED_BasicValue basic_value_kind) = toString basic_value_kind; toString (AED_Record descriptor_name) = descriptor_name; toString AED_Boxed = "Boxed"; }; instance toString BasicValueKind where { toString BVK_Int = "Int"; toString BVK_Real = "Real"; toString BVK_Bool = "Bool"; }; decode_descriptor_offset :: !DynamicHeader !{#Int} !Int !{#Char} -> (Int,Int,Int); decode_descriptor_offset header indices graph_o graph // | F ("graph_o: " +++ toString graph_o +++ " size graph: " +++ toString (size graph)) True # (prefix,partial_arity,expanded_desc_table_o) = decode_descriptor_offset2 graph_o graph; # expanded_desc_table_o = if (DYNAMIC_CONTAINS_BLOCKTABLE header) indices.[expanded_desc_table_o] expanded_desc_table_o; = (prefix,partial_arity,expanded_desc_table_o); check :: !.a -> .a; check i | F "Check" True = i; WriteBlockTable :: !BinaryDynamic !*File -> *File; WriteBlockTable dynamic_info=:{header={block_table_i,block_table_s},block_table,graph,block_table_as_string} file | not (DYNAMIC_CONTAINS_BLOCKTABLE dynamic_info.header) = file; #! file = write_header file; #! (offset,file) = write_entry 0 ("number of blocks " +++ hex_int_without_prefixed_zeroes ( FromStringToInt block_table_as_string 0) ) file; #! file = fwritec '\n' file; #! file = loop offset block_table_s file; = file; where { loop offset limit file | offset == limit = file; #! block_i = FromStringToInt block_table_as_string offset; #! bk_offset = block_table.[block_i].bk_offset #! (offset,file) = write_entry offset ("Block " +++ hex_int_without_prefixed_zeroes block_i) file; #! (offset,file) = write_entry offset ("Block starts at " +++ hex_int_without_prefixed_zeroes bk_offset) file; #! (offset,file) = write_entry offset ("Block size " +++ hex_int_without_prefixed_zeroes block_table.[block_i].bk_size) file; #! bk_entries = block_table.[block_i].bk_entries; #! (offset,file) = write_entry offset ("Node entries: " +++ (hex_int_without_prefixed_zeroes ((if ((size bk_entries) == 0) 1 0) + block_table.[block_i].bk_n_node_entries))) file; #! (offset,file) = case ((size bk_entries) == 0) of { True -> (offset,file); False -> write_entry_node_offsets 0 (size bk_entries) offset file bk_entries bk_offset; }; #! file = fwritec '\n' file; = loop offset limit file; write_entry_node_offsets i limit offset file bk_entries bk_offset | i == limit = (offset,file); #! (offset,file) = write_entry offset ("Entry node " +++ hex_int_without_prefixed_zeroes i +++ " at offset " +++ hex_int_without_prefixed_zeroes (bk_entries.[i] - bk_offset)) file; = write_entry_node_offsets (inc i) limit offset file bk_entries bk_offset; write_entry offset title file // Offset #! file = fwrites SepSpaces file; #! file = fwrites (hex_int offset) file; // Raw data #! file = fwrites SepSpaces file; #! file = fwrites (hex_int (FromStringToInt block_table_as_string offset)) file; #! file = fwrites SepSpaces file; #! file = fwrites title file; #! file = fwritec '\n' file; = (offset + 4,file); write_header file #! file = fwrites "BLOCK TABLE\n" file; #! file = write_entry2 block_table_s "entries" file; #! file = write_entry2 block_table_i "relative file pointer" file; #! file = fwritec '\n' file; #! file = fwrites title file; #! file = fwritec '\n' file; #! file = fwrites title_underlined file; #! file = fwritec '\n' file; = file; offset_raw_data_text // 12345678 12345678901 = "Offset " +++ SepSpaces +++ "Raw data" +++ SepSpaces; offset_raw_data_underlined = "--------" +++ SepSpaces +++ "--------" +++ SepSpaces; title = SepSpaces +++ offset_raw_data_text +++ "Comment"; title_underlined = SepSpaces +++ offset_raw_data_underlined +++ "-------"; } // WriteBlockTable