Commit 1caf0059 authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

improved dynamics

parent 3ab71268
......@@ -148,8 +148,8 @@ where
special_instances type_pattern_vars (var_heap, type_heaps) coercion_env predef_symbols error
| is_reducible tc_types
| is_predefined_symbol glob_module ds_index PD_TypeCodeClass predef_symbols
# (red_context, (special_instances, type_pattern_vars, var_heap))
= reduce_TC_context class_symb (hd tc_types) special_instances type_pattern_vars var_heap
# (red_context, (new_contexts, special_instances, type_pattern_vars, var_heap))
= reduce_TC_context class_symb (hd tc_types) new_contexts special_instances type_pattern_vars var_heap
= (red_context, new_contexts, special_instances, type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, error)
# (class_appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
= reduce_context tc defs instance_info new_contexts special_instances type_pattern_vars
......@@ -354,38 +354,40 @@ where
ai_record = record }
reduce_TC_context type_code_class tc_type special_instances type_pattern_vars var_heap
= reduce_tc_context type_code_class tc_type (special_instances, type_pattern_vars, var_heap)
reduce_TC_context type_code_class tc_type new_contexts special_instances type_pattern_vars var_heap
= reduce_tc_context type_code_class tc_type (new_contexts, special_instances, type_pattern_vars, var_heap)
where
reduce_tc_context type_code_class (TA cons_id cons_args) (special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap)
reduce_tc_context type_code_class (TA cons_id cons_args) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap)
# (inst_index, (si_next_TC_member_index, si_TC_instances))
= addGlobalTCInstance (GTT_Constructor cons_id) (si_next_TC_member_index, si_TC_instances)
(rc_red_contexts, instances) = reduce_TC_contexts type_code_class cons_args
({ special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap)
(new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap)
= (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = rc_red_contexts }, instances)
reduce_tc_context type_code_class (TB basic_type) (special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap)
reduce_tc_context type_code_class (TB basic_type) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap)
# (inst_index, (si_next_TC_member_index, si_TC_instances))
= addGlobalTCInstance (GTT_Basic basic_type) (si_next_TC_member_index, si_TC_instances)
= (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = [] },
({ special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap))
(new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap))
reduce_tc_context type_code_class (arg_type --> result_type) (special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap)
reduce_tc_context type_code_class (arg_type --> result_type) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap)
# (inst_index, (si_next_TC_member_index, si_TC_instances))
= addGlobalTCInstance GTT_Function (si_next_TC_member_index, si_TC_instances)
(rc_red_contexts, instances) = reduce_TC_contexts type_code_class [arg_type, result_type]
({ special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap)
(new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap)
= (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = rc_red_contexts }, instances)
reduce_tc_context type_code_class (TempQV var_number) (special_instances, type_pattern_vars, var_heap)
reduce_tc_context type_code_class (TempQV var_number) (new_contexts, special_instances, type_pattern_vars, var_heap)
# (inst_var, (type_pattern_vars, var_heap)) = addLocalTCInstance var_number (type_pattern_vars, var_heap)
= (CA_LocalTypeCode inst_var, (special_instances, type_pattern_vars, var_heap))
= (CA_LocalTypeCode inst_var, (new_contexts, special_instances, type_pattern_vars, var_heap))
reduce_tc_context type_code_class (TempV var_number) (special_instances, type_pattern_vars, var_heap)
// # (tc_var, var_heap) = newPtr VI_Empty var_heap
= (CA_Context { tc_class = type_code_class, tc_types = [TempV var_number], tc_var = nilPtr }, (special_instances, type_pattern_vars, var_heap))
reduce_tc_context type_code_class (TempV var_number) (new_contexts, special_instances, type_pattern_vars, var_heap)
# (tc_var, var_heap) = newPtr VI_Empty var_heap
tc = { tc_class = type_code_class, tc_types = [TempV var_number], tc_var = tc_var }
| containsContext tc new_contexts
= (CA_Context tc, (new_contexts, special_instances, type_pattern_vars, var_heap))
= (CA_Context tc, ([tc : new_contexts], special_instances, type_pattern_vars, var_heap))
reduce_TC_contexts type_code_class cons_args instances
= mapSt (\{at_type} -> reduce_tc_context type_code_class at_type) cons_args instances
......@@ -643,7 +645,11 @@ convertOverloadedCall defs contexts {symb_name} expr_info_ptr appls heaps
expressionToTypeCodeExpression (TypeCodeExpression texpr) = texpr
expressionToTypeCodeExpression (ClassVariable var_info_ptr) = TCE_Var var_info_ptr
/*
expressionToTypeCodeExpression (Var {var_info_ptr}) = TCE_Var var_info_ptr
*/
expressionToTypeCodeExpression expr = abort ("expressionToTypeCodeExpression (overloading.icl)" <<- expr)
generateClassSelection address last_selectors
= mapAppend (\(off_set,selector) -> RecordSelection selector off_set) address last_selectors
......@@ -789,17 +795,19 @@ where
= (fun_defs, fun_env, symbol_heap, type_code_info, var_heap, error)
update_dynamics [fun:funs] type_pattern_vars fun_defs fun_env symbol_heap type_code_info var_heap error
#! fun_def = fun_defs.[fun]
# {fun_body,fun_info={fi_group_index, fi_dynamics}} = fun_def
# {fun_body,fun_symb,fun_info={fi_group_index, fi_dynamics}} = fun_def
| isEmpty fi_dynamics
= update_dynamics funs type_pattern_vars fun_defs fun_env symbol_heap type_code_info var_heap error
# (type_code_info, symbol_heap, type_pattern_vars, var_heap)
= convertDynamicTypes fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap)
# (type_code_info, symbol_heap, type_pattern_vars, var_heap, error)
= convertDynamicTypes fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap, error)
(TransformedBody tb) = fun_body
(tb_rhs, {ui_instance_calls, ui_symbol_heap, ui_var_heap, ui_fun_defs, ui_fun_env, ui_error}) = updateExpression fi_group_index tb.tb_rhs
{ ui_instance_calls = [], ui_symbol_heap = symbol_heap, ui_fun_defs = fun_defs, ui_local_vars = [],
ui_fun_env = fun_env, ui_var_heap = var_heap, ui_error = error }
fun_def = { fun_def & fun_body = TransformedBody {tb & tb_rhs = tb_rhs}}
= update_dynamics funs type_pattern_vars { ui_fun_defs & [fun] = fun_def } ui_fun_env ui_symbol_heap type_code_info ui_var_heap ui_error
= update_dynamics funs type_pattern_vars ({ ui_fun_defs & [fun] = fun_def }
/* ---> ("update_dynamics", fun_symb, tb_rhs) */)
ui_fun_env ui_symbol_heap type_code_info ui_var_heap ui_error
removeOverloadedFunctions :: ![Index] ![LocalTypePatternVariable] !*{#FunDef} !*{! FunctionType} !*ExpressionHeap
!*TypeCodeInfo !*VarHeap !*ErrorAdmin
......@@ -817,7 +825,8 @@ where
(rev_variables, var_heap) = foldSt determine_class_argument st_context ([], var_heap)
// ---> ("remove_overloaded_function", fun_symb, st_context))
error = setErrorAdmin (newPosition fun_symb fun_pos) error
(type_code_info, symbol_heap, type_pattern_vars, var_heap) = convertDynamicTypes fun_info.fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap)
(type_code_info, symbol_heap, type_pattern_vars, var_heap, error)
= convertDynamicTypes fun_info.fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap, error)
(tb_rhs, {ui_instance_calls, ui_local_vars, ui_symbol_heap, ui_var_heap, ui_fun_defs, ui_fun_env, ui_error})
= updateExpression fun_info.fi_group_index tb_rhs { ui_instance_calls = [], ui_local_vars = fun_info.fi_local_vars, ui_symbol_heap = symbol_heap,
ui_var_heap = var_heap, ui_fun_defs = fun_defs, ui_fun_env = fun_env, ui_error = error }
......@@ -858,7 +867,7 @@ where
convertDynamicTypes dyn_ptrs update_info
= foldSt update_dynamic dyn_ptrs update_info
where
update_dynamic dyn_ptr (type_code_info, expr_heap, type_pattern_vars, var_heap)
update_dynamic dyn_ptr (type_code_info, expr_heap, type_pattern_vars, var_heap, error)
# (dyn_info, expr_heap) = readPtr dyn_ptr expr_heap
= case dyn_info of
EI_TempDynamicType (Yes {dt_global_vars, dt_uni_vars, dt_type}) _ _ expr_ptr _
......@@ -869,19 +878,21 @@ where
dt_global_vars type_codes type_code_info.tci_type_var_heap
(uni_vars, (type_var_heap, var_heap)) = new_type_variables dt_uni_vars (type_var_heap, var_heap)
(type_code_expr, type_code_info) = toTypeCodeExpression dt_type { type_code_info & tci_type_var_heap = type_var_heap }
-> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic uni_vars type_code_expr), type_pattern_vars, var_heap)
-> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic uni_vars type_code_expr), type_pattern_vars, var_heap, error)
EI_Empty
# (uni_vars, (type_var_heap, var_heap)) = new_type_variables dt_uni_vars (type_code_info.tci_type_var_heap, var_heap)
(type_code_expr, type_code_info) = toTypeCodeExpression dt_type { type_code_info & tci_type_var_heap = type_var_heap }
-> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic uni_vars type_code_expr), type_pattern_vars, var_heap)
EI_TempDynamicType No _ _ expr_ptr _
-> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic uni_vars type_code_expr), type_pattern_vars, var_heap, error)
EI_TempDynamicType No _ _ expr_ptr {symb_name}
# (expr_info, expr_heap) = readPtr expr_ptr expr_heap
-> case expr_info of
EI_TypeCode type_expr
-> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic [] type_expr), type_pattern_vars, var_heap)
# (type_expr, (free_vars, var_heap, error)) = retrieve_free_vars symb_name type_expr ([], var_heap, error)
var_heap = foldSt mark_free_var free_vars var_heap
-> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic free_vars type_expr), type_pattern_vars, var_heap, error)
EI_Selection selectors record_var _
# (_, var_info_ptr, var_heap) = abort "getClassVariable record_var var_heap (overloading.icl)"
-> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic [] (convert_selectors selectors var_info_ptr)), type_pattern_vars, var_heap)
# (_, var_info_ptr, var_heap, error) = getClassVariable symb_name record_var var_heap error
-> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic [] (convert_selectors selectors var_info_ptr)), type_pattern_vars, var_heap, error)
EI_TempDynamicPattern type_vars {dt_global_vars, dt_type} loc_dynamics temp_local_vars _ _ expr_ptr _
# (expr_info, expr_heap) = readPtr expr_ptr expr_heap
-> case expr_info of
......@@ -890,12 +901,12 @@ where
(var_ptrs, (type_pattern_vars, var_heap)) = mapSt addLocalTCInstance temp_local_vars (type_pattern_vars, var_heap)
type_var_heap = fold2St (\{tv_info_ptr} var_ptr -> writePtr tv_info_ptr (TVI_TypeCode (TCE_Var var_ptr))) type_vars var_ptrs type_var_heap
(type_code_expr, type_code_info) = toTypeCodeExpression dt_type { type_code_info & tci_type_var_heap = type_var_heap }
-> convert_local_dynamics loc_dynamics (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr), type_pattern_vars, var_heap)
-> convert_local_dynamics loc_dynamics (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr), type_pattern_vars, var_heap, error)
EI_Empty
# (var_ptrs, (type_pattern_vars, var_heap)) = mapSt addLocalTCInstance temp_local_vars (type_pattern_vars, var_heap)
type_var_heap = fold2St (\{tv_info_ptr} var_ptr -> writePtr tv_info_ptr (TVI_TypeCode (TCE_Var var_ptr))) type_vars var_ptrs type_code_info.tci_type_var_heap
(type_code_expr, type_code_info) = toTypeCodeExpression dt_type { type_code_info & tci_type_var_heap = type_var_heap }
-> convert_local_dynamics loc_dynamics (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr), type_pattern_vars, var_heap)
-> convert_local_dynamics loc_dynamics (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr), type_pattern_vars, var_heap, error)
where
convert_local_dynamics loc_dynamics state
......@@ -913,6 +924,32 @@ where
# (new_var_ptr, var_heap) = newPtr VI_Empty var_heap
= (new_var_ptr, (type_var_heap <:= (tv_info_ptr, TVI_TypeCode (TCE_Var new_var_ptr)), var_heap))
retrieve_free_vars symb_name (TCE_Var var_info_ptr) free_vars_and_var_heap
# (var_info_ptr, free_vars_and_var_heap) = retrieve_var symb_name var_info_ptr free_vars_and_var_heap
= (TCE_Var var_info_ptr, free_vars_and_var_heap)
retrieve_free_vars symb_name (TCE_Constructor type_index type_args) free_vars_and_var_heap
# (type_args, free_vars_and_var_heap) = mapSt (retrieve_free_vars symb_name) type_args free_vars_and_var_heap
= (TCE_Constructor type_index type_args, free_vars_and_var_heap)
retrieve_free_vars symb_name (TCE_Selector selections var_info_ptr) free_vars_and_var_heap
# (var_info_ptr, free_vars_and_var_heap) = retrieve_var symb_name var_info_ptr free_vars_and_var_heap
= (TCE_Selector selections var_info_ptr, free_vars_and_var_heap)
retrieve_free_vars symb_name TCE_Empty free_vars_and_var_heap
= (TCE_Empty, free_vars_and_var_heap)
retrieve_var symb_name var_info_ptr (free_vars, var_heap, error)
= case (readPtr var_info_ptr var_heap) of
(VI_ClassVar var_name new_info_ptr count, var_heap)
-> (new_info_ptr, (free_vars, var_heap <:= (var_info_ptr, VI_ClassVar var_name new_info_ptr (inc count)), error))
(VI_Defined, var_heap)
-> (var_info_ptr, (free_vars, var_heap, error))
(VI_LocallyDefined, var_heap)
-> (var_info_ptr, (free_vars, var_heap, overloadingError symb_name error))
(_, var_heap)
-> (var_info_ptr, ([var_info_ptr : free_vars], var_heap <:= (var_info_ptr, VI_Defined), error))
mark_free_var var_info_ptr var_heap
= var_heap <:= (var_info_ptr, VI_LocallyDefined)
:: TypeCodeInfo =
{ tci_next_index :: !Index
, tci_instances :: ![GlobalTCInstance]
......@@ -1285,3 +1322,14 @@ where
(<<<) file (EI_Selection sels var_ptr exprs) = file <<< sels <<< var_ptr <<< exprs
(<<<) file (EI_Context exprs) = file <<< exprs
(<<<) file _ = file
instance <<< ClassApplication
where
(<<<) file (CA_Instance rc) = file <<< "CA_Instance"
(<<<) file (CA_Context tc) = file <<< "CA_Context " <<< tc
(<<<) file (CA_LocalTypeCode tc) = file <<< "CA_LocalTypeCode " <<< tc
(<<<) file (CA_GlobalTypeCode tci) = file <<< "CA_GlobalTypeCode " <<< tci
instance <<< TypeCodeInstance
where
(<<<) file {tci_index, tci_contexts} = file <<< tci_index <<< ' ' <<< tci_contexts
......@@ -461,7 +461,8 @@ cIsALocalVar :== False
VI_Default !Int | VI_Indirection !Int | /* used during conversion of dynamics; the Int indiacted the refenrence count */
VI_Body !SymbIdent !TransformedBody ![FreeVar] | /* used during fusion */
VI_Dictionary !SymbIdent ![Expression] !Type | /* used during fusion */
VI_Extended !ExtendedVarInfo !VarInfo
VI_Extended !ExtendedVarInfo !VarInfo |
VI_Defined /* for marking type code variables during overloading */ | VI_LocallyDefined
:: ExtendedVarInfo = EVI_VarType !AType
......
......@@ -436,7 +436,8 @@ cIsALocalVar :== False
VI_Default !Int | VI_Indirection !Int | /* used during conversion of dynamics; the Int indiacted the refenrence count */
VI_Body !SymbIdent !TransformedBody ![FreeVar] | /* used during fusion */
VI_Dictionary !SymbIdent ![Expression] !Type | /* used during fusion */
VI_Extended !ExtendedVarInfo !VarInfo
VI_Extended !ExtendedVarInfo !VarInfo |
VI_Defined /* for marking type code variables during overloading */ | VI_LocallyDefined
:: ExtendedVarInfo = EVI_VarType !AType
......
......@@ -1182,15 +1182,15 @@ where
{ prop_type_heaps = ts_type_heaps, prop_td_infos = ts_td_infos,
prop_attr_vars = st_attr_vars, prop_attr_env = st_attr_env, prop_error = ts_error}
(st_result, _, {prop_type_heaps,prop_td_infos,prop_attr_vars,prop_error,prop_attr_env}) = addPropagationAttributesToAType common_defs st_result ps
ft = { ft & st_args = st_args, st_result = st_result, st_attr_vars = prop_attr_vars, st_attr_env = prop_attr_env }
ft_with_prop = { ft & st_args = st_args, st_result = st_result, st_attr_vars = prop_attr_vars, st_attr_env = prop_attr_env }
(th_vars, ts_expr_heap) = clear_dynamics fi_dynamics (prop_type_heaps.th_vars, ts.ts_expr_heap)
(fresh_fun_type, cons_variables, ts) = freshSymbolType cWithoutFreshContextVars ft common_defs { ts & ts_type_heaps = { prop_type_heaps & th_vars = th_vars }, ts_expr_heap = ts_expr_heap,
(fresh_fun_type, cons_variables, ts) = freshSymbolType cWithoutFreshContextVars ft_with_prop common_defs { ts & ts_type_heaps = { prop_type_heaps & th_vars = th_vars }, ts_expr_heap = ts_expr_heap,
ts_td_infos = prop_td_infos, ts_error = prop_error }
(lifted_args, ts) = fresh_non_unique_type_variables fun_lifted [] ts
(ts_var_store, ts_type_heaps, ts_var_heap, ts_expr_heap, pre_def_symbols)
= fresh_dynamics fi_dynamics (ts.ts_var_store, ts.ts_type_heaps, ts.ts_var_heap, ts.ts_expr_heap, pre_def_symbols)
= (pre_def_symbols, [ cons_variables : req_cons_variables],
{ ts & ts_fun_env = { ts.ts_fun_env & [fun] = SpecifiedType ft lifted_args
{ ts & ts_fun_env = { ts.ts_fun_env & [fun] = SpecifiedType ft_with_prop lifted_args
{ fresh_fun_type & tst_arity = st_arity + fun_lifted, tst_args = lifted_args ++ fresh_fun_type.tst_args, tst_lifted = fun_lifted }},
ts_var_heap = ts_var_heap, ts_var_store = ts_var_store, ts_expr_heap = ts_expr_heap, ts_type_heaps = ts_type_heaps })
initial_symbol_type is_start_rule common_defs {fun_arity, fun_lifted, fun_info = {fi_dynamics}} (pre_def_symbols, req_cons_variables, ts)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment