implementation module DLState; // Linkers from containers import arg_is_strict; EXTEND_TYPE_INFO yes no :== no; import SearchObject; import ReadObject; import SortSymbols; import link_library_instance; // StdEnv import StdEnv; // Linker import State; import ProcessSerialNumber; from typetable import hashValue; // Ext import ExtList; import Set; import StdEnv; //import ClientWindow; import DynamicLink; import Directory; import ExtInt; import dynamics; // internal constants for dynamics import DynamicID; import StdDynamicLowLevelInterface; import typetable; import MemoryState; import LibraryInstance; import type_io_equal_types; import TypeImplementationTable; import ToAndFromGraph; import ToAndFromGraph; import ExtList; import link_switches; from utilities import fold2St; :: *DLServerState = { // general data quit_server :: !Bool , application_path :: !String , static_application_as_client :: !Bool // clients , dl_client_states :: *[*DLClientState] // client windows , global_client_window :: !GlobalClientWindow // conversions , convert_functions :: !ConvertFunctions // NEW TO HANDLE .LIB DEMANDS , dlss_lib_mode :: !Bool , dlss_lib_command_line :: !{{#Char}} }; instance DefaultElemU DLServerState where { default_elemU = { // general data quit_server = False , application_path = "" , static_application_as_client = False // clients , dl_client_states = [] // client windows , global_client_window = DefaultGlobalClientWindow // conversions , convert_functions = default_convertfunctions // NEW TO HANDLE .LIB DEMANDS , dlss_lib_mode = False , dlss_lib_command_line = {} }; }; AddToDLServerState :: *DLClientState *DLServerState -> *DLServerState; AddToDLServerState dl_client_state dl_server_state=:{dl_client_states} #! dl_server_state = { dl_server_state & dl_client_states = [dl_client_state:dl_client_states] }; = dl_server_state; RemoveFromDLServerState :: !ProcessSerialNumber !*DLServerState -> (!Bool,!*DLClientState,!*DLServerState); RemoveFromDLServerState client_id dl_server_state=:{dl_client_states} #! (l,r) = splitAtPred f dl_client_states [] []; #! (l_empty,l) = is_empty l; | not l_empty #! dl_server_state = { dl_server_state & dl_client_states = r }; = (True,hd l,dl_server_state); = (False,default_elemU,{dl_server_state & dl_client_states = r}); where { f dl_client_state=:{id} = (id == client_id,dl_client_state); }; acc_dl_client_states :: ([*DLClientState] -> (.x,[*DLClientState])) !*DLServerState -> (.x,!*DLServerState); acc_dl_client_states f dl_server_state=:{dl_client_states} #! (x,dl_client_states) = f dl_client_states; = (x, {dl_server_state & dl_client_states = dl_client_states} ); app_dl_client_states :: ([*DLClientState] -> [*DLClientState]) !*DLServerState -> *DLServerState; app_dl_client_states f dl_server_state=:{dl_client_states} = {dl_server_state & dl_client_states = f dl_client_states}; selacc_client_state :: !ProcessSerialNumber (*DLClientState -> (.x,*DLClientState)) !*DLServerState -> (.x,!*DLServerState); selacc_client_state client_id g dl_server_state=:{dl_client_states} #! (l,r) = splitAtPred f dl_client_states [] []; #! (l_empty,l) = is_empty l; | not l_empty #! (x,l) = g (hd l); #! dl_server_state = { dl_server_state & dl_client_states = [l:r] }; = (x,dl_server_state); where { f dl_client_state=:{id} = (id == client_id,dl_client_state); }; selacc_app_linker_state :: !ProcessSerialNumber !(*State -> *(.a,*State)) !*DLServerState -> *(.a,*DLServerState); selacc_app_linker_state client_id f dl_server_state #! (x,dl_server_state) = selacc_client_state client_id w dl_server_state; = (x,dl_server_state); where { w dl_client_state=:{app_linker_state} #! (x,app_linker_state) = f app_linker_state; = (x, {dl_client_state & app_linker_state = app_linker_state}); }; :: *DLClientState = { // client identification id :: !ProcessSerialNumber , initial_link :: !Bool // application linker state , app_linker_state :: !*State // client window , client_window :: !ClientWindow // support for block dynamics (only one , dynamic_ids :: !*DynamicID // Library implementation , cs_main_library_name :: !String , cs_type_tables :: !*{#TypeTable} , cs_dynamic_info :: !*{#DynamicInfo} , cs_library_instances :: !*LibraryInstances // all info specific to a library instance , cs_main_library_instance_i :: !Maybe Int , cs_intra_type_equalities :: !*EqTypesState , cs_type_implementation_table :: *TypeImplementationTable , cs_to_and_from_graph :: !ToAndFromGraphTable , cs_n_fixed_available_types :: !Maybe Int , do_dump_dynamic :: !Bool , cs_n_lazy_dynamics :: !Int // first free dynamic , cs_lazy_dynamic_index_to_dynamic_id :: !*{#LazyDynamicInfo} // indexed by lazy_dynamic_index (rt) with No meaning not initialized, Yes is initialized and dynamic id is the integer , cs_share_runtime_system :: !Bool , cs_conversion :: ![ConversionInfo] , cs_dlink_dir :: !String }; :: ConversionInfo = { ci_version :: !Version , ci_has_from_graph_been_added :: !Bool , ci_has_to_graph_been_added :: !Bool }; :: LazyDynamicInfo = { ldi_lazy_dynamic_index_to_dynamic :: !Maybe Int , ldi_parent_index :: !Int // index in cs_dynamic_info }; instance DefaultElem LazyDynamicInfo where { default_elem = { ldi_lazy_dynamic_index_to_dynamic = Nothing , ldi_parent_index = 0xffffffff }; }; instance DynamicIDs DLClientState where { new_dynamic_id dl_client_state=:{dynamic_ids} # (id,dynamic_ids) = new_dynamic_id dynamic_ids; = (id,{dl_client_state & dynamic_ids = dynamic_ids}); free_dynamic_id id dl_client_state=:{dynamic_ids} # dynamic_ids = free_dynamic_id id dynamic_ids; = {dl_client_state & dynamic_ids = dynamic_ids}; is_valid_id id dl_client_state=:{dynamic_ids} # dynamic_ids = is_valid_id id dynamic_ids; = {dl_client_state & dynamic_ids = dynamic_ids}; is_valid_id2 id dl_client_state=:{dynamic_ids} # (ok,dynamic_ids) = is_valid_id2 id dynamic_ids; = (ok,{dl_client_state & dynamic_ids = dynamic_ids}); }; acc_dynamic_ids :: (*DynamicID -> (.x,!*DynamicID)) !*DLClientState -> (.x,!*DLClientState); acc_dynamic_ids f dl_client_state=:{dynamic_ids} # (x,dynamic_ids) = f dynamic_ids; = (x,{dl_client_state & dynamic_ids = dynamic_ids}); instance DefaultElemU DLClientState where { default_elemU = { // client identification id = DefaultProcessSerialNumber , initial_link = False // application linker state , app_linker_state = EmptyState // client window , client_window = DefaultClientWindow // support for block dynamics , dynamic_ids = default_dynamic_id // Library implementation , cs_main_library_name = {} , cs_type_tables = {} , cs_dynamic_info = {} , cs_library_instances = default_library_instances , cs_main_library_instance_i = Nothing , cs_intra_type_equalities = default_eq_types_state , cs_type_implementation_table = default_type_implementation_table , cs_to_and_from_graph = default_elemU , cs_n_fixed_available_types = Nothing , do_dump_dynamic = False , cs_n_lazy_dynamics = INITIAL_LAZY_DYNAMIC_INDEX , cs_lazy_dynamic_index_to_dynamic_id = createArray INITIAL_LAZY_DYNAMIC_INDEX default_elem , cs_share_runtime_system = False , cs_conversion = [] , cs_dlink_dir = "" }; }; // ADDED instance AddMessage DLClientState where { AddMessage linker_message dl_client_state=:{app_linker_state} #! app_linker_state = AddMessage linker_message app_linker_state; = {dl_client_state & app_linker_state = app_linker_state}; IsErrorOccured dl_client_state=:{app_linker_state} #! (ok,app_linker_state) = IsErrorOccured app_linker_state; = (ok,{dl_client_state & app_linker_state = app_linker_state}); GetLinkerMessages dl_client_state=:{app_linker_state} #! (messages,app_linker_state) = GetLinkerMessages app_linker_state; = (messages,{ dl_client_state & app_linker_state = app_linker_state }); SetLinkerMessages messages dl_client_state=:{app_linker_state} #! app_linker_state = SetLinkerMessages messages app_linker_state; = {dl_client_state & app_linker_state = app_linker_state}; }; app_state :: (*State -> *State) !*DLClientState -> *DLClientState; app_state f dl_client_state=:{app_linker_state} = { dl_client_state & app_linker_state = f app_linker_state }; acc_state :: (*State -> (!.x,!*State)) !*DLClientState -> (!.x,*DLClientState); acc_state f dl_client_state=:{app_linker_state} # (x,app_linker_state) = f app_linker_state; = (x,{dl_client_state & app_linker_state = app_linker_state}); class AppPdState s where { app_pd_state :: !(*PDState -> *PDState) !*s -> *s }; instance AppPdState DLClientState where { app_pd_state f dl_client_state = app_state (\s=:{pd_state} -> {s & pd_state = f pd_state}) dl_client_state }; instance AppPdState State where { app_pd_state f state=:{pd_state} = {state & pd_state = f pd_state}; }; class AccPdState s where { acc_pd_state :: !(*PDState -> (!.x,!*PDState)) !*s -> (!.x,!*s) }; instance AccPdState State where { acc_pd_state f state=:{pd_state} #! (x,pd_state) = f pd_state; = (x,{ state & pd_state = pd_state}); }; instance AccPdState DLClientState where { acc_pd_state f dl_client_state=:{app_linker_state} #! (x,app_linker_state) = acc_pd_state f app_linker_state; = (x,{dl_client_state & app_linker_state = app_linker_state}); }; // -------------------------------------------------------------------------------------------------------------------------- // VERSION MANAGEMENT OF CONVERSION FUNCTIONS :: ConvertFunctions = { graph_to_string :: [Version] , string_to_graph :: [Version] }; default_convertfunctions :: ConvertFunctions; default_convertfunctions = { ConvertFunctions | graph_to_string = [] , string_to_graph = [] }; /* ** Two situations at the moment, looking for ** - an appropriate graph_to_string function (write) ** The highest major and minor version are being used to store dynamics. ** - an appropriate string_to_graph function (read) ** The expected and required major version numbers *must* match. Because ** minor version number stand for non-structural bugfixes, the highest ** minor version is taken. ** ** The situation is different when using unique and/or lazy read and written ** dynamics. An unique dynamic should probably always be saved using the ** major version used during storing of the dynamic, the minor could be the ** most recent. This is also valid for a lazily read or written dynamic. ** ** The major version number is mainly for (large) structural changes to the ** conversion functions e.g. the arity of each function is stored in five ** bits, hence an arity of maximal 31 is the limit. This can be improved by ** making the reasonable assumption that a partial arity of 30 should be ** enough. The full arity whatever it is can then be represented by zero. In ** this case zero is interpreted differently, so a major version change is ** necessary. ** An example for minor change is a check that the arity of the function is ** smaller than the 31-limit. This change is minor because it does not affect ** the interpretation of the dynamic. ** ** hex ASCII representation of the 4 byte version number: ** 0 (msb): reserved e.g. flags for endianess, without pointers/with pointers, uniqueness or not ** 1 : major, higher part ** 2 : major, lower part ** 3 : minor */ eager_read_version :: !Version !*DLClientState !*DLServerState -> (!Bool,!Version,!*DLClientState,!*DLServerState); eager_read_version {major=major_required} dl_client_state dl_server_state=:{convert_functions={string_to_graph}} #! minors = filter (\{major} -> major == major_required) string_to_graph; | isEmpty minors #! msg = "No string_to_graph function with major version " +++ toString major_required +++ " present" #! dl_client_state = AddMessage (LinkerError msg) dl_client_state; = (False,DefaultVersion,dl_client_state,dl_server_state); // at least one minor present = (True,last minors,dl_client_state,dl_server_state); eager_write_version :: !*DLClientState !*DLServerState -> (!Bool,!Version,!*DLClientState,!*DLServerState); eager_write_version dl_client_state dl_server_state=:{convert_functions={graph_to_string=[]}} = abort "eager_write_version; there are no conversion functions"; eager_write_version dl_client_state dl_server_state=:{convert_functions={graph_to_string}} = (True,last graph_to_string,dl_client_state,dl_server_state); import ExtString; import directory_structure; GetDynamicLinkerDirectory :: !*DLServerState -> (!String,!*DLServerState); GetDynamicLinkerDirectory dl_server_state=:{application_path} = (application_path +++ "\\" +++ DS_CONVERSION_DIR,dl_server_state); InitServerState :: !*DLServerState !*a -> (!*DLServerState,!*a) | FileEnv a; InitServerState dl_server_state=:{convert_functions} io #! (dlink_dir,dl_server_state) = GetDynamicLinkerDirectory dl_server_state; #! ((ok,dlink_path),io) = accFiles (pd_StringToPath dlink_dir) io | not ok = abort "InitServerState: internal error 1"; #! ((dir_error,dir_entries),io) = accFiles (getDirectoryContents dlink_path) io | dir_error <> NoDirError = abort "InitServerState: internal error 2"; #! (graph_to_string,string_to_graph) = build_conversions dir_entries [] []; #! convert_functions = { convert_functions & graph_to_string = sortBy less_version graph_to_string , string_to_graph = sortBy less_version string_to_graph }; #! dl_server_state = { DLServerState | dl_server_state & convert_functions = convert_functions }; = (dl_server_state,io); where { // smallest major and minor at start of the version list less_version {major=major1,minor=minor1} {major=major2,minor=minor2} | major1 < major2 = True; | major1 == major2 = minor1 < minor2; = False; // foldSt build_conversions [] graph_to_string string_to_graph = (graph_to_string,string_to_graph); build_conversions [{fileName}:ds] graph_to_string string_to_graph #! (found,s_prefix) = starts copy_graph_to_string_0x fileName; | not found #! (found,s_prefix) = starts copy_string_to_graph_0x fileName; | not found = build_conversions ds graph_to_string string_to_graph; // a string_to_graph function found #! version = from_base_i fileName 16 s_prefix 8; = build_conversions ds graph_to_string [toVersion version:string_to_graph]; // a graph_to_string function #! version = from_base_i fileName 16 s_prefix 8; = build_conversions ds [toVersion version:graph_to_string] string_to_graph; copy_graph_to_string_0x => copy_graph_to_string +++ "_0x"; copy_string_to_graph_0x => copy_string_to_graph +++ "_0x"; } instance TypeTableOps DLClientState where { AddReferenceToTypeTable type_table_reference dl_client_state # (cs_type_tables,dl_client_state) = get_type_tables dl_client_state; # (type_table_index,cs_type_tables) = AddReferenceToTypeTable type_table_reference cs_type_tables; # dl_client_state = { dl_client_state & cs_type_tables = cs_type_tables }; = (type_table_index,dl_client_state); AddTypeTable type_table_index type_table dl_client_state # (cs_type_tables,dl_client_state) = get_type_tables dl_client_state; # cs_type_tables = AddTypeTable type_table_index type_table cs_type_tables; # dl_client_state = { dl_client_state & cs_type_tables = cs_type_tables }; = dl_client_state; }; get_type_tables :: !*DLClientState -> *(*{#*TypeTable},*DLClientState); get_type_tables dl_client_state=:{cs_type_tables} = (cs_type_tables,{dl_client_state & cs_type_tables = {}}); get_ets :: !*DLClientState -> *(!*EqTypesState,*DLClientState); get_ets dl_client_state=:{cs_intra_type_equalities} = (cs_intra_type_equalities,{dl_client_state & cs_intra_type_equalities = default_eq_types_state}); get_type_implementation_table :: !*DLClientState -> (!*TypeImplementationTable,!*DLClientState); get_type_implementation_table dl_client_state=:{cs_type_implementation_table} = (cs_type_implementation_table,{dl_client_state & cs_type_implementation_table = default_type_implementation_table}); instance DynamicInfoOps DLClientState where { UpdateDynamicInfo dynamic_info_index dynamic_info dl_client_state # (cs_dynamic_info,dl_client_state) = get_dynamic_infos dl_client_state; # cs_dynamic_info = UpdateDynamicInfo dynamic_info_index dynamic_info cs_dynamic_info # dl_client_state = { dl_client_state & cs_dynamic_info = cs_dynamic_info }; = dl_client_state; }; get_dynamic_infos dl_client_state=:{cs_dynamic_info} = (cs_dynamic_info,{dl_client_state & cs_dynamic_info = {}}); instance Library_Instances DLClientState where { AddLibraryInstance dynamic_index library_name type_table_i dl_client_state=:{cs_library_instances} # (library_instance_i,cs_library_instances) = AddLibraryInstance dynamic_index library_name type_table_i cs_library_instances; = (library_instance_i,{dl_client_state & cs_library_instances = cs_library_instances}); }; import ExtArray; from type_io_common import PredefinedModuleName; from utilities import foldSt; print_type_implementation_table :: !*DLClientState -> *DLClientState; print_type_implementation_table dl_client_state # (n_type_implementations,dl_client_state) = dl_client_state!cs_type_implementation_table.teit_n_type_implementations; # msg = if IS_COLLECT_AND_RENUMBER_EXTERNAL_TYPE_REFERENCES "Type Implementation Table (format: module_name\nor ?(ith_type_redirection_entry,rt_lazy_dynamic_index)" "Type Implementation Table (format: module_name\nor ?(disk_library_instance,rt_lazy_dynamic_index)" ; # dl_client_state = AddMessage (Verbose msg) dl_client_state; = loopAst print_type_implementation dl_client_state n_type_implementations; where { print_type_implementation type_implementation_ref dl_client_state // | True // = dl_client_state; // get implementation type to be printed # ({tei_type_implementations,tei_chosen_type_implementation},dl_client_state) = dl_client_state!cs_type_implementation_table.teit_type_implementations_a.[type_implementation_ref]; // get names # ((type_name,_,_,_,_),dl_client_state) = get_info_library_instance_type_reference (hd tei_type_implementations) dl_client_state; // determine the type implementation used, if any # (used_implementation,dl_client_state) = case tei_chosen_type_implementation of { Nothing -> ("No",dl_client_state); Just chosen_type # (chosen_type,dl_client_state) = get_info_library_instance_type_reference chosen_type dl_client_state; -> (make_module_name chosen_type,dl_client_state); }; // convert equivalences to string # (type_equivalences_as_string,dl_client_state) = foldSt f tei_type_implementations ("",dl_client_state); # msg = toString type_implementation_ref +++ " (" +++ type_name +++ ","+++ used_implementation +++ "):" +++ type_equivalences_as_string; # dl_client_state = AddMessage (Verbose msg) dl_client_state; = dl_client_state; // 0: Tree; module_name; chosen: none where { make_module_name (type_name,module_name,type_table_i,library_instance_i,tio_type_ref) = module_name +++ "<" +++ toString type_table_i +++ "," +++ toString library_instance_i +++ (make_string tio_type_ref) +++ ">"; where { make_string {tio_type_without_definition,tio_tr_module_n,tio_tr_type_def_n} #! s1 = if (isNothing tio_type_without_definition) "Nothing" ("Just " +++ fromJust tio_type_without_definition); #! s2 = toString tio_tr_module_n #! s3 = toString tio_tr_type_def_n = EXTEND_TYPE_INFO (" ! " +++ s1 +++ " " +++ s2 +++ " " +++ s3) ""; }; f library_instance_type_reference (s,dl_client_state) # (type_info,dl_client_state) = get_info_library_instance_type_reference library_instance_type_reference dl_client_state; = (s +++ " " +++ make_module_name type_info,dl_client_state); }; }; get_info_library_instance_type_reference :: !LibraryInstanceTypeReference !*DLClientState -> ((!String,!String,Int,Int,TIO_TypeReference),*DLClientState); get_info_library_instance_type_reference q=:(LIT_TypeReference (LibRefViaLazyDynamic disk_library_instance rt_lazy_dynamic_index type_table_i) tio_type_ref) dl_client_state | IS_COLLECT_AND_RENUMBER_EXTERNAL_TYPE_REFERENCES = abort "get_info_library_instance_type_reference; switch COLLECT_AND_RENUMBER_EXTERNAL_TYPE_REFERENCES off"; # (type_name,module_name,dl_client_state) = get_names tio_type_ref type_table_i dl_client_state; = ((type_name,module_name,disk_library_instance,rt_lazy_dynamic_index,tio_type_ref),dl_client_state); get_info_library_instance_type_reference q=:(LIT_TypeReference (LazyLibRef type_redirection_table_i rt_lazy_dynamic_index type_table_i) tio_type_ref) dl_client_state | not IS_COLLECT_AND_RENUMBER_EXTERNAL_TYPE_REFERENCES = abort "get_info_library_instance_type_reference; switch COLLECT_AND_RENUMBER_EXTERNAL_TYPE_REFERENCES on"; # (type_name,module_name,dl_client_state) = get_names tio_type_ref type_table_i dl_client_state; // DANGEROUS #! disk_library_instance = type_redirection_table_i; = ((type_name,module_name,disk_library_instance,rt_lazy_dynamic_index,tio_type_ref),dl_client_state); get_info_library_instance_type_reference (LIT_TypeReference (LibRef library_instance_i) tio_type_ref) dl_client_state # (type_table_i,dl_client_state) = dl_client_state!cs_library_instances.lis_library_instances.[library_instance_i].li_type_table_i; # (type_name,module_name,dl_client_state) = get_names tio_type_ref type_table_i dl_client_state; = ((type_name,module_name,type_table_i,library_instance_i,tio_type_ref),dl_client_state); // where { get_names {tio_type_without_definition=Just type_name} type_table_i dl_client_state = (type_name,PredefinedModuleName,dl_client_state); get_names {tio_type_without_definition=Nothing,tio_tr_module_n,tio_tr_type_def_n} type_table_i dl_client_state #! (string_table,dl_client_state) = dl_client_state!cs_type_tables.[type_table_i].tt_type_io_state.tis_string_table; // get type name #! (tio_td_name,dl_client_state) = dl_client_state!cs_type_tables.[type_table_i].tt_tio_common_defs.[tio_tr_module_n].tio_com_type_defs.[tio_tr_type_def_n].tio_td_name; # type_name = get_name_from_string_table tio_td_name string_table; // get module name #! (tio_module,dl_client_state) = dl_client_state!cs_type_tables.[type_table_i].tt_tio_common_defs.[tio_tr_module_n].tio_module; # module_name = get_name_from_string_table tio_module string_table; = (type_name,module_name,dl_client_state); // }; get_from_graph_function_address2 :: !(Maybe Version) !*DLClientState -> (ToAndFromGraphEntry,ToAndFromGraphEntryIndex,!*DLClientState); get_from_graph_function_address2 maybe_version dl_client_state #! (cs_to_and_from_graph,dl_client_state) = get_cs_to_and_from_graph dl_client_state; #! (x1,x2,cs_to_and_from_graph) = get_from_graph_function_address maybe_version cs_to_and_from_graph; #! dl_client_state = { dl_client_state & cs_to_and_from_graph = cs_to_and_from_graph }; = (x1,x2,dl_client_state); get_to_graph_function_address2 :: !(Maybe Version) !*DLClientState -> (Maybe (ToAndFromGraphEntry,ToAndFromGraphEntryIndex),!*DLClientState); get_to_graph_function_address2 maybe_version dl_client_state #! (cs_to_and_from_graph,dl_client_state) = get_cs_to_and_from_graph dl_client_state; #! (x,cs_to_and_from_graph) = get_to_graph_function_address maybe_version cs_to_and_from_graph; #! dl_client_state = { dl_client_state & cs_to_and_from_graph = cs_to_and_from_graph }; = (x,dl_client_state); get_cs_to_and_from_graph dl_client_state=:{cs_to_and_from_graph} = (cs_to_and_from_graph,{dl_client_state & cs_to_and_from_graph = default_elemU}); instance symbol_n_to_offset DLClientState where { symbol_n_to_offset file_n symbol_n dl_client_state #! (symbol_index,dl_client_state) = acc_state (\state -> symbol_n_to_offset file_n symbol_n state) dl_client_state; = (symbol_index,dl_client_state); }; check_whether_implementation_is_available :: !Int !String !*DLClientState -> (!Bool,!*DLClientState); check_whether_implementation_is_available library_instance_i label_name dl_client_state #! (bool,_,_,dl_client_state) = check_whether_implementation_is_available2 library_instance_i label_name dl_client_state; = (bool,dl_client_state); check_whether_implementation_is_available2 :: !Int !String !*DLClientState -> (!Bool,!Maybe Int,!Maybe (!Int,!Int),!*DLClientState); check_whether_implementation_is_available2 library_instance_i label_name dl_client_state #! (li_library_initialized,dl_client_state) = dl_client_state!cs_library_instances.lis_library_instances.[library_instance_i].li_library_initialized; | not li_library_initialized #! dl_client_state = dl_client_state; = (False,Nothing,Nothing,dl_client_state); #! (maybe_file_n_symbol_n,dl_client_state) = findLabel label_name library_instance_i dl_client_state; | isNothing maybe_file_n_symbol_n #! dl_client_state = dl_client_state; = (False,Nothing,Nothing,dl_client_state); #! (file_n,symbol_n) = fromJust maybe_file_n_symbol_n; #! (maybe_address,dl_client_state) = isLabelImplemented file_n symbol_n dl_client_state; | False <<- ("check_whether_implementation_is_available2", label_name, maybe_file_n_symbol_n, maybe_address) = undef; = (isJust maybe_address,maybe_address,maybe_file_n_symbol_n,dl_client_state); findLabel :: !String !Int !*DLClientState -> (!Maybe (!Int,!Int),!*DLClientState); findLabel label_name library_instance_i dl_client_state #! (names_table_element,dl_client_state) = find_symbol_in_symbol_table_new label_name (\index dl_client_state -> dl_client_state!cs_library_instances.lis_library_instances.[library_instance_i].li_names_table.[index]) dl_client_state; #! label_name_found = get names_table_element; = (label_name_found,dl_client_state); where { get (NamesTableElement _ symbol_n file_n _) = Just (file_n,symbol_n); get _ = Nothing; }; isLabelImplemented :: !Int !Int !*DLClientState -> (!Maybe Int,!*DLClientState); isLabelImplemented file_n symbol_n dl_client_state | file_n < 0 = abort "isLabelImplemented; internal error; cannot deal with file_n < 0"; #! (first_symbol_n,dl_client_state) = dl_client_state!app_linker_state.marked_offset_a.[file_n]; #! (marked,dl_client_state) = dl_client_state!app_linker_state.marked_bool_a.[first_symbol_n+symbol_n]; | not marked = (Nothing,dl_client_state); #! (symbol_address,dl_client_state) = acc_state (address_of_label2 file_n symbol_n) dl_client_state; = (Just symbol_address,dl_client_state); isTypeImplemented :: !LibraryInstanceTypeReference !*DLClientState -> (!Maybe (!String,[String]),*DLClientState); isTypeImplemented library_instance_type_reference dl_client_state = isTypeImplemented2 allSt library_instance_type_reference dl_client_state; isAnyConstructorOfTypeImplemented :: !LibraryInstanceTypeReference !*DLClientState -> (!Maybe (!String,[String]),*DLClientState); isAnyConstructorOfTypeImplemented library_instance_type_reference dl_client_state = isTypeImplemented2 anySt library_instance_type_reference dl_client_state; from type_io_common import UnderscoreSystemModule; import predefined_types; isTypeImplemented2 all_or_any (LIT_TypeReference (LazyLibRef _ _ _) _) dl_client_state | not IS_COLLECT_AND_RENUMBER_EXTERNAL_TYPE_REFERENCES = abort "isTypeImplemented2; switch COLLECT_AND_RENUMBER_EXTERNAL_TYPE_REFERENCES on"; = (Nothing,dl_client_state); isTypeImplemented2 all_or_any (LIT_TypeReference (LibRefViaLazyDynamic _ _ _) _) dl_client_state | IS_COLLECT_AND_RENUMBER_EXTERNAL_TYPE_REFERENCES = abort "isTypeImplemented2; switch COLLECT_AND_RENUMBER_EXTERNAL_TYPE_REFERENCES off"; = (Nothing,dl_client_state); isTypeImplemented2 all_or_any (LIT_TypeReference (LibRef library_instance_i) tio_type_reference=:{tio_type_without_definition=Nothing}) dl_client_state #! (li_type_table_i,dl_client_state) = dl_client_state!cs_library_instances.lis_library_instances.[library_instance_i].li_type_table_i; #! (type_name,_,labels_implementing_type,dl_client_state) = get_type_label_names tio_type_reference li_type_table_i dl_client_state; #! (implementation_is_available,dl_client_state) = all_or_any (check_whether_implementation_is_available library_instance_i) labels_implementing_type dl_client_state; | False <<- ("\nisTypeImplemented2 ", implementation_is_available, type_name,labels_implementing_type) = undef; // = anySt (check_whether_implementation_is_available library_instance_i) labels_implementing_type dl_client_state; | implementation_is_available // #! dl_client_state // = dl_client_state <<- ("isTypeImplemented2",labels_implementing_type); = (Just (type_name,labels_implementing_type),dl_client_state); = (Nothing,dl_client_state); isTypeImplemented2 _ (LIT_TypeReference (LibRef library_instance_i) tio_type_reference=:{tio_type_without_definition=Just type_name}) dl_client_state #! (li_type_table_i,dl_client_state) = dl_client_state!cs_library_instances.lis_library_instances.[library_instance_i].li_type_table_i; #! (type_name,_,labels_implementing_type,dl_client_state) = get_type_label_names tio_type_reference li_type_table_i dl_client_state; = (Just (type_name,labels_implementing_type),dl_client_state); has_strict_field :: !Int !Int !Bool !StrictnessList -> Bool; has_strict_field _ _ True _ = True; has_strict_field i arity _ tio_st_args_strictness | i == arity = False; = has_strict_field (inc i) arity (arg_is_strict i tio_st_args_strictness) tio_st_args_strictness; get_type_label_names :: !TIO_TypeReference !Int !*DLClientState -> (!String,!String,[String],!*DLClientState); get_type_label_names {tio_type_without_definition=Just type_name} type_table_i dl_client_state #! list = filter (\{pt_type_name} -> type_name == pt_type_name) PredefinedTypes; | isEmpty list = abort ("get_type_label_names; internal error; unknown predefined type '" +++ type_name +++ "'"); #! pt_constructor_names = map (\label_name -> gen_label_name True (label_name,UnderscoreSystemModule) '?') (hd list).pt_constructor_names; = (type_name,UnderscoreSystemModule,pt_constructor_names,dl_client_state); get_type_label_names type_def=:{tio_tr_module_n,tio_tr_type_def_n} type_table_i dl_client_state #! (string_table_i,dl_client_state) = dl_client_state!cs_type_tables.[type_table_i].tt_type_io_state.tis_string_table; #! (tio_module,dl_client_state) = dl_client_state!cs_type_tables.[type_table_i].tt_tio_common_defs.[tio_tr_module_n].tio_module; #! module_name = get_name_from_string_table tio_module string_table_i; // list with constructor names #! ({tio_td_name,tio_td_rhs},dl_client_state) = dl_client_state!cs_type_tables.[type_table_i].tt_tio_common_defs.[tio_tr_module_n].tio_com_type_defs.[tio_tr_type_def_n]; #! type_name = get_name_from_string_table tio_td_name string_table_i; #! (label_names,dl_client_state) = case tio_td_rhs of { (TIO_AlgType defined_symbols) -> foldSt (generate_algebraic_type_label_names type_def type_table_i string_table_i) defined_symbols ([],dl_client_state); TIO_RecordType tio_record_type -> generate_record_label type_def type_table_i string_table_i type_name tio_record_type dl_client_state; TIO_SynType _ | True && OUTPUT_UNIMPLEMENTED_FEATURES_WARNINGS (True <<- ("get_type_label_names; elimination of synonym types should still be done")) (True) -> ([],dl_client_state); s | True <<- (s,type_name) -> abort "lsdfklsfdksdk" <<- s; }; = (type_name,module_name,label_names,dl_client_state); generate_record_label :: !.TIO_TypeReference !.Int !String !String !TIO_RecordType !*DLClientState -> ([String],*DLClientState); generate_record_label {tio_tr_module_n} type_table_i string_table_i record_descriptor_name {tio_rt_constructor={tio_ds_arity,tio_ds_index},tio_rt_fields} dl_client_state // get module name #! (tio_module,dl_client_state) = dl_client_state!cs_type_tables.[type_table_i].tt_tio_common_defs.[tio_tr_module_n].tio_module; #! module_name = get_name_from_string_table tio_module string_table_i; #! (tio_st_args_strictness,dl_client_state) = dl_client_state!cs_type_tables.[type_table_i].tt_tio_common_defs.[tio_tr_module_n].tio_com_cons_defs.[tio_ds_index].tio_cons_type.tio_st_args_strictness; #! is_strict_record = has_strict_field 0 tio_ds_arity False tio_st_args_strictness; #! r_prefixed_label = gen_label_name True (record_descriptor_name,module_name) 'r'; | is_strict_record // strict #! t_prefixed_label = gen_label_name True (record_descriptor_name,module_name) 't'; #! c_prefixed_label = gen_label_name True (record_descriptor_name,module_name) 'c'; = ([r_prefixed_label,t_prefixed_label,c_prefixed_label],dl_client_state); // non strict record = ([r_prefixed_label],dl_client_state); generate_algebraic_type_label_names :: !TIO_TypeReference !Int !String !TIO_DefinedSymbol !*([String],!*DLClientState) -> ([String],!*DLClientState); generate_algebraic_type_label_names {tio_tr_module_n} type_table_i string_table_i {tio_ds_ident,tio_ds_index,tio_ds_arity} (label_names,dl_client_state) #! (tio_module,dl_client_state) = dl_client_state!cs_type_tables.[type_table_i].tt_tio_common_defs.[tio_tr_module_n].tio_module; #! module_name = get_name_from_string_table tio_module string_table_i; #! constructor_name = get_name_from_string_table tio_ds_ident string_table_i; #! (tio_cons_type=:{tio_st_args_strictness},dl_client_state) = dl_client_state!cs_type_tables.[type_table_i].tt_tio_common_defs.[tio_tr_module_n].tio_com_cons_defs.[tio_ds_index].tio_cons_type; #! is_strict_constructor = has_strict_field 0 tio_ds_arity False tio_st_args_strictness; #! d_prefixed_label = gen_label_name True (constructor_name,module_name) 'd'; | is_strict_constructor // strict #! k_prefixed_label = gen_label_name True (constructor_name,module_name) 'k'; #! n_prefixed_label = gen_label_name True (constructor_name,module_name) 'n'; #! label_names = [k_prefixed_label,d_prefixed_label,n_prefixed_label:label_names]; = (label_names,dl_client_state); // non-strict #! label_names = [d_prefixed_label:label_names]; = (label_names,dl_client_state); acc_library_instances :: .(*LibraryInstances -> *(.a,*LibraryInstances)) !*DLClientState -> *(.a,*DLClientState); acc_library_instances f dl_client_state=:{cs_library_instances} # (x,cs_library_instances) = f cs_library_instances; = (x,{dl_client_state & cs_library_instances = cs_library_instances}); acc_lis_library_instances :: .(*{#*LibraryInstance} -> *(.a,*{#*LibraryInstance})) !*LibraryInstances -> *(.a,*LibraryInstances); acc_lis_library_instances f cs_library_instances=:{lis_library_instances} # (x,lis_library_instances) = f lis_library_instances; = (x,{cs_library_instances & lis_library_instances = lis_library_instances} ); acc_library_instance :: .(*{!NamesTableElement} -> *(.a,*{!NamesTableElement})) !*LibraryInstance -> *(.a,*LibraryInstance); acc_library_instance f library_instance=:{li_names_table} # (x,li_names_table) = f li_names_table; = (x,{library_instance & li_names_table = li_names_table}); acc_names_table :: !Int !*DLClientState -> *(.{!NamesTableElement},*DLClientState); acc_names_table library_instance_i dl_client_state = acc_library_instances (\library_instances -> acc_lis_library_instances select_library_instance library_instances) dl_client_state; where { select_library_instance library_instances # (library_instance,library_instances) = replace library_instances library_instance_i default_library_instance; # (x,library_instance) = acc_library_instance (\nt -> (nt,{})) library_instance; # library_instances = { library_instances & [library_instance_i] = library_instance }; = (x,library_instances); } instance findImplementationType DLClientState where { findImplementationType litr dl_client_state # (type_implementation_table,dl_client_state) = get_type_implementation_table dl_client_state; # (is_type_equation,type_implementation_ref,type_implementation_table) = findImplementationType litr type_implementation_table; # dl_client_state = { dl_client_state & cs_type_implementation_table = type_implementation_table }; = (is_type_equation,type_implementation_ref,dl_client_state); }; print_type_table_reference :: !Int !TIO_TypeReference !{#*TypeTable} -> (!String,{#*TypeTable}); print_type_table_reference type_table_i {tio_tr_module_n,tio_tr_type_def_n,tio_type_without_definition=Nothing} type_tables #! (string_table_i,type_tables) = type_tables![type_table_i].tt_type_io_state.tis_string_table; #! (tio_td_name,type_tables) = type_tables![type_table_i].tt_tio_common_defs.[tio_tr_module_n].tio_com_type_defs.[tio_tr_type_def_n].tio_td_name; #! type_name = get_name_from_string_table tio_td_name string_table_i; = (type_name,type_tables); print_type_table_reference type_table_i {tio_type_without_definition=Just type_name} type_tables = (type_name,type_tables); get_lazy_dynamic_index_to_dynamic_id :: !*DLClientState -> *(!*{#LazyDynamicInfo},!*DLClientState); get_lazy_dynamic_index_to_dynamic_id dl_client_state=:{cs_lazy_dynamic_index_to_dynamic_id} = (cs_lazy_dynamic_index_to_dynamic_id,{dl_client_state & cs_lazy_dynamic_index_to_dynamic_id = {} }); // utility get_number_of_type_tables :: *DLClientState -> *(Int,*DLClientState); get_number_of_type_tables dl_client_state // get number of type tables # (type_tables,dl_client_state) = get_type_tables dl_client_state; # (n_type_tables,type_tables) = usize type_tables # dl_client_state = { dl_client_state & cs_type_tables = type_tables }; = (n_type_tables,dl_client_state); add_object_module_to_library_instance :: {#.Char} !.Int !*DLClientState .a !*f -> *(*DLClientState,.a,!*f) | FileEnv f; add_object_module_to_library_instance object_name library_instance_i dl_client_state s io # (state,dl_client_state) = get_state dl_client_state; // extract namestable #! (names_table,dl_client_state) = acc_names_table library_instance_i dl_client_state; #! state = {state & namestable = names_table }; // add new object module # (ok,labels,state,dl_client_state,s,io) = load_object object_name 0 "" state dl_client_state s io; | not ok || (not (isEmpty labels)) = abort ("add_object_module_to_library_instance; internal error" +++ (fst3 (hd labels))); // restoring namestable #! (names_table,state) = get_names_table state; #! dl_client_state = { dl_client_state & cs_library_instances.lis_library_instances.[library_instance_i].li_names_table = names_table }; # dl_client_state = { dl_client_state & app_linker_state = state }; = (dl_client_state,s,io); where { get_names_table state=:{namestable} = (namestable,{state & namestable = {}}); }; get_state :: !*DLClientState -> (!*State,!*DLClientState); get_state dl_client_state=:{app_linker_state} = (app_linker_state,{dl_client_state & app_linker_state = EmptyState}); internal_error :: !{#Char} !ProcessSerialNumber !*DLClientState !*DLServerState .a -> *(!Bool,!ProcessSerialNumber,!DLServerState,.a); internal_error message client_id dl_client_state=:{app_linker_state=state} s io #! dl_client_state = { dl_client_state & id = client_id , app_linker_state = AddMessage (LinkerError message) state }; = (True,client_id,AddToDLServerState dl_client_state s,io); from selectively_import_and_mark_labels import replace_section_label_by_label2, has_section_label_already_been_replaced; replaceLabel :: !String !Int !Int !Int !String !*DLClientState -> *DLClientState; replaceLabel refering_label library_instance_i file_n symbol_n chosen_label_name dl_client_state | False <<- ("replaceLabel", refering_label) = undef; #! ((symbol_hash,ref_file_n,ref_symbol_n,names_table_element_list),dl_client_state) = split_symbol_list_in_symbol_table refering_label (\index dl_client_state -> dl_client_state!cs_library_instances.lis_library_instances.[library_instance_i].li_names_table.[index]) dl_client_state; #! msg = "replace " +++ refering_label +++ "<" +++ toString ref_file_n +++ "," +++ toString ref_symbol_n +++ "," +++ toString library_instance_i +++ "> by " +++ chosen_label_name +++ "<" +++ toString file_n +++ "," +++ toString symbol_n +++ ">"; | False <<- msg = undef; #! dl_client_state = AddMessage (Verbose msg) dl_client_state; | ref_file_n == file_n && ref_symbol_n == symbol_n | False <<- ("replaceLabel cancelled") = undef; = dl_client_state; /* #! (already_replaced,dl_client_state) = acc_state (has_section_label_already_been_replaced ref_file_n ref_symbol_n) dl_client_state; | already_replaced | False <<- ("replaceLabel already replaced",ref_file_n,ref_symbol_n) = undef; = dl_client_state; */ #! new_names_table_element = NamesTableElement refering_label symbol_n file_n names_table_element_list; #! dl_client_state = { dl_client_state & cs_library_instances.lis_library_instances.[library_instance_i].li_names_table.[symbol_hash] = new_names_table_element }; //!!!! // The chosen_label_name which implements a type can be referenced within the defining object module or // from some other object module. The latter references are resolved by name using the names table. The // former reference by symbol index. These references are accounted for by marking the symbol itself and // its defining section (module) as linked and by copying the address of the defining module of the chosen // symbol to that referencing module. // find module containing referencing symbol #! (ref_module_n,dl_client_state) = acc_state (replace_section_label_by_label2 ref_file_n ref_symbol_n) dl_client_state; // find module containing chosen symbol #! (chosen_symbol,dl_client_state) = dl_client_state!app_linker_state.xcoff_a.[file_n].symbol_table.symbols.[symbol_n]; #! (chosen_symbol_not_yet_implemented,chosen_module_n,dl_client_state) = case chosen_symbol of { Label _ _ module_n -> (False,module_n,dl_client_state); SectionLabel section_n _ | False <<- ("replaceLabel", "SectionLabel at:", file_n, hex_int symbol_n) -> undef; #! (module_n,dl_client_state) = dl_client_state!app_linker_state.xcoff_a.[file_n].symbol_table.section_symbol_ns.[section_n]; -> (True,module_n,dl_client_state); }; // compute address of chosen module_n #! (chosen_module_n_index,dl_client_state) = symbol_n_to_offset file_n chosen_module_n dl_client_state; #! (chosen_module_n_address,dl_client_state) = dl_client_state!app_linker_state.module_offset_a.[chosen_module_n_index]; // mark referencing module as marked by settings its address to that of the chosen module #! (ref_module_n_index,dl_client_state) = symbol_n_to_offset ref_file_n ref_module_n dl_client_state; #! dl_client_state = { dl_client_state & app_linker_state.module_offset_a.[ref_module_n_index] = f chosen_module_n_address chosen_module_n_index chosen_symbol_not_yet_implemented ref_module_n_index // if (chosen_module_n_address == 0) (~chosen_module_n_index) chosen_module_n_address , app_linker_state.marked_bool_a.[ref_module_n_index] = True }; with { f 0 chosen_module_n_index chosen_symbol_not_yet_implemented ref_module_n_index | chosen_symbol_not_yet_implemented <<- ("replaceLabel; neg index",~chosen_module_n_index,chosen_module_n_index, ref_module_n_index) = ~chosen_module_n_index; f chosen_module_n_address _ _ _ = chosen_module_n_address; }; #! (ref_symbol_n_index,dl_client_state) = symbol_n_to_offset ref_file_n ref_symbol_n dl_client_state; #! dl_client_state = { dl_client_state & app_linker_state.marked_bool_a.[ref_symbol_n_index] = True }; | False <<- ("REPLACED: '" +++ refering_label +++ "'") = undef; = dl_client_state; instance get_type_implementation DLClientState where { get_type_implementation index_of_type_equivalence_class dl_client_state # (type_implementation_table,dl_client_state) = get_type_implementation_table dl_client_state; # (implementation_type,type_implementation_table) = get_type_implementation index_of_type_equivalence_class type_implementation_table; # dl_client_state = { dl_client_state & cs_type_implementation_table = type_implementation_table }; = (implementation_type,dl_client_state); }; instance enter_implementation_type_for_equivalence_class2 DLClientState where { enter_implementation_type_for_equivalence_class2 index_of_type_equivalence_class type_implementing_type_equivalence_class dl_client_state # (type_implementation_table,dl_client_state) = get_type_implementation_table dl_client_state; # type_implementation_table = enter_implementation_type_for_equivalence_class2 index_of_type_equivalence_class type_implementing_type_equivalence_class type_implementation_table; # dl_client_state = { dl_client_state & cs_type_implementation_table = type_implementation_table }; = dl_client_state; }; get_dynamic_id :: !Int !*DLClientState -> (!(Maybe (!Int,!Int)),!*DLClientState); get_dynamic_id searched_rt_lazy_dynamic_index dl_client_state #! (n_dynamics,dl_client_state) = dl_client_state!dynamic_ids.did_counter; #! (result,dl_client_state) = findAst is_searched_dynamic_index dl_client_state n_dynamics; = (result,dl_client_state); where { is_searched_dynamic_index dynamic_index dl_client_state // determine whether the dynamic id is valid # (is_valid_dynamic_index,dl_client_state) = is_valid_id2 dynamic_index dl_client_state; | not is_valid_dynamic_index = (Nothing,dl_client_state); // valid, extract array holding all run-time lazy dynamic indices # (di_disk_to_rt_dynamic_indices,dl_client_state) = dl_client_state!cs_dynamic_info.[dynamic_index].di_disk_to_rt_dynamic_indices; # result = findAi is_lazy_disk_dynamic di_disk_to_rt_dynamic_indices; = (result,dl_client_state); where { is_lazy_disk_dynamic disk_lazy_dynamic_index rt_lazy_dynamic_index | searched_rt_lazy_dynamic_index == rt_lazy_dynamic_index = Just (disk_lazy_dynamic_index,dynamic_index); = Nothing; }; // is_searched_dynamic }; // get_dynamic_id2 // may only be called *before* a type implementation has been chosen because then replaceLabel has a side-effect // which causes repeated calls of the function below to think that more than type implementation has been linked // in. check_for_at_most_one_type_implementation s types dl_client_state # types = removeDup types; # (implemented_types,dl_client_state) = foldSt check_type_implementation types ([],dl_client_state); | length implemented_types > 1 <<- ("implemented_types",s, "\n",implemented_types,types) # s = " type '" +++ fst (hd implemented_types) +++ "' " +++ toString (length implemented_types); = abort ("check_for_at_most_one_type_implementation; at most one type implementation per type equivalent class is allowed" +++ s); # result = if (isEmpty implemented_types) Nothing (Just (hd implemented_types)); = (result,dl_client_state); where { check_type_implementation type (implemented_types,dl_client_state) #! (maybe_type_implemented,dl_client_state) = isTypeImplemented type dl_client_state; | isNothing maybe_type_implemented = (implemented_types,dl_client_state); = ([(fst (fromJust maybe_type_implemented),type):implemented_types],dl_client_state); }; isSynonymType type dl_client_state | isTypeWithoutDefinition type = (False,dl_client_state); # ({tio_td_rhs},dl_client_state) = extractType type dl_client_state; = case tio_td_rhs of { TIO_SynType _ -> (True,dl_client_state); _ -> (False,dl_client_state); }; extractTypeTable_i :: !LibRef !*DLClientState -> (!Int,!*DLClientState); extractTypeTable_i (LibRef library_instance_i) dl_client_state = dl_client_state!cs_library_instances.lis_library_instances.[library_instance_i].li_type_table_i; extractTypeTable_i (LibRefViaLazyDynamic _ _ type_table_i) dl_client_state | IS_COLLECT_AND_RENUMBER_EXTERNAL_TYPE_REFERENCES = abort "convert_encoded_type_reference_to_rt_type_reference; switch COLLECT_AND_RENUMBER_EXTERNAL_TYPE_REFERENCES off"; = (type_table_i,dl_client_state); extractTypeTable_i (LazyLibRef _ _ type_table_i) dl_client_state | not IS_COLLECT_AND_RENUMBER_EXTERNAL_TYPE_REFERENCES = abort "extractTypeTable_i; switch COLLECT_AND_RENUMBER_EXTERNAL_TYPE_REFERENCES on"; = (type_table_i,dl_client_state); EqualType type1 type2 dl_client_state # (type_tables,dl_client_state) = get_type_tables dl_client_state; # (ets,dl_client_state) = get_ets dl_client_state; # (rt_type_reference1,dl_client_state) = convert_lit_type_reference_to_type_table_reference type1 dl_client_state; # (rt_type_reference2,dl_client_state) = convert_lit_type_reference_to_type_table_reference type2 dl_client_state; # (equivalent_type_defs,type_tables,ets) = equal_type_defs rt_type_reference1 rt_type_reference2 type_tables ets; # (ets_proven_type_equivalences,ets) = ets!ets_proven_type_equivalences; # dl_client_state = { dl_client_state & cs_type_tables = type_tables , cs_intra_type_equalities = ets }; = (equivalent_type_defs,dl_client_state); convert_lit_type_reference_to_type_table_reference :: !.LibraryInstanceTypeReference !*DLClientState -> *(.TypeTableTypeReference,*DLClientState); convert_lit_type_reference_to_type_table_reference (LIT_TypeReference lib_ref tio_type_ref) dl_client_state #! (type_table_i,dl_client_state) = extractTypeTable_i lib_ref dl_client_state; = (TypeTableTypeReference type_table_i tio_type_ref,dl_client_state); extractType (LIT_TypeReference lib_ref {tio_type_without_definition=Nothing,tio_tr_module_n,tio_tr_type_def_n}) dl_client_state # (type_table_i,dl_client_state) = extractTypeTable_i lib_ref dl_client_state #! (tio_type_def,dl_client_state) = dl_client_state!cs_type_tables.[type_table_i].tt_tio_common_defs.[tio_tr_module_n].tio_com_type_defs.[tio_tr_type_def_n]; = (tio_type_def,dl_client_state); search_equivalence_class type ith_entry type_implementation=:{tei_type_implementations=[class_representant:_]} dl_client_state # (equivalence_class_found,dl_client_state) = EqualType type class_representant dl_client_state; | equivalence_class_found = (Just ith_entry,dl_client_state); = (Nothing,dl_client_state); find_type_implementation_equivalent_class :: .LibraryInstanceTypeReference !*DLClientState -> *((Maybe Int),*DLClientState); find_type_implementation_equivalent_class representant dl_client_state #! (type_implementation_table,dl_client_state) = get_type_implementation_table dl_client_state; #! (existing_type_equivalent_class,(type_implementation_table,dl_client_state)) = find_TypeImplementationTable (search_equivalence_class representant) type_implementation_table dl_client_state; #! dl_client_state = { dl_client_state & cs_type_implementation_table = type_implementation_table }; = (existing_type_equivalent_class,dl_client_state); // assumptions // 1. all constructors of class implementation must come from a single library instance // 1. case // a) class has implementation (coming from a single library instance) // all constructors are implemented (replaceLabel) // 2. all element in types must be unique enter_type_equation_new :: ![.LibraryInstanceTypeReference] *DLClientState *a -> *((Maybe (Int,Bool)),*DLClientState,*a) | FileEnv a; enter_type_equation_new [] dl_client_state io | False <<- ("enter_type_equation_new") = undef; = abort "enter_type_equation_new; internal error; empty list is not accepted"; //enter_type_equation_new (types=:[representant:_]) dl_client_state=:{cs_library_instances={lis_n_library_instances}} io // = abort "aaa"; // handling of context types for a type equivalent class enter_type_equation_new (types=:[representant:_]) dl_client_state=:{cs_library_instances={lis_n_library_instances}} io // | False <<- ("\nenter_type_equation_new", types) // = undef; // predefined types | any isTypeWithoutDefinition types = (Nothing,dl_client_state,io); // synonyms #! (any_synonym_type,dl_client_state) = anySt isSynonymType types dl_client_state; | any_synonym_type # ((type_name,_,_,_,_),dl_client_state) = get_info_library_instance_type_reference representant dl_client_state; #! msg = "Ignoring synonym type '" +++ type_name +++ "'"; #! (dl_client_state) = AddMessage (LinkerWarning msg) dl_client_state; = (Nothing,dl_client_state,io); #! (all_types,dl_client_state) = collect_equivalent_context_types representant types dl_client_state; #! all_types = removeDup all_types; = enter_type_equation_new2 all_types dl_client_state io; collect_equivalent_context_types :: .LibraryInstanceTypeReference u:[.LibraryInstanceTypeReference] !*DLClientState -> *(v:[LibraryInstanceTypeReference],*DLClientState), [u <= v]; collect_equivalent_context_types representant typesQ dl_client_state=:{cs_library_instances={lis_n_library_instances}} #! types = typesQ; #! (all_types,dl_client_state) = loopAst collect_context_types (types,dl_client_state) lis_n_library_instances; // | True // = abort (toString (length all_types) +++ " " +++ toString (length typesQ)); = (all_types,dl_client_state); where { // NEW collect_context_types library_instance_i (types,dl_client_state) | library_instance_i < RTID_LIBRARY_INSTANCE_ID_START = (types,dl_client_state); #! ((type_name,module_name,type_table_i,library_instance_j,tio_type_ref),dl_client_state) = get_info_library_instance_type_reference representant dl_client_state; // | library_instance_i == library_instance_j <<- (type_name) // = (types,dl_client_state); #! hash_value_of_name = hashValue type_name; #! (type_table_i,dl_client_state) = dl_client_state!cs_library_instances.lis_library_instances.[library_instance_i].li_type_table_i; #! (l,dl_client_state) = dl_client_state!cs_type_tables.[type_table_i].tt_hash_table.[hash_value_of_name]; #! (types,dl_client_state) = loopAst (look_for_type type_name l type_table_i library_instance_i) (types,dl_client_state) (size l) = (types,dl_client_state); where { look_for_type type_name a type_table_i library_instance_i i s=:(l,dl_client_state) //{tthe_kind=TTHE_TypeName tio_type_reference type_name_i} = case a.[i].tthe_kind of { TTHE_TypeName tio_type_reference type_name_i // extract type name of found type #! (string_table,dl_client_state) = dl_client_state!cs_type_tables.[type_table_i].tt_type_io_state.tis_string_table; # found_type_name = get_name_from_string_table type_name_i string_table; // | type_name <> found_type_name -> (l,dl_client_state); #! lit_type_reference = LIT_TypeReference (LibRef library_instance_i) tio_type_reference; # (equivalent_types,dl_client_state) = EqualType lit_type_reference representant dl_client_state; -> (if equivalent_types [lit_type_reference:l] l ,dl_client_state); _ -> s; }; }; // collect_context_types }; // collect_equivalent_context_types // type equivalent class enter_type_equation_new2 (types1=:[representant:_]) dl_client_state io // find type implementation equivalent class #! (maybe_type_equivalent_class_reference,dl_client_state) = find_type_implementation_equivalent_class representant dl_client_state; | isNothing maybe_type_equivalent_class_reference && (length types1 == 1) = (Nothing,dl_client_state,io); // find type implementation of class #! (maybe_class_implementation,dl_client_state) = case maybe_type_equivalent_class_reference of { Nothing -> (Nothing,dl_client_state); Just index -> dl_client_state!cs_type_implementation_table.teit_type_implementations_a.[index].tei_chosen_type_implementation; }; | False <<- ("maybe_class_implementation", maybe_class_implementation) = undef; // consistency type equality check #! (equivalent_types,types,dl_client_state) = check_equality_of_types types1 maybe_type_equivalent_class_reference dl_client_state; | not equivalent_types = abort "enter_type_equation_new: internal error; not all types are equivalent"; | False <<- ("types", types) = undef; // #! (x,dl_client_state,io) = try_to_fix_class_implementation maybe_class_implementation types maybe_type_equivalent_class_reference dl_client_state io; = (x,dl_client_state,io); where { try_to_fix_class_implementation Nothing types maybe_type_equivalent_class_reference dl_client_state io // check for at most one implemented class member #! (maybe_class_implementation,dl_client_state) = SAFETY_CHECK (foldSt check_type_implementation_ types (Nothing,dl_client_state)) (abort "try_to_fix_class_implementation; SAFETY check unimplemented"); | False <<- ("try_to_fix_class_implementation; maybe_class_implementation", maybe_class_implementation) = undef; #! maybe_class_implementation = case maybe_class_implementation of { Nothing -> Nothing; Just (t,_) -> Just t; }; #! (dl_client_state,io) = case maybe_class_implementation of { Nothing -> (dl_client_state,io); Just class_implementation #! types_without_class_implementation = filter (\type1 -> type1 <> class_implementation) types; // administer the class implementation at link level by redirecting all remaining type reference // to the chosen one. #! (dl_client_state,io) = foldSt initialize_libraries types (dl_client_state,io); #! dl_client_state = redirect_type_implementation_equivalent_class class_implementation types_without_class_implementation dl_client_state; -> (dl_client_state,io); }; #! (type_implementation_table,dl_client_state) = get_type_implementation_table dl_client_state; #! (x,type_implementation_table) = case (length (removeDup types) == 1) of { True -> (Nothing,type_implementation_table); False -> case maybe_type_equivalent_class_reference of { Nothing -> enter_type_equation (hd types) (hd (tl types)) type_implementation_table; Just ref -> (Just (ref,False),type_implementation_table); }; }; | isNothing x #! dl_client_state = { dl_client_state & cs_type_implementation_table = type_implementation_table }; = (x,dl_client_state,io); #! (Just (ref,_)) = x; #! type_implementation_table = { type_implementation_table & teit_type_implementations_a.[ref].tei_type_implementations = types , teit_type_implementations_a.[ref].tei_chosen_type_implementation = maybe_class_implementation }; #! dl_client_state = { dl_client_state & cs_type_implementation_table = type_implementation_table }; // #! dl_client_state // = print_type_implementation_table dl_client_state; = (x,dl_client_state,io); where { initialize_libraries (LIT_TypeReference (LibRef library_instance_i) _) (dl_client_state,io) #! (_,dl_client_state,io) = initialize_library_instance library_instance_i dl_client_state io = (dl_client_state,io); initialize_libraries _ s = s; }; try_to_fix_class_implementation t=:(Just type=:(LIT_TypeReference (LibRef library_instance_i) tio_type_ref)) types (Just type_equivalence_class_reference) dl_client_state io | False <<- ("try_to_fix_class_implementation (CLASS ALREADY IMPLEMENTED BY ", t ) = undef; // collect labels of type implementing the class #! (class_module_name,class_implemention_addresses,dl_client_state,io) = convert_lit_type_reference type collect_class_implementation_labels ("",[],dl_client_state,io); | False <<- ("##",map (\(s,i,file_n,symbol_n) -> (s,hex_int i,file_n,symbol_n)) class_implemention_addresses) = undef; // adapt other labels #! (dl_client_state,io) = foldSt (check_and_redirect_type class_module_name (reverse class_implemention_addresses)) types (dl_client_state,io); // up-date state #! dl_client_state = { dl_client_state & cs_type_implementation_table.teit_type_implementations_a.[type_equivalence_class_reference].tei_type_implementations = types }; // find_type_equation = (Just (type_equivalence_class_reference,False),dl_client_state,io); where { collect_class_implementation_labels _ (Just label_address) constructor_name file_n symbol_n _ (st,dl_client_state) = ([(constructor_name,label_address,file_n,symbol_n):st],dl_client_state); collect_class_implementation_labels _ _ constructor_name file_n symbol_n _ (st,dl_client_state) | False <<- ("collect_class_implementation_labels", constructor_name, file_n, symbol_n) = undef; = abort constructor_name; check_and_redirect_type class_module_name class_addresses type (dl_client_state,io) | False <<- ("begin new type") = undef; #! (_,_,dl_client_state,io) = convert_lit_type_reference type check_and_redirect_constructor_label ("",0,dl_client_state,io); | False <<- ("end new type", type) = undef; = (dl_client_state,io); where { check_and_redirect_constructor_label module_name (Just label_address) constructor_name file_n symbol_n library_instance_j (st,dl_client_state) // check ... #! implemented_label = filter (\(constructor_name2,label_address2,_,_) -> label_address == label_address2) class_addresses; | length implemented_label == 1 // ... check = (st,dl_client_state); // type_equivalence_class_reference #! msg = "check_and_redirect_constructor_label; internal error\nat most one type equivalence class implementation permitted\n" +++ "in class " +++ toString type_equivalence_class_reference +++ ": " +++ constructor_name +++ " from library instance " +++ toString library_instance_j +++ "\n" +++ "should only be implemented by library_instance " +++ toString library_instance_i; = abort msg; check_and_redirect_constructor_label module_name Nothing constructor_name file_n symbol_n library_instance_i (st,dl_client_state) | False <<- ("check_and_redirect_constructor_label", constructor_name) = undef; // new ... #! expanded_module_name = gen_label_name True ("",module_name) '?'; #! s_expanded_module_name_without_prefix = (size expanded_module_name) - 2; #! expanded_class_module_name = gen_label_name True ("",class_module_name) '?'; #! s_expanded_class_module_name_without_prefix = (size expanded_class_module_name) - 2; #! implemented_label = filter (\(constructor_name2,label_address2,_,_) -> compare_substring s_expanded_class_module_name_without_prefix s_expanded_module_name_without_prefix constructor_name2 constructor_name) class_addresses; // constructor_name2 +++ " - " +++ constructor_name) ) class_addresses; | length implemented_label <> 1 = abort ("check_and_redirect_constructor_label; " +++ toString constructor_name ); //(st,dl_client_state); #! (_,_,file_n,symbol_n) = hd implemented_label; // ... new #! dl_client_state = replaceLabel constructor_name library_instance_i file_n symbol_n "check_and_redirect_constructor_label" dl_client_state; = (st,dl_client_state); where { compare_substring :: !Int !Int !String !String -> Bool; compare_substring i j i_string j_string = cmp_substring i j (size i_string) (size j_string); where { cmp_substring i j i_limit j_limit | i == i_limit || j == j_limit = True; //abort ("vergelijken " +++ i_string +++ " " +++ j_string); | i_string.[i] == j_string.[j] = cmp_substring (inc i) (inc j) i_limit j_limit; = False; //abort ("vergelijken " +++ i_string +++ " " +++ j_string); }; }; } convert_lit_type_reference (LIT_TypeReference (LibRef library_instance_i) tio_type_ref) f (module_name,st,dl_client_state,io) #! (type_table_i,dl_client_state) = dl_client_state!cs_library_instances.lis_library_instances.[library_instance_i].li_type_table_i; #! (type_name,module_name,labels_implementing_class_type,dl_client_state) = get_type_label_names tio_type_ref type_table_i dl_client_state; #! (st,dl_client_state,io) = foldSt (convert_label_name module_name) labels_implementing_class_type (st,dl_client_state,io); = (module_name,st,dl_client_state,io); where { convert_label_name module_name constructor_name (st,dl_client_state,io) #! (_,dl_client_state,io) = initialize_library_instance library_instance_i dl_client_state io #! (maybe_file_n_symbol_n,dl_client_state) = findLabel constructor_name library_instance_i dl_client_state; | isNothing maybe_file_n_symbol_n = abort ("convert_label_name; internal error; file_n and symbol_n do not exist"); #! (file_n,symbol_n) = fromJust maybe_file_n_symbol_n; #! (marked,dl_client_state) = acc_state (is_marked_symbol file_n symbol_n) dl_client_state; | False <<- constructor_name = undef; #! (maybe_label_address,dl_client_state) = case marked of { True -> isLabelImplemented file_n symbol_n dl_client_state; _ -> (Nothing,dl_client_state); }; #! (st,dl_client_state) = f module_name maybe_label_address constructor_name file_n symbol_n library_instance_i (st,dl_client_state); = (st,dl_client_state,io); where { is_marked_symbol file_n symbol_n state #! (symbol_offset,state) = symbol_n_to_offset file_n symbol_n state; = selacc_marked_bool_a symbol_offset state; }; }; convert_lit_type_reference _ _ s // Case for lazy references which may not have a concrete implementation. Because lazy references are converted // as soon as a lazy dynamic is being initialized. This would be an extra consistency check. = s; }; check_type_implementation_ type (Nothing,dl_client_state) #! (maybe_type_labels,dl_client_state) = isTypeImplemented type dl_client_state; | False <<- ("!check_type_implementation_ ", type,maybe_type_labels) = undef; | isNothing maybe_type_labels = (Nothing,dl_client_state); #! (label_addresses,dl_client_state) = get_type_label_addresses type maybe_type_labels dl_client_state; = (Just (type,label_addresses),dl_client_state); // safety check, could be turned off... check_type_implementation_ type (x=:(Just (_,labels)),dl_client_state) #! (maybe_type_implemented,dl_client_state) = isTypeImplemented type dl_client_state; | isJust maybe_type_implemented #! (label_addresses,dl_client_state) = get_type_label_addresses type maybe_type_implemented dl_client_state; #! dl_client_state = fold2St check_label labels label_addresses dl_client_state; with { check_label label_address1 label_address2 dl_client_state | label_address1 == label_address2 = dl_client_state; = abort "check_type_implementation_; internal error; type has more implementations"; }; = (x,dl_client_state); = (x,dl_client_state); get_type_label_addresses :: !LibraryInstanceTypeReference !(Maybe (.a,[String])) !*DLClientState -> ([Int],!*DLClientState); get_type_label_addresses (LIT_TypeReference (LibRef library_instance_i) _) (Just (type_name,labels_implementing_type)) dl_client_state | not USE_SAFETY_CHECK = ([],dl_client_state); #! (label_addresses,dl_client_state) = mapSt get_label_address labels_implementing_type dl_client_state; = (sort label_addresses,dl_client_state); where { get_label_address label dl_client_state #! (_,maybe_label_address,_,dl_client_state) = check_whether_implementation_is_available2 library_instance_i label dl_client_state; | False <<- ("label",label,maybe_label_address) = undef; = (fromJust maybe_label_address,dl_client_state); }; // - inbouwen: als de lijst maar 1 (verschillend) element bevat, dan *moet* er een type equivalentie klasse zijn // waaraan dit element moet worden toegevoegd. // - vrij dure operatie removeDup kan misschien verwijderd worden. check_equality_of_types :: [LibraryInstanceTypeReference] (Maybe Int) !*DLClientState -> (Bool,[LibraryInstanceTypeReference],!*DLClientState); check_equality_of_types types Nothing dl_client_state #! (equal,dl_client_state) = allSt (\type dl_client_state -> EqualType type representant dl_client_state) (removeDup types) dl_client_state; = (equal,removeDup types,dl_client_state); check_equality_of_types types (Just index) dl_client_state #! (equal1,dl_client_state) = allSt (\type dl_client_state -> EqualType type representant dl_client_state) types dl_client_state; #! (types2,dl_client_state) = dl_client_state!cs_type_implementation_table.teit_type_implementations_a.[index].tei_type_implementations; #! (equal2,dl_client_state) = allSt (\type dl_client_state -> EqualType type representant dl_client_state) types2 dl_client_state; #! types = removeDup (types ++ types2); = (equal1&&equal2,types,dl_client_state); }; old_enter_type_equation :: !LibraryInstanceTypeReference !LibraryInstanceTypeReference !*DLClientState !*f -> (Maybe (Int,Bool),!*DLClientState,!*f) | FileEnv f; old_enter_type_equation type1 type2 dl_client_state s = USE_ENTER_NEW_TYPE_EQUATIONS (enter_type_equation_new [type1,type2] dl_client_state s) (foo dl_client_state s) ; where { foo dl_client_state s # (x,dl_client_state) = enter_type_equation type1 type2 dl_client_state; = (x,dl_client_state,s) }; instance enter_type_equation DLClientState where { enter_type_equation type1 type2 dl_client_state | isTypeWithoutDefinition type1 && isTypeWithoutDefinition type2 // types without definitions are implemented in the rts and are shared by default = (Nothing,dl_client_state); // Synonym types cannot be entered; they should already been removed. # (is_synonym_type,dl_client_state) = isSynonymType type1 dl_client_state; | is_synonym_type = (Nothing,dl_client_state); # (type_implementation_table,dl_client_state) = get_type_implementation_table dl_client_state; # (existing_type_equivalent_class,(type_implementation_table,dl_client_state)) = find_TypeImplementationTable (search_equivalence_class type1) type_implementation_table dl_client_state; # dl_client_state = { dl_client_state & cs_type_implementation_table = type_implementation_table }; | isNothing existing_type_equivalent_class // A type equivalent class must be created. In addition the enter_type_equation-function // checks whether there is already an equivalent class for type{1,2} but this has already // been checked above. #! (type_implementation,dl_client_state) = check_for_at_most_one_type_implementation "new" [type1,type2] dl_client_state; # (type_implementation_table,dl_client_state) = get_type_implementation_table dl_client_state; # (Just (index_of_type_equivalence_class,_),type_implementation_table) = enter_type_equation type1 type2 type_implementation_table; # dl_client_state = { dl_client_state & cs_type_implementation_table = type_implementation_table }; // enter type implementation if possible #! dl_client_state = case type_implementation of { Just (type_name,type) -> enter_implementation_type_for_equivalence_class2 index_of_type_equivalence_class type dl_client_state; Nothing -> dl_client_state; }; = (Just (index_of_type_equivalence_class,True),dl_client_state); // The already existing type equivalent class is extended to include type{1,2}. #! index_of_type_equivalence_class = fromJust existing_type_equivalent_class; #! ({tei_chosen_type_implementation,tei_type_implementations},dl_client_state) = get_type_implementation index_of_type_equivalence_class dl_client_state; # new_type_implementations = removeDup (union [type1,type2] tei_type_implementations); #! dl_client_state = set_type_equations index_of_type_equivalence_class new_type_implementations dl_client_state; #! dl_client_state = case tei_chosen_type_implementation of { Just _ -> dl_client_state; _ #! (type_implementation,dl_client_state) = check_for_at_most_one_type_implementation "existing" tei_type_implementations dl_client_state; #! dl_client_state = case type_implementation of { Just (type_name,type) -> enter_implementation_type_for_equivalence_class2 index_of_type_equivalence_class type dl_client_state; Nothing -> dl_client_state; }; -> dl_client_state; }; = (Just (index_of_type_equivalence_class,False),dl_client_state); }; /* ** Loads a module in memory. If necessary e.g. (size symbol_name) > 0 then it is ** checked if the module is its defining module. Accordingly to the result, the ** returned bool is set. If it is false, the module is not loaded e.g. integrated ** with existing modules. */ load_object object_path_name_ext object_fp_in_library symbol_name state=:{one_pass_link,n_xcoff_files} dl_client_state dl_server_state io /* ** If symbol_name must be defined (length greater than zero), then create a ** new, empty names_table because it is unknown if the specified module ** actually defines the symbol. */ #! (names_table,state) = case (size symbol_name) of { 0 #! (names_table,state) = select_namestable state; #! (s_names_table,names_table) = usize names_table; | s_names_table == 0 -> abort "names table is zero" -> (names_table,state); //-> select_namestable state; _ -> (create_names_table,state); } // read object file #! (redirection_state,state) = get_redirection_state state; #! ((any_extra_sections,errors,xcoff_list,names_table,redirection_state),io) = accFiles (ReadXcoffM False object_path_name_ext object_fp_in_library names_table one_pass_link n_xcoff_files redirection_state) io; #! state = put_redirection_state redirection_state state; | not (isEmpty errors) #! state = { state & namestable = names_table }; #! messages = [LinkerError m \\ m <- errors]; = (False,[],SetLinkerMessages messages state,dl_client_state,dl_server_state,io); // if necessary, check if symbol_name is defined in this module #! (symbol_found,names_table,state) = case (size symbol_name) of { 0 // symbol_name needs not be defined -> (True,names_table,state); _ // symbol_name must be defined #! (names_table_element,names_table) = find_symbol_in_symbol_table symbol_name names_table -> case names_table_element of { NamesTableElement _ _ _ _ #! (old_namestable,state) = select_namestable state; -> (True, (MergeNamesTables old_namestable names_table),state); _ -> (False,names_table,state); } } | not symbol_found #! state = { state & namestable = names_table }; #! message = "module '" +++ object_path_name_ext +++ "' requires symbol " +++ symbol_name +++ "to be defined"; = (False,[],AddMessage (LinkerError message) state,dl_client_state,dl_server_state,io); // import as many symbols as can be resolved; sort on macos probably not needed #! map_function = sel_platform sort_modules // winos (\xcoff -> sort_modules (split_data_symbol_lists_without_removing_unmarked_symbols xcoff)) // macos ; #! (undefined_symbols,xcoff_list,names_table) = import_symbols_in_xcoff_files /*[sort_modules xcoff]*/ (map map_function xcoff_list) n_xcoff_files [] names_table; #! state = update_namestable names_table state; = (True,undefined_symbols,/*add_module (hd xcoffs) state*/ foldl (\state xcoff -> add_module xcoff state) state xcoff_list,dl_client_state,dl_server_state,io); RegisterLibrary :: (Maybe .Int) !{#.Char} !*DLClientState !*f -> *(Int,Int,*DLClientState,!*f) | FileEnv f; RegisterLibrary dynamic_index library_name s io # (type_table_i,s) = AddReferenceToTypeTable library_name s; # (library_instance_i,s) = AddLibraryInstance dynamic_index library_name type_table_i s; // print #! msg = "Register library as library instance #" +++ toString library_instance_i +++ " and name '" +++ library_name +++ "'"; #! (s) = AddMessage (Verbose msg) s; #! (s,io) = LoadTypeTable type_table_i s io; #! (ok,s,io) = initialize_library_instance library_instance_i s io = (library_instance_i,type_table_i,s,io); determine_implementation_for_dus_entry :: !String !String !Int !Int !Int !*DLClientState -> *(.DusImplementation,*DLClientState); determine_implementation_for_dus_entry descriptor_name module_name dus_library_instance_nr_on_disk prefix_set_and_string_ptr id dl_client_state=:{cs_main_library_instance_i} #! (library_instance_i,dl_client_state) = dl_client_state!cs_dynamic_info.[id].di_disk_id_to_library_instance_i.[dus_library_instance_nr_on_disk]; #! (type_table_i,dl_client_state) = dl_client_state!cs_library_instances.lis_library_instances.[library_instance_i].li_type_table_i; /* ** :: Rec ** = { ... } ** :: Xyz ** = Rec ... ** ** At run-time both the Rec-record constructor and the equally named constructor of type Xyz have the same descriptor. ** The Clean-compiler internally distinguishes between both constructors by prefixing the record constructor with an ** underscore. */ #! descriptor_name_as_used_in_type_table = convert_descriptor_name_to_type_constructor_name (is_record (get_prefix_set prefix_set_and_string_ptr)) descriptor_name; #! (result,dl_client_state) = findTypeUsingConstructorName descriptor_name_as_used_in_type_table module_name type_table_i dl_client_state; | isNothing result // <<- ("searching",descriptor_name_as_used_in_type_table, module_name,library_instance_i, result) // label is not a Clean type but e.g. a closure, a function. It *cannot* be a non-Clean label (rts) because they // cannot occur in the datagraph. The implementation // comes from the current library instance except for run-time system label which should always come from // the main-library instance. | module_name == UnderscoreSystemModule # dus_implementation = { dusi_descriptor_name = descriptor_name , dusi_module_name = module_name , dusi_library_instance_i = fromJust cs_main_library_instance_i , dusi_linked = False , dusi_label_kind = DSL_RUNTIME_SYSTEM_LABEL }; = (dus_implementation,dl_client_state); # dus_implementation = { dusi_descriptor_name = descriptor_name , dusi_module_name = module_name , dusi_library_instance_i = library_instance_i , dusi_linked = False , dusi_label_kind = DSL_CLEAN_LABEL_BUT_NOT_A_TYPE }; = (dus_implementation,dl_client_state); // Label belongs to a Clean-type # (is_type_equation,type_implementation_ref,dl_client_state) = findImplementationType (LIT_TypeReference (LibRef library_instance_i) (fromJust result)) dl_client_state; | not is_type_equation // <<- (descriptor_name,module_name) // a Clean type without equation. The implementation of the type comes from the current library // instance. Possibilities: // (KAN NIET) - rts-label -> use rts-label from main library_instance_i // - otherwise -> use labels from library instance i # dus_implementation = { dusi_descriptor_name = descriptor_name , dusi_module_name = module_name , dusi_library_instance_i = library_instance_i , dusi_linked = False , dusi_label_kind = DSL_RUNTIME_SYSTEM_LABEL }; = (dus_implementation,dl_client_state); // Get possible implementation type # type_implementation_ref = fromJust type_implementation_ref; # (chosen_implementation_type,dl_client_state) = getImplementationType type_implementation_ref dl_client_state; // Clean type in equivalence class | isNothing chosen_implementation_type // <<- ("^^^",type_implementation_ref) // A Clean type belong to some type equivalence class *without* implementation. The implementation // chosen is that of the current library instance. // # dus_implementation = { dusi_descriptor_name = descriptor_name , dusi_module_name = module_name , dusi_library_instance_i = library_instance_i , dusi_linked = False , dusi_label_kind = DSL_RUNTIME_SYSTEM_LABEL }; = (dus_implementation,dl_client_state); // a Clean type, member of a type equivalence class and *with* implementation // # (new_module_name,new_library_instance_i,dl_client_state) = case (fromJust chosen_implementation_type) of { (LIT_TypeReference (LibRef library_instance_i) {tio_type_without_definition=Just _}) // an internal type -> (module_name,library_instance_i,dl_client_state); (LIT_TypeReference (LibRef library_instance_i) {tio_tr_module_n}) #! (li_type_table_i,dl_client_state) = dl_client_state!cs_library_instances.lis_library_instances.[library_instance_i].li_type_table_i; #! (tio_module,dl_client_state) = dl_client_state!cs_type_tables.[li_type_table_i].tt_tio_common_defs.[tio_tr_module_n].tio_module; #! (string_table_i,dl_client_state) = dl_client_state!cs_type_tables.[li_type_table_i].tt_type_io_state.tis_string_table; #! module_name = get_name_from_string_table tio_module string_table_i; -> (module_name,library_instance_i,dl_client_state) }; # dus_implementation = { dusi_descriptor_name = descriptor_name , dusi_module_name = new_module_name , dusi_library_instance_i = new_library_instance_i , dusi_linked = True // , dusi_label_kind = DSL_TYPE_EQUIVALENT_CLASS_WITH_IMPLEMENTATION }; = (dus_implementation,dl_client_state); where { convert_descriptor_name_to_type_constructor_name True constructor_name = "_" +++ constructor_name; convert_descriptor_name_to_type_constructor_name is_record constructor_name = constructor_name; }; instance getImplementationType DLClientState where { getImplementationType index_of_type_equivalence_class dl_client_state # (type_implementation_table,dl_client_state) = get_type_implementation_table dl_client_state; # (implementation_type,type_implementation_table) = getImplementationType index_of_type_equivalence_class type_implementation_table; # dl_client_state = { dl_client_state & cs_type_implementation_table = type_implementation_table }; = (implementation_type,dl_client_state); }; instance findTypeUsingTypeName DLClientState where { findTypeUsingTypeName type_name module_name type_table_i dl_client_state # (type_tables,dl_client_state) = get_type_tables dl_client_state; # (result,type_tables) = findTypeUsingTypeName type_name module_name type_table_i type_tables; # dl_client_state = { dl_client_state & cs_type_tables = type_tables }; = (result,dl_client_state); }; instance findTypeUsingConstructorName DLClientState where { findTypeUsingConstructorName type_name module_name type_table_i dl_client_state # (type_tables,dl_client_state) = get_type_tables dl_client_state; # (result,type_tables) = findTypeUsingConstructorName type_name module_name type_table_i type_tables; # dl_client_state = { dl_client_state & cs_type_tables = type_tables }; = (result,dl_client_state); }; instance set_type_equations DLClientState where { set_type_equations index library_instance_type_references dl_client_state # (type_implementation_table,dl_client_state) = get_type_implementation_table dl_client_state; # type_implementation_table = set_type_equations index library_instance_type_references type_implementation_table; # dl_client_state = { dl_client_state & cs_type_implementation_table = type_implementation_table }; = dl_client_state; };