Commit ca6cbbce authored by Martin Wierich's avatar Martin Wierich
Browse files

1. bugfix concerning dictionaries that contain let expressions

2. bugfix for fusion algorithm
parent aa7feb3d
...@@ -186,8 +186,8 @@ where ...@@ -186,8 +186,8 @@ where
# (dp_rhs, ls) = lift dp_rhs ls # (dp_rhs, ls) = lift dp_rhs ls
= ({ pattern & dp_rhs = dp_rhs }, ls) = ({ pattern & dp_rhs = dp_rhs }, ls)
unfoldVariable :: !BoundVar !*UnfoldState -> (!Expression, !*UnfoldState) unfoldVariable :: !BoundVar UnfoldInfo !*UnfoldState -> (!Expression, !*UnfoldState)
unfoldVariable var=:{var_name,var_info_ptr} us unfoldVariable var=:{var_name,var_info_ptr} ui us
#! (var_info, us) = readVarInfo var_info_ptr us #! (var_info, us) = readVarInfo var_info_ptr us
= case var_info of = case var_info of
VI_Expression expr VI_Expression expr
...@@ -203,8 +203,9 @@ unfoldVariable var=:{var_name,var_info_ptr} us ...@@ -203,8 +203,9 @@ unfoldVariable var=:{var_name,var_info_ptr} us
VI_Dictionary app_symb app_args class_type VI_Dictionary app_symb app_args class_type
# (new_class_type, us_opt_type_heaps) = substitute_class_types class_type us.us_opt_type_heaps # (new_class_type, us_opt_type_heaps) = substitute_class_types class_type us.us_opt_type_heaps
(new_info_ptr, us_symbol_heap) = newPtr (EI_DictionaryType new_class_type) us.us_symbol_heap (new_info_ptr, us_symbol_heap) = newPtr (EI_DictionaryType new_class_type) us.us_symbol_heap
-> (App { app_symb = app_symb, app_args = app_args, app_info_ptr = new_info_ptr }, app = App { app_symb = app_symb, app_args = app_args, app_info_ptr = new_info_ptr }
{ us & us_opt_type_heaps = us_opt_type_heaps, us_symbol_heap = us_symbol_heap }) us = { us & us_opt_type_heaps = us_opt_type_heaps, us_symbol_heap = us_symbol_heap }
-> unfold app ui us
_ _
-> (Var var, us) -> (Var var, us)
where where
...@@ -214,6 +215,7 @@ unfoldVariable var=:{var_name,var_info_ptr} us ...@@ -214,6 +215,7 @@ unfoldVariable var=:{var_name,var_info_ptr} us
# (_,new_class_types, type_heaps) = substitute class_types type_heaps # (_,new_class_types, type_heaps) = substitute class_types type_heaps
= (new_class_types, Yes type_heaps) = (new_class_types, Yes type_heaps)
readVarInfo var_info_ptr us readVarInfo var_info_ptr us
#! var_info = sreadPtr var_info_ptr us.us_var_heap #! var_info = sreadPtr var_info_ptr us.us_var_heap
= case var_info of = case var_info of
...@@ -260,7 +262,7 @@ class unfold a :: !a !UnfoldInfo !*UnfoldState -> (!a, !*UnfoldState) ...@@ -260,7 +262,7 @@ class unfold a :: !a !UnfoldInfo !*UnfoldState -> (!a, !*UnfoldState)
instance unfold Expression instance unfold Expression
where where
unfold (Var var) ui us unfold (Var var) ui us
= unfoldVariable var us = unfoldVariable var ui us
unfold (App app) ui us unfold (App app) ui us
# (app, us) = unfold app ui us # (app, us) = unfold app ui us
= (App app, us) = (App app, us)
...@@ -312,7 +314,7 @@ where ...@@ -312,7 +314,7 @@ where
unfold (DictionarySelection var selectors expr_ptr index_expr) ui us=:{us_symbol_heap} unfold (DictionarySelection var selectors expr_ptr index_expr) ui us=:{us_symbol_heap}
# (new_ptr, us_symbol_heap) = newPtr EI_Empty us_symbol_heap # (new_ptr, us_symbol_heap) = newPtr EI_Empty us_symbol_heap
(index_expr, us) = unfold index_expr ui { us & us_symbol_heap = us_symbol_heap} (index_expr, us) = unfold index_expr ui { us & us_symbol_heap = us_symbol_heap}
(var_expr, us) = unfoldVariable var us (var_expr, us) = unfoldVariable var ui us
= case var_expr of = case var_expr of
App {app_symb={symb_kind= SK_Constructor _ }, app_args} App {app_symb={symb_kind= SK_Constructor _ }, app_args}
# [RecordSelection _ field_index:_] = selectors # [RecordSelection _ field_index:_] = selectors
...@@ -458,8 +460,7 @@ where ...@@ -458,8 +460,7 @@ where
No -> (No, us) No -> (No, us)
Yes fvs # (fvs_subst, us) = mapSt unfoldBoundVar fvs us Yes fvs # (fvs_subst, us) = mapSt unfoldBoundVar fvs us
-> (Yes fvs_subst, us) -> (Yes fvs_subst, us)
(var_info, us_var_heap) = readPtr var_info_ptr us.us_var_heap (var_info, us) = readVarInfo var_info_ptr us
us = { us & us_var_heap = us_var_heap }
-> case var_info of -> case var_info of
VI_Body fun_symb {tb_args, tb_rhs} new_aci_params VI_Body fun_symb {tb_args, tb_rhs} new_aci_params
# tb_args_ptrs = [ fv_info_ptr \\ {fv_info_ptr}<-tb_args ] # tb_args_ptrs = [ fv_info_ptr \\ {fv_info_ptr}<-tb_args ]
......
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