diff options
| -rw-r--r-- | frontend/convertDynamics.icl | 35 | ||||
| -rw-r--r-- | frontend/trans.icl | 33 | ||||
| -rw-r--r-- | frontend/transform.icl | 5 | ||||
| -rw-r--r-- | frontend/typesupport.dcl | 2 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 2 |
5 files changed, 48 insertions, 29 deletions
diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index 32ef5ec..11c2a05 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -48,11 +48,13 @@ where = convert_groups (inc group_nr) groups global_type_instances (foldSt (convert_function group_nr global_type_instances) group.group_members fun_defs_and_ci) convert_function group_nr global_type_instances fun (fun_defs, ci) - #! fun_def = fun_defs.[fun] - # {fun_body, fun_type, fun_info} = fun_def - (fun_body, ci) = convert_dynamics_in_body {cinp_glob_type_inst = global_type_instances, cinp_group_index = group_nr} fun_body fun_type ci - = ({fun_defs & [fun] = { fun_def & fun_body = fun_body, fun_info = { fun_info & fi_local_vars = ci.ci_new_variables ++ fun_info.fi_local_vars }}}, - { ci & ci_new_variables = [] }) ---> ("convert_function", ci.ci_new_variables ++ fun_info.fi_local_vars) + # (fun_def, fun_defs) = fun_defs![fun] + {fun_body, fun_type, fun_info} = fun_def + | isEmpty fun_info.fi_dynamics + = (fun_defs, ci) + # (fun_body, ci) = convert_dynamics_in_body {cinp_glob_type_inst = global_type_instances, cinp_group_index = group_nr} fun_body fun_type ci + = ({fun_defs & [fun] = { fun_def & fun_body = fun_body, fun_info = { fun_info & fi_local_vars = ci.ci_new_variables ++ fun_info.fi_local_vars }}}, + { ci & ci_new_variables = [] }) convert_dynamics_in_body global_type_instances (TransformedBody {tb_args,tb_rhs}) (Yes {st_args}) ci # vars_with_types = bindVarsToTypes tb_args st_args [] @@ -295,17 +297,16 @@ where /*** convert the elements of this pattern ***/ - x_i_bind = { bind_src = opened_dynamic.opened_dynamic_expr, bind_dst = dp_var } - (a_ij_binds, ci) = createVariables dp_type_patterns_vars [] ci - (type_code, ci) = convertTypecode cinp dp_type_code ci - (dp_rhs, ci) = convertDynamics cinp bound_vars this_default dp_rhs ci + (a_ij_binds, ci) = createVariables dp_type_patterns_vars [] ci + (type_code, ci) = convertTypecode cinp dp_type_code ci + (dp_rhs, ci) = convertDynamics cinp bound_vars this_default dp_rhs ci /*** recursively convert the other patterns ***/ - (binds, ci) = convert_other_patterns cinp bound_vars this_default pattern_number opened_dynamic result_type last_default patterns ci + (binds, ci) = convert_other_patterns cinp bound_vars this_default pattern_number opened_dynamic result_type last_default patterns ci - /*** generate the expression ***/ + (unify_symb, ci) = getSymbol PD_unify SK_Function 2 ci (twotuple, ci) = getTupleSymbol 2 ci (let_info_ptr, ci) = let_ptr ci @@ -313,10 +314,11 @@ where (default_expr, ci) = toExpression this_default ci (unify_result_var, ci) = newVariable "result" VI_Empty ci unify_result_fv = varToFreeVar unify_result_var 1 - (unify_bool_var, ci) = newVariable "unify_bool" VI_Empty ci + (unify_bool_var, ci) = newVariable "unify_bool" VI_Empty ci unify_bool_fv = varToFreeVar unify_bool_var 1 - (let_binds, ci) = bind_indirection_var ind_var unify_result_var twotuple ci + (let_binds, ci) = bind_indirection_var ind_var unify_result_var twotuple ci + a_ij_binds = add_x_i_bind opened_dynamic.opened_dynamic_expr dp_var a_ij_binds let_expr = Let { let_strict = False, let_binds = [{ bind_src = App { app_symb = unify_symb, app_args = [opened_dynamic.opened_dynamic_type, type_code], app_info_ptr = nilPtr }, @@ -330,7 +332,7 @@ where case_ident = No, case_info_ptr = case_info_ptr }, let_info_ptr = let_info_ptr } - = ([x_i_bind : a_ij_binds ++ binds], let_expr, { ci & ci_new_variables = [unify_result_fv, unify_bool_fv : ci.ci_new_variables]}) + = (a_ij_binds ++ binds, let_expr, { ci & ci_new_variables = [unify_result_fv, unify_bool_fv : ci.ci_new_variables]}) where bind_indirection_var var=:{var_info_ptr} unify_result_var twotuple ci=:{ci_var_heap,ci_new_variables} # (VI_Indirection ref_count, ci_var_heap) = readPtr var_info_ptr ci_var_heap @@ -340,6 +342,11 @@ where { ci & ci_var_heap = ci_var_heap, ci_new_variables = [ ind_fv : ci_new_variables ]}) = ([], {ci & ci_var_heap = ci_var_heap}) + add_x_i_bind bind_src bind_dst=:{fv_count} binds + | fv_count > 0 + = [ { bind_src = bind_src, bind_dst = bind_dst } : binds ] + = binds + convert_other_patterns :: ConversionInput BoundVariables DefaultExpression Int OpenedDynamic AType !(Optional Expression) ![DynamicPattern] !*ConversionInfo -> (Env Expression FreeVar, *ConversionInfo) convert_other_patterns _ _ _ _ _ _ No [] ci diff --git a/frontend/trans.icl b/frontend/trans.icl index 9c2dc76..4ea972a 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -196,7 +196,7 @@ not_an_unsafe_pattern (cc, _, ai) = (cc, False, ai) instance consumerRequirements BoundVar where - consumerRequirements {var_info_ptr} _ ai=:{ai_var_heap} + consumerRequirements {var_name,var_info_ptr} _ ai=:{ai_var_heap} # (var_info, ai_var_heap) = readPtr var_info_ptr ai_var_heap = continuation var_info { ai & ai_var_heap=ai_var_heap } where @@ -206,6 +206,8 @@ where #! ref_count = ai_cur_ref_counts.[arg_position] ai_cur_ref_counts = { ai_cur_ref_counts & [arg_position]=min (ref_count+1) 2 } = (temp_var, False, { ai & ai_cur_ref_counts=ai_cur_ref_counts }) + continuation var_info ai=:{ai_cur_ref_counts} + = abort ("consumerRequirements" ---> (var_name <<- var_info)) // continuation vi ai // = (cPassive, ai) @@ -224,7 +226,7 @@ instance consumerRequirements Expression where { ai & ai_next_var = new_next_var, ai_next_var_of_fun = new_ai_next_var_of_fun, ai_var_heap = ai_var_heap } = consumerRequirements let_expr common_defs ai // XXX why not not_an_unsafe_pattern where - init_variables [{bind_dst={fv_count, fv_info_ptr}} : binds] ai_next_var ai_next_var_of_fun ai_var_heap + init_variables [{bind_dst={fv_name, fv_count, fv_info_ptr}} : binds] ai_next_var ai_next_var_of_fun ai_var_heap /* Sjaak ... */ | fv_count > 0 = init_variables binds (inc ai_next_var) (inc ai_next_var_of_fun) @@ -1561,7 +1563,7 @@ where transformApplication :: !App ![Expression] !ReadOnlyTI !*TransformInfo -> *(!Expression,!*TransformInfo) transformApplication app=:{app_symb=symb=:{symb_kind = SK_Function {glob_module, glob_object},symb_arity}, app_args} extra_args - ro ti=:{ti_cons_args,ti_instances,ti_fun_defs} + ro ti=:{ti_cons_args,ti_instances,ti_fun_defs} | glob_module == cIclModIndex | glob_object < size ti_cons_args #! cons_class = ti_cons_args.[glob_object] @@ -1587,9 +1589,17 @@ transformApplication app=:{app_symb=symb=:{symb_kind = SK_Function {glob_module, /* ... Sjaak */ // XXX linear_bits field has to be added for generated functions -transformApplication app=:{app_symb={symb_kind = SK_GeneratedFunction fun_def_ptr _}} extra_args ro ti=:{ti_fun_heap} - # (FI_Function {gf_fun_def,gf_instance_info,gf_cons_args}, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap - = transformFunctionApplication gf_fun_def gf_instance_info gf_cons_args app extra_args ro { ti & ti_fun_heap = ti_fun_heap } +/* Sjaak ... */ +transformApplication app=:{app_symb={symb_name,symb_kind = SK_GeneratedFunction fun_def_ptr fun_index}} extra_args + ro ti=:{ti_cons_args,ti_instances,ti_fun_defs,ti_fun_heap} + | fun_index < size ti_cons_args + #! cons_class = ti_cons_args.[fun_index] + instances = ti_instances.[fun_index] + fun_def = ti_fun_defs.[fun_index] + = transformFunctionApplication fun_def instances cons_class app extra_args ro ti + # (FI_Function {gf_fun_def,gf_instance_info,gf_cons_args}, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap + = transformFunctionApplication gf_fun_def gf_instance_info gf_cons_args app extra_args ro { ti & ti_fun_heap = ti_fun_heap } +/* ... Sjaak */ transformApplication app [] ro ti = (App app, ti) transformApplication app extra_args ro ti @@ -1790,14 +1800,15 @@ where (foldSt (transform_function common_defs imported_funs) group_members { ti & ti_fun_defs = ti_fun_defs, ti_type_heaps = ti_type_heaps, ti_var_heap = ti_var_heap }) = (groups, imported_types, collected_imports, ti) + transform_function common_defs imported_funs fun ti=:{ti_fun_defs} #! fun_def = ti_fun_defs.[fun] # {fun_body = TransformedBody tb} = fun_def - ro = { ro_imported_funs = imported_funs - , ro_common_defs = common_defs - , ro_root_case_mode = case tb of {{tb_rhs=Case _} -> RootCase; _ -> NotRootCase} - , ro_fun = fun_def_to_symb_ident fun fun_def - , ro_fun_args = tb.tb_args + ro = { ro_imported_funs = imported_funs + , ro_common_defs = common_defs + , ro_root_case_mode = case tb of {{tb_rhs=Case _} -> RootCase; _ -> NotRootCase} + , ro_fun = fun_def_to_symb_ident fun fun_def + , ro_fun_args = tb.tb_args } (fun_rhs, ti) = transform tb.tb_rhs ro ti = { ti & ti_fun_defs = {ti.ti_fun_defs & [fun] = { fun_def & fun_body = TransformedBody { tb & tb_rhs = fun_rhs }}}} diff --git a/frontend/transform.icl b/frontend/transform.icl index 76e5628..a60978a 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -1247,13 +1247,14 @@ where = collect_variables_in_binds binds collected_binds free_vars cos = (collected_binds, free_vars, cos) - examine_reachable_binds bind_found [bind=:{bind_dst={fv_info_ptr},bind_src} : binds] collected_binds free_vars cos + examine_reachable_binds bind_found [bind=:{bind_dst=fv=:{fv_info_ptr},bind_src} : binds] collected_binds free_vars cos # (bind_found, binds, collected_binds, free_vars, cos) = examine_reachable_binds bind_found binds collected_binds free_vars cos #! var_info = sreadPtr fv_info_ptr cos.cos_var_heap # (VI_Count count is_global) = var_info | count > 0 # (bind_src, free_vars, cos) = collectVariables bind_src free_vars cos - = (True, binds, [ { bind & bind_src = bind_src } : collected_binds ], free_vars, cos) +/* Sjaak */ + = (True, binds, [ { bind_dst = { fv & fv_count = count }, bind_src = bind_src } : collected_binds ], free_vars, cos) = (bind_found, [bind : binds], collected_binds, free_vars, cos) examine_reachable_binds bind_found [] collected_binds free_vars cos = (bind_found, [], collected_binds, free_vars, cos) diff --git a/frontend/typesupport.dcl b/frontend/typesupport.dcl index a8b1c2e..388a029 100644 --- a/frontend/typesupport.dcl +++ b/frontend/typesupport.dcl @@ -5,7 +5,7 @@ import checksupport, StdCompare from unitype import Coercions, CoercionTree, AttributePartition // MW: this switch is used to en(dis)able the fusion algorithm -SwitchFusion fuse dont_fuse :== fuse +SwitchFusion fuse dont_fuse :== dont_fuse errorHeading :: !String !*ErrorAdmin -> *ErrorAdmin diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index 7e43869..1890ac0 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -4,7 +4,7 @@ import StdEnv, StdCompare import syntax, parse, check, unitype, utilities, RWSDebug // MW: this switch is used to en(dis)able the fusion algorithm -SwitchFusion fuse dont_fuse :== fuse +SwitchFusion fuse dont_fuse :== dont_fuse :: Store :== Int |