diff options
| -rw-r--r-- | frontend/check.icl | 56 | ||||
| -rw-r--r-- | frontend/checksupport.dcl | 4 | ||||
| -rw-r--r-- | frontend/checksupport.icl | 3 | ||||
| -rw-r--r-- | frontend/checktypes.icl | 9 | ||||
| -rw-r--r-- | frontend/comparedefimp.icl | 2 | ||||
| -rw-r--r-- | frontend/convertcases.icl | 71 | ||||
| -rw-r--r-- | frontend/explicitimports.icl | 7 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 2 | ||||
| -rw-r--r-- | frontend/syntax.icl | 9 | ||||
| -rw-r--r-- | frontend/trans.icl | 46 | ||||
| -rw-r--r-- | frontend/transform.icl | 24 |
11 files changed, 135 insertions, 98 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index 84b8b2e..86a4cf4 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -1258,7 +1258,7 @@ checkExpression free_vars (PE_Case case_ident expr alts) e_input e_state e_info (guards, _, pattern_variables, defaul, free_vars, e_state, e_info, cs) = check_guarded_expressions free_vars alts [] case_ident.id_name e_input e_state e_info cs (pattern_expr, binds, es_expr_heap) = bind_pattern_variables pattern_variables pattern_expr e_state.es_expr_heap (case_expr, es_expr_heap) = build_case guards defaul pattern_expr case_ident es_expr_heap - (result_expr, es_expr_heap) = buildLetExpression binds cIsNotStrict case_expr es_expr_heap + (result_expr, es_expr_heap) = buildLetExpression [] binds case_expr es_expr_heap = (result_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs) where @@ -1418,7 +1418,7 @@ where bind_default_variable bind_src bind_dst result_expr expr_heap # (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap - = (Let {let_strict_binds = [{ bind_src = bind_src, bind_dst = bind_dst }], let_lazy_binds = [], + = (Let {let_strict_binds = [], let_lazy_binds = [{ bind_src = bind_src, bind_dst = bind_dst }], let_expr = result_expr, let_info_ptr = let_expr_ptr }, expr_heap) bind_pattern_variables [] pattern_expr expr_heap @@ -1667,14 +1667,12 @@ checkArraySelection glob_select_symb free_vars index_expr e_input e_state e_info (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap = (ArraySelection glob_select_symb new_info_ptr index_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs) -buildLetExpression :: !(Env Expression FreeVar) !Bool !Expression !*ExpressionHeap -> (!Expression, !*ExpressionHeap) -buildLetExpression [] is_strict expr expr_heap +buildLetExpression :: !(Env Expression FreeVar) !(Env Expression FreeVar) !Expression !*ExpressionHeap -> (!Expression, !*ExpressionHeap) +buildLetExpression [] [] expr expr_heap = (expr, expr_heap) -buildLetExpression binds is_strict expr expr_heap - # (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap - | is_strict - = (Let {let_strict_binds = binds, let_lazy_binds = [], let_expr = expr, let_info_ptr = let_expr_ptr }, expr_heap) - = (Let {let_strict_binds = [], let_lazy_binds = binds, let_expr = expr, let_info_ptr = let_expr_ptr }, expr_heap) +buildLetExpression let_strict_binds let_lazy_binds expr expr_heap + # (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + = (Let {let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = expr, let_info_ptr = let_expr_ptr }, expr_heap) checkLhssOfLocalDefs def_level mod_index (CollectedLocalDefs {loc_functions={ir_from,ir_to},loc_nodes}) e_state=:{es_var_heap,es_fun_defs} e_info cs # (loc_defs, accus, {ps_fun_defs,ps_var_heap}, e_info, cs) @@ -1694,7 +1692,7 @@ checkRhssAndTransformLocalDefs free_vars [] rhs_expr e_input e_state e_info cs = (rhs_expr, free_vars, e_state, e_info, cs) checkRhssAndTransformLocalDefs free_vars loc_defs rhs_expr e_input e_state e_info cs # (binds, free_vars, e_state, e_info, cs) = checkAndTransformPatternIntoBind free_vars loc_defs e_input e_state e_info cs - (rhs_expr, es_expr_heap) = buildLetExpression binds cIsNotStrict rhs_expr e_state.es_expr_heap + (rhs_expr, es_expr_heap) = buildLetExpression [] binds rhs_expr e_state.es_expr_heap = (rhs_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs) checkAndTransformPatternIntoBind free_vars [{nd_dst,nd_alts,nd_locals} : local_defs] e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs @@ -1894,9 +1892,9 @@ where (let_binds, es_var_heap, es_expr_heap, e_info, cs) = transfromPatternIntoBind ei_mod_index ei_expr_level pattern_expr src_expr e_state.es_var_heap e_state.es_expr_heap e_info cs e_state = { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap } - (_, array_pattern_binds, free_vars, e_state, e_info, cs) // XXX arrays currently not strictly evaluated + (strict_array_pattern_binds, lazy_array_pattern_binds, free_vars, e_state, e_info, cs) = foldSt (buildSelections e_input) array_patterns ([], [], free_vars, e_state, e_info, cs) - all_binds = [(seq_let.ndwl_strict, let_binds), (nOT_STRICT, array_pattern_binds) : binds] with nOT_STRICT = False + all_binds = [if seq_let.ndwl_strict (let_binds,[]) ([],let_binds), (strict_array_pattern_binds, lazy_array_pattern_binds) : binds] = (all_binds, loc_envs, max_expr_level, free_vars, e_state, e_info, cs) check_sequential_lets free_vars [] let_vars_list e_input=:{ei_expr_level} e_state e_info cs = ([], let_vars_list, ei_expr_level, free_vars, e_state, e_info, cs) @@ -1917,14 +1915,13 @@ where e_state = { e_state & es_var_heap = ps_var_heap, es_expr_heap = hp_expression_heap, es_type_heaps = hp_type_heaps, es_fun_defs = ps_fun_defs } = (src_expr, pattern, accus, free_vars, e_state, e_info, cs) - build_sequential_lets :: ![(Bool,[Bind Expression FreeVar])] !Expression !*ExpressionHeap -> (!Expression, !*ExpressionHeap) + build_sequential_lets :: ![(![Bind Expression FreeVar],![Bind Expression FreeVar])] !Expression !*ExpressionHeap -> (!Expression, !*ExpressionHeap) build_sequential_lets [] expr expr_heap = (expr, expr_heap) - build_sequential_lets [(nd_strict,[]) : seq_lets] expr expr_heap - = build_sequential_lets seq_lets expr expr_heap - build_sequential_lets [(nd_strict,binds) : seq_lets] expr expr_heap + build_sequential_lets [(strict_binds, lazy_binds) : seq_lets] expr expr_heap # (let_expr, expr_heap) = build_sequential_lets seq_lets expr expr_heap - = buildLetExpression binds nd_strict let_expr expr_heap + = buildLetExpression strict_binds lazy_binds let_expr expr_heap + newVarId name = { id_name = name, id_info = nilPtr } @@ -1945,8 +1942,8 @@ convertSubPattern (AP_Variable name var_info (Yes {bind_src,bind_dst})) result_e # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap bound_var = { var_name = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr } free_var = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 } - (let_expr, expr_heap) = buildLetExpression [{ bind_src = Var bound_var, - bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}] cIsNotStrict result_expr expr_heap + (let_expr, expr_heap) = buildLetExpression [] [{ bind_src = Var bound_var, + bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}] result_expr expr_heap = (free_var, let_expr, var_store, expr_heap, opt_dynamics, cs) convertSubPattern (AP_Variable name var_info No) result_expr var_store expr_heap opt_dynamics cs = ({ fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, result_expr, var_store, expr_heap, opt_dynamics, cs) @@ -1995,7 +1992,6 @@ typeOfBasicValue (BVS _) cs = (BT_String (TA (MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident ds_arity) []), cs) -// XXX no strict_binds addArraySelections [] rhs_expr free_vars e_input e_state e_info cs = (rhs_expr, free_vars, e_state, e_info, cs) addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs @@ -2013,21 +2009,21 @@ addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs buildSelections e_input {ap_opt_var, ap_array_var, ap_selections} (strict_binds, lazy_binds, free_vars, e_state, e_info, cs) - # (ap_array_var, strict_binds, lazy_binds, free_vars, e_state, e_info, cs) - = foldSt (build_sc e_input) ap_selections - (ap_array_var, strict_binds, lazy_binds, free_vars, e_state, e_info, cs) + # (ap_array_var, [last_array_selection:lazy_binds], free_vars, e_state, e_info, cs) + = foldSt (build_sc e_input) (reverse ap_selections) // reverse to make cycle-in-spine behaviour compatible to Clean 1.3 + (ap_array_var, lazy_binds, free_vars, e_state, e_info, cs) (lazy_binds, e_state) = case ap_opt_var of Yes { bind_src = opt_var_ident, bind_dst = opt_var_var_info_ptr } # (bound_array_var, es_expr_heap) = allocate_bound_var ap_array_var e_state.es_expr_heap free_var = { fv_name = opt_var_ident, fv_info_ptr = opt_var_var_info_ptr, fv_def_level = NotALevel, fv_count = 0 } - -> ([{ bind_dst = free_var, bind_src = Var bound_array_var } : lazy_binds], + -> ([{ bind_dst = free_var, bind_src = Var bound_array_var }: lazy_binds], { e_state & es_expr_heap = es_expr_heap }) no -> (lazy_binds, e_state) - = (strict_binds, lazy_binds, free_vars, e_state, e_info, cs) + = ([last_array_selection:strict_binds], lazy_binds, free_vars, e_state, e_info, cs) where - build_sc e_input {bind_dst=parsed_index_exprs, bind_src=array_element_var} (ap_array_var, strict_binds, lazy_binds, free_vars, e_state, e_info, cs) + build_sc e_input {bind_dst=parsed_index_exprs, bind_src=array_element_var} (ap_array_var, binds, free_vars, e_state, e_info, cs) # (var_for_uselect_result, es_var_heap) = allocate_free_var { id_name = "_x", id_info = nilPtr } e_state.es_var_heap (new_array_var, es_var_heap) @@ -2036,7 +2032,8 @@ buildSelections e_input {ap_opt_var, ap_array_var, ap_selections} = allocate_bound_var ap_array_var e_state.es_expr_heap (bound_var_for_uselect_result, es_expr_heap) = allocate_bound_var var_for_uselect_result es_expr_heap - dimension = length parsed_index_exprs + dimension + = length parsed_index_exprs (new_expr_ptrs, es_expr_heap) = mapSt newPtr (repeatn dimension EI_Empty) es_expr_heap (tuple_cons, cs) @@ -2055,11 +2052,10 @@ buildSelections e_input {ap_opt_var, ap_array_var, ap_selections} selections = [ ArraySelection glob_select_symb new_expr_ptr index_expr \\ new_expr_ptr<-new_expr_ptrs & index_expr<-index_exprs ] = ( new_array_var - , strict_binds , [ {bind_dst = var_for_uselect_result, bind_src = Selection opt_tuple_type (Var bound_array_var) selections} - , {bind_dst = new_array_var, bind_src = TupleSelect tuple_cons.glob_object 1 (Var bound_var_for_uselect_result)} + , {bind_dst = new_array_var, bind_src = TupleSelect tuple_cons.glob_object 1 (Var bound_var_for_uselect_result)} , {bind_dst = array_element_var, bind_src = TupleSelect tuple_cons.glob_object 0 (Var bound_var_for_uselect_result)} - : lazy_binds + : binds ] , free_vars , e_state diff --git a/frontend/checksupport.dcl b/frontend/checksupport.dcl index 374c72c..36f7c73 100644 --- a/frontend/checksupport.dcl +++ b/frontend/checksupport.dcl @@ -3,6 +3,10 @@ definition module checksupport import StdEnv import syntax, predef + +SwitchUniquenessBug with_bug without_bug :== with_bug +// temporary switch for compiling the Object I/O library + cIclModIndex :== 0 CS_NotChecked :== -1 diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl index e5d8292..6e57ca1 100644 --- a/frontend/checksupport.icl +++ b/frontend/checksupport.icl @@ -6,6 +6,9 @@ import utilities :: VarHeap :== Heap VarInfo +SwitchUniquenessBug with_bug without_bug :== with_bug +// temporary switch for compiling the Object I/O library + cIclModIndex :== 0 CS_NotChecked :== -1 diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index a94f7fa..ffa1f7c 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -1021,13 +1021,8 @@ where TA_Var var -> (TA_RootVar var, error) _ - -> (TA_RootVar undef, error) -/* = case root_attr of - TA_Var var - -> (TA_RootVar var, error) - _ - -> (root_attr, error) -*/ check_attribute attr root_attr name error + -> (SwitchUniquenessBug (TA_RootVar (abort "SwitchUniquenessBug is on")) root_attr, error) + check_attribute attr root_attr name error = (TA_Multi, checkError name "specified attribute not allowed" error) retrieveKinds :: ![ATypeVar] *TypeVarHeap -> (![TypeKind], !*TypeVarHeap) diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index 47a12d7..41bf4e7 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -505,7 +505,7 @@ instance t_corresponds TypeAttribute where t_corresponds (TA_Var dclDef) (TA_Var iclDef) = t_corresponds dclDef iclDef t_corresponds (TA_RootVar dclDef) (TA_RootVar iclDef) - = t_corresponds dclDef iclDef + = SwitchUniquenessBug (return True) (t_corresponds dclDef iclDef) t_corresponds _ TA_Anonymous = return True t_corresponds TA_None icl diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl index 88b5845..9d56ee7 100644 --- a/frontend/convertcases.icl +++ b/frontend/convertcases.icl @@ -486,7 +486,7 @@ where convert_function group_index dcl_functions common_defs fun (fun_defs, collected_imports, ci) #! fun_def = fun_defs.[fun] # {fun_body,fun_type} = fun_def - (fun_body, (collected_imports, ci)) = eliminate_code_sharing_in_function dcl_functions common_defs fun_body /* (fun_body ---> ("convert_function", fun_def.fun_symb, fun_body)) */(collected_imports, ci) + (fun_body, (collected_imports, ci)) = eliminate_code_sharing_in_function dcl_functions common_defs fun_body /* (fun_body ---> ("convert_function", fun_def.fun_symb, fun_body)) */ (collected_imports, ci) (fun_body, ci) = convert_cases_into_function_patterns fun_body fun_type group_index common_defs ci = ({fun_defs & [fun] = { fun_def & fun_body = fun_body }}, collected_imports, ci) @@ -935,10 +935,10 @@ where /* - weightedRefCount determines the references counts of variables in an expression. Runtime behaviour of constructs into account: + weightedRefCount determines the reference counts of variables in an expression. Runtime behaviour of constructs is taken into account: multiple occurrences of variables in different alternatives of the same case clause are counted only once. The outcome is used to distribute shared expressions (via let declarations) over cases. In this way code sharing is eliminated. - As a side effect, weightedRefCount returns a list of all imported function that have been used iinside the expression. + As a side effect, weightedRefCount returns a list of all imported functions that have been used inside the expression. */ @@ -988,21 +988,21 @@ where weightedRefCount dcl_functions common_defs depth (fun_expr @ exprs) rc_info = weightedRefCount dcl_functions common_defs depth (fun_expr, exprs) rc_info weightedRefCount dcl_functions common_defs depth (Let {let_strict_binds,let_lazy_binds,let_expr, let_info_ptr}) rc_info=:{rc_var_heap} - # let_binds = let_strict_binds ++ let_lazy_binds - # rc_info = weightedRefCount dcl_functions common_defs depth let_expr { rc_info & rc_var_heap = foldSt store_binding let_binds rc_var_heap } + # rc_info = weightedRefCount dcl_functions common_defs depth let_strict_binds { rc_info & rc_var_heap = foldSt store_binding let_lazy_binds rc_var_heap } + rc_info = weightedRefCount dcl_functions common_defs depth let_expr rc_info (let_info, rc_expr_heap) = readPtr let_info_ptr rc_info.rc_expr_heap rc_info = { rc_info & rc_expr_heap = rc_expr_heap } = case let_info of EI_LetType let_type - # (ref_counts, rc_var_heap) = mapSt get_ref_count let_binds rc_info.rc_var_heap - (rc_free_vars, rc_var_heap) = foldl remove_variable (rc_info.rc_free_vars, rc_var_heap) let_binds + # (ref_counts, rc_var_heap) = mapSt get_ref_count let_lazy_binds rc_info.rc_var_heap + (rc_free_vars, rc_var_heap) = foldl remove_variable (rc_info.rc_free_vars, rc_var_heap) let_lazy_binds -> { rc_info & rc_free_vars = rc_free_vars, rc_var_heap = rc_var_heap, rc_expr_heap = rc_info.rc_expr_heap <:= (let_info_ptr, EI_LetTypeAndRefCounts let_type ref_counts)} -// ---> ("weightedRefCount (EI_LetType)", ptrToInt let_info_ptr, [ x.bind_dst \\ x <- let_binds]) +// ---> ("weightedRefCount (EI_LetType)", ptrToInt let_info_ptr, [ x.bind_dst \\ x <- let_lazy_binds]) _ - # (rc_free_vars, rc_var_heap) = foldl remove_variable (rc_info.rc_free_vars, rc_info.rc_var_heap) let_binds + # (rc_free_vars, rc_var_heap) = foldl remove_variable (rc_info.rc_free_vars, rc_info.rc_var_heap) let_lazy_binds -> { rc_info & rc_free_vars = rc_free_vars, rc_var_heap = rc_var_heap } -// ---> ("weightedRefCount (_)", ptrToInt let_info_ptr, [ x.bind_dst \\ x <- let_binds]) +// ---> ("weightedRefCount (_)", ptrToInt let_info_ptr, [ x.bind_dst \\ x <- let_lazy_binds]) where remove_variable ([], var_heap) let_bind = ([], var_heap) @@ -1219,9 +1219,9 @@ checkImportedSymbol symb_kind symb_type_ptr (collected_imports, var_heap) , di_expr_heap :: !.ExpressionHeap } /* - distributeLets tries to move shared expressions as close as possible to the location at ewhich they are used. - Case-expression may require unsharing if the shared expression is used in different alternatives. Of course - only if the expreesion is not used in the pattern nor in a surrounding expression. + distributeLets tries to move shared expressions as close as possible to the location at which they are used. + Case-expressions may require unsharing if the shared expression is used in different alternatives. Of course + only if the expression is neither used in the pattern nor in a surrounding expression. */ class distributeLets e :: !Int !e !*DistributeInfo -> (!e, !*DistributeInfo) @@ -1284,12 +1284,22 @@ where distributeLets depth (Let lad=:{let_strict_binds,let_lazy_binds,let_expr,let_info_ptr}) dl_info=:{di_expr_heap,di_var_heap} # (let_info, di_expr_heap) = readPtr let_info_ptr di_expr_heap # (EI_LetTypeAndRefCounts let_type ref_counts) = let_info - let_binds = [(True, bind) \\ bind <- let_strict_binds] ++ [(False, bind) \\ bind <- let_lazy_binds] - di_var_heap = set_let_expression_info depth let_binds ref_counts let_type di_var_heap + nr_of_strict_lets = length let_strict_binds + let_binds = [(False, bind) \\ bind <- let_lazy_binds] + di_var_heap = set_let_expression_info depth let_binds ref_counts (drop nr_of_strict_lets let_type) di_var_heap (let_expr, dl_info) = distributeLets depth let_expr { dl_info & di_var_heap = di_var_heap, di_expr_heap = di_expr_heap } - dl_info = foldSt (distribute_lets_in_non_distributed_let depth) let_strict_binds dl_info + (let_strict_binds, dl_info) = distributeLets depth let_strict_binds dl_info dl_info = foldSt (distribute_lets_in_non_distributed_let depth) let_lazy_binds dl_info - = (let_expr, dl_info) + | nr_of_strict_lets == 0 + = (let_expr, dl_info) + = case let_expr of + Let inner_let=:{let_info_ptr=inner_let_info_ptr} + # (EI_LetType strict_inner_types, di_expr_heap) = readPtr inner_let_info_ptr dl_info.di_expr_heap + di_expr_heap = writePtr inner_let_info_ptr (EI_LetType ((take nr_of_strict_lets let_type)++strict_inner_types)) di_expr_heap + -> (Let { inner_let & let_strict_binds = let_strict_binds++inner_let.let_strict_binds}, + {dl_info & di_expr_heap = di_expr_heap}) + _ -> (Let { lad & let_strict_binds = let_strict_binds, let_expr = let_expr, let_lazy_binds = []}, + {dl_info & di_expr_heap = dl_info.di_expr_heap <:= (let_info_ptr, EI_LetType (take nr_of_strict_lets let_type))}) where set_let_expression_info depth [(let_strict, {bind_src,bind_dst}):binds][ref_count:ref_counts][type:types] var_heap # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap @@ -1385,7 +1395,7 @@ where mark_local_let_var depth {cv_variable, cv_count} (local_vars, var_heap) # (VI_LetExpression lei=:{lei_count,lei_depth}, var_heap) = readPtr cv_variable var_heap - | lei_count == cv_count + | lei_count == cv_count = ([(cv_variable, lei_count, lei_depth) : local_vars ], var_heap <:= (cv_variable, VI_LetExpression { lei & lei_depth = depth})) ==> ("mark_local_let_var ", lei.lei_var.fv_name, cv_variable, (lei.lei_var.fv_info_ptr, cv_count, depth)) = (local_vars, var_heap) @@ -1430,16 +1440,21 @@ distributeLetsInLetExpression depth let_var_info_ptr lei=:{lei_expression, lei_s buildLetExpr :: ![VarInfoPtr] !Expression !*(!*VarHeap, !*ExpressionHeap) -> (!Expression, !(!*VarHeap, !*ExpressionHeap)) buildLetExpr let_vars let_expr (var_heap, expr_heap) - # (strict_binds, strict_bind_types, lazy_binds, lazy_binds_types, var_heap) = foldr build_bind ([], [], [], [], var_heap) let_vars - | isEmpty strict_binds && isEmpty lazy_binds + # (lazy_binds, lazy_binds_types, var_heap) = foldr build_bind ([], [], var_heap) let_vars + | isEmpty lazy_binds = (let_expr, (var_heap, expr_heap)) - # (let_info_ptr, expr_heap) = newPtr (EI_LetType (strict_bind_types ++ lazy_binds_types)) expr_heap - = (Let { let_strict_binds = strict_binds, let_lazy_binds = lazy_binds, let_expr = let_expr, let_info_ptr = let_info_ptr }, (var_heap, expr_heap)) - + = case let_expr of + Let inner_let=:{let_info_ptr } + # (EI_LetType strict_bind_types, expr_heap) = readPtr let_info_ptr expr_heap + expr_heap = writePtr let_info_ptr (EI_LetType (strict_bind_types ++ lazy_binds_types)) expr_heap + -> (Let { inner_let & let_lazy_binds = lazy_binds }, (var_heap, expr_heap)) + _ + # (let_info_ptr, expr_heap) = newPtr (EI_LetType lazy_binds_types) expr_heap + -> (Let { let_strict_binds = [], let_lazy_binds = lazy_binds, let_expr = let_expr, let_info_ptr = let_info_ptr }, (var_heap, expr_heap)) where - build_bind :: !VarInfoPtr !(!Env Expression FreeVar, ![AType], !Env Expression FreeVar, ![AType], !*VarHeap) - -> (!Env Expression FreeVar, ![AType], !Env Expression FreeVar, ![AType], !*VarHeap) - build_bind info_ptr (strict_binds, strict_bind_types, lazy_binds, lazy_binds_types, var_heap) + build_bind :: !VarInfoPtr !(!Env Expression FreeVar, ![AType], !*VarHeap) + -> (!Env Expression FreeVar, ![AType], !*VarHeap) + build_bind info_ptr (lazy_binds, lazy_binds_types, var_heap) # (let_info, var_heap) = readPtr info_ptr var_heap # (VI_LetExpression lei=:{lei_strict,lei_var,lei_expression,lei_status,lei_type}) = let_info (LES_Updated updated_expr) = lei_status @@ -1447,8 +1462,8 @@ where var_heap = var_heap <:= (info_ptr, VI_LetExpression { lei & lei_status = LES_Untouched, lei_var = { lei_var & fv_info_ptr = new_info_ptr }}) // ==> (lei_var.fv_name, info_ptr, new_info_ptr) | lei_strict - = ([{ bind_src = updated_expr, bind_dst = lei_var } : strict_binds], [lei_type : strict_bind_types ], lazy_binds, lazy_binds_types, var_heap) - = (strict_binds, strict_bind_types, [{ bind_src = updated_expr, bind_dst = lei_var } : lazy_binds], [lei_type : lazy_binds_types ], var_heap) + = abort "assertion 1 failed in module convercases" + = ([{ bind_src = updated_expr, bind_dst = lei_var } : lazy_binds], [lei_type : lazy_binds_types ], var_heap) instance distributeLets Selection where diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl index 68fe201..f0c3623 100644 --- a/frontend/explicitimports.icl +++ b/frontend/explicitimports.icl @@ -777,15 +777,14 @@ instance consequences Expression consequences (FreeVar _) = [] consequences (DynamicExpr dynamicExpr) = consequences dynamicExpr consequences EE = [] -// RWS ... consequences (Update expr1 selections expr2) = consequences expr1++consequences selections++consequences expr2 consequences expr = abort "explicitimports:consequences (Expression) does not match" <<- expr -// ... RWS + instance consequences FunctionBody where consequences (CheckedBody body) = consequences body consequences (TransformedBody body) = consequences body - // other alternatives should not occur - + consequences (RhsMacroBody body) = consequences body + instance consequences FunType where consequences {ft_type} = consequences ft_type diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 5417dfe..02a6191 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -486,7 +486,7 @@ cIsALocalVar :== False :: LetExpressionInfo = { lei_count :: !Int , lei_depth :: !Int - , lei_strict :: !Bool + , lei_strict :: !Bool // MW this field seems to be superfluos , lei_var :: !FreeVar , lei_expression :: !Expression // , lei_moved :: !Bool diff --git a/frontend/syntax.icl b/frontend/syntax.icl index ee9303b..4d7f79f 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -1325,12 +1325,13 @@ where (<<<) file (App {app_symb, app_args, app_info_ptr}) = file <<< app_symb <<< ' ' <<< app_args (<<<) file (f_exp @ a_exp) = file <<< '(' <<< f_exp <<< " @ " <<< a_exp <<< ')' - (<<<) file (Let {let_info_ptr, let_strict_binds, let_lazy_binds, let_expr}) = write_binds (file <<< "let" <<< '\n') (let_strict_binds++let_lazy_binds) <<< "in\n" <<< let_expr + (<<<) file (Let {let_info_ptr, let_strict_binds, let_lazy_binds, let_expr}) + = write_binds "" (write_binds "!" (file <<< "let" <<< '\n') let_strict_binds) let_lazy_binds <<< "in\n" <<< let_expr where - write_binds file [] + write_binds x file [] = file - write_binds file [bind : binds] - = write_binds (file <<< bind <<< '\n') binds + write_binds x file [bind : binds] + = write_binds x (file <<< x <<< " " <<< bind <<< '\n') binds (<<<) file (Case {case_expr,case_guards,case_default=No}) = file <<< "case " <<< case_expr <<< " of\n" <<< case_guards (<<<) file (Case {case_expr,case_guards,case_default= Yes def_expr}) diff --git a/frontend/trans.icl b/frontend/trans.icl index 5b26a53..c72afbc 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -1733,32 +1733,46 @@ determineProducer is_applied_to_macro_fun linear_bit app=:{app_symb = symb=:{sym = (producers, [App app : new_args ], ti) # (fun_def, ti_fun_defs) = (ti.ti_fun_defs)![glob_object] ti = { ti & ti_fun_defs=ti_fun_defs } - is_curried = fun_def.fun_arity<>length app_args - is_good_producer = (implies is_curried is_applied_to_macro_fun) && (implies (not is_curried) (SwitchFusion linear_bit False)) - | is_good_producer - // curried applications may be fused with non linear consumers in functions local to a macro - = ({ producers & [prod_index] = PR_Function symb glob_object (length app_args)}, app_args ++ new_args, ti) - = (producers, [App app : new_args ], ti) - + nr_of_app_args = length app_args + = determineFunAppProducer fun_def nr_of_app_args (PR_Function symb glob_object nr_of_app_args) + is_applied_to_macro_fun linear_bit app new_args prod_index producers ti determineProducer is_applied_to_macro_fun linear_bit app=:{app_symb = symb=:{ symb_kind = SK_GeneratedFunction fun_ptr fun_index}, app_args} _ new_args prod_index producers ti # (FI_Function {gf_fun_def}, ti_fun_heap) = readPtr fun_ptr ti.ti_fun_heap ti = { ti & ti_fun_heap=ti_fun_heap } - # is_curried = gf_fun_def.fun_arity<>length app_args - is_good_producer = (implies is_curried is_applied_to_macro_fun) && (implies (not is_curried) (SwitchFusion linear_bit False)) - | is_good_producer - // curried applications may be fused with non linear consumers in functions local to a macro - = case gf_fun_def.fun_body of - Expanding _ -> (producers, [App app : new_args ], ti) - _ -> ({ producers & [prod_index] = PR_GeneratedFunction symb fun_index (length app_args)}, app_args ++ new_args, ti) - = (producers, [App app : new_args ], ti) + nr_of_app_args = length app_args + = determineFunAppProducer gf_fun_def nr_of_app_args (PR_GeneratedFunction symb fun_index nr_of_app_args) + is_applied_to_macro_fun linear_bit app new_args prod_index producers ti // XXX determineProducer {app_symb = symb=:{symb_kind = SK_Constructor glob_index}, app_args} new_args prod_index producers ti // = ({ producers & [prod_index] = PR_Constructor symb app_args}, new_args, ti) // XXX */ determineProducer _ _ app _ new_args _ producers ti = (producers, [App app : new_args ], ti) - +determineFunAppProducer {fun_body, fun_arity} nr_of_app_args new_producer + is_applied_to_macro_fun linear_bit app=:{app_args} new_args prod_index producers ti + # is_curried = fun_arity<>nr_of_app_args + is_expanding = case fun_body of { Expanding _ -> True; _ -> False } + is_good_producer = not is_expanding + && (implies is_curried is_applied_to_macro_fun) + && (implies (not is_curried) (SwitchFusion (linear_bit && is_good_body tb_rhs) False)) + // curried applications may be fused with non linear consumers in functions local to a macro + | is_good_producer + = ({ producers & [prod_index] = new_producer}, app_args ++ new_args, ti) + = (producers, [App app : new_args ], ti) + where + (TransformedBody {tb_rhs}) = fun_body + + is_good_body (AnyCodeExpr _ _ _) = False + is_good_body (ABCCodeExpr _ _) = False + is_good_body (Let {let_strict_binds}) = isEmpty let_strict_binds + // currently a producer's body must not be a let with strict bindings. The code sharing elimination algorithm assumes that + // all strict let bindings are on the top level expression (see "convertCasesOfFunctionsIntoPatterns"). This assumption + // could otherwise be violated during fusion. + // -> Here is place for optimisation: Either the fusion algorithm or the code sharing elimination algorithm could be + // extended to generate new functions when a strict let ends up during fusion in a non top level position (MW) + is_good_body _ = True + /* verify_class_members [ App {app_symb, app_args} : mems] = verify_class_members app_args && verify_class_members mems diff --git a/frontend/transform.icl b/frontend/transform.icl index a7ce914..80a6cdd 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -1190,14 +1190,15 @@ where = (Let {lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds }, free_vars, { cos & cos_var_heap = cos_var_heap, cos_error = checkError "" "cyclic let definition" cos.cos_error}) | otherwise - # (let_expr, free_vars, cos) = collectVariables let_expr free_vars { cos & cos_var_heap = cos_var_heap } - (let_strict_binds, free_vars, cos) = collect_variables_in_binds let_strict_binds [] free_vars cos - (let_lazy_binds, free_vars, cos) = collect_variables_in_binds let_lazy_binds [] free_vars cos + # (let_expr, free_vars, cos) = collectVariables let_expr free_vars { cos & cos_var_heap = cos_var_heap } + all_binds = mapAppend (\sb->(True, sb)) let_strict_binds [(False, lb) \\ lb<-let_lazy_binds] + (collected_binds, free_vars, cos) = collect_variables_in_binds all_binds [] free_vars cos + (let_strict_binds, let_lazy_binds) = split collected_binds | isEmpty let_strict_binds && isEmpty let_lazy_binds = (let_expr, free_vars, cos) = (Let {lad & let_expr = let_expr, let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds}, free_vars, cos) where - + /* Set the 'var_info_field' of each bound variable to either 'VI_Alias var' (if this variable is an alias for 'var') or to 'VI_Count 0 cIsALocalVar' to initialise the reference count info. @@ -1211,7 +1212,7 @@ where = var_heap - /* Remove all aliases from the list of 'let'-binds. Be carefull with cycles! */ + /* Remove all aliases from the list of 'let'-binds. Be careful with cycles! */ detect_cycles_and_remove_alias_binds [] var_heap = (cContainsNoCycle, [], var_heap) @@ -1247,17 +1248,26 @@ 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=:{fv_info_ptr},bind_src} : binds] collected_binds free_vars cos + examine_reachable_binds bind_found [bind=:(is_strict, {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_dst = { fv & fv_count = count }, bind_src = bind_src } : collected_binds ], free_vars, cos) + = (True, binds, [ (is_strict, { 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) + split :: ![(Bool, x)] -> (![x], ![x]) + split [] + = ([], []) + split [(p, x):xs] + # (l, r) = split xs + | p + = ([x:l], r) + = (l, [x:r]) + collectVariables (Case case_expr) free_vars cos # (case_expr, free_vars, cos) = collectVariables case_expr free_vars cos = (Case case_expr, free_vars, cos) |